which included commits to RCS files with non-trunk default branches.
--- /dev/null
+static Int_t eventsPerRun = 100;
+enum PprGeo_t
+{
+ kHoles, kNoHoles
+};
+static PprGeo_t geo = kHoles;
+
+void Config()
+{
+ // 7-DEC-2000 09:00
+ // Switch on Transition Radiation simulation. 6/12/00 18:00
+ // iZDC=1 7/12/00 09:00
+ // ThetaRange is (0., 180.). It was (0.28,179.72) 7/12/00 09:00
+ // Theta range given through pseudorapidity limits 22/6/2001
+
+ // Set Random Number seed
+ gRandom->SetSeed(123456);
+
+
+ // libraries required by geant321
+ gSystem->Load("libgeant321");
+
+ new TGeant3("C++ Interface to Geant3");
+
+ if (!gSystem->Getenv("CONFIG_FILE"))
+ {
+ TFile *rootfile = new TFile("galice.root", "recreate");
+
+ rootfile->SetCompressionLevel(2);
+ }
+
+ TGeant3 *geant3 = (TGeant3 *) gMC;
+ AliIonPDGCodes *PDGcodes = new AliIonPDGCodes();
+ PDGcodes->AddParticlesToPdgDataBase();
+ geant3->DefineIons();
+
+ //
+ // Set External decayer
+ TVirtualMCDecayer *decayer = new AliDecayerPythia();
+
+ decayer->SetForceDecay(kAll);
+ decayer->Init();
+ gMC->SetExternalDecayer(decayer);
+ //
+ //
+ //=======================================================================
+ // ******* GEANT STEERING parameters FOR ALICE SIMULATION *******
+ geant3->SetTRIG(1); //Number of events to be processed
+ geant3->SetSWIT(4, 10);
+ geant3->SetDEBU(0, 0, 1);
+ //geant3->SetSWIT(2,2);
+ geant3->SetDCAY(1);
+ geant3->SetPAIR(1);
+ geant3->SetCOMP(1);
+ geant3->SetPHOT(1);
+ geant3->SetPFIS(0);
+ geant3->SetDRAY(0);
+ geant3->SetANNI(1);
+ geant3->SetBREM(1);
+ geant3->SetMUNU(1);
+ geant3->SetCKOV(1);
+ geant3->SetHADR(0); //Select pure GEANH (HADR 1) or GEANH/NUCRIN (HADR 3)
+ geant3->SetLOSS(2);
+ geant3->SetMULS(1);
+ geant3->SetRAYL(1);
+ geant3->SetAUTO(1); //Select automatic STMIN etc... calc. (AUTO 1) or manual (AUTO 0)
+ geant3->SetABAN(0); //Restore 3.16 behaviour for abandoned tracks
+ geant3->SetOPTI(2); //Select optimisation level for GEANT geometry searches (0,1,2)
+ geant3->SetERAN(5.e-7);
+
+ Float_t cut = 1.e-3; // 1MeV cut by default
+ Float_t tofmax = 1.e10;
+
+ // GAM ELEC NHAD CHAD MUON EBREM MUHAB EDEL MUDEL MUPA TOFMAX
+ geant3->SetCUTS(cut, cut, cut, cut, cut, cut, cut, cut, cut, cut,
+ tofmax);
+ //
+ //=======================================================================
+ // ************* STEERING parameters FOR ALICE SIMULATION **************
+ // --- Specify event type to be tracked through the ALICE setup
+ // --- All positions are in cm, angles in degrees, and P and E in GeV
+ // #### AliGenDPMjet generation ######################################
+ AliGenDPMjet *gener = new AliGenDPMjet(1);
+ gener->SetBeamEnergy(2700.);
+ gener->SetEnergyCMS(5400.);
+ gener->SetProjectile(208,82);
+ gener->SetTarget(208,82);
+ gener->SetImpactParameterRange(12.,16.);
+ gener->SetTrackingFlag(1);
+ gener->Init();
+ //
+ // Activate this line if you want the vertex smearing to happen
+ // track by track
+ //
+ //gener->SetVertexSmear(perTrack);
+ // Field (L3 0.4 T)
+ AliMagFMaps* field = new AliMagFMaps("Maps","Maps", 2, 1., 10., 1);
+ rootfile->cd();
+ gAlice->SetField(field);
+
+
+ Int_t iABSO = 1;
+ Int_t iDIPO = 1;
+ Int_t iFMD = 0;
+ Int_t iFRAME = 0;
+ Int_t iHALL = 0;
+ Int_t iITS = 0;
+ Int_t iMAG = 0;
+ Int_t iMUON = 0;
+ Int_t iPHOS = 0;
+ Int_t iPIPE = 1;
+ Int_t iPMD = 0;
+ Int_t iRICH = 0;
+ Int_t iSHIL = 1;
+ Int_t iSTART = 0;
+ Int_t iTOF = 0;
+ Int_t iTPC = 0;
+ Int_t iTRD = 0;
+ Int_t iZDC = 1;
+ Int_t iEMCAL = 0;
+ Int_t iCRT = 0;
+ Int_t iVZERO = 0;
+
+ //=================== Alice BODY parameters =============================
+ AliBODY *BODY = new AliBODY("BODY", "Alice envelop");
+
+ if (iMAG)
+ {
+ //=================== MAG parameters ============================
+ // --- Start with Magnet since detector layouts may be depending ---
+ // --- on the selected Magnet dimensions ---
+ AliMAG *MAG = new AliMAG("MAG", "Magnet");
+ }
+
+
+ if (iABSO)
+ {
+ //=================== ABSO parameters ============================
+ AliABSO *ABSO = new AliABSOv0("ABSO", "Muon Absorber");
+ }
+
+ if (iDIPO)
+ {
+ //=================== DIPO parameters ============================
+
+ AliDIPO *DIPO = new AliDIPOv2("DIPO", "Dipole version 2");
+ }
+
+ if (iHALL)
+ {
+ //=================== HALL parameters ============================
+
+ AliHALL *HALL = new AliHALL("HALL", "Alice Hall");
+ }
+
+
+ if (iFRAME)
+ {
+ //=================== FRAME parameters ============================
+
+ AliFRAMEv2 *FRAME = new AliFRAMEv2("FRAME", "Space Frame");
+ if (geo == kHoles) {
+ FRAME->SetHoles(1);
+ } else {
+ FRAME->SetHoles(0);
+ }
+ }
+
+ if (iSHIL)
+ {
+ //=================== SHIL parameters ============================
+
+ AliSHIL *SHIL = new AliSHILv2("SHIL", "Shielding Version 2");
+ }
+
+
+ if (iPIPE)
+ {
+ //=================== PIPE parameters ============================
+
+ AliPIPE *PIPE = new AliPIPEv0("PIPE", "Beam Pipe");
+ }
+
+ if(iITS) {
+
+ //=================== ITS parameters ============================
+ //
+ // As the innermost detector in ALICE, the Inner Tracking System "impacts" on
+ // almost all other detectors. This involves the fact that the ITS geometry
+ // still has several options to be followed in parallel in order to determine
+ // the best set-up which minimizes the induced background. All the geometries
+ // available to date are described in the following. Read carefully the comments
+ // and use the default version (the only one uncommented) unless you are making
+ // comparisons and you know what you are doing. In this case just uncomment the
+ // ITS geometry you want to use and run Aliroot.
+ //
+ // Detailed geometries:
+ //
+ //
+ //AliITS *ITS = new AliITSv5symm("ITS","Updated ITS TDR detailed version with symmetric services");
+ //
+ //AliITS *ITS = new AliITSv5asymm("ITS","Updates ITS TDR detailed version with asymmetric services");
+ //
+ AliITSvPPRasymm *ITS = new AliITSvPPRasymm("ITS","New ITS PPR detailed version with asymmetric services");
+ ITS->SetMinorVersion(2); // don't touch this parameter if you're not an ITS developer
+ ITS->SetReadDet(kFALSE); // don't touch this parameter if you're not an ITS developer
+ // ITS->SetWriteDet("$ALICE_ROOT/ITS/ITSgeometry_vPPRasymm2.det"); // don't touch this parameter if you're not an ITS developer
+ ITS->SetThicknessDet1(200.); // detector thickness on layer 1 must be in the range [100,300]
+ ITS->SetThicknessDet2(200.); // detector thickness on layer 2 must be in the range [100,300]
+ ITS->SetThicknessChip1(200.); // chip thickness on layer 1 must be in the range [150,300]
+ ITS->SetThicknessChip2(200.); // chip thickness on layer 2 must be in the range [150,300]
+ ITS->SetRails(0); // 1 --> rails in ; 0 --> rails out
+ ITS->SetCoolingFluid(1); // 1 --> water ; 0 --> freon
+ //
+ //AliITSvPPRsymm *ITS = new AliITSvPPRsymm("ITS","New ITS PPR detailed version with symmetric services");
+ //ITS->SetMinorVersion(2); // don't touch this parameter if you're not an ITS developer
+ //ITS->SetReadDet(kFALSE); // don't touch this parameter if you're not an ITS developer
+ //ITS->SetWriteDet("$ALICE_ROOT/ITS/ITSgeometry_vPPRsymm2.det"); // don't touch this parameter if you're not an ITS developer
+ //ITS->SetThicknessDet1(200.); // detector thickness on layer 1 must be in the range [100,300]
+ //ITS->SetThicknessDet2(200.); // detector thickness on layer 2 must be in the range [100,300]
+ //ITS->SetThicknessChip1(200.); // chip thickness on layer 1 must be in the range [150,300]
+ //ITS->SetThicknessChip2(200.); // chip thickness on layer 2 must be in the range [150,300]
+ //ITS->SetRails(0); // 1 --> rails in ; 0 --> rails out
+ //ITS->SetCoolingFluid(1); // 1 --> water ; 0 --> freon
+ //
+ //
+ // Coarse geometries (warning: no hits are produced with these coarse geometries and they unuseful
+ // for reconstruction !):
+ //
+ //
+ //AliITSvPPRcoarseasymm *ITS = new AliITSvPPRcoarseasymm("ITS","New ITS PPR coarse version with asymmetric services");
+ //ITS->SetRails(0); // 1 --> rails in ; 0 --> rails out
+ //ITS->SetSupportMaterial(0); // 0 --> Copper ; 1 --> Aluminum ; 2 --> Carbon
+ //
+ //AliITS *ITS = new AliITSvPPRcoarsesymm("ITS","New ITS PPR coarse version with symmetric services");
+ //ITS->SetRails(0); // 1 --> rails in ; 0 --> rails out
+ //ITS->SetSupportMaterial(0); // 0 --> Copper ; 1 --> Aluminum ; 2 --> Carbon
+ //
+ //
+ //
+ // Geant3 <-> EUCLID conversion
+ // ============================
+ //
+ // SetEUCLID is a flag to output (=1) or not to output (=0) both geometry and
+ // media to two ASCII files (called by default ITSgeometry.euc and
+ // ITSgeometry.tme) in a format understandable to the CAD system EUCLID.
+ // The default (=0) means that you dont want to use this facility.
+ //
+ ITS->SetEUCLID(0);
+ }
+
+ if (iTPC)
+ {
+ //============================ TPC parameters ================================
+ // --- This allows the user to specify sectors for the SLOW (TPC geometry 2)
+ // --- Simulator. SecAL (SecAU) <0 means that ALL lower (upper)
+ // --- sectors are specified, any value other than that requires at least one
+ // --- sector (lower or upper)to be specified!
+ // --- Reminder: sectors 1-24 are lower sectors (1-12 -> z>0, 13-24 -> z<0)
+ // --- sectors 25-72 are the upper ones (25-48 -> z>0, 49-72 -> z<0)
+ // --- SecLows - number of lower sectors specified (up to 6)
+ // --- SecUps - number of upper sectors specified (up to 12)
+ // --- Sens - sensitive strips for the Slow Simulator !!!
+ // --- This does NOT work if all S or L-sectors are specified, i.e.
+ // --- if SecAL or SecAU < 0
+ //
+ //
+ //-----------------------------------------------------------------------------
+
+ // gROOT->LoadMacro("SetTPCParam.C");
+ // AliTPCParam *param = SetTPCParam();
+ AliTPC *TPC = new AliTPCv2("TPC", "Default");
+
+ // All sectors included
+ TPC->SetSecAL(-1);
+ TPC->SetSecAU(-1);
+
+ }
+
+
+ if (iTOF) {
+ if (geo == kHoles) {
+ //=================== TOF parameters ============================
+ AliTOF *TOF = new AliTOFv2FHoles("TOF", "TOF with Holes");
+ } else {
+ AliTOF *TOF = new AliTOFv4T0("TOF", "normal TOF");
+ }
+ }
+
+
+ if (iRICH)
+ {
+ //=================== RICH parameters ===========================
+ AliRICH *RICH = new AliRICHv3("RICH", "normal RICH");
+
+ }
+
+
+ if (iZDC)
+ {
+ //=================== ZDC parameters ============================
+
+ AliZDC *ZDC = new AliZDCv2("ZDC", "normal ZDC");
+ ZDC->NoShower();
+ }
+
+ if (iTRD)
+ {
+ //=================== TRD parameters ============================
+
+ AliTRD *TRD = new AliTRDv1("TRD", "TRD slow simulator");
+
+ // Select the gas mixture (0: 97% Xe + 3% isobutane, 1: 90% Xe + 10% CO2)
+ TRD->SetGasMix(1);
+ if (geo == kHoles) {
+ // With hole in front of PHOS
+ TRD->SetPHOShole();
+ // With hole in front of RICH
+ TRD->SetRICHhole();
+ }
+ // Switch on TR
+ AliTRDsim *TRDsim = TRD->CreateTR();
+ }
+
+ if (iFMD)
+ {
+ //=================== FMD parameters ============================
+ AliFMD *FMD = new AliFMDv1("FMD", "normal FMD");
+ FMD->SetRingsSi1(256);
+ FMD->SetRingsSi2(128);
+ FMD->SetSectorsSi1(20);
+ FMD->SetSectorsSi2(40);
+ }
+
+ if (iMUON)
+ {
+ //=================== MUON parameters ===========================
+
+ AliMUON *MUON = new AliMUONv1("MUON", "default");
+ }
+ //=================== PHOS parameters ===========================
+
+ if (iPHOS)
+ {
+ AliPHOS *PHOS = new AliPHOSv1("PHOS", "IHEP");
+ }
+
+
+ if (iPMD)
+ {
+ //=================== PMD parameters ============================
+ AliPMD *PMD = new AliPMDv1("PMD", "normal PMD");
+ }
+
+ if (iSTART)
+ {
+ //=================== START parameters ============================
+ AliSTART *START = new AliSTARTv1("START", "START Detector");
+ }
+
+ if (iEMCAL)
+ {
+ //=================== EMCAL parameters ============================
+ AliEMCAL *EMCAL = new AliEMCALv1("EMCAL", "G56_2_55_19_104_14");
+ }
+
+ if (iCRT)
+ {
+ //=================== CRT parameters ============================
+ AliCRT *CRT = new AliCRTv0("CRT", "normal ACORDE");
+ }
+
+ if (iVZERO)
+ {
+ //=================== CRT parameters ============================
+ AliVZERO *VZERO = new AliVZEROv2("VZERO", "normal VZERO");
+ }
+
+}
+
--- /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, PYTHIA 6.115 and LEPTO 6.5.1 |
+ | |
+ +-------------------------------------------------------------+
+
+
+
+ INPUT OPTIONS
+ _______________
+
+
+ The input of DPMJET consists of option cards. Option cards have all the
+ same structure and have to be given in fixed format except for the
+ section enclosed by PHOINPUT and ENDINPUT which can be given in free format.
+
+ CODEWD, (WHAT(I),I=1,6), SDUM (default fixed format is
+ A10,6E10.0,A8)
+
+ where:
+
+ - CODEWD is the option keyword
+ - The WHAT-parameters are numerical data
+ - SDUM may contain literal data
+
+ The order of the input cards is free, with the exception of the START card
+ which initiates event generation and the BEAM card (see below).
+
+ Most definitions have some default values. If these are acceptable,
+ it is not compulsory that the corresponding option card appear
+ explicitly in the input sequence. Similarly, for most WHAT and/or SDUM
+ parameters a default value is applied if the corresponding field is left
+ blank (or set = 0.0) in the input card.
+
+ Several option cards may appear more than once in the input sequence.
+ In most cases, each of such additional cards obviously adds more
+ definitions to those already given, provided they are different and not
+ contradictory. In case of conflict, the last given generally overrides
+ the previous one(s).
+
+ Any line starting with "*" is treated as a comment line.
+
+
+ 1) List of input options
+ ------------------------
+
+ *** general options ***
+
+ TITLE title of run
+ START start of event generation
+ STOP stop of the event generation
+ RNDMINIT initialization of random number generator
+
+ *** interacting particles ***
+
+ PROJPAR projectile parameters
+ TARPAR target parameters
+ EMULSION definition of nuclear target emulsions or composite targets
+
+ *** collision energy ***
+
+ ENERGY interaction energy (per nucleon, lab)
+ MOMENTUM interaction momentum (per nucleon, lab)
+ CMENERGY interaction energy (nucleon-nucleon cms)
+ BEAM definition of beam parameters
+
+ *** model for hadron / lepton / photon - nucleon interactions ***
+
+ MODEL model to be used to treat nucleon-nucleon interactions
+ PHOINPUT start of PHOJET-specific input
+ ENDINPUT end of PHOJET-specific input
+ HADRIN HADRIN module
+ LEPTO-CUT parameter CUT in LEPTO-common /LEPTOU/
+ LEPTO-LST parameter LST in LEPTO-common /LEPTOU/
+ LEPTO-PARL parameter PARL in LEPTO-common /LEPTOU/
+
+ *** Glauber formalism - cross sections ***
+
+ GLAUB-PAR parameters in Glauber-formalism
+ GLAUB-INI pre-initialization of profile function
+ FLUCTUAT treatment of cross section fluctuations
+ VDM-PAR1 parameters in gamma-nucleus cross section calculation
+ VDM-PAR2 parameters in gamma-nucleus cross section calculation
+ XS-TABLE output of cross section table for requested interaction
+ CENTRAL biasing in impact parameter
+
+ *** parameters in DPM two-chain approximation ***
+
+ RECOMBIN chain recombination
+ COMBIJET chain fusion
+ CRONINPT Cronin multiple scattering of partons
+ DIQUARKS sea-diquark/antidiquark-pairs
+
+ *** hadronization and JETSET-parameters ***
+
+ LUND-MSTU set parameter MSTU in JETSET-common /LUDAT1/
+ LUND-PARJ set parameter PARJ in JETSET-common /LUDAT1/
+ LUND-PARU set parameter PARJ in JETSET-common /LUDAT1/
+ POPCORN Popcorn-effect in fragmentation
+ PARDECAY decay of Sigma0, Asigma0, pion^0
+
+ *** nuclear fragmentation ***
+
+ FERMI Fermi momentum of nucleons
+ TAUFOR formation time suppressed intranuclear cascade
+ PAULI treatment of Pauli's principle
+ COULOMB treatment of Coulomb force
+ EVAP evaporation / fragmentation module
+
+ *** output and checks ***
+
+ FRAME Lorentz-frame in which final state is given in DTEVT1
+ HISTOGRAM activate different classes of histograms
+ EMCCHECK extended energy-momentum / quantum-number conservation check
+
+ *** lepton tagger ***
+
+ L-TAG lepton tagger (lepton-nucleus interactions only)
+ L-ETAG lepton tagger (lepton-nucleus interactions only)
+ ECMS-CUT lepton tagger (lepton-nucleus interactions only)
+
+ *** for code development only ***
+
+ INTPT intrinsic transverse momenta of partons
+ OUTLEVEL output control switches
+ RESONANC treatment of low mass chains
+ SEASU3 treatment of strange-quarks at chain ends
+ XCUTS thresholds for x-sampling
+
+
+ 2) Description of input options
+ -------------------------------
+
+
+ *** general options ***
+
+______________________________________________________________________
+
+ control card: codewd = TITLE
+
+ what (1..6), sdum no meaning
+
+ Note: The control-card following this card must consist of
+ a string of characters usually giving the title of
+ the run.
+______________________________________________________________________
+
+ control card: codewd = START
+
+ what (1) = number of events default: 100.
+______________________________________________________________________
+
+ control card: codewd = STOP
+
+ stop of the event generation
+
+ what (1..6) no meaning
+______________________________________________________________________
+
+ control card: RNDMINIT
+
+ initialization of random number generator
+
+ what (1..4) values for initialization (= 1..168)
+ what (5..6), sdum no meaning
+______________________________________________________________________
+
+
+ *** interacting particles ***
+
+______________________________________________________________________
+
+ control card: codewd = PROJPAR
+
+ definition of projectile properties
+
+ what (1) = (nucleus) mass number
+ (photon) virtuality Q^2
+ (lepton, PHOJET)
+ maximum virtuality Q^2 of emitted photon
+ (otherwise) no meaning
+ what (2) = (nucleus) charge number
+ (otherwise) no meaning
+ what (3..6) no meaning
+ sdum (hadrons,photons,leptons) particle code word
+
+ Note: In general, projectile nuclei are defined by what (1) and
+ what (2). All other projectiles are defined by sdum.
+______________________________________________________________________
+
+ control card: codewd = TARPAR
+
+ definition of target properties
+
+ what (1) = (nucleus) mass number
+ (otherwise) no meaning
+ what (2) = (nucleus) charge number
+ (otherwise) no meaning
+ what (3..6) no meaning
+ sdum (hadrons) particle code word
+
+ Note: In general, target nuclei are defined by what (1) and
+ what (2). Target hadrons are defined by sdum.
+______________________________________________________________________
+
+
+ control card: codewd = EMULSION
+
+ definition of nuclear target emulsions or composite targets
+
+ what(1) mass number of emulsion component
+ what(2) charge of emulsion component
+ what(3) fraction of events with this target
+ what(4,5,6) as what(1,2,3) but for a further 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 relative values.
+ This control card can be repeatedly used to define
+ emulsions / composite targets consisting of up to 10
+ elements.
+______________________________________________________________________
+
+
+ *** collision energy ***
+
+______________________________________________________________________
+
+ control card: codewd = ENERGY
+
+ definition of laboratory energy
+
+ what (1) > 0: what (1) = total energy per nucleon (GeV)
+ < 0: |what(1)| = kinetic energy per nucleon (GeV)
+ default: 200 GeV
+ if |what(2)| > 0: min. total/kinetic energy per nucleon
+ for variable energy runs
+ what (2) max. energy per nucleon for variable energy runs
+ > 0: what (2) = total energy per nucleon (GeV)
+ < 0: |what(1)| = kinetic energy per nucleon (GeV)
+______________________________________________________________________
+
+ control card: codewd = MOMENTUM
+
+ definition of laboratory momentum
+
+ what (1) = momentum per nucleon (GeV/c) of projectile in Lab.
+ default: 200 GeV/c
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = CMENERGY
+
+ what (1) = nucleon-nucleon c.m. energy default: none
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = BEAM
+
+ definition of beam parameters
+
+ what (1/2) > 0 : energy per nucleon of beam 1/2 (GeV)
+ < 0 : |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) !
+______________________________________________________________________
+
+
+ *** model for hadron / lepton / photon - nucleon interactions ***
+
+______________________________________________________________________
+
+ control card: codewd = MODEL
+
+ Model used to describe nucleon(hadron,photon,lepton)-nucleon
+ interactions
+
+ what (1) (only if sdum = LEPTO)
+ variable INTER (see LEPTO-manual)
+ = 1 gamma exchange
+ = 2 W+- exchange
+ = 3 Z0 exchange
+ = 4 gamma/Z0 exchange
+
+ sdum = DTUNUC two-chain model as for versions 1.xx
+ (nucleon/hadron-nucleon interactions only)
+ = PHOJET multiple chains including minijets
+ = LEPTO DIS
+ default: PHOJET
+ what (2..6) no meaning
+______________________________________________________________________
+
+ control card: codewd = PHOINPUT
+
+ Start of PHOJET-specific input.
+ For details and a list of PHOJET input cards see the PHOJET-manual
+ available at
+ http://lepton.bartol.udel.edu/~eng/phojet.html
+ Note: This part of the input has to be closed by the ENDINPUT-card
+
+ what (1..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = ENDINPUT
+
+ End of PHOJET-specific input.
+ what (1..6), sdum no meaning
+______________________________________________________________________
+
+ 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: steady transition btw. HADRIN and
+ DPM in the range 4-7 GeV
+ what (3..6), sdum no meaning
+______________________________________________________________________
+
+ 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
+
+ Note: see LEPTO-manual.
+______________________________________________________________________
+
+ 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
+
+ Note: see LEPTO-manual.
+______________________________________________________________________
+
+ 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
+
+ Note: see LEPTO-manual.
+______________________________________________________________________
+
+
+ *** Glauber formalism - cross sections ***
+
+______________________________________________________________________
+
+ control card: codewd = GLAUB-PAR
+
+ parameters in Glauber-formalism
+
+ what (1) number of nucleon configurations sampled in integration
+ over nuclear density default: 1000
+ what (2) number 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
+ otherwise calculation of production cross sections only
+ default: 0
+ what (4) = 1 read pre-calculated impact-parameter distribution
+ from "sdum".glb for fixed projectile/target/energy
+ runs
+ = -1 dump calculated impact-parameter distribution
+ into "sdum".glb for fixed or variable projectile/
+ target/energy runs
+ = 100 read pre-calculated impact-parameter distribution
+ from "sdum".glb for variable projectile/target/
+ energy runs
+ default: 0
+ what (5..6) no meaning
+ sdum if |what (4)| = 1 name of in/output-file (sdum.glb)
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+ control card: codewd = FLUCTUAT
+
+ Treatment of cross section fluctuations
+
+ what (1) = 1 cross section fluctuations treated default: 0.
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+
+ 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
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+ control card: codewd = CENTRAL
+
+ Biasing in impact parameter
+
+ what (1) = 1. central production
+ (not recommended, has to be updated)
+ what (1) < 0 and > -100
+ what (2) = min. impact parameter
+ what (3) = max. impact parameter
+ what (1) < -99
+ what (2) = fraction of cross section
+ what (4..6), sdum no meaning
+
+ Note: if what (1) = -1 : evaporation is suppressed
+ if what (1) < -1 : evaporation is allowed
+______________________________________________________________________
+
+
+ *** parameters in DPM two-chain approximation ***
+
+______________________________________________________________________
+
+ 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
+
+ Note: Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+ 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
+
+ Note: Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+ control card: codewd = CRONINPT
+
+ Cronin effect (multiple scattering of partons at chain ends)
+
+ what (1) = -1 Cronin effect not treated
+ default (h+A): 1 (A+A): 0
+ what (2) scattering parameter default: 0.64
+ what (3..6), sdum no meaning
+
+ Note: The Cronin-treatment should not be invoked for A+A int.
+______________________________________________________________________
+
+ control card: codewd = DIQUARKS
+
+ what (1) = -1. sea-diquark/antidiquark-pairs not treated
+ default: -1.
+ what (2..6), sdum no meaning
+
+ Note: Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+
+ *** hadronization and JETSET-parameters ***
+
+______________________________________________________________________
+
+ control card: codewd = LUND-MSTU
+
+ 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 used in the same way as what (1) and what (2)
+
+ Note: The use of this card is not recommended. Some parameters
+ can presently not be changed with this card anyway.
+ Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+ control card: codewd = LUND-PARJ
+
+ 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 used in the same way as what (1) and what (2)
+
+ Note: The use of this card is not recommended. Some parameters
+ can presently not be changed with this card anyway.
+ Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+ control card: codewd = LUND-PARU
+
+ 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 used in the same way as what (1) and what (2)
+
+ Note: The use of this card is not recommended. Some parameters
+ can presently not be changed with this card anyway.
+ Limited applicability for MODEL = PHOJET.
+______________________________________________________________________
+
+ control card: codewd = POPCORN
+
+ "Popcorn-effect" in fragmentation
+
+ what (1) < 0 Popcorn-effect switched off (MSTJ(12) = 1)
+ >=0 Popcorn-effect treated (PARJ(5) = what (1))
+ default: 0.15
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = PARDECAY
+
+ what (1) = 1. Sigma0/Asigma0 decay treated by JETSET
+ = 2. pion^0 decay after intranucl. cascade
+ default: 0 (no such decays)
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+
+ *** nuclear fragmentation ***
+
+______________________________________________________________________
+
+ control card: codewd = FERMI
+
+ what (1) = -1 Fermi-motion of nucleons not treated default: 1
+ what (2) = scale factor for Fermi-momentum default: 0.68
+ what (3..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = TAUFOR
+
+ formation time suppressed intranuclear cascade
+
+ what (1) formation time (in fm/c) default: 3.1 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
+______________________________________________________________________
+
+ control card: codewd = PAULI
+
+ what (1) = -1 Pauli's principle for secondary
+ interactions not treated default: 1
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = COULOMB
+
+ what (1) = -1. Coulomb-energy treatment switched off default: 1
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ control card: codewd = EVAP
+
+ evaporation module of FLUKA
+
+ The following options and defaults apply only if the code is linked
+ to the FLUKA-library (see README file).
+
+ 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 is 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 are produced and
+ Fermi break up is activated
+ what (3..6), sdum no meaning
+______________________________________________________________________
+
+
+ *** output and checks ***
+
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+
+ control card: codewd = HISTOGRAM
+
+ activate different classes of histograms
+
+ default: no histograms
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+
+ *** lepton tagger ***
+
+______________________________________________________________________
+
+ control card: codewd = L-TAG
+ (lepton-nucleus interactions with MODEL=PHOJET only)
+
+ lepton tagger:
+ definition of kinematic 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
+______________________________________________________________________
+
+
+ control card: codewd = L-ETAG
+ (lepton-nucleus interactions with MODEL=PHOJET only)
+
+ 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
+______________________________________________________________________
+
+ control card: codewd = ECMS-CUT
+ (lepton-nucleus interactions with MODEL=PHOJET only)
+
+ 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
+______________________________________________________________________
+
+
+ *** for code development only ***
+
+______________________________________________________________________
+
+ control card: codewd = INTPT
+
+ what (1) = -1 intrinsic transverse momenta of partons
+ not treated default: 1
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ 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..6) internal warning messages default: 0
+______________________________________________________________________
+
+ control card: codewd = RESONANC
+
+ treatment of low mass chains
+
+ what (1) = -1 low chain masses are not corrected for resonance
+ masses default: 1.
+ what (2) = -1 massless partons 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
+______________________________________________________________________
+
+ control card: codewd = SEASU3
+
+ Treatment of strange-quarks at chain ends
+
+ what (1) (SEASQ) strange-quark suppression factor
+ iflav = 1.+rndm*(2.+SEASQ) default: 1.
+ what (2..6), sdum no meaning
+______________________________________________________________________
+
+ 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
+______________________________________________________________________
+
+
+
+ EVENT HISTORY - COMMON /DTEVT1/
+ _________________________________
+
+
+ 1) Common block DTEVT1
+ ----------------------
+
+ The complete history of each event can be found in COMMON /DTEVT1/
+ and COMMON /EXTEVT/.
+
+ COMMON /DTEVT1/ :
+ NHKK number of entries in common block
+ NEVHKK number of the event
+ ISTHKK(i) status code for entry i
+ IDHKK(i) identifier for the entry
+ (for particles: identifier according to the PDG scheme)
+ JMOHKK(1,i) pointer to the entry of the first mother of entry i
+ JMOHKK(2,i) pointer to the entry of the second mother of entry i
+ JDAHKK(1,i) pointer to the entry of the first daughter of entry i
+ JDAHKK(2,i) pointer to the entry of the second daughter of entry i
+ PHKK(1..3,i) 3-momentum
+ PHKK(4,i) energy
+ PHKK(5,i) mass
+ VHKK / WHKK spatial position of particle in target / projectile
+ rest frame
+
+ 2) Final state particles
+ ------------------------
+
+ The final state particles from the actual event (number NEVHKK)
+ can be found in DTEVT1 and identified by their status:
+
+ ISTHKK(i) = 1 final state particle produced in
+ photon-/hadron-/nucleon-nucleon collisions or
+ in intranuclear cascade processes
+ -1 nucleons, deuterons, H-3, He-3, He-4 evaporated
+ from excited nucleus, fragmentation and fission
+ products (A > 4) and photons produced in nuclear
+ deexcitation processes
+ 1001 residual nucleus (ground state)
+
+ The types of these particles/nuclei are given in IDHKK as follows
+
+ all final state particles except nuclei :
+ IDHKK(i)=particle identifier according to PDG numbering scheme
+ nuclei (A > 1: evaporation / fragmentation / fission products, and
+ residual nuclei) :
+ IDHKK(i)=80000, IDRES(i)=mass number, IDXRES(i)=charge number
+
+ The 4-momenta and masses can be found in PHKK (target nucleus rest frame
+ unless defined by the FRAME-card):
+ PHKK(1..3,i) 3-momentum (p_x,p_y,p_z)
+ PHKK(4,i) energy
+ PHKK(5,i) mass
--- /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 './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(PAREVT)'
+ INCLUDE './flukapro/(EVAPAR)'
+ INCLUDE './flukapro/(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/PbPbLHC.inp'
+ OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
+
+
+ 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
+ PP1(K) = PHKK(K,N1)
+ PT1(K) = PHKK(K,N1+1)
+ PP2(K) = PHKK(K,N2)
+ PT2(K) = PHKK(K,N2+1)
+ 4 CONTINUE
+ AMCH1 = PHKK(5,N1+2)
+ AMCH2 = PHKK(5,N2+2)
+* get meson-identity corresponding to flavors of q-aq chain
+ ITMP = IRESRJ
+ IRESRJ = 0
+ CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
+ & ZERO,AMCH1N,1,IDUM)
+ IRESRJ = ITMP
+* change kinematics of chains
+ CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
+ & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 10
+* check second chain for resonance
+ IDCHAI = 2
+ IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
+ CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
+ & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
+ IF (IREJ1.NE.0) GOTO 10
+ IF (IDR2.NE.0) IDR2 = 100*IDR2
+* add partons and chains to DTEVT1
+ DO 5 K=1,4
+ PCH1(K) = PP1(K)+PT1(K)
+ PCH2(K) = PP2(K)+PT2(K)
+ 5 CONTINUE
+ CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
+ & PP1(3),PP1(4),0,0,0)
+ CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
+ & PT1(2),PT1(3),PT1(4),0,0,0)
+ KCH = ISTHKK(N1+2)+100
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
+ & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
+ IDHKK(N1+2) = 22222
+ CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
+ & PP2(3),PP2(4),0,0,0)
+ CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
+ & PT2(2),PT2(3),PT2(4),0,0,0)
+ KCH = ISTHKK(N2+2)+100
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
+ & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
+ IDHKK(N2+2) = 22222
+ ENDIF
+ ENDIF
+ ELSE
+ GOTO 11
+ ENDIF
+ 10 CONTINUE
+ NC = NC+6
+ GOTO 2
+
+ 11 CONTINUE
+
+ RETURN
+ END
+*
+*=== phnsch ===========================================================*
+*
+CDECK ID>, DT_PHNSCH
+ DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
+
+*----------------------------------------------------------------------*
+* *
+* Probability for Hadron Nucleon Single CHain interactions: *
+* *
+* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-jan-94 by Alfredo Ferrari *
+* *
+* modified by J.R.for use in DTUNUC 6.1.94 *
+* *
+* Input variables: *
+* Kp = hadron projectile index (Part numbering *
+* scheme) *
+* Ktarg = target nucleon index (1=proton, 8=neutron) *
+* Plab = projectile laboratory momentum (GeV/c) *
+* Output variable: *
+* Phnsch = probability per single chain (particle *
+* exchange) interactions *
+* *
+*----------------------------------------------------------------------*
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LUNOUT = 6 )
+ PARAMETER ( LUNERR = 6 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( ZERZER = 0.D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( FIVFIV = 5.D+00 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+
+ PARAMETER ( NALLWP = 39 )
+ PARAMETER ( IDMAXP = 210 )
+
+ DIMENSION ICHRGE(39),AM(39)
+
+* 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)
+
+ DIMENSION KPTOIP(210)
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+
+ DIMENSION SGTCOE (5,33), IHLP (NALLWP)
+ DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
+ SAVE SGTCOE, IHLP
+ SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
+ EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
+ EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
+ EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
+
+* Conversion from part to paprop numbering
+ DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
+ & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
+
+* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
+ DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
+ & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
+ DATA SGTCO1 /
+* 1st reaction: gamma p total
+ &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
+* 2nd reaction: gamma d total
+ &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
+* 3rd reaction: pi+ p total
+ &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
+* 4th reaction: pi- p total
+ &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
+* 5th reaction: pi+/- d total
+ &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
+* 6th reaction: K+ p total
+ &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
+* 7th reaction: K+ n total
+ &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
+* 8th reaction: K+ d total
+ &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
+* 9th reaction: K- p total
+ &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
+* 10th reaction: K- n total
+ &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
+ DATA SGTCO2 /
+* 11th reaction: K- d total
+ &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
+* 12th reaction: p p total
+ &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
+* 13th reaction: p n total
+ &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
+* 14th reaction: p d total
+ &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
+* 15th reaction: pbar p total
+ &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
+* 16th reaction: pbar n total
+ &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
+* 17th reaction: pbar d total
+ &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
+* 18th reaction: Lamda p total
+ &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
+C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
+ DATA SGTCO3 /
+* 19th reaction: pi+ p elastic
+ &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
+* 20th reaction: pi- p elastic
+ &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
+* 21st reaction: K+ p elastic
+ &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
+* 22nd reaction: K- p elastic
+ &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
+* 23rd reaction: p p elastic
+ &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
+* 24th reaction: p d elastic
+ &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
+* 25th reaction: pbar p elastic
+ &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
+* 26th reaction: pbar p elastic bis
+ &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
+* 27th reaction: pbar n elastic
+ &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
+* 28th reaction: Lamda p elastic
+ &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
+* 29th reaction: K- p ela bis
+ &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
+* 30th reaction: pi- p cx
+ &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
+* 31st reaction: K- p cx
+ &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
+* 32nd reaction: K+ n cx
+ &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
+* 33rd reaction: pbar p cx
+ &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
+*
+* +-------------------------------------------------------------------*
+ ICHRGE(KTARG)=IICH(KTARG)
+ AM (KTARG)=AAM (KTARG)
+* | Check for pi0 (d-dbar)
+ IF ( KP .NE. 26 ) THEN
+ IP = KPTOIP (KP)
+ IF(IP.EQ.0)IP=1
+ ICHRGE(IP)=IICH(KP)
+ AM (IP)=AAM (KP)
+* |
+* +-------------------------------------------------------------------*
+* |
+ ELSE
+ IP = 23
+ ICHRGE(IP)=0
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | No such interactions for baryon-baryon
+ IF ( IIBAR (KP) .GT. 0 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for K+ p/n
+ ELSE IF ( IP .EQ. 15 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for K0 p/n
+ ELSE IF ( IP .EQ. 24 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+* |
+* +-------------------------------------------------------------------*
+* | No "annihilation" diagram possible for Omebar p/n
+ ELSE IF ( IP .GE. 38 ) THEN
+ DT_PHNSCH = ZERZER
+ RETURN
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | If the momentum is larger than 50 GeV/c, compute the single
+* | chain probability at 50 GeV/c and extrapolate to the present
+* | momentum according to 1/sqrt(s)
+* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
+* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
+* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
+* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
+* | x sqrt(s/s(50))
+* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
+ IF ( PLAB .GT. 50.D+00 ) THEN
+ PLA = 50.D+00
+ AMPSQ = AM (IP)**2
+ AMTSQ = AM (KTARG)**2
+ EPROJ = SQRT ( PLAB**2 + AMPSQ )
+ UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ EPROJ = SQRT ( PLA**2 + AMPSQ )
+ UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ UMORAT = SQRT ( UMOSQ / UMO50 )
+* |
+* +-------------------------------------------------------------------*
+* | P < 3 GeV/c
+ ELSE IF ( PLAB .LT. 3.D+00 ) THEN
+ PLA = 3.D+00
+ AMPSQ = AM (IP)**2
+ AMTSQ = AM (KTARG)**2
+ EPROJ = SQRT ( PLAB**2 + AMPSQ )
+ UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ EPROJ = SQRT ( PLA**2 + AMPSQ )
+ UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
+ UMORAT = SQRT ( UMOSQ / UMO50 )
+* |
+* +-------------------------------------------------------------------*
+* | P < 50 GeV/c
+ ELSE
+ PLA = PLAB
+ UMORAT = ONEONE
+ END IF
+* |
+* +-------------------------------------------------------------------*
+ ALGPLA = LOG (PLA)
+* +-------------------------------------------------------------------*
+* | Pions:
+ IF ( IHLP (IP) .EQ. 2 ) THEN
+ ACOF = SGTCOE (1,3)
+ BCOF = SGTCOE (2,3)
+ ENNE = SGTCOE (3,3)
+ CCOF = SGTCOE (4,3)
+ DCOF = SGTCOE (5,3)
+* | Compute the pi+ p total cross section:
+ SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,19)
+ BCOF = SGTCOE (2,19)
+ ENNE = SGTCOE (3,19)
+ CCOF = SGTCOE (4,19)
+ DCOF = SGTCOE (5,19)
+* | Compute the pi+ p elastic cross section:
+ SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pi+ p inelastic cross section:
+ SPPPIN = SPPPTT - SPPPEL
+ ACOF = SGTCOE (1,4)
+ BCOF = SGTCOE (2,4)
+ ENNE = SGTCOE (3,4)
+ CCOF = SGTCOE (4,4)
+ DCOF = SGTCOE (5,4)
+* | Compute the pi- p total cross section:
+ SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,20)
+ BCOF = SGTCOE (2,20)
+ ENNE = SGTCOE (3,20)
+ CCOF = SGTCOE (4,20)
+ DCOF = SGTCOE (5,20)
+* | Compute the pi- p elastic cross section:
+ SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pi- p inelastic cross section:
+ SPMPIN = SPMPTT - SPMPEL
+ SIGDIA = SPMPIN - SPPPIN
+* | +----------------------------------------------------------------*
+* | | Charged pions: besides isospin consideration it is supposed
+* | | that (pi+ n)el is almost equal to (pi- p)el
+* | | and (pi+ p)el " " " " (pi- n)el
+* | | and all are almost equal among each others
+* | | (reasonable above 5 GeV/c)
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ KHELP = KTARG / 8
+ JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | | Compute the elastic cross section:
+ SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+* | | Number of diagrams:
+ NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 1 + IP - 13
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 1 + IP - 13
+* | |
+* | +----------------------------------------------------------------*
+* | | pi0: besides isospin consideration it is supposed that the
+* | | elastic cross section is not very different from
+* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
+ ELSE
+ KHELP = KTARG / 8
+ K2HLP = ( KP - 23 ) / 3
+* | | Number of diagrams:
+* | | For u ubar (k2hlp=0):
+* NDIAGR = 2 - KHELP
+* | | For d dbar (k2hlp=1):
+* NDIAGR = 2 + KHELP - K2HLP
+ NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
+ SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 1 + K2HLP
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 2 - K2HLP
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* | end pi's
+* +-------------------------------------------------------------------*
+* | Kaons:
+ ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
+ ACOF = SGTCOE (1,6)
+ BCOF = SGTCOE (2,6)
+ ENNE = SGTCOE (3,6)
+ CCOF = SGTCOE (4,6)
+ DCOF = SGTCOE (5,6)
+* | Compute the K+ p total cross section:
+ SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,21)
+ BCOF = SGTCOE (2,21)
+ ENNE = SGTCOE (3,21)
+ CCOF = SGTCOE (4,21)
+ DCOF = SGTCOE (5,21)
+* | Compute the K+ p elastic cross section:
+ SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K+ p inelastic cross section:
+ SKPPIN = SKPPTT - SKPPEL
+ ACOF = SGTCOE (1,9)
+ BCOF = SGTCOE (2,9)
+ ENNE = SGTCOE (3,9)
+ CCOF = SGTCOE (4,9)
+ DCOF = SGTCOE (5,9)
+* | Compute the K- p total cross section:
+ SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,22)
+ BCOF = SGTCOE (2,22)
+ ENNE = SGTCOE (3,22)
+ CCOF = SGTCOE (4,22)
+ DCOF = SGTCOE (5,22)
+* | Compute the K- p elastic cross section:
+ SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K- p inelastic cross section:
+ SKMPIN = SKMPTT - SKMPEL
+ SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
+* | +----------------------------------------------------------------*
+* | | Charged Kaons: actually only K-
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ KHELP = KTARG / 8
+* | | +-------------------------------------------------------------*
+* | | | Proton target:
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SKMPIN
+* | | | Number of diagrams:
+ NDIAGR = 2
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: besides isospin consideration it is supposed
+* | | | that (K- n)el is almost equal to (K- p)el
+* | | | (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,10)
+ BCOF = SGTCOE (2,10)
+ ENNE = SGTCOE (3,10)
+ CCOF = SGTCOE (4,10)
+ DCOF = SGTCOE (5,10)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SKMPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+* | | | Number of diagrams:
+ NDIAGR = 1
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 3
+ IQFSC2 = 0
+ IQBSC1 = 1 + KHELP
+ IQBSC2 = 2
+* | |
+* | +----------------------------------------------------------------*
+* | | K0's: (actually only K0bar)
+ ELSE
+ KHELP = KTARG / 8
+* | | +-------------------------------------------------------------*
+* | | | Proton target: (K0bar p)in supposed to be given by
+* | | | (K- p)in - Sig_diagr
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SKMPIN - SIGDIA
+* | | | Number of diagrams:
+ NDIAGR = 1
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: (K0bar n)in supposed to be given by
+* | | | (K- n)in + Sig_diagr
+* | | | besides isospin consideration it is supposed
+* | | | that (K- n)el is almost equal to (K- p)el
+* | | | (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,10)
+ BCOF = SGTCOE (2,10)
+ ENNE = SGTCOE (3,10)
+ CCOF = SGTCOE (4,10)
+ DCOF = SGTCOE (5,10)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SKMPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL + SIGDIA
+* | | | Number of diagrams:
+ NDIAGR = 2
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+ IQFSC1 = 3
+ IQFSC2 = 0
+ IQBSC1 = 1
+ IQBSC2 = 1 + KHELP
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* | end Kaon's
+* +-------------------------------------------------------------------*
+* | Antinucleons:
+ ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
+* | For momenta between 3 and 5 GeV/c the use of tabulated data
+* | should be implemented!
+ ACOF = SGTCOE (1,15)
+ BCOF = SGTCOE (2,15)
+ ENNE = SGTCOE (3,15)
+ CCOF = SGTCOE (4,15)
+ DCOF = SGTCOE (5,15)
+* | Compute the pbar p total cross section:
+ SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ IF ( PLA .LT. FIVFIV ) THEN
+ JREAC = 26
+ ELSE
+ JREAC = 25
+ END IF
+ ACOF = SGTCOE (1,JREAC)
+ BCOF = SGTCOE (2,JREAC)
+ ENNE = SGTCOE (3,JREAC)
+ CCOF = SGTCOE (4,JREAC)
+ DCOF = SGTCOE (5,JREAC)
+* | Compute the pbar p elastic cross section:
+ SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the pbar p inelastic cross section:
+ SAPPIN = SAPPTT - SAPPEL
+ ACOF = SGTCOE (1,12)
+ BCOF = SGTCOE (2,12)
+ ENNE = SGTCOE (3,12)
+ CCOF = SGTCOE (4,12)
+ DCOF = SGTCOE (5,12)
+* | Compute the p p total cross section:
+ SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+ ACOF = SGTCOE (1,23)
+ BCOF = SGTCOE (2,23)
+ ENNE = SGTCOE (3,23)
+ CCOF = SGTCOE (4,23)
+ DCOF = SGTCOE (5,23)
+* | Compute the p p elastic cross section:
+ SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | Compute the K- p inelastic cross section:
+ SPPINE = SPPTOT - SPPELA
+ SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
+ KHELP = KTARG / 8
+* | +----------------------------------------------------------------*
+* | | Pbar:
+ IF ( ICHRGE (IP) .NE. 0 ) THEN
+ NDIAGR = 5 - KHELP
+* | | +-------------------------------------------------------------*
+* | | | Proton target:
+ IF ( KHELP .EQ. 0 ) THEN
+* | | | Number of diagrams:
+ SHNCIN = SAPPIN
+ PUUBAR = 0.8D+00
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: it is supposed that (ap n)el is almost equal
+* | | | to (ap p)el (reasonable above 5 GeV/c)
+ ELSE
+ ACOF = SGTCOE (1,16)
+ BCOF = SGTCOE (2,16)
+ ENNE = SGTCOE (3,16)
+ CCOF = SGTCOE (4,16)
+ DCOF = SGTCOE (5,16)
+* | | | Compute the total cross section:
+ SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
+ & + DCOF * ALGPLA
+* | | | Compute the elastic cross section:
+ SHNCEL = SAPPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+ PUUBAR = HLFHLF
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+* | | there are different possibilities, make a random choiche:
+ IQFSC1 = -1
+ RNCHEN = DT_RNDM(PUUBAR)
+ IF ( RNCHEN .LT. PUUBAR ) THEN
+ IQFSC2 = -2
+ ELSE
+ IQFSC2 = -1
+ END IF
+ IQBSC1 = -IQFSC1 + KHELP
+ IQBSC2 = -IQFSC2
+* | |
+* | +----------------------------------------------------------------*
+* | | nbar:
+ ELSE
+ NDIAGR = 4 + KHELP
+* | | +-------------------------------------------------------------*
+* | | | Proton target: (nbar p)in supposed to be given by
+* | | | (pbar p)in - Sig_diagr
+ IF ( KHELP .EQ. 0 ) THEN
+ SHNCIN = SAPPIN - SIGDIA
+ PDDBAR = HLFHLF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | | Neutron target: (nbar n)el is supposed to be equal to
+* | | | (pbar p)el (reasonable above 5 GeV/c)
+ ELSE
+* | | | Compute the total cross section:
+ SHNCTT = SAPPTT
+* | | | Compute the elastic cross section:
+ SHNCEL = SAPPEL
+* | | | Compute the inelastic cross section:
+ SHNCIN = SHNCTT - SHNCEL
+ PDDBAR = 0.8D+00
+ END IF
+* | | |
+* | | +-------------------------------------------------------------*
+* | | Now compute the chain end (anti)quark-(anti)diquark
+* | | there are different possibilities, make a random choiche:
+ IQFSC1 = -2
+ RNCHEN = DT_RNDM(RNCHEN)
+ IF ( RNCHEN .LT. PDDBAR ) THEN
+ IQFSC2 = -1
+ ELSE
+ IQFSC2 = -2
+ END IF
+ IQBSC1 = -IQFSC1 + KHELP - 1
+ IQBSC2 = -IQFSC2
+ END IF
+* | |
+* | +----------------------------------------------------------------*
+* |
+* +-------------------------------------------------------------------*
+* | Others: not yet implemented
+ ELSE
+ SIGDIA = ZERZER
+ SHNCIN = ONEONE
+ NDIAGR = 0
+ DT_PHNSCH = ZERZER
+ RETURN
+ END IF
+* | end others
+* +-------------------------------------------------------------------*
+ DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
+ IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
+ & + IQECHR (IQBSC2)
+ IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
+ & + IQBCHR (IQBSC2)
+ IQECHC = IQECHC / 3
+ IQBCHC = IQBCHC / 3
+ IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
+ & + IQSCHR (IQBSC2)
+ IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
+ & + IQSCHR (MQUARK(3,IP))
+* +-------------------------------------------------------------------*
+* | Consistency check:
+ IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
+ WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
+ & DT_PHNSCH,KP,KTARG,PLA,' ****'
+ WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
+ & DT_PHNSCH,KP,KTARG,PLA,' ****'
+ DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
+ DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* +-------------------------------------------------------------------*
+* | Consistency check:
+ IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
+ & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
+ WRITE (LUNOUT,*)
+ &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
+ & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
+ WRITE (LUNERR,*)
+ &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
+ & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
+ END IF
+* |
+* +-------------------------------------------------------------------*
+* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
+ IF ( UMORAT .GT. ONEPLS )
+ & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
+ & - ONEONE ) * UMORAT + ONEONE )
+ RETURN
+*
+ ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
+ DT_SCHQUA = ONEONE
+ JQFSC1 = IQFSC1
+ JQFSC2 = IQFSC2
+ JQBSC1 = IQBSC1
+ JQBSC2 = IQBSC2
+*=== End of function Phnsch ===========================================*
+ RETURN
+ END
+*
+*===respt==============================================================*
+*
+CDECK ID>, DT_RESPT
+ SUBROUTINE DT_RESPT
+
+************************************************************************
+* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
+* 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 (TINY7=1.0D-7,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)
+
+* 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)) THEN
+C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
+* skip VV-,SS- systems
+ IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
+ & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
+* check if both "chains" are resonances
+ IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
+ CALL DT_SAPTRE(NC,NC+3)
+ ENDIF
+ ENDIF
+ ELSE
+ GOTO 3
+ ENDIF
+ NC = NC+6
+ GOTO 2
+
+ 3 CONTINUE
+
+ RETURN
+ END
+*
+*===evtres=============================================================*
+*
+CDECK ID>, DT_EVTRES
+ SUBROUTINE DT_EVTRES(IREJ)
+
+************************************************************************
+* This version dated 14.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY5=1.0D-5,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)
+* 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
+* 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)
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
+
+ IREJ = 0
+
+ DO 1 I=NPOINT(3),NHKK
+ IF (ABS(IDRES(I)).GE.100) THEN
+ AMMX = 0.0D0
+ DO 2 J=NPOINT(3),NHKK
+ IF (IDHKK(J).EQ.88888) THEN
+ IF (PHKK(5,J).GT.AMMX) THEN
+ AMMX = PHKK(5,J)
+ IMMX = J
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ IF (IDRES(IMMX).NE.0) THEN
+ IF (IOULEV(3).GT.0) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'EVTRES: no chain for correc. found'
+C GOTO 6
+ GOTO 9999
+ ELSE
+ GOTO 9999
+ ENDIF
+ ENDIF
+ IMO11 = JMOHKK(1,I)
+ IMO12 = JMOHKK(2,I)
+ IF (PHKK(3,IMO11).LT.0.0D0) THEN
+ IMO11 = JMOHKK(2,I)
+ IMO12 = JMOHKK(1,I)
+ ENDIF
+ IMO21 = JMOHKK(1,IMMX)
+ IMO22 = JMOHKK(2,IMMX)
+ IF (PHKK(3,IMO21).LT.0.0D0) THEN
+ IMO21 = JMOHKK(2,IMMX)
+ IMO22 = JMOHKK(1,IMMX)
+ ENDIF
+ AMCH1 = PHKK(5,I)
+ AMCH1N = AAM(IDXRES(I))
+
+ IFPR1 = IDHKK(IMO11)
+ IFPR2 = IDHKK(IMO21)
+ IFTA1 = IDHKK(IMO12)
+ IFTA2 = IDHKK(IMO22)
+ DO 4 J=1,4
+ PP1(J) = PHKK(J,IMO11)
+ PP2(J) = PHKK(J,IMO21)
+ PT1(J) = PHKK(J,IMO12)
+ PT2(J) = PHKK(J,IMO22)
+ 4 CONTINUE
+* store initial configuration for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
+* correct kinematics of second chain
+ CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+ & AMCH1,AMCH1N,AMCH2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+* check now this chain for resonance mass
+ IFP(1) = IDT_IPDG2B(IFPR2,1,2)
+ IFP(2) = 0
+ IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
+ IFT(1) = IDT_IPDG2B(IFTA2,1,2)
+ IFT(2) = 0
+ IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
+ IDCH2 = 2
+ IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
+ IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
+ CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
+ & AMCH2,AMCH2N,IDCH2,IREJ1)
+ IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,*) ' correction for resonance not poss.'
+**sr test
+C GOTO 1
+C GOTO 9999
+**
+ ENDIF
+* store final configuration for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
+ CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ DO 5 J=1,4
+ PHKK(J,IMO11) = PP1(J)
+ PHKK(J,IMO21) = PP2(J)
+ PHKK(J,IMO12) = PT1(J)
+ PHKK(J,IMO22) = PT2(J)
+ 5 CONTINUE
+* correct entries of chains
+ DO 3 K=1,4
+ PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
+ PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
+ 3 CONTINUE
+ AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
+ AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
+ & PHKK(3,IMMX)**2
+* ?? the following should now be obsolete
+**sr test
+C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
+ IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
+**
+ WRITE(LOUT,'(1X,A,4G10.3)')
+ & 'EVTRES: inonsistent mass-corr.',AM1,AM2
+C GOTO 9999
+ GOTO 1
+ ENDIF
+ PHKK(5,I) = SQRT(AM1)
+ PHKK(5,IMMX) = SQRT(AM2)
+ IDRES(I) = IDRES(I)/100
+ IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
+ & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
+ WRITE(LOUT,'(1X,A,4G10.3)')
+ & 'EVTRES: inconsistent chain-masses',
+ & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
+ GOTO 9999
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+ 6 CONTINUE
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===getspt=============================================================*
+*
+CDECK ID>, DT_GETSPT
+ SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
+ & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
+ & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
+
+************************************************************************
+* This version dated 12.12.94 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,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
+
+* 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
+* 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),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
+ & PT2(4),PT2I(4),P1(4),P2(4),
+ & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
+ & PTOTI(4),PTOTF(4),DIFF(4)
+
+ IC = 0
+ IREJ = 0
+C B33P = 4.0D0
+C B33T = 4.0D0
+C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
+C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
+ REDU = 1.0D0
+C B33P = 3.5D0
+C B33T = 3.5D0
+ B33P = 4.0D0
+ B33T = 4.0D0
+ IF (IDIFF.NE.0) THEN
+ B33P = 16.0D0
+ B33T = 16.0D0
+ ENDIF
+
+ DO 1 I=1,4
+ PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
+ PP1(I) = PP1I(I)
+ PP2(I) = PP2I(I)
+ PT1(I) = PT1I(I)
+ PT2(I) = PT2I(I)
+ 1 CONTINUE
+* get initial chain masses
+ 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.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
+ & AM1,AM2
+ GOTO 9999
+ ENDIF
+ AM1 = SQRT(AM1)
+ AM2 = SQRT(AM2)
+ AM1N = ZERO
+ AM2N = ZERO
+
+ MODE = 0
+C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
+C MODE = 0
+C ELSE
+C MODE = 1
+C IF (AM1.LT.0.6) THEN
+C B33P = 10.0D0
+C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
+CC B33P = 4.0D0
+C ENDIF
+C IF (AM2.LT.0.6) THEN
+C B33T = 10.0D0
+C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
+CC B33T = 4.0D0
+C ENDIF
+C ENDIF
+
+* check chain masses for very low mass chains
+C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
+C & AM1,DUM,-IDCH1,IREJ1)
+C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
+C & AM2,DUM,-IDCH2,IREJ2)
+C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
+C B33P = 20.0D0
+C B33T = 20.0D0
+C ENDIF
+
+ JMSHL = IMSHL
+
+ 2 CONTINUE
+ IC = IC+1
+ IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
+ IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
+ IF (MOD(IC,18).EQ.0) REDU = 0.0D0
+C IF (MOD(IC,19).EQ.0) JMSHL = 0
+ IF (MOD(IC,20).EQ.0) GOTO 7
+C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
+C RETURN
+C GOTO 9999
+C ENDIF
+
+* get transverse momentum
+ IF (LINTPT) THEN
+ ES = -2.0D0/(B33P**2)
+ & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
+ HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
+ HPSP = HPSP*REDU
+ ES = -2.0D0/(B33T**2)
+ & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
+ HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
+ HPST = HPST*REDU
+ ELSE
+ HPSP = ZERO
+ HPST = ZERO
+ ENDIF
+ CALL DT_DSFECF(SFE1,CFE1)
+ CALL DT_DSFECF(SFE2,CFE2)
+ IF (MODE.EQ.0) THEN
+ PP1(1) = PP1I(1)+HPSP*CFE1
+ PP1(2) = PP1I(2)+HPSP*SFE1
+ PP2(1) = PP2I(1)-HPSP*CFE1
+ PP2(2) = PP2I(2)-HPSP*SFE1
+ PT1(1) = PT1I(1)+HPST*CFE2
+ PT1(2) = PT1I(2)+HPST*SFE2
+ PT2(1) = PT2I(1)-HPST*CFE2
+ PT2(2) = PT2I(2)-HPST*SFE2
+ ELSE
+ PP1(1) = PP1I(1)+HPSP*CFE1
+ PP1(2) = PP1I(2)+HPSP*SFE1
+ PT1(1) = PT1I(1)-HPSP*CFE1
+ PT1(2) = PT1I(2)-HPSP*SFE1
+ PP2(1) = PP2I(1)+HPST*CFE2
+ PP2(2) = PP2I(2)+HPST*SFE2
+ PT2(1) = PT2I(1)-HPST*CFE2
+ PT2(2) = PT2I(2)-HPST*SFE2
+ ENDIF
+
+* put partons on mass shell
+ XMP1 = 0.0D0
+ XMT1 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XMP1 = PYMASS(IFPR1)
+ XMT1 = PYMASS(IFTA1)
+
+ ENDIF
+ CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ DO 3 I=1,4
+ PTOTF(I) = P1(I)+P2(I)
+ PP1(I) = P1(I)
+ PT1(I) = P2(I)
+ 3 CONTINUE
+ XMP2 = 0.0D0
+ XMT2 = 0.0D0
+ IF (JMSHL.EQ.1) THEN
+
+ XMP2 = PYMASS(IFPR2)
+ XMT2 = PYMASS(IFTA2)
+
+ ENDIF
+ CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ DO 4 I=1,4
+ PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
+ PP2(I) = P1(I)
+ PT2(I) = P2(I)
+ 4 CONTINUE
+
+* check consistency
+ DO 5 I=1,4
+ DIFF(I) = PTOTI(I)-PTOTF(I)
+ 5 CONTINUE
+ IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
+ & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
+ WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
+ GOTO 9999
+ ENDIF
+ PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
+ AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
+ PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
+ AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
+ PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
+ AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
+ PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
+ AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
+ IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
+ & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
+ & THEN
+ WRITE(LOUT,'(1X,A,2(4G10.3,/))')
+ & 'GETSPT: inconsistent masses',
+ & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
+* sr 22.11.00: commented. It should only have inconsistent masses for
+* ultrahigh energies due to rounding problems
+C GOTO 9999
+ ENDIF
+
+* get chain masses
+ PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+ & +(PP1(3)+PT1(3))**2)
+ ECH = PP1(4)+PT1(4)
+ AM1N = (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)
+ AM2N = (ECH+PTOCH)*(ECH-PTOCH)
+ IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
+ IF (IOULEV(1).GT.0)
+ & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
+ & AM1N,AM2N
+ GOTO 2
+ ENDIF
+ AM1N = SQRT(AM1N)
+ AM2N = SQRT(AM2N)
+
+* check chain masses for very low mass chains
+ CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
+ & AM1N,DUM,-IDCH1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 2
+ CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
+ & AM2N,DUM,-IDCH2,IREJ2)
+ IF (IREJ2.NE.0) GOTO 2
+
+ 7 CONTINUE
+ IF (AM1N.GT.ZERO) THEN
+ AM1 = AM1N
+ AM2 = AM2N
+ ENDIF
+ DO 6 I=1,4
+ PP1I(I) = PP1(I)
+ PP2I(I) = PP2(I)
+ PT1I(I) = PT1(I)
+ PT2I(I) = PT2(I)
+ 6 CONTINUE
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===saptre=============================================================*
+*
+CDECK ID>, DT_SAPTRE
+ SUBROUTINE DT_SAPTRE(IDX1,IDX2)
+
+************************************************************************
+* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
+* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
+* Adopted from the original SAPTRE written by J. Ranft. *
+* 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 (TINY7=1.0D-7,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)
+* 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 PA1(4),PA2(4),P1(4),P2(4)
+
+ DATA B3 /4.0D0/
+
+ ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
+ ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
+ ESMAX = MIN(ESMAX1,ESMAX2)
+ IF (ESMAX.LE.0.05D0) RETURN
+
+ HMA = PHKK(5,IDX1)
+ DO 1 K=1,4
+ PA1(K) = PHKK(K,IDX1)
+ PA2(K) = PHKK(K,IDX2)
+ 1 CONTINUE
+
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
+ ENDIF
+
+ EXEB = 0.0D0
+ IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
+ BEXP = HMA*(1.0D0-EXEB)/B3
+ AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
+ WA = AXEXP/(BEXP+AXEXP)
+ XAB = DT_RNDM(WA)
+ 10 CONTINUE
+* ES is the transverse kinetic energy
+ IF (XAB.LT.WA)THEN
+ X = DT_RNDM(WA)
+ Y = DT_RNDM(WA)
+ ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
+ ELSE
+ X = DT_RNDM(Y)
+ ES = ABS(-LOG(X+TINY7)/B3)
+ ENDIF
+ IF (ES.GT.ESMAX) GOTO 10
+ ES = ES+HMA
+* transverse momentum
+ HPS = SQRT((ES-HMA)*(ES+HMA))
+
+ CALL DT_DSFECF(SFE,CFE)
+ HPX = HPS*CFE
+ HPY = HPS*SFE
+ PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
+ PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
+ IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
+
+C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
+C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
+ PA1(1) = PA1(1)+HPX
+ PA1(2) = PA1(2)+HPY
+ PA2(1) = PA2(1)-HPX
+ PA2(2) = PA2(2)-HPY
+
+* put resonances on mass-shell again
+ XM1 = PHKK(5,IDX1)
+ XM2 = PHKK(5,IDX2)
+ CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) RETURN
+
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
+ IF (IREJ1.NE.0) RETURN
+ ENDIF
+
+ DO 2 K=1,4
+ PHKK(K,IDX1) = P1(K)
+ PHKK(K,IDX2) = P2(K)
+ 2 CONTINUE
+
+ RETURN
+ END
+*
+*===cronin=============================================================*
+*
+CDECK ID>, DT_CRONIN
+ SUBROUTINE DT_CRONIN(INCL)
+
+************************************************************************
+* Cronin-Effect. Multiple scattering of partons at chain ends. *
+* INCL = 1 multiple sc. in projectile *
+* = 2 multiple sc. in target *
+* This version dated 05.01.96 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)
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+
+ DIMENSION R(3),PIN(4),POUT(4),DEV(4)
+
+ DO 1 K=1,4
+ DEV(K) = ZERO
+ 1 CONTINUE
+
+ DO 2 I=NPOINT(2),NHKK
+ IF (ISTHKK(I).LT.0) THEN
+* get z-position of the chain
+ R(1) = VHKK(1,I)*1.0D12
+ IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
+ R(2) = VHKK(2,I)*1.0D12
+ IDXNU = JMOHKK(1,I)
+ IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
+ & IDXNU = JMOHKK(1,I-1)
+ IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
+ & IDXNU = JMOHKK(1,I+1)
+ R(3) = VHKK(3,IDXNU)*1.0D12
+* position of target parton the chain is connected to
+ DO 3 K=1,4
+ PIN(K) = PHKK(K,I)
+ 3 CONTINUE
+* multiple scattering of parton with DTEVT1-index I
+ CALL DT_CROMSC(PIN,R,POUT,INCL)
+**testprint
+C IF (NEVHKK.EQ.5) THEN
+C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
+C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
+C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
+C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
+C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
+C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
+C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
+C ENDIF
+**
+* increase accumulator by energy-momentum difference
+ DO 4 K=1,4
+ DEV(K) = DEV(K)+POUT(K)-PIN(K)
+ PHKK(K,I) = POUT(K)
+ 4 CONTINUE
+ PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+ & PHKK(2,I)**2-PHKK(3,I)**2))
+ ENDIF
+ 2 CONTINUE
+
+* dump accumulator to momenta of valence partons
+ NVAL = 0
+ ETOT = 0.0D0
+ DO 5 I=NPOINT(2),NHKK
+ IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
+ NVAL = NVAL+1
+ ETOT = ETOT+PHKK(4,I)
+ ENDIF
+ 5 CONTINUE
+C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
+ 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
+ & 9X,4E12.4)
+ DO 6 I=NPOINT(2),NHKK
+ IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
+ E = PHKK(4,I)
+ DO 7 K=1,4
+C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
+ PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
+ 7 CONTINUE
+ PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+ & PHKK(2,I)**2-PHKK(3,I)**2))
+ ENDIF
+ 6 CONTINUE
+
+ RETURN
+ END
+*
+*===cromsc=============================================================*
+*
+CDECK ID>, DT_CROMSC
+ SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
+
+************************************************************************
+* Cronin-Effect. Multiple scattering of one parton passing through *
+* nuclear matter. *
+* PIN(4) input 4-momentum of parton *
+* POUT(4) 4-momentum of parton after mult. scatt. *
+* R(3) spatial position of parton in target nucleus *
+* INCL = 1 multiple sc. in projectile *
+* = 2 multiple sc. in target *
+* This is a revised version of the original version written by J. Ranft*
+* This version dated 17.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)
+
+ LOGICAL LSTART
+
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* 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 PIN(4),POUT(4),R(3)
+
+ DATA LSTART /.TRUE./
+
+ IRCRON(1) = IRCRON(1)+1
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) CRONCO
+ 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
+ & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
+ LSTART = .FALSE.
+ ENDIF
+
+ NCBACK = 0
+ RNCL = RPROJ
+ IF (INCL.EQ.2) RNCL = RTARG
+
+* Lorentz-transformation into Lab.
+ MODE = -(INCL+1)
+ CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
+
+ PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
+ IF (PTOT.LE.8.0D0) GOTO 9997
+
+* direction cosines of parton before mult. scattering
+ COSX = PIN(1)/PTOT
+ COSY = PIN(2)/PTOT
+ COSZ = PZ/PTOT
+
+ RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
+ IF (RTESQ.GE.-TINY3) GOTO 9999
+
+* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
+* in the direction of particle motion
+
+ A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
+ TMP = A**2-RTESQ
+ IF (TMP.LT.ZERO) GOTO 9998
+ DIST = -A+SQRT(TMP)
+
+* multiple scattering angle
+ THETO = CRONCO*SQRT(DIST)/PTOT
+ IF (THETO.GT.0.1D0) THETO=0.1D0
+
+ 1 CONTINUE
+* Gaussian sampling of spatial angle
+ CALL DT_RANNOR(R1,R2)
+ THETA = ABS(R1*THETO)
+ IF (THETA.GT.0.3D0) GOTO 9997
+ CALL DT_DSFECF(SFE,CFE)
+ COSTH = COS(THETA)
+ SINTH = SIN(THETA)
+
+* new direction cosines
+ CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
+ & COSXN,COSYN,COSZN)
+
+ POUT(1) = COSXN*PTOT
+ POUT(2) = COSYN*PTOT
+ PZ = COSZN*PTOT
+* Lorentz-transformation into nucl.-nucl. cms
+ MODE = INCL+1
+ CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
+
+C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
+C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
+ IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
+ THETO = THETO/2.0D0
+ NCBACK = NCBACK+1
+ IF (MOD(NCBACK,200).EQ.0) THEN
+ WRITE(LOUT,1001) THETO,PIN,POUT
+ 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
+ & E12.4,/,1X,' PIN :',4E12.4,/,
+ & 1X,' POUT:',4E12.4)
+ GOTO 9997
+ ENDIF
+ GOTO 1
+ ENDIF
+
+ RETURN
+
+ 9997 IRCRON(2) = IRCRON(2)+1
+ GOTO 9999
+ 9998 IRCRON(3) = IRCRON(3)+1
+
+ 9999 CONTINUE
+ DO 100 K=1,4
+ POUT(K) = PIN(K)
+ 100 CONTINUE
+ RETURN
+ END
+*
+*===com2sr=============================================================*
+*
+CDECK ID>, DT_COM2CR
+ SUBROUTINE DT_COM2CR
+
+************************************************************************
+* COMbine q-aq chains to Color Ropes (qq-aqaq). *
+* CUTOF parameter determining minimum number of not *
+* combined q-aq chains *
+* This subroutine replaces KKEVCC etc. *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+* 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 IDXQA(248),IDXAQ(248)
+
+ ICCHAI(1,9) = ICCHAI(1,9)+1
+ NQA = 0
+ NAQ = 0
+* scan DTEVT1 for q-aq, aq-q chains
+ DO 10 I=NPOINT(3),NHKK
+* skip "chains" which are resonances
+ IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
+ MO1 = JMOHKK(1,I)
+ MO2 = JMOHKK(2,I)
+ IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
+* q-aq, aq-q chain found, keep index
+ IF (IDHKK(MO1).GT.0) THEN
+ NQA = NQA+1
+ IDXQA(NQA) = I
+ ELSE
+ NAQ = NAQ+1
+ IDXAQ(NAQ) = I
+ ENDIF
+ ENDIF
+ ENDIF
+ 10 CONTINUE
+
+* minimum number of q-aq chains requested for the same projectile/
+* target
+ NCHMIN = IDT_NPOISS(CUTOF)
+
+* combine q-aq chains of the same projectile
+ CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
+* combine q-aq chains of the same target
+ CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
+* combine aq-q chains of the same projectile
+ CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
+* combine aq-q chains of the same target
+ CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
+
+ RETURN
+ END
+*
+*===scn4cr=============================================================*
+*
+CDECK ID>, DT_SCN4CR
+ SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
+
+************************************************************************
+* SCan q-aq chains for Color Ropes. *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ DIMENSION IDXCH(248),IDXJN(248)
+
+ DO 1 I=1,NCH
+ IF (IDXCH(I).GT.0) THEN
+ NJOIN = 1
+ IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
+ IDXJN(NJOIN) = I
+ IF (I.LT.NCH) THEN
+ DO 2 J=I+1,NCH
+ IF (IDXCH(J).GT.0) THEN
+ IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
+ IF (IDXMO.EQ.IDXMO1) THEN
+ NJOIN = NJOIN+1
+ IDXJN(NJOIN) = J
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ IF (NJOIN.GE.NCHMIN+2) THEN
+ NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
+ DO 3 J=1,2*NJ,2
+ CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
+ IF (IREJ1.NE.0) GOTO 3
+ IDXCH(IDXJN(J)) = 0
+ IDXCH(IDXJN(J+1)) = 0
+ 3 CONTINUE
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===join===============================================================*
+*
+CDECK ID>, DT_JOIN
+ SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
+
+************************************************************************
+* This subroutine joins two q-aq chains to one qq-aqaq chain. *
+* IDX1, IDX2 DTEVT1 indices of chains to be joined *
+* This version dated 11.01.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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 MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
+
+ IREJ = 0
+
+ IDX(1) = IDX1
+ IDX(2) = IDX2
+ DO 1 I=1,2
+ DO 2 J=1,2
+ MO(I,J) = JMOHKK(J,IDX(I))
+ ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
+ 2 CONTINUE
+ 1 CONTINUE
+
+* check consistency
+ IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
+ & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
+ & ((ID(1,1)*ID(2,1)).LT.0).OR.
+ & ((ID(1,2)*ID(2,2)).LT.0)) THEN
+ WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
+ & MO(2,2)
+ 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
+ & 2I5,' chain ',I4,':',2I5)
+ ENDIF
+
+* join chains
+ DO 3 K=1,4
+ PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
+ PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
+ 3 CONTINUE
+ IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
+ IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
+ IST1 = ISTHKK(MO(1,1))
+ IST2 = ISTHKK(MO(1,2))
+
+* put partons again on mass shell
+ XM1 = 0.0D0
+ XM2 = 0.0D0
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IF1)
+ XM2 = PYMASS(IF2)
+
+ ENDIF
+ CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 I=1,4
+ PP(I) = P1(I)
+ PT(I) = P2(I)
+ 4 CONTINUE
+
+* store new partons in DTEVT1
+ CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
+ & 0,0,0)
+ CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
+ & 0,0,0)
+ DO 5 K=1,4
+ PCH(K) = PP(K)+PT(K)
+ 5 CONTINUE
+
+* check new chain for lower mass limit
+ IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+ AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
+ CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
+ & AMCH,AMCHN,3,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ NHKK = NHKK-2
+ GOTO 9999
+ ENDIF
+ ENDIF
+
+ ICCHAI(2,9) = ICCHAI(2,9)+1
+* store new chain in DTEVT1
+ KCH = 191
+ CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
+ IDHKK(IDX(1)) = 22222
+ IDHKK(IDX(2)) = 22222
+* special treatment for space-time coordinates
+ DO 6 K=1,4
+ VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
+ WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
+ 6 CONTINUE
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===xsglau=============================================================*
+*
+CDECK ID>, DT_XSGLAU
+ SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
+
+************************************************************************
+* Total, elastic, quasi-elastic, inelastic cross sections according to *
+* Glauber's approach. *
+* NA / NB mass numbers of proj./target nuclei *
+* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
+* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
+* IE,IQ indices of energy and virtuality (the latter for gamma *
+* projectiles only) *
+* NIDX index of projectile/target nucleus *
+* This version dated 17.3.98 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ COMPLEX*16 CZERO,CONE,CTWO
+ CHARACTER*12 CFILE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
+ & ONETHI=ONE/THREE,TINY25=1.0D-25)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & GEV2FM = 0.1972D0,
+ & ALPHEM = ONE/137.0D0,
+* proton mass
+ & AMP = 0.938D0,
+ & AMP2 = AMP**2,
+* approx. nucleon radius
+ & RNUCLE = 1.12D0)
+
+* 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)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+* 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
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* parameters for hA-diffraction
+ COMMON /DTDIHA/ DIBETA,DIALPH
+
+ COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
+ & OMPP11,OMPP12,OMPP21,OMPP22,
+ & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
+ & PPTMP1,PPTMP2
+ COMPLEX*16 C,CA,CI
+ DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
+ & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
+ & BPROD(KSITEB)
+
+ PARAMETER (NPOINT=16)
+ DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+
+ LOGICAL LFIRST,LOPEN
+ DATA LFIRST,LOPEN /.TRUE.,.FALSE./
+
+ NTARG = ABS(NIDX)
+* for quasi-elastic neutrino scattering set projectile to proton
+* it should not have an effect since the whole Glauber-formalism is
+* not needed for these interactions..
+ IF (MCGENE.EQ.4) THEN
+ IJPROJ = 1
+ ELSE
+ IJPROJ = JJPROJ
+ ENDIF
+
+ IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
+ I = INDEX(CGLB,' ')
+ IF (I.EQ.0) THEN
+ CFILE = CGLB//'.glb'
+ OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
+ ELSEIF (I.GT.1) THEN
+ CFILE = CGLB(1:I-1)//'.glb'
+ OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
+ ELSE
+ STOP 'XSGLAU 1'
+ ENDIF
+ LOPEN = .TRUE.
+ ENDIF
+
+ CZERO = DCMPLX(ZERO,ZERO)
+ CONE = DCMPLX(ONE,ZERO)
+ CTWO = DCMPLX(TWO,ZERO)
+ NEBINI = IE
+ NQBINI = IQ
+
+* re-define kinematics
+ S = ECMI**2
+ Q2 = Q2I
+ X = XI
+* g(Q2=0)-A, h-A, A-A scattering
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(S+Q2-AMP2)
+* g(Q2>0)-A scattering
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
+ X = Q2/(S+Q2-AMP2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
+ Q2 = (S-AMP2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ S = Q2*(ONE-X)/X+AMP2
+ ELSE
+ WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
+ STOP
+ ENDIF
+ ECMNN(IE) = SQRT(S)
+ Q2G(IQ) = Q2
+ XNU = (S+Q2-AMP2)/(TWO*AMP)
+
+* parameters determining statistics in evaluating Glauber-xsection
+ NSTATB = JSTATB
+ NSITEB = JBINSB
+ IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
+
+* set up interaction geometry (common /DTGLAM/)
+* projectile/target radii
+ RPRNCL = DT_RNCLUS(NA)
+ RTANCL = DT_RNCLUS(NB)
+ IF (IJPROJ.EQ.7) THEN
+ RASH(1) = ZERO
+ RBSH(NTARG) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
+ ELSE
+ IF (NIDX.LE.-1) THEN
+ RASH(1) = RPRNCL
+ RBSH(NTARG) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
+ ELSE
+ RASH(NTARG) = RPRNCL
+ RBSH(1) = RTANCL
+ BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
+ ENDIF
+ ENDIF
+* maximum impact-parameter
+ BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
+
+* slope, rho ( Re(f(0))/Im(f(0)) )
+ IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
+ & BSLOPE,0)
+ ELSE
+ BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
+ ENDIF
+ IF (ECMNN(IE).LE.3.0D0) THEN
+ ROSH = -0.43D0
+ ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
+ ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
+ ELSEIF (ECMNN(IE).GT.50.0D0) THEN
+ ROSH = 0.1D0
+ ENDIF
+ ELSEIF (IJPROJ.EQ.7) THEN
+ ROSH = 0.1D0
+ ELSE
+ BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
+ ROSH = 0.01D0
+ ENDIF
+
+* projectile-nucleon xsection (in fm)
+ IF (IJPROJ.EQ.7) THEN
+ SIGSH = DT_SIGVP(X,Q2)/10.0D0
+ ELSE
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+
+* parameters for projectile diffraction (hA scattering only)
+ IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
+ & .AND.(DIBETA.GE.ZERO)) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
+C DIBETA = SDIF1/STOT
+ DIBETA = 0.2D0
+ DIGAMM = SQRT(DIALPH**2+DIBETA**2)
+ IF (DIBETA.LE.ZERO) THEN
+ ALPGAM = ONE
+ ELSE
+ ALPGAM = DIALPH/DIGAMM
+ ENDIF
+ FACDI1 = ONE-ALPGAM
+ FACDI2 = ONE+ALPGAM
+ FACDI = SQRT(FACDI1*FACDI2)
+ WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
+ ELSE
+ DIBETA = -1.0D0
+ DIALPH = ZERO
+ DIGAMM = ZERO
+ FACDI1 = ZERO
+ FACDI2 = 2.0D0
+ FACDI = ZERO
+ ENDIF
+
+* initializations
+ DO 10 I=1,NSITEB
+ BSITE( 0,IQ,NTARG,I) = ZERO
+ BSITE(IE,IQ,NTARG,I) = ZERO
+ BPROD(I) = ZERO
+ 10 CONTINUE
+ STOT = ZERO
+ STOT2 = ZERO
+ SELA = ZERO
+ SELA2 = ZERO
+ SQEP = ZERO
+ SQEP2 = ZERO
+ SQET = ZERO
+ SQET2 = ZERO
+ SQE2 = ZERO
+ SQE22 = ZERO
+ SPRO = ZERO
+ SPRO2 = ZERO
+ SDEL = ZERO
+ SDEL2 = ZERO
+ SDQE = ZERO
+ SDQE2 = ZERO
+ FACN = ONE/DBLE(NSTATB)
+
+ IPNT = 0
+ RPNT = ZERO
+
+* initialize Gauss-integration for photon-proj.
+ JPOINT = 1
+ IF (IJPROJ.EQ.7) THEN
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECMNN(IE)-AMP)**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+ XAMLO = LOG( AMLO2+Q2 )
+ XAMHI = LOG( AMHI2+Q2 )
+**PHOJET105a
+C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+ CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+
+**
+ JPOINT = NPOINT
+* ratio direct/total photon-nucleon xsection
+ CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
+ ENDIF
+
+* read pre-initialized profile-function from file
+ IF (IOGLB.EQ.1) THEN
+ READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
+ IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
+ WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
+ & NA,NB,NSTATB,NSITEB
+ 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
+ & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
+ & ' (NA,NB,NSTATB,NSITEB) ',4I10)
+ STOP
+ ENDIF
+ IF (LFIRST) WRITE(LOUT,1001) CFILE
+ 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
+ & 'file ',A12,/)
+ READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
+ & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
+ & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
+ READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
+ & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
+ & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
+ NLINES = INT(DBLE(NSITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 21 I=1,NLINES
+ ISTART = 7*I-6
+ READ(LDAT,'(7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
+ 21 CONTINUE
+ ENDIF
+ ISTART = 7*NLINES+1
+ IF (ISTART.LE.NSITEB) THEN
+ READ(LDAT,'(7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
+ ENDIF
+ LFIRST = .FALSE.
+ GOTO 100
+* variable projectile/target/energy runs:
+* read pre-initialized profile-functions from file
+ ELSEIF (IOGLB.EQ.100) THEN
+ CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
+ GOTO 100
+ ENDIF
+
+* cross sections averaged over NSTATB nucleon configurations
+ DO 11 IS=1,NSTATB
+C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
+ STOTN = ZERO
+ SELAN = ZERO
+ SQEPN = ZERO
+ SQETN = ZERO
+ SQE2N = ZERO
+ SPRON = ZERO
+ SDELN = ZERO
+ SDQEN = ZERO
+
+ IF (NIDX.LE.-1) THEN
+ CALL DT_CONUCL(COOP1,NA,RASH(1),0)
+ CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ CALL DT_CONUCL(COOP2,NA,RASH(1),0)
+ CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
+ ENDIF
+ ELSE
+ CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
+ ENDIF
+ ENDIF
+
+* integration over impact parameter B
+ DO 12 IB=1,NSITEB-1
+ STOTB = ZERO
+ SELAB = ZERO
+ SQEPB = ZERO
+ SQETB = ZERO
+ SQE2B = ZERO
+ SPROB = ZERO
+ SDIR = ZERO
+ SDELB = ZERO
+ SDQEB = ZERO
+ B = DBLE(IB)*BSTEP(NTARG)
+ FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
+
+* integration over M_V^2 for photon-proj.
+ DO 14 IM=1,JPOINT
+ PP11(1) = CONE
+ PP12(1) = CONE
+ PP21(1) = CONE
+ PP22(1) = CONE
+ IF (IJPROJ.EQ.7) THEN
+ DO 13 K=2,NB
+ PP11(K) = CONE
+ PP12(K) = CONE
+ PP21(K) = CONE
+ PP22(K) = CONE
+ 13 CONTINUE
+ ENDIF
+ SHI = ZERO
+ FACM = ONE
+ DCOH = 1.0D10
+
+ IF (IJPROJ.EQ.7) THEN
+ AMV2 = EXP(ABSZX(IM))-Q2
+ AMV = SQRT(AMV2)
+ IF (AMV2.LT.16.0D0) THEN
+ R = TWO
+ ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
+ R = 10.0D0/3.0D0
+ ELSE
+ R = 11.0D0/3.0D0
+ ENDIF
+* define M_V dependent properties of nucleon scattering amplitude
+* V_M-nucleon xsection
+ SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
+ SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
+* slope-parametrisation a la Kaidalov
+ BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
+ & +0.25D0*LOG(S/(AMV2+Q2)))
+* coherence length
+ IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
+* integration weight factor
+ FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
+ & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
+ ENDIF
+ GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
+ GAM = GSH
+ IF (IJPROJ.EQ.7) THEN
+ RCA = GAM*SIGMV/TWOPI
+ ELSE
+ RCA = GAM*SIGSH/TWOPI
+ ENDIF
+ FCA = -ROSH*RCA
+ CA = DCMPLX(RCA,FCA)
+ CI = CONE
+
+ DO 15 INA=1,NA
+ KK1 = 1
+ INT1 = 1
+ KK2 = 1
+ INT2 = 1
+ DO 16 INB=1,NB
+* photon-projectile: check for supression by coherence length
+ IF (IJPROJ.EQ.7) THEN
+ IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
+ KK1 = INB
+ INT1 = INT1+1
+ ENDIF
+ IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
+ KK2 = INB
+ INT2 = INT2+1
+ ENDIF
+ ENDIF
+
+ X11 = B+COOT1(1,INB)-COOP1(1,INA)
+ Y11 = COOT1(2,INB)-COOP1(2,INA)
+ XY11 = GAM*(X11*X11+Y11*Y11)
+ IF (XY11.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY11)
+ AR = DBLE(PP11(INT1))
+ AI = DIMAG(PP11(INT1))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP11(INT1) = DCMPLX(AR,AI)
+ PP11(INT1) = PP11(INT1)*C
+ AR = DBLE(C)
+ AI = DIMAG(C)
+ SHI = SHI+LOG(AR*AR+AI*AI)
+ ENDIF
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ X12 = B+COOT2(1,INB)-COOP1(1,INA)
+ Y12 = COOT2(2,INB)-COOP1(2,INA)
+ XY12 = GAM*(X12*X12+Y12*Y12)
+ IF (XY12.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY12)
+ AR = DBLE(PP12(INT2))
+ AI = DIMAG(PP12(INT2))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP12(INT2) = DCMPLX(AR,AI)
+ PP12(INT2) = PP12(INT2)*C
+ ENDIF
+ X21 = B+COOT1(1,INB)-COOP2(1,INA)
+ Y21 = COOT1(2,INB)-COOP2(2,INA)
+ XY21 = GAM*(X21*X21+Y21*Y21)
+ IF (XY21.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY21)
+ AR = DBLE(PP21(INT1))
+ AI = DIMAG(PP21(INT1))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP21(INT1) = DCMPLX(AR,AI)
+ PP21(INT1) = PP21(INT1)*C
+ ENDIF
+ X22 = B+COOT2(1,INB)-COOP2(1,INA)
+ Y22 = COOT2(2,INB)-COOP2(2,INA)
+ XY22 = GAM*(X22*X22+Y22*Y22)
+ IF (XY22.LE.15.0D0) THEN
+ C = CONE-CA*EXP(-XY22)
+ AR = DBLE(PP22(INT2))
+ AI = DIMAG(PP22(INT2))
+ IF (ABS(AR).LT.TINY25) AR = ZERO
+ IF (ABS(AI).LT.TINY25) AI = ZERO
+ PP22(INT2) = DCMPLX(AR,AI)
+ PP22(INT2) = PP22(INT2)*C
+ ENDIF
+ ENDIF
+ 16 CONTINUE
+ 15 CONTINUE
+
+ OMPP11 = CZERO
+ OMPP21 = CZERO
+ DIPP11 = CZERO
+ DIPP21 = CZERO
+ DO 17 K=1,INT1
+ IF (PP11(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP11 = OMPP11+AVDIPP
+C OMPP11 = OMPP11+(CONE-PP11(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP11 = DIPP11+AVDIPP
+ IF (PP21(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP21 = OMPP21+AVDIPP
+C OMPP21 = OMPP21+(CONE-PP21(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP21 = DIPP21+AVDIPP
+ 17 CONTINUE
+ OMPP12 = CZERO
+ OMPP22 = CZERO
+ DIPP12 = CZERO
+ DIPP22 = CZERO
+ DO 18 K=1,INT2
+ IF (PP12(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP12 = OMPP12+AVDIPP
+C OMPP12 = OMPP12+(CONE-PP12(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP12 = DIPP12+AVDIPP
+ IF (PP22(K).EQ.CZERO) THEN
+ PPTMP1 = CZERO
+ PPTMP2 = CZERO
+ ELSE
+ PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
+ PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
+ ENDIF
+ AVDIPP = 0.5D0*
+ & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
+ OMPP22 = OMPP22+AVDIPP
+C OMPP22 = OMPP22+(CONE-PP22(K))
+ AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
+ DIPP22 = DIPP22+AVDIPP
+ 18 CONTINUE
+
+ SPROM = ONE-EXP(SHI)
+ SPROB = SPROB+FACM*SPROM
+ IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
+ STOTM = DBLE(OMPP11+OMPP22)
+ SELAM = DBLE(OMPP11*DCONJG(OMPP22))
+ SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
+ SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
+ SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
+ SDELM = DBLE(DIPP11*DCONJG(DIPP22))
+ SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
+ STOTB = STOTB+FACM*STOTM
+ SELAB = SELAB+FACM*SELAM
+ SDELB = SDELB+FACM*SDELM
+ IF (NB.GT.1) THEN
+ SQEPB = SQEPB+FACM*SQEPM
+ SDQEB = SDQEB+FACM*SDQEM
+ ENDIF
+ IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
+ IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
+ IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
+ ENDIF
+
+ 14 CONTINUE
+
+ STOTN = STOTN+FACB*STOTB
+ SELAN = SELAN+FACB*SELAB
+ SQEPN = SQEPN+FACB*SQEPB
+ SQETN = SQETN+FACB*SQETB
+ SQE2N = SQE2N+FACB*SQE2B
+ SPRON = SPRON+FACB*SPROB
+ SDELN = SDELN+FACB*SDELB
+ SDQEN = SDQEN+FACB*SDQEB
+
+ IF (IJPROJ.EQ.7) THEN
+ BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
+ ELSE
+ IF (DIBETA.GT.ZERO) THEN
+ BPROD(IB+1)= BPROD(IB+1)
+ & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
+ ELSE
+ BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
+ ENDIF
+ ENDIF
+
+ 12 CONTINUE
+
+ STOT = STOT +FACN*STOTN
+ STOT2 = STOT2+FACN*STOTN**2
+ SELA = SELA +FACN*SELAN
+ SELA2 = SELA2+FACN*SELAN**2
+ SQEP = SQEP +FACN*SQEPN
+ SQEP2 = SQEP2+FACN*SQEPN**2
+ SQET = SQET +FACN*SQETN
+ SQET2 = SQET2+FACN*SQETN**2
+ SQE2 = SQE2 +FACN*SQE2N
+ SQE22 = SQE22+FACN*SQE2N**2
+ SPRO = SPRO +FACN*SPRON
+ SPRO2 = SPRO2+FACN*SPRON**2
+ SDEL = SDEL +FACN*SDELN
+ SDEL2 = SDEL2+FACN*SDELN**2
+ SDQE = SDQE +FACN*SDQEN
+ SDQE2 = SDQE2+FACN*SDQEN**2
+
+ 11 CONTINUE
+
+* final cross sections
+* 1) total
+ XSTOT(IE,IQ,NTARG) = STOT
+ IF (IJPROJ.EQ.7)
+ & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
+* 2) elastic
+ XSELA(IE,IQ,NTARG) = SELA
+* 3) quasi-el.: A+B-->A+X (excluding 2)
+ XSQEP(IE,IQ,NTARG) = SQEP
+* 4) quasi-el.: A+B-->X+B (excluding 2)
+ XSQET(IE,IQ,NTARG) = SQET
+* 5) quasi-el.: A+B-->X (excluding 2-4)
+ XSQE2(IE,IQ,NTARG) = SQE2
+* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
+ IF (SDEL.GT.ZERO) THEN
+ XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
+ ELSE
+ XSPRO(IE,IQ,NTARG) = SPRO
+ ENDIF
+* 7) projectile diffraction (el. scatt. off target)
+ XSDEL(IE,IQ,NTARG) = SDEL
+* 8) projectile diffraction (quasi-el. scatt. off target)
+ XSDQE(IE,IQ,NTARG) = SDQE
+* stat. errors
+ XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
+ XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
+ XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
+ XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
+ XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
+ XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
+ XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
+ XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
+
+ IF (IJPROJ.EQ.7) THEN
+ BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
+ & -XSQEP(IE,IQ,NTARG)
+ ELSE
+ BNORM = XSPRO(IE,IQ,NTARG)
+ ENDIF
+ DO 19 I=2,NSITEB
+ BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
+ IF ((IE.EQ.1).AND.(IQ.EQ.1))
+ & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
+ 19 CONTINUE
+
+* write profile function data into file
+ IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
+ WRITE(LDAT,'(5I10,1P,E15.5)')
+ & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
+ WRITE(LDAT,'(1P,6E12.5)')
+ & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
+ & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
+ WRITE(LDAT,'(1P,6E12.5)')
+ & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
+ & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
+ NLINES = INT(DBLE(NSITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 20 I=1,NLINES
+ ISTART = 7*I-6
+ WRITE(LDAT,'(1P,7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
+ 20 CONTINUE
+ ENDIF
+ ISTART = 7*NLINES+1
+ IF (ISTART.LE.NSITEB) THEN
+ WRITE(LDAT,'(1P,7E11.4)')
+ & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
+ ENDIF
+ ENDIF
+
+ 100 CONTINUE
+
+C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
+
+ RETURN
+ END
+*
+*===getbxs=============================================================*
+*
+CDECK ID>, DT_GETBXS
+ SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
+
+************************************************************************
+* Biasing in impact parameter space. *
+* XSFRAC = 0 : BLO - minimum impact parameter (input) *
+* BHI - maximum impact parameter (input) *
+* XSFRAC - fraction of cross section corresponding *
+* to impact parameter range (BLO,BHI) *
+* (output) *
+* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
+* BHI - maximum impact parameter giving requested *
+* fraction of cross section in impact *
+* parameter range (0,BMAX) (output) *
+* This version dated 17.03.00 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)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+
+ NTARG = ABS(NIDX)
+ IF (XSFRAC.LE.0.0D0) THEN
+ ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
+ IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
+ IF (ILO.GE.IHI) THEN
+ XSFRAC = 0.0D0
+ RETURN
+ ENDIF
+ IF (ILO.EQ.NSITEB-1) THEN
+ FRCLO = BSITE(0,1,NTARG,NSITEB)
+ ELSE
+ FRCLO = BSITE(0,1,NTARG,ILO+1)
+ & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
+ & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
+ ENDIF
+ IF (IHI.EQ.NSITEB-1) THEN
+ FRCHI = BSITE(0,1,NTARG,NSITEB)
+ ELSE
+ FRCHI = BSITE(0,1,NTARG,IHI+1)
+ & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
+ & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
+ ENDIF
+ XSFRAC = FRCHI-FRCLO
+ ELSE
+ BLO = 0.0D0
+ BHI = BMAX(NTARG)
+ DO 1 I=1,NSITEB-1
+ IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
+ FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
+ & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
+ BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+*
+*===conucl=============================================================*
+*
+CDECK ID>, DT_CONUCL
+ SUBROUTINE DT_CONUCL(X,N,R,MODE)
+
+************************************************************************
+* Calculation of coordinates of nucleons within nuclei. *
+* X(3,N) spatial coordinates of nucleons (in fm) (output) *
+* N / R number of nucleons / radius of nucleus (input) *
+* MODE = 0 coordinates not sorted *
+* = 1 coordinates sorted with increasing X(3,i) *
+* = 2 coordinates sorted with decreasing X(3,i) *
+* This version dated 26.10.95 is revised 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,THREE=3.0D0,
+ & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
+
+ PARAMETER (TWOPI = 6.283185307179586454D+00 )
+
+ PARAMETER (NSRT=10)
+ DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
+ DIMENSION X(3,N),XTMP(3,260)
+
+ CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
+
+ IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
+ K = 0
+ DO 1 I=1,NSRT
+ IF (MODE.EQ.2) THEN
+ ISRT = NSRT+1-I
+ ELSE
+ ISRT = I
+ ENDIF
+ K1 = K
+ DO 2 J=1,ICSRT(ISRT)
+ K = K+1
+ X(1,K) = XTMP(1,IDXSRT(ISRT,J))
+ X(2,K) = XTMP(2,IDXSRT(ISRT,J))
+ X(3,K) = XTMP(3,IDXSRT(ISRT,J))
+ 2 CONTINUE
+ IF (ICSRT(ISRT).GT.1) THEN
+ I0 = K1+1
+ I1 = K
+ CALL DT_SORT(X,N,I0,I1,MODE)
+ ENDIF
+ 1 CONTINUE
+ ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
+ DO 3 I=1,N
+ X(1,I) = XTMP(1,I)
+ X(2,I) = XTMP(2,I)
+ X(3,I) = XTMP(3,I)
+ 3 CONTINUE
+ CALL DT_SORT(X,N,1,N,MODE)
+ ELSE
+ DO 4 I=1,N
+ X(1,I) = XTMP(1,I)
+ X(2,I) = XTMP(2,I)
+ X(3,I) = XTMP(3,I)
+ 4 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+*
+*===coordi=============================================================*
+*
+CDECK ID>, DT_COORDI
+ SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
+
+************************************************************************
+* Calculation of coordinates of nucleons within nuclei. *
+* X(3,N) spatial coordinates of nucleons (in fm) (output) *
+* N / R number of nucleons / radius of nucleus (input) *
+* Based on the original version by Shmakov et al. *
+* This version dated 26.10.95 is revised 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,THREE=3.0D0,
+ & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
+
+ PARAMETER (TWOPI = 6.283185307179586454D+00 )
+
+ LOGICAL LSTART
+
+ PARAMETER (NSRT=10)
+ DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
+ DIMENSION X(3,260),WD(4),RD(3)
+
+ DATA PDIF/0.545D0/,R2MIN/0.16D0/
+ DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
+ DATA RD /2.09D0, 0.935D0, 0.697D0/
+
+ X1SUM = ZERO
+ X2SUM = ZERO
+ X3SUM = ZERO
+
+ IF (N.EQ.1) THEN
+ X(1,1) = ZERO
+ X(2,1) = ZERO
+ X(3,1) = ZERO
+ ELSEIF (N.EQ.2) THEN
+ EPS = DT_RNDM(RD(1))
+ DO 30 I=1,3
+ IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 50 J=1,3
+ CALL DT_RANNOR(X1,X2)
+ X(J,1) = RD(I)*X1
+ X(J,2) = -X(J,1)
+ 50 CONTINUE
+ ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
+ SIGMA = R/SQRTWO
+ LSTART = .TRUE.
+ CALL DT_RANNOR(X3,X4)
+ DO 100 I=1,N
+ CALL DT_RANNOR(X1,X2)
+ X(1,I) = SIGMA*X1
+ X(2,I) = SIGMA*X2
+ IF (LSTART) GOTO 80
+ X(3,I) = SIGMA*X4
+ CALL DT_RANNOR(X3,X4)
+ GOTO 90
+ 80 CONTINUE
+ X(3,I) = SIGMA*X3
+ 90 CONTINUE
+ LSTART = .NOT.LSTART
+ X1SUM = X1SUM+X(1,I)
+ X2SUM = X2SUM+X(2,I)
+ X3SUM = X3SUM+X(3,I)
+ 100 CONTINUE
+ X1SUM = X1SUM/DBLE(N)
+ X2SUM = X2SUM/DBLE(N)
+ X3SUM = X3SUM/DBLE(N)
+ DO 101 I=1,N
+ X(1,I) = X(1,I)-X1SUM
+ X(2,I) = X(2,I)-X2SUM
+ X(3,I) = X(3,I)-X3SUM
+ 101 CONTINUE
+ ELSE
+
+* maximum nuclear radius for coordinate sampling
+ RMAX = R+4.605D0*PDIF
+
+* initialize pre-sorting
+ DO 121 I=1,NSRT
+ ICSRT(I) = 0
+ 121 CONTINUE
+ DR = TWO*RMAX/DBLE(NSRT)
+
+* sample coordinates for N nucleons
+ DO 140 I=1,N
+ 120 CONTINUE
+ RAD = RMAX*(DT_RNDM(DR))**ONETHI
+ F = DT_DENSIT(N,RAD,R)
+ IF (DT_RNDM(RAD).GT.F) GOTO 120
+* theta, phi uniformly distributed
+ CT = ONE-TWO*DT_RNDM(F)
+ ST = SQRT((ONE-CT)*(ONE+CT))
+ CALL DT_DSFECF(SFE,CFE)
+ X(1,I) = RAD*ST*CFE
+ X(2,I) = RAD*ST*SFE
+ X(3,I) = RAD*CT
+* ensure that distance between two nucleons is greater than R2MIN
+ IF (I.LT.2) GOTO 122
+ I1 = I-1
+ DO 130 I2=1,I1
+ DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
+ & (X(3,I)-X(3,I2))**2
+ IF (DIST2.LE.R2MIN) GOTO 120
+ 130 CONTINUE
+ 122 CONTINUE
+* save index according to z-bin
+ IDXZ = INT( (X(3,I)+RMAX)/DR )+1
+ ICSRT(IDXZ) = ICSRT(IDXZ)+1
+ IDXSRT(IDXZ,ICSRT(IDXZ)) = I
+ X1SUM = X1SUM+X(1,I)
+ X2SUM = X2SUM+X(2,I)
+ X3SUM = X3SUM+X(3,I)
+ 140 CONTINUE
+ X1SUM = X1SUM/DBLE(N)
+ X2SUM = X2SUM/DBLE(N)
+ X3SUM = X3SUM/DBLE(N)
+ DO 141 I=1,N
+ X(1,I) = X(1,I)-X1SUM
+ X(2,I) = X(2,I)-X2SUM
+ X(3,I) = X(3,I)-X3SUM
+ 141 CONTINUE
+
+ ENDIF
+
+ RETURN
+ END
+*
+*===densit=============================================================*
+*
+CDECK ID>, DT_DENSIT
+ DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO)
+
+ DIMENSION R0(18),FNORM(18)
+ DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
+ & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
+ & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
+ & 2.72D0, 2.66D0, 2.79D0/
+ DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
+ & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
+ & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
+ & .1214D+01,.1265D+01,.1318D+01/
+ DATA PDIF /0.545D0/
+
+ DT_DENSIT = ZERO
+* shell model
+ IF (NA.LE.4) THEN
+ STOP 'DT_DENSIT-0'
+ ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
+ R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
+ DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
+ & *EXP(-(R/R1)**2)/FNORM(NA)
+* Woods-Saxon
+ ELSEIF (NA.GT.18) THEN
+ DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
+ ENDIF
+
+ RETURN
+ END
+*
+*===rnclus=============================================================*
+*
+CDECK ID>, DT_RNCLUS
+ DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
+
+************************************************************************
+* Nuclear radius for nucleus with mass number N. *
+* This version dated 26.9.00 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
+
+* nucleon radius
+ PARAMETER (RNUCLE = 1.12D0)
+
+* nuclear radii for selected nuclei
+ DIMENSION RADNUC(18)
+ DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
+ & 2.58D0,2.71D0,2.66D0,2.71D0/
+
+ IF (N.LE.18) THEN
+ IF (RADNUC(N).GT.0.0D0) THEN
+ DT_RNCLUS = RADNUC(N)
+ ELSE
+ DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
+ ENDIF
+ ELSE
+ DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
+ ENDIF
+
+ RETURN
+ END
+*
+*===dentst=============================================================*
+*
+C PROGRAM DT_DENTST
+CDECK ID>, DT_DENTST
+ SUBROUTINE DT_DENTST
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
+ OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
+
+ RMIN = 0.0D0
+ RMAX = 8.0D0
+ NBINS = 500.0D0
+ DR = (RMAX-RMIN)/DBLE(NBINS)
+ DO 1 IA=5,18
+ FMAX = 0.0D0
+ DO 2 IR=1,NBINS+1
+ R = RMIN+DBLE(IR-1)*DR
+ F = DT_DENSIT(IA,R,R)
+ IF (F.GT.FMAX) FMAX = F
+ WRITE(40,'(1X,I3,2E15.5)') IA,R,F
+ 2 CONTINUE
+ WRITE(41,'(1X,I3,E15.5)') IA,FMAX
+ 1 CONTINUE
+
+ CLOSE(40)
+ CLOSE(41)
+
+ END
+*
+*===shmaki=============================================================*
+*
+CDECK ID>, DT_SHMAKI
+ SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
+
+************************************************************************
+* Initialisation of Glauber formalism. This subroutine has to be *
+* called once (in case of target emulsions as often as many different *
+* target nuclei are considered) before events are sampled. *
+* NA / NCA mass number/charge of projectile nucleus *
+* NB / NCB mass number/charge of target nucleus *
+* IJP identity of projectile (hadrons/leptons/photons) *
+* PPN projectile momentum (for projectile nuclei: *
+* momentum per nucleon) in target rest system *
+* MODE = 0 Glauber formalism invoked *
+* = 1 fitted results are loaded from data-file *
+* = 99 NTARG is forced to be 1 *
+* (used in connection with GLAUBERI-card only) *
+* This version dated 22.03.96 is based on the original SHMAKI-routine *
+* and revised 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,ONE=1.0D0,TWO=2.0D0,
+ & THREE=3.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* kinematical cuts for lepton-nucleus interactions
+ COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+ & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+* 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
+* cuts for variable energy runs
+ COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ DATA NTARG,ICOUT,IVEOUT /0,0,0/
+
+C CALL DT_HISHAD
+C STOP
+
+ NTARG = NTARG+1
+ IF (MODE.EQ.99) NTARG = 1
+ NIDX = -NTARG
+ IF (MODE.EQ.-1) NIDX = NTARG
+
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
+ IF (ICOUT.EQ.1) WRITE(LOUT,1000)
+ 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
+ & ' initialization',/,12X,'--------------------------',
+ & '-------------------------',/)
+
+ IF (MODE.EQ.2) THEN
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
+ CALL DT_SHFAST(MODE,PPN,IBACK)
+ STOP ' Glauber pre-initialization done'
+ ENDIF
+ IF (MODE.EQ.1) THEN
+ CALL DT_PROFBI(NA,NB,PPN,NTARG)
+ ELSE
+ IBACK = 1
+ IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
+ IF (IBACK.EQ.1) THEN
+* lepton-nucleus (variable energy runs)
+ IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
+ & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1002) NB,NCB
+ 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
+ & ' target A/Z: ',I3,' /',I3,/,/,8X,
+ & 'E_cm (GeV) Q^2 (GeV^2)',
+ & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
+ & '--------------------------------',
+ & '------------------------------')
+ AECMLO = LOG10(MIN(UMO,ECMLI))
+ AECMHI = LOG10(MIN(UMO,ECMHI))
+ IESTEP = NEB-1
+ DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
+ IF (AECMLO.EQ.AECMHI) IESTEP = 0
+ DO 1 I=1,IESTEP+1
+ ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
+ IF (Q2HI.GT.0.1D0) THEN
+ IF (Q2LI.LT.0.01D0) THEN
+ CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003)
+ & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ Q2LI = 0.01D0
+ IBIN = 2
+ ELSE
+ IBIN = 1
+ ENDIF
+ IQSTEP = NQB-IBIN
+ AQ2LO = LOG10(Q2LI)
+ AQ2HI = LOG10(Q2HI)
+ DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
+ DO 2 J=IBIN,IQSTEP+IBIN
+ Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
+ CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003) ECMNN(I),
+ & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
+ 2 CONTINUE
+ ELSE
+ CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1003)
+ & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ ENDIF
+ 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
+ 1 CONTINUE
+ IVEOUT = 1
+ ELSE
+* hadron/photon/nucleus-nucleus
+ IF ((ABS(VAREHI).GT.ZERO).AND.
+ & (ABS(VAREHI).GT.ABS(VARELO))) THEN
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
+ WRITE(LOUT,1004) NA,NB,NCB
+ 1004 FORMAT(1X,'variable energy run: projectile-id:',
+ & I3,' target A/Z: ',I3,' /',I3,/)
+ WRITE(LOUT,1005)
+ 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
+ & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
+ & ' -------------------------------------',
+ & '--------------------------------------')
+ ENDIF
+ AECMLO = LOG10(VARCLO)
+ AECMHI = LOG10(VARCHI)
+ IESTEP = NEB-1
+ DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
+ IF (AECMLO.EQ.AECMHI) IESTEP = 0
+ DO 3 I=1,IESTEP+1
+ ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
+ AMP = 0.938D0
+ AMT = 0.938D0
+ AMP2 = AMP**2
+ AMT2 = AMT**2
+ ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
+ PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
+ IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
+ & WRITE(LOUT,1006)
+ & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
+ 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
+ 3 CONTINUE
+ IVEOUT = 1
+ ELSE
+ CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
+ & (IOGLB.NE.100)) THEN
+ WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
+ & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
+ 1001 FORMAT(38X,'projectile',
+ & ' target',/,1X,'Mass number / charge',
+ & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
+ & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
+ & 'Parameters of elastic scattering amplitude:',/,5X,
+ & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
+ & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
+ & 'statistics at each b-step',4X,I5,/,/,1X,
+ & 'Prod. cross section ',5X,F10.4,' mb',/)
+ ENDIF
+
+ RETURN
+ END
+*
+*===profbi=============================================================*
+*
+CDECK ID>, DT_PROFBI
+ SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
+
+************************************************************************
+* Integral over profile function (to be used for impact-parameter *
+* sampling during event generation). *
+* Fitted results are used. *
+* NA / NB mass numbers of proj./target nuclei *
+* PPN projectile momentum (for projectile nuclei: *
+* momentum per nucleon) in target rest system *
+* NTARG index of target material (i.e. kind of nucleus) *
+* This version dated 31.05.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ SAVE
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
+
+ LOGICAL LSTART
+ CHARACTER CNAME*80
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+
+ PARAMETER (NGLMAX=8000)
+ DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
+ & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
+
+ DATA LSTART /.TRUE./
+
+ IF (LSTART) THEN
+* read fit-parameters from file
+ OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
+ I = 0
+ 1 CONTINUE
+ READ(47,'(A80)') CNAME
+ IF (CNAME.EQ.'STOP') GOTO 2
+ I = I+1
+ READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
+ & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
+ & GLAFIT(4,I),GLAFIT(5,I)
+ IF (I+1.GT.NGLMAX) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
+ & 'program stopped')
+ STOP
+ ENDIF
+ GOTO 1
+ 2 CONTINUE
+ NGLPAR = I
+ LSTART = .FALSE.
+ ENDIF
+
+ NNA = NA
+ NNB = NB
+ IF (NA.GT.NB) THEN
+ NNA = NB
+ NNB = NA
+ ENDIF
+ IDXGLA = 0
+ DO 3 J=1,NGLPAR
+ IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
+ IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
+ DO 4 K=1,J-1
+ IPOINT = J-K
+ IF (J.EQ.NGLPAR) IPOINT = J+1-K
+ IF ((NNA.GT.NGLIP(IPOINT)).OR.
+ & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
+ IF (IPOINT.EQ.1) IPOINT = 0
+ NATMP = NGLIP(IPOINT+1)
+ IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
+ IDXGLA = IPOINT+1
+ GOTO 6
+ ELSE
+ J1BEG = IPOINT+1
+ J1END = J
+C IF (J.EQ.NGLPAR) THEN
+C J1BEG = IPOINT
+C J1END = J
+C ENDIF
+ DO 5 J1=J1BEG,J1END
+ IF (NGLIP(J1).EQ.NATMP) THEN
+ IF (PPN.LT.GLAPPN(J1)) THEN
+ IDXGLA = J1
+ GOTO 6
+ ENDIF
+ ELSE
+ IDXGLA = J1-1
+ GOTO 6
+ ENDIF
+ 5 CONTINUE
+ IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
+ & IDXGLA = NGLPAR
+ ENDIF
+ ENDIF
+ 4 CONTINUE
+ ENDIF
+ 3 CONTINUE
+
+ 6 CONTINUE
+ IF (IDXGLA.EQ.0) THEN
+ WRITE(LOUT,1001) NNA,NNB,PPN
+ 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
+ & 2I4,F6.0,') not found ')
+ STOP
+ ENDIF
+
+* no interpolation yet available
+ XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
+
+ BSITE(1,1,NTARG,1) = ZERO
+ DO 10 I=2,NSITEB
+ XX = DBLE(I)
+ POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
+ & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
+ & GLAFIT(5,IDXGLA)*XX**4
+ IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
+ BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
+ IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
+ 10 CONTINUE
+
+ RETURN
+ END
+*
+*===glaube=============================================================*
+*
+CDECK ID>, DT_GLAUBE
+ SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
+
+************************************************************************
+* Calculation of configuartion of interacting nucleons for one event. *
+* NA / NB mass numbers of proj./target nuclei (input) *
+* B impact parameter (output) *
+* INTT total number of wounded nucleons " *
+* INTA / INTB number of wounded nucleons in proj. / target " *
+* JS / JT(i) number of collisions proj. / target nucleon i is *
+* involved (output) *
+* NIDX index of projectile/target material (input)*
+* This is an update of the original routine SHMAKO by J.Ranft/HJM *
+* This version dated 22.03.96 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+* 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
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* Glauber formalism: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ DIMENSION JS(MAXNCL),JT(MAXNCL)
+
+ NTARG = ABS(NIDX)
+
+* get actual energy from /DTLTRA/
+ ECMNOW = UMO
+ Q2 = VIRT
+*
+* new patch for pre-initialized variable projectile/target/energy runs
+ IF (IOGLB.EQ.100) THEN
+ CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
+*
+* variable energy run, interpolate profile function
+ ELSE
+ I1 = 1
+ I2 = 1
+ RATE = ONE
+ IF (NEBINI.GT.1) THEN
+ IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
+ DO 1 I=2,NEBINI
+ IF (ECMNOW.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ONE
+ IF (NQBINI.GT.1) THEN
+ IF (Q2.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (Q2.GT.Q2G(1)) THEN
+ DO 3 I=2,NQBINI
+ IF (Q2.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
+ GOTO 4
+ ENDIF
+ 3 CONTINUE
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ DO 5 I=1,KSITEB
+ BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
+ & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
+ & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
+ & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
+ & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
+ 5 CONTINUE
+ ENDIF
+
+ CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
+ IF (NIDX.LE.-1) THEN
+ RPROJ = RASH(1)
+ RTARG = RBSH(NTARG)
+ ELSE
+ RPROJ = RASH(NTARG)
+ RTARG = RBSH(1)
+ ENDIF
+
+ RETURN
+ END
+*
+*===diagr==============================================================*
+*
+CDECK ID>, DT_DIAGR
+ SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
+ & NIDX)
+
+************************************************************************
+* Based on the original version by Shmakov et al. *
+* This version dated 21.04.95 is revised 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,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & GEV2FM = 0.1972D0,
+ & ALPHEM = ONE/137.0D0,
+* proton mass
+ & AMP = 0.938D0,
+ & AMP2 = AMP**2,
+* rho0 mass
+ & AMRHO0 = 0.77D0)
+
+ COMPLEX*16 C,CA,CI
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+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)
+
+ 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
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+**PHOJET105a
+C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+**PHOJET112
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+**
+* 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)
+* statistics: Glauber-formalism
+ COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+
+ DIMENSION JS(MAXNCL),JT(MAXNCL),
+ & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
+ & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
+ DIMENSION NWA(0:210),NWB(0:210)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+ DATA NTARGO,ICNT /0,0/
+
+ NTARG = ABS(NIDX)
+
+ IF (LFIRST) THEN
+ LFIRST = .FALSE.
+ IF (NCOMPO.EQ.0) THEN
+ NCALL = 0
+ NWAMAX = NA
+ NWBMAX = NB
+ DO 17 I=0,210
+ NWA(I) = 0
+ NWB(I) = 0
+ 17 CONTINUE
+ ENDIF
+ ENDIF
+ IF (NTARG.EQ.-1) THEN
+ IF (NCOMPO.EQ.0) THEN
+ WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
+ WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
+ & NCALL,NWAMAX,NWBMAX
+ DO 18 I=1,MAX(NWAMAX,NWBMAX)
+ WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
+ & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
+ & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
+ 18 CONTINUE
+ ENDIF
+ RETURN
+ ENDIF
+
+ DCOH = 1.0D10
+ IPNT = 0
+
+ SQ2 = Q2
+ IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
+ S = ECMNOW**2
+ X = SQ2/(S+SQ2-AMP2)
+ XNU = (S+SQ2-AMP2)/(TWO*AMP)
+* photon projectiles: recalculate photon-nucleon amplitude
+ IF (IJPROJ.EQ.7) THEN
+ 15 CONTINUE
+* VDM assumption: mass of V-meson
+ AMV2 = DT_SAM2(SQ2,ECMNOW)
+ AMV = SQRT(AMV2)
+ IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
+* check for pointlike interaction
+ CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
+**sr 27.10.
+C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
+ SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
+**
+ ROSH = 0.1D0
+ BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
+ & +0.25D0*LOG(S/(AMV2+SQ2)))
+* coherence length
+ IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
+ ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
+ & BSLOPE,0)
+ ELSE
+ BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
+ ENDIF
+ IF (ECMNOW.LE.3.0D0) THEN
+ ROSH = -0.43D0
+ ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
+ ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
+ ELSEIF (ECMNOW.GT.50.0D0) THEN
+ ROSH = 0.1D0
+ ENDIF
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+ IF (MCGENE.EQ.2) THEN
+ ZERO1 = ZERO
+ CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
+ & BDUM,0)
+ SIGSH = SIGSH/10.0D0
+ ELSE
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+ ELSE
+ BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
+ ROSH = 0.01D0
+ ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
+ PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
+C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
+ DUMZER = ZERO
+ CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
+ SIGSH = SIGSH/10.0D0
+ ENDIF
+ GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
+ GAM = GSH
+ RCA = GAM*SIGSH/TWOPI
+ FCA = -ROSH*RCA
+ CA = DCMPLX(RCA,FCA)
+ CI = DCMPLX(ONE,ZERO)
+
+ 16 CONTINUE
+* impact parameter
+ IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
+
+ NTRY = 0
+ 3 CONTINUE
+ NTRY = NTRY+1
+* initializations
+ JNT = 0
+ DO 1 I=1,NA
+ JS(I) = 0
+ 1 CONTINUE
+ DO 2 I=1,NB
+ JT(I) = 0
+ 2 CONTINUE
+ IF (IJPROJ.EQ.7) THEN
+ DO 8 I=1,MAXNCL
+ JS0(I) = 0
+ JNT0(I)= 0
+ DO 9 J=1,NB
+ JT0(I,J) = 0
+ 9 CONTINUE
+ 8 CONTINUE
+ ENDIF
+
+* nucleon configuration
+C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
+ IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
+C CALL DT_CONUCL(PKOO,NA,RASH,2)
+C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
+ IF (NIDX.LE.-1) THEN
+ CALL DT_CONUCL(PKOO,NA,RASH(1),0)
+ CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
+ ELSE
+ CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
+ CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
+ ENDIF
+ NTARGO = NTARG
+ ENDIF
+ ICNT = ICNT+1
+
+* LEPTO: pick out one struck nucleon
+ IF (MCGENE.EQ.3) THEN
+ JNT = 1
+ JS(1) = 1
+ IDX = INT(DT_RNDM(X)*NB)+1
+ JT(IDX) = 1
+ B = ZERO
+ GOTO 19
+ ENDIF
+
+ DO 4 INA=1,NA
+* cross section fluctuations
+ AFLUC = ONE
+ IF (IFLUCT.EQ.1) THEN
+ IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
+ AFLUC = FLUIXX(IFLUK)
+ ENDIF
+ KK1 = 1
+ KINT = 1
+ DO 5 INB=1,NB
+* photon-projectile: check for supression by coherence length
+ IF (IJPROJ.EQ.7) THEN
+ IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
+ KK1 = INB
+ KINT = KINT+1
+ ENDIF
+ ENDIF
+ QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
+ QQ2 = TKOO(2,INB)-PKOO(2,INA)
+ XY = GAM*(QQ1*QQ1+QQ2*QQ2)
+ IF (XY.LE.15.0D0) THEN
+ C = CI-CA*AFLUC*EXP(-XY)
+ AR = DBLE(C)
+ AI = DIMAG(C)
+ P = AR*AR+AI*AI
+ IF (DT_RNDM(XY).GE.P) THEN
+ JNT = JNT+1
+ IF (IJPROJ.EQ.7) THEN
+ JNT0(KINT) = JNT0(KINT)+1
+ IF (JNT0(KINT).GT.MAXNCL) THEN
+ WRITE(LOUT,1001) MAXNCL
+ 1001 FORMAT(1X,
+ & 'DIAGR: no. of requested interactions',
+ & ' exceeds array dimensions ',I4)
+ STOP
+ ENDIF
+ JS0(KINT) = JS0(KINT)+1
+ JT0(KINT,INB) = JT0(KINT,INB)+1
+ JI1(KINT,JNT0(KINT)) = INA
+ JI2(KINT,JNT0(KINT)) = INB
+ ELSE
+ IF (JNT.GT.MAXINT) THEN
+ WRITE(LOUT,1000) JNT, MAXINT
+ 1000 FORMAT(1X,
+ & 'DIAGR: no. of requested interactions ('
+ & ,I4,') exceeds array dimensions (',I4,')')
+ STOP
+ ENDIF
+ JS(INA) = JS(INA)+1
+ JT(INB) = JT(INB)+1
+ INTER1(JNT) = INA
+ INTER2(JNT) = INB
+ ENDIF
+ ENDIF
+ ENDIF
+ 5 CONTINUE
+ 4 CONTINUE
+
+ IF (JNT.EQ.0) THEN
+ IF (NTRY.LT.500) THEN
+ GOTO 3
+ ELSE
+C WRITE(6,*) ' new impact parameter required (old= ',B,')'
+ GOTO 16
+ ENDIF
+ ENDIF
+
+ IDIREC = 0
+ IF (IJPROJ.EQ.7) THEN
+ K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
+ 10 CONTINUE
+ IF (JNT0(K).EQ.0) THEN
+ K = K+1
+ IF (K.GT.KINT) K = 1
+ GOTO 10
+ ENDIF
+* supress Glauber-cascade by direct photon processes
+ CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
+ IF (IPNT.GT.0) THEN
+ JNT = 1
+ JS(1) = 1
+ DO 11 INB=1,NB
+ JT(INB) = JT0(K,INB)
+ IF (JT(INB).GT.0) GOTO 12
+ 11 CONTINUE
+ 12 CONTINUE
+ INTER1(1) = 1
+ INTER2(1) = INB
+ IDIREC = IPNT
+ ELSE
+ JNT = JNT0(K)
+ JS(1) = JS0(K)
+ DO 13 INB=1,NB
+ JT(INB) = JT0(K,INB)
+ 13 CONTINUE
+ DO 14 I=1,JNT
+ INTER1(I) = JI1(K,I)
+ INTER2(I) = JI2(K,I)
+ 14 CONTINUE
+ ENDIF
+ ENDIF
+
+ 19 CONTINUE
+ INTA = 0
+ INTB = 0
+ DO 6 I=1,NA
+ IF (JS(I).NE.0) INTA=INTA+1
+ 6 CONTINUE
+ DO 7 I=1,NB
+ IF (JT(I).NE.0) INTB=INTB+1
+ 7 CONTINUE
+ ICWPG = INTA
+ ICWTG = INTB
+ ICIG = JNT
+ IPGLB = IPGLB+INTA
+ ITGLB = ITGLB+INTB
+ NGLB = NGLB+1
+
+ IF (NCOMPO.EQ.0) THEN
+ NCALL = NCALL+1
+ NWA(INTA) = NWA(INTA)+1
+ NWB(INTB) = NWB(INTB)+1
+ ENDIF
+
+ RETURN
+ END
+*
+*===modb===============================================================*
+*
+CDECK ID>, DT_MODB
+ SUBROUTINE DT_MODB(B,NIDX)
+
+************************************************************************
+* Sampling of impact parameter of collision. *
+* B impact parameter (output) *
+* NIDX index of projectile/target material (input)*
+* Based on the original version by Shmakov et al. *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
+
+ LOGICAL LEFT,LFIRST
+
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+
+ DATA LFIRST /.TRUE./
+
+ NTARG = ABS(NIDX)
+ IF (NIDX.LE.-1) THEN
+ RA = RASH(1)
+ RB = RBSH(NTARG)
+ ELSE
+ RA = RASH(NTARG)
+ RB = RBSH(1)
+ ENDIF
+
+ IF (ICENTR.EQ.2) THEN
+ IF (RA.EQ.RB) THEN
+ BB = DT_RNDM(B)*(0.3D0*RA)**2
+ B = SQRT(BB)
+ ELSEIF(RA.LT.RB)THEN
+ BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
+ B = SQRT(BB)
+ ELSEIF(RA.GT.RB)THEN
+ BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
+ B = SQRT(BB)
+ ENDIF
+ ELSE
+ 9 CONTINUE
+ Y = DT_RNDM(BB)
+ I0 = 1
+ I2 = NSITEB
+ 10 CONTINUE
+ I1 = (I0+I2)/2
+ LEFT = ((BSITE(0,1,NTARG,I0)-Y)
+ & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
+ IF (LEFT) GOTO 20
+ I0 = I1
+ GOTO 30
+ 20 CONTINUE
+ I2 = I1
+ 30 CONTINUE
+ IF (I2-I0-2) 40,50,60
+ 40 CONTINUE
+ I1 = I2+1
+ IF (I1.GT.NSITEB) I1 = I0-1
+ GOTO 70
+ 50 CONTINUE
+ I1 = I0+1
+ GOTO 70
+ 60 CONTINUE
+ GOTO 10
+ 70 CONTINUE
+ X0 = DBLE(I0-1)*BSTEP(NTARG)
+ X1 = DBLE(I1-1)*BSTEP(NTARG)
+ X2 = DBLE(I2-1)*BSTEP(NTARG)
+ Y0 = BSITE(0,1,NTARG,I0)
+ Y1 = BSITE(0,1,NTARG,I1)
+ Y2 = BSITE(0,1,NTARG,I2)
+ 80 CONTINUE
+ B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
+ & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
+ & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
+**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
+ B = B+0.5D0*BSTEP(NTARG)
+ IF (B.LT.ZERO) B = X1
+ IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
+ IF (ICENTR.LT.0) THEN
+ IF (LFIRST) THEN
+ LFIRST = .FALSE.
+ IF (ICENTR.LE.-100) THEN
+ BIMIN = 0.0D0
+ ELSE
+ XSFRAC = 0.0D0
+ ENDIF
+ CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
+ WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
+ & BIMIN,BIMAX,XSFRAC*100.0D0,
+ & XSFRAC*XSPRO(1,1,NTARG)
+ 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
+ & /,15X,'---------------------------'/,/,4X,
+ & 'average radii of proj / targ :',F10.3,' fm /',
+ & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
+ & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
+ & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
+ & ' cross section :',F10.3,' %',/,5X,
+ & 'corresponding cross section :',F10.3,' mb',/)
+ ENDIF
+ IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
+ B = BIMIN
+ ELSE
+ IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+*
+*===shfast=============================================================*
+*
+CDECK ID>, DT_SHFAST
+ SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
+ & ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* Glauber formalism: parameters
+ COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+ & BMAX(NCOMPX),BSTEP(NCOMPX),
+ & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+ & NSITEB,NSTATB
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* 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
+
+ IBACK = 0
+
+ IF (MODE.EQ.2) THEN
+ OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
+ WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
+ 1000 FORMAT(1X,8I5,E15.5)
+ WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
+ 1001 FORMAT(1X,4E15.5)
+ WRITE(47,1002) SIGSH,ROSH,GSH
+ 1002 FORMAT(1X,3E15.5)
+ DO 10 I=1,100
+ WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
+ 10 CONTINUE
+ WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
+ 1003 FORMAT(1X,2I10,3E15.5)
+ CLOSE(47)
+ ELSE
+ OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
+ READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
+ IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
+ & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
+ & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
+ & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
+ READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
+ READ(47,1002) SIGSH,ROSH,GSH
+ DO 11 I=1,100
+ READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
+ 11 CONTINUE
+ READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
+ ELSE
+ IBACK = 1
+ ENDIF
+ CLOSE(47)
+ ENDIF
+
+ RETURN
+ END
+*
+*===poilik=============================================================*
+*
+CDECK ID>, DT_POILIK
+ SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
+ PARAMETER (NE = 8)
+
+**PHOJET105a
+C CHARACTER*8 MDLNA
+C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+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 energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+**sr 22.7.97
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+**
+
+ DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
+
+ IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
+
+* load cross sections from interpolation table
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+
+ SIGANO = DT_SANO(ECM)
+
+* cross section dependence on photon virtuality
+ FSUP1 = ZERO
+ DO 150 I=1,3
+ FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
+ & /(ONE+VIRT/PARMDL(30+I))**2
+ 150 CONTINUE
+ FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
+ FAC1 = FAC1*FSUP1
+ FAC2 = FAC2*FSUP1
+ FSUP2 = ONE
+
+ ECMOLD = ECM
+ Q2OLD = VIRT
+
+ 3 CONTINUE
+
+C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
+ IF (ISHAD(1).EQ.1) THEN
+ SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+ ELSE
+ SIGDIR = ZERO
+ ENDIF
+ SIGANO = FSUP1*FSUP2*SIGANO
+ SIGTOT = SIGTOT-SIGDIR-SIGANO
+ SIGDIR = SIGDIR/(FSUP1*FSUP2)
+ SIGANO = SIGANO/(FSUP1*FSUP2)
+ SIGTOT = SIGTOT+SIGDIR+SIGANO
+
+ RR = DT_RNDM(SIGTOT)
+ IF (RR.LT.SIGDIR/SIGTOT) THEN
+ IPNT = 1
+ ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
+ & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
+ IPNT = 2
+ ELSE
+ IPNT = 0
+ ENDIF
+ RPNT = (SIGDIR+SIGANO)/SIGTOT
+C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
+C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
+C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
+C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
+ IF (MODE.EQ.1) RETURN
+
+**sr 22.7.97
+ K1 = 1
+ K2 = 1
+ RATE = ZERO
+ IF (ECM.GE.ECMNN(NEBINI)) THEN
+ K1 = NEBINI
+ K2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECM.GT.ECMNN(1)) THEN
+ DO 10 I=2,NEBINI
+ IF (ECM.LT.ECMNN(I)) THEN
+ K1 = I-1
+ K2 = I
+ RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
+ GOTO 11
+ ENDIF
+ 10 CONTINUE
+ 11 CONTINUE
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ZERO
+ IF (NQBINI.GT.1) THEN
+ IF (VIRT.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (VIRT.GT.Q2G(1)) THEN
+ DO 12 I=2,NQBINI
+ IF (VIRT.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+ GOTO 13
+ ENDIF
+ 12 CONTINUE
+ 13 CONTINUE
+ ENDIF
+ ENDIF
+ SGA = XSPRO(K1,J1,NTARG)+
+ & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
+ & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
+ & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
+ & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
+ SDI = DBLE(NB)*SIGDIR
+ SAN = DBLE(NB)*SIGANO
+ SPL = SDI+SAN
+ RR = DT_RNDM(SPL)
+ IF (RR.LT.SDI/SGA) THEN
+ IPNT = 1
+ ELSEIF ((RR.GE.SDI/SGA).AND.
+ & (RR.LT.SPL/SGA)) THEN
+ IPNT = 2
+ ELSE
+ IPNT = 0
+ ENDIF
+ RPNT = SPL/SGA
+C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
+**
+
+ RETURN
+ END
+*
+*===glbini=============================================================*
+*
+CDECK ID>, DT_GLBINI
+ SUBROUTINE DT_GLBINI(WHAT)
+
+************************************************************************
+* Pre-initialization of profile function *
+* This version dated 28.11.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,TINY14=1.D-14)
+
+ LOGICAL LCMS
+
+* 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
+
+ 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
+* number of data sets other than protons and nuclei
+* at the moment = 2 (pions and kaons)
+ PARAMETER (MAXOFF=2)
+ DIMENSION IJPINI(5),IOFFST(25)
+ DATA IJPINI / 13, 15, 0, 0, 0/
+* Glauber data-set to be used for hadron projectiles
+* (0=proton, 1=pion, 2=kaon)
+ DATA (IOFFST(K),K=1,25) /
+ & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
+ & 0, 0, 1, 2, 2/
+* Acceptance interval for target nucleus mass
+ PARAMETER (KBACC = 6)
+
+ PARAMETER (MAXMSS = 100)
+ DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
+ DIMENSION WHAT(6)
+
+ DATA JPEACH,JPSTEP / 18, 5 /
+
+* temporary patch until fix has been implemented in phojet:
+* maximum energy for pion projectile
+ DATA ECMXPI / 100000.0D0 /
+*
+*--------------------------------------------------------------------------
+* general initializations
+*
+* steps in projectile mass number for initialization
+ IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
+ IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
+*
+* energy range and binning
+ ELO = ABS(WHAT(1))
+ EHI = ABS(WHAT(2))
+ IF (ELO.GT.EHI) ELO = EHI
+ NEBIN = MAX(INT(WHAT(3)),1)
+ IF (ELO.EQ.EHI) NEBIN = 0
+ LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
+ IF (LCMS) THEN
+ ECMINI = EHI
+ ELSE
+ ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
+ & +2.0D0*AAM(IJTARG)*EHI)
+ ENDIF
+*
+* default arguments for Glauber-routine
+ XI = ZERO
+ Q2I = ZERO
+*
+* initialize nuclear parameters, etc.
+
+ CALL BERTTP
+ CALL INCINI
+
+*
+* open Glauber-data output file
+ IDX = INDEX(CGLB,' ')
+ K = 12
+ IF (IDX.GT.1) K = IDX-1
+ OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
+*
+*--------------------------------------------------------------------------
+* Glauber-initialization for proton and nuclei projectiles
+*
+* initialize phojet for proton-proton interactions
+ ELAB = ZERO
+ PLAB = ZERO
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
+ CALL DT_PHOINI
+*
+* record projectile masses
+ NASAV = 0
+ NPROJ = MIN(IP,JPEACH)
+ DO 10 KPROJ=1,NPROJ
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = KPROJ
+ 10 CONTINUE
+ IF (IP.GT.JPEACH) THEN
+ NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
+ IF (NPROJ.EQ.0) THEN
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = IP
+ ELSE
+ DO 11 IPROJ=1,NPROJ
+ KPROJ = JPEACH+IPROJ*JPSTEP
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = KPROJ
+ 11 CONTINUE
+ IF (KPROJ.LT.IP) THEN
+ NASAV = NASAV+1
+ IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
+ IASAV(NASAV) = IP
+ ENDIF
+ ENDIF
+ ENDIF
+*
+* record target masses
+ NBSAV = 0
+ NTARG = 1
+ IF (NCOMPO.GT.0) NTARG = NCOMPO
+ DO 12 ITARG=1,NTARG
+ NBSAV = NBSAV+1
+ IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
+ IF (NCOMPO.GT.0) THEN
+ IBSAV(NBSAV) = IEMUMA(ITARG)
+ ELSE
+ IBSAV(NBSAV) = IT
+ ENDIF
+ 12 CONTINUE
+*
+* print masses
+ WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
+ 1000 FORMAT(I4,A,1P,2E13.5)
+ NLINES = DBLE(NASAV)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 13 I=1,NLINES
+ IF (I.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
+ ENDIF
+ 13 CONTINUE
+ ENDIF
+ I0 = 18*NLINES+1
+ IF (I0.LE.NASAV) THEN
+ IF (I0.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
+ ENDIF
+ ENDIF
+ NLINES = DBLE(NBSAV)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 14 I=1,NLINES
+ IF (I.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
+ ENDIF
+ 14 CONTINUE
+ ENDIF
+ I0 = 18*NLINES+1
+ IF (I0.LE.NBSAV) THEN
+ IF (I0.EQ.1) THEN
+ WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
+ ELSE
+ WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
+ ENDIF
+ ENDIF
+*
+* calculate Glauber-data for each energy and mass combination
+*
+* loop over energy bins
+ ELO = LOG10(ELO)
+ EHI = LOG10(EHI)
+ DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
+ DO 1 IE=1,NEBIN+1
+ E = ELO+DBLE(IE-1)*DEBIN
+ E = 10**E
+ IF (LCMS) THEN
+ E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
+ ECM = E
+ ELSE
+ PLAB = ZERO
+ ECM = ZERO
+ E = MAX(AAM(IJPROJ)+0.1D0,E)
+ CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
+ ENDIF
+*
+* loop over projectile and target masses
+ DO 2 ITARG=1,NBSAV
+ DO 3 IPROJ=1,NASAV
+ CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
+ & XI,Q2I,ECM,1,1,-1)
+ 3 CONTINUE
+ 2 CONTINUE
+*
+ 1 CONTINUE
+*
+*--------------------------------------------------------------------------
+* Glauber-initialization for pion, kaon, ... projectiles
+*
+ DO 6 IJ=1,MAXOFF
+*
+* initialize phojet for this interaction
+ ELAB = ZERO
+ PLAB = ZERO
+ IJPROJ = IJPINI(IJ)
+ IP = 1
+ IPZ = 1
+*
+* temporary patch until fix has been implemented in phojet:
+ IF (ECMINI.GT.ECMXPI) THEN
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
+ ELSE
+ CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
+ ENDIF
+ CALL DT_PHOINI
+*
+* calculate Glauber-data for each energy and mass combination
+*
+* loop over energy bins
+ DO 4 IE=1,NEBIN+1
+ E = ELO+DBLE(IE-1)*DEBIN
+ E = 10**E
+ IF (LCMS) THEN
+ E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
+ ECM = E
+ ELSE
+ PLAB = ZERO
+ ECM = ZERO
+ E = MAX(AAM(IJPROJ)+TINY14,E)
+ CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
+ ENDIF
+*
+* loop over projectile and target masses
+ DO 5 ITARG=1,NBSAV
+ CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
+ 5 CONTINUE
+*
+ 4 CONTINUE
+*
+ 6 CONTINUE
+
+*--------------------------------------------------------------------------
+* close output unit(s), etc.
+*
+ CLOSE(LDAT)
+
+ RETURN
+ END
+*
+*===glbset=============================================================*
+*
+CDECK ID>, DT_GLBSET
+ SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
+************************************************************************
+* Interpolation of pre-initialized profile functions *
+* This version dated 28.11.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)
+
+ LOGICAL LCMS,LREAD,LFRST1,LFRST2
+
+* 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: flags and parameters for statistics
+ LOGICAL LPROD
+ CHARACTER*8 CGLB
+ COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+* number of data sets other than protons and nuclei
+* at the moment = 2 (pions and kaons)
+ PARAMETER (MAXOFF=2)
+ DIMENSION IJPINI(5),IOFFST(25)
+ DATA IJPINI / 13, 15, 0, 0, 0/
+* Glauber data-set to be used for hadron projectiles
+* (0=proton, 1=pion, 2=kaon)
+ DATA (IOFFST(K),K=1,25) /
+ & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
+ & 0, 0, 1, 2, 2/
+* Acceptance interval for target nucleus mass
+ PARAMETER (KBACC = 6)
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+ PARAMETER (MAXSET=5000,
+ & MAXBIN=100)
+ DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
+ DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
+ & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
+ & IAIDX(10)
+
+ DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
+*
+* read data from file
+*
+ IF (MODE.EQ.0) THEN
+
+ IF (LREAD) RETURN
+
+ DO 1 I=1,MAXSET
+ DO 2 J=1,6
+ XSIG(I,J) = ZERO
+ XERR(I,J) = ZERO
+ 2 CONTINUE
+ DO 3 J=1,KSITEB
+ BPROFL(I,J) = ZERO
+ 3 CONTINUE
+ 1 CONTINUE
+ DO 4 I=1,MAXBIN
+ IABIN(I) = 0
+ IBBIN(I) = 0
+ 4 CONTINUE
+ DO 5 I=1,KSITEB
+ BPRO0(I) = ZERO
+ BPRO1(I) = ZERO
+ BPRO(I) = ZERO
+ 5 CONTINUE
+
+ IDX = INDEX(CGLB,' ')
+ K = 12
+ IF (IDX.GT.1) K = IDX-1
+ OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
+ WRITE(LOUT,1000) CGLB(1:K)//'.glb'
+ 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
+ & 'file ',A12,/)
+*
+* read binning information
+ READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
+* return lower energy threshold to Fluka-interface
+ ELAB = ELO
+ LCMS = ELO.LT.ZERO
+ WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
+ IF (LCMS) THEN
+ WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
+ ELSE
+ WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
+ ENDIF
+ 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
+ & 'No. of bins:',I5,/)
+ ELO = LOG10(ABS(ELO))
+ EHI = LOG10(ABS(EHI))
+ DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
+ WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
+ READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
+ IF (NABIN.LT.18) THEN
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
+ ELSE
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
+ ENDIF
+ IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
+ IF (NABIN.GT.18) THEN
+ NLINES = DBLE(NABIN-18)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 7 I=1,NLINES
+ I0 = 18*(I+1)-17
+ READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
+ 7 CONTINUE
+ ENDIF
+ I0 = 18*(NLINES+1)+1
+ IF (I0.LE.NABIN) THEN
+ READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
+ WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
+ ENDIF
+ ENDIF
+ WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
+ READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
+ IF (NBBIN.LT.18) THEN
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
+ ELSE
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
+ ENDIF
+ IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
+ IF (NBBIN.GT.18) THEN
+ NLINES = DBLE(NBBIN-18)/18.0D0
+ IF (NLINES.GT.0) THEN
+ DO 8 I=1,NLINES
+ I0 = 18*(I+1)-17
+ READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
+ 8 CONTINUE
+ ENDIF
+ I0 = 18*(NLINES+1)+1
+ IF (I0.LE.NBBIN) THEN
+ READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
+ WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
+ ENDIF
+ ENDIF
+* number of data sets to follow in the Glauber data file
+* this variable is used for checks of consistency of projectile
+* and target mass configurations given in header of Glauber data
+* file and the data-sets which follow in this file
+ NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
+*
+* read profile function data
+ NSET = 0
+ NAIDX = 0
+ IPOLD = 0
+ 10 CONTINUE
+ NSET = NSET+1
+ IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
+ READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
+ 1002 FORMAT(5I10,E15.5)
+ IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
+ NAIDX = NAIDX+1
+ IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
+ IAIDX(NAIDX) = IP
+ IPOLD = IP
+ ENDIF
+ READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
+ READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
+ NLINES = INT(DBLE(ISITEB)/7.0D0)
+ IF (NLINES.GT.0) THEN
+ DO 11 I=1,NLINES
+ READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
+ 11 CONTINUE
+ ENDIF
+ I0 = 7*NLINES+1
+ IF (I0.LE.ISITEB)
+ & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
+ GOTO 10
+ 100 CONTINUE
+ NSET = NSET-1
+ IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
+ WRITE(LOUT,'(/,1X,A)')
+ & ' projectiles other than protons and nuclei: (particle index)'
+ IF (NAIDX.GT.0) THEN
+ WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
+ ELSE
+ WRITE(LOUT,'(6X,A)') 'none'
+ ENDIF
+*
+ CLOSE(LDAT)
+ WRITE(LOUT,*)
+ LREAD = .TRUE.
+
+ IF (NCOMPO.EQ.0) THEN
+ DO 12 J=1,NBBIN
+ NCOMPO = NCOMPO+1
+ IEMUMA(NCOMPO) = IBBIN(J)
+ IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
+ EMUFRA(NCOMPO) = 1.0D0
+ 12 CONTINUE
+ IEMUL = 1
+ ENDIF
+*
+* calculate profile function for certain set of parameters
+*
+ ELSE
+
+c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
+*
+* check for type of projectile and set index-offset to entry in
+* Glauber data array correspondingly
+ IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
+ IF (IOFFST(IDPROJ).EQ.-1) THEN
+ STOP ' GLBSET: no data for this projectile !'
+ ELSEIF (IOFFST(IDPROJ).GT.0) THEN
+ IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
+ ELSE
+ IDXOFF = 0
+ ENDIF
+*
+* get energy bin and interpolation factor
+ IF (LCMS) THEN
+ E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
+ ELSE
+ E = ELAB
+ ENDIF
+ E = LOG10(E)
+ IF (E.LT.ELO) THEN
+ IF (LFRST1) THEN
+ WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
+ LFRST1 = .FALSE.
+ ENDIF
+ E = ELO
+ ENDIF
+ IF (E.GT.EHI) THEN
+ IF (LFRST2) THEN
+ WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
+ LFRST2 = .FALSE.
+ ENDIF
+ E = EHI
+ ENDIF
+ IE0 = (E-ELO)/DEBIN+1
+ IE1 = IE0+1
+ FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
+*
+* get target nucleus index
+ KB = 0
+ NBACC = KBACC
+ DO 20 I=1,NBBIN
+ NBDIFF = ABS(NB-IBBIN(I))
+ IF (NB.EQ.IBBIN(I)) THEN
+ KB = I
+ GOTO 21
+ ELSEIF (NBDIFF.LE.NBACC) THEN
+ KB = I
+ NBACC = NBDIFF
+ ENDIF
+ 20 CONTINUE
+ IF (KB.NE.0) GOTO 21
+ WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
+ STOP
+ 21 CONTINUE
+*
+* get projectile nucleus bin and interpolation factor
+ KA0 = 0
+ KA1 = 0
+ FACNA = 0
+ IF (IDXOFF.GT.0) THEN
+ KA0 = 1
+ KA1 = 1
+ KABIN = 1
+ ELSE
+ IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
+ DO 22 I=1,NABIN
+ IF (NA.EQ.IABIN(I)) THEN
+ KA0 = I
+ KA1 = I
+ GOTO 23
+ ELSEIF (NA.LT.IABIN(I)) THEN
+ KA0 = I-1
+ KA1 = I
+ GOTO 23
+ ENDIF
+ 22 CONTINUE
+ WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
+ STOP
+ 23 CONTINUE
+ IF (KA0.NE.KA1)
+ & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
+ KABIN = NABIN
+ ENDIF
+*
+* interpolate profile functions for interactions ka0-kb and ka1-kb
+* for energy E separately
+ IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
+ IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
+ IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
+ IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
+ DO 30 I=1,ISITEB
+ BPRO0(I) = BPROFL(IDX0,I)
+ & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
+ BPRO1(I) = BPROFL(IDY0,I)
+ & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
+ 30 CONTINUE
+ RADB = DT_RNCLUS(NB)
+ BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
+ BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
+*
+* interpolate cross sections for energy E and projectile mass
+ DO 31 I=1,6
+ XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
+ XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
+ XS(I) = XS0+FACNA*(XS1-XS0)
+ XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
+ XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
+ XE(I) = XE0+FACNA*(XE1-XE0)
+ 31 CONTINUE
+*
+* interpolate between ka0 and ka1
+ RADA = DT_RNCLUS(NA)
+ BMX = 2.0D0*(RADA+RADB)
+ BSTP = BMX/DBLE(ISITEB-1)
+ BPRO(1) = ZERO
+ DO 32 I=1,ISITEB-1
+ B = DBLE(I)*BSTP
+*
+* calculate values of profile functions at B
+ IDX0 = B/BSTP0+1
+ IF (IDX0.GT.ISITEB) IDX0 = ISITEB
+ IDX1 = MIN(IDX0+1,ISITEB)
+ FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
+ BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
+ IDX0 = B/BSTP1+1
+ IF (IDX0.GT.ISITEB) IDX0 = ISITEB
+ IDX1 = MIN(IDX0+1,ISITEB)
+ FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
+ BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
+*
+ BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
+ 32 CONTINUE
+*
+* fill common dtglam
+ NSITEB = ISITEB
+ RASH(1) = RADA
+ RBSH(1) = RADB
+ BMAX(1) = BMX
+ BSTEP(1) = BSTP
+ DO 33 I=1,KSITEB
+ BSITE(0,1,1,I) = BPRO(I)
+ 33 CONTINUE
+*
+* fill common dtglxs
+ XSTOT(1,1,1) = XS(1)
+ XSELA(1,1,1) = XS(2)
+ XSQEP(1,1,1) = XS(3)
+ XSQET(1,1,1) = XS(4)
+ XSQE2(1,1,1) = XS(5)
+ XSPRO(1,1,1) = XS(6)
+ XETOT(1,1,1) = XE(1)
+ XEELA(1,1,1) = XE(2)
+ XEQEP(1,1,1) = XE(3)
+ XEQET(1,1,1) = XE(4)
+ XEQE2(1,1,1) = XE(5)
+ XEPRO(1,1,1) = XE(6)
+
+ ENDIF
+
+ RETURN
+ END
+*
+*===xksamp=============================================================*
+*
+CDECK ID>, DT_XKSAMP
+ SUBROUTINE DT_XKSAMP(NN,ECM)
+
+************************************************************************
+* Sampling of parton x-values and chain system for one interaction. *
+* processed by S. Roesler, 9.8.95 *
+************************************************************************
+
+ 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,ONE=1.0D0)
+ SAVE
+
+ PARAMETER (
+* lower cuts for (valence-sea/sea-valence) chain masses
+* antiquark-quark (u/d-sea quark) (s-sea quark)
+ & AMIU = 0.5D0, AMIS = 0.8D0,
+* quark-diquark (u/d-sea quark) (s-sea quark)
+ & AMAU = 2.6D0, AMAS = 2.6D0,
+* maximum lower valence-x threshold
+ & XVMAX = 0.98D0,
+* fraction of sea-diquarks sampled out of sea-partons
+**test
+C & FRCDIQ = 0.9D0,
+**
+*
+ & SQMA = 0.7D0,
+*
+* maximum number of trials to generate x's for the required number
+* of sea quark pairs for a given hadron
+C & NSEATY = 12
+ & NSEATY = 3
+ & )
+
+ LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
+
+ 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)
+* 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)
+* interface between Glauber formalism and DPM
+ COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
+ & INTER1(MAXINT),INTER2(MAXINT)
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+* 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)
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+* 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 ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
+ & INTLO(MAXINT)
+
+* (1) initializations
+*-----------------------------------------------------------------------
+
+**test
+ IF (ECM.LT.4.5D0) THEN
+C FRCDIQ = 0.6D0
+ FRCDIQ = 0.4D0
+ ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
+C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
+ FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
+ ELSE
+C FRCDIQ = 0.9D0
+ FRCDIQ = 0.7D0
+ ENDIF
+**
+ DO 30 I=1,MAXSQU
+ ZUOSP(I) = .FALSE.
+ ZUOST(I) = .FALSE.
+ IF (I.LE.MAXVQU) THEN
+ ZUOVP(I) = .FALSE.
+ ZUOVT(I) = .FALSE.
+ ENDIF
+ 30 CONTINUE
+
+* lower thresholds for x-selection
+* sea-quarks (default: CSEA=0.2)
+ IF (ECM.LT.10.0D0) THEN
+**!!test
+ XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
+C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
+ NSEA = NSEATY
+C XSTHR = ONE/ECM**2
+ ELSE
+**sr 30.3.98
+C XSTHR = CSEA/ECM
+ XSTHR = CSEA/ECM**2
+C XSTHR = ONE/ECM**2
+**
+ IF ((IP.GE.150).AND.(IT.GE.150))
+ & XSTHR = 2.5D0/(ECM*SQRT(ECM))
+ NSEA = NSEATY
+ ENDIF
+* (default: SSMIMA=0.14) used for sea-diquarks (?)
+ XSSTHR = SSMIMA/ECM
+ BSQMA = SQMA/ECM
+* valence-quarks (default: CVQ=1.0)
+ XVTHR = CVQ/ECM
+* valence-diquarks (default: CDQ=2.0)
+ XDTHR = CDQ/ECM
+
+* maximum-x for sea-quarks
+ XVCUT = XVTHR+XDTHR
+ IF (XVCUT.GT.XVMAX) THEN
+ XVCUT = XVMAX
+ XVTHR = XVCUT/3.0D0
+ XDTHR = XVCUT-XVTHR
+ ENDIF
+ XXSEAM = ONE-XVCUT
+**sr 18.4. test: DPMJET
+C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
+C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
+C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
+**
+* maximum number of sea-pairs allowed kinematically
+C NSMAX = INT(OHALF*XXSEAM/XSTHR)
+ RNSMAX = OHALF*XXSEAM/XSTHR
+ IF (RNSMAX.GT.10000.0D0) THEN
+ NSMAX = 10000
+ ELSE
+ NSMAX = INT(OHALF*XXSEAM/XSTHR)
+ ENDIF
+* check kinematical limit for valence-x thresholds
+* (should be obsolete now)
+ IF (XVCUT.GT.XVMAX) THEN
+ WRITE(LOUT,1000) XVCUT,ECM
+ 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
+ & ' thresholds not allowed (',2E9.3,')')
+C XVTHR = XVMAX-XDTHR
+C IF (XVTHR.LT.ZERO) STOP
+ STOP
+ ENDIF
+
+* set eta for valence-x sampling (BETREJ)
+* (UNON per default, UNOM used for projectile mesons only)
+ IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
+ UNOPRV = UNOM
+ ELSE
+ UNOPRV = UNON
+ ENDIF
+
+* (2) select parton x-values of interacting projectile nucleons
+*-----------------------------------------------------------------------
+
+ IXPV = 0
+ IXPS = 0
+
+ DO 100 IPP=1,IP
+* get interacting projectile nucleon as sampled by Glauber
+ IF (JSSH(IPP).NE.0) THEN
+ IXSTMP = IXPS
+ IXVTMP = IXPV
+ 99 CONTINUE
+ IXPS = IXSTMP
+ IXPV = IXVTMP
+* JIPP is the actual number of sea-pairs sampled for this nucleon
+ JIPP = MIN(JSSH(IPP)-1,NSMAX)
+ 41 CONTINUE
+ XXSEA = ZERO
+ IF (JIPP.GT.0) THEN
+ XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
+*???
+ IF (XSTHR.GE.XSMAX) THEN
+ JIPP = JIPP-1
+ GOTO 41
+ ENDIF
+
+*>>>get x-values of sea-quark pairs
+ NSCOUN = 0
+ PLW = 0.5D0
+ 40 CONTINUE
+* accumulator for sea x-values
+ XXSEA = ZERO
+ NSCOUN = NSCOUN+1
+ IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
+ IF (NSCOUN.GT.NSEA) THEN
+* decrease the number of interactions after NSEA trials
+ JIPP = JIPP-1
+ NSCOUN = 0
+ ENDIF
+ DO 70 ISQ=1,JIPP
+* sea-quarks
+ IF (IPSQ(IXPS+1).LE.2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+* sea-antiquarks
+ IF (IPSAQ(IXPS+1).GE.-2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+ XXSEA = XXSEA+XPSQI+XPSAQI
+* check for maximum allowed sea x-value
+ IF (XXSEA.GE.XXSEAM) THEN
+ IXPS = IXPS-ISQ+1
+ GOTO 40
+ ENDIF
+* accept this sea-quark pair
+ IXPS = IXPS+1
+ XPSQ(IXPS) = XPSQI
+ XPSAQ(IXPS) = XPSAQI
+ IFROSP(IXPS) = IPP
+ ZUOSP(IXPS) = .TRUE.
+ 70 CONTINUE
+ ENDIF
+
+*>>>get x-values of valence partons
+* valence quark
+ IF (XVTHR.GT.0.05D0) THEN
+ XVHI = ONE-XXSEA-XDTHR
+ XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
+ ELSE
+ 90 CONTINUE
+ XPVQI = DT_DBETAR(OHALF,UNOPRV)
+ IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
+ & GOTO 90
+ ENDIF
+* valence diquark
+ XPVDI = ONE-XPVQI-XXSEA
+* reject according to x**1.5
+ XDTMP = XPVDI**1.5D0
+ IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
+* accept these valence partons
+ IXPV = IXPV+1
+ XPVQ(IXPV) = XPVQI
+ XPVD(IXPV) = XPVDI
+ IFROVP(IXPV) = IPP
+ ITOVP(IPP) = IXPV
+ ZUOVP(IXPV) = .TRUE.
+
+ ENDIF
+ 100 CONTINUE
+
+* (3) select parton x-values of interacting target nucleons
+*-----------------------------------------------------------------------
+
+ IXTV = 0
+ IXTS = 0
+
+ DO 170 ITT=1,IT
+* get interacting target nucleon as sampled by Glauber
+ IF (JTSH(ITT).NE.0) THEN
+ IXSTMP = IXTS
+ IXVTMP = IXTV
+ 169 CONTINUE
+ IXTS = IXSTMP
+ IXTV = IXVTMP
+* JITT is the actual number of sea-pairs sampled for this nucleon
+ JITT = MIN(JTSH(ITT)-1,NSMAX)
+ 111 CONTINUE
+ XXSEA = ZERO
+ IF (JITT.GT.0) THEN
+ XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
+*???
+ IF (XSTHR.GE.XSMAX) THEN
+ JITT = JITT-1
+ GOTO 111
+ ENDIF
+
+*>>>get x-values of sea-quark pairs
+ NSCOUN = 0
+ PLW = 0.5D0
+ 110 CONTINUE
+* accumulator for sea x-values
+ XXSEA = ZERO
+ NSCOUN = NSCOUN+1
+ IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
+ IF (NSCOUN.GT.NSEA)THEN
+* decrease the number of interactions after NSEA trials
+ JITT = JITT-1
+ NSCOUN = 0
+ ENDIF
+ DO 140 ISQ=1,JITT
+* sea-quarks
+ IF (ITSQ(IXTS+1).LE.2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+* sea-antiquarks
+ IF (ITSAQ(IXTS+1).GE.-2) THEN
+**sr 8.4.98 (1/sqrt(x))
+C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ELSE
+ IF (XSMAX.GT.XSTHR+BSQMA) THEN
+ XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
+ ELSE
+**sr 8.4.98 (1/sqrt(x))
+C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
+C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
+ XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
+**
+ ENDIF
+ ENDIF
+ XXSEA = XXSEA+XTSQI+XTSAQI
+* check for maximum allowed sea x-value
+ IF (XXSEA.GE.XXSEAM) THEN
+ IXTS = IXTS-ISQ+1
+ GOTO 110
+ ENDIF
+* accept this sea-quark pair
+ IXTS = IXTS+1
+ XTSQ(IXTS) = XTSQI
+ XTSAQ(IXTS) = XTSAQI
+ IFROST(IXTS) = ITT
+ ZUOST(IXTS) = .TRUE.
+ 140 CONTINUE
+ ENDIF
+
+*>>>get x-values of valence partons
+* valence quark
+ IF (XVTHR.GT.0.05D0) THEN
+ XVHI = ONE-XXSEA-XDTHR
+ XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
+ ELSE
+ 160 CONTINUE
+ XTVQI = DT_DBETAR(OHALF,UNON)
+ IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
+ & GOTO 160
+ ENDIF
+* valence diquark
+ XTVDI = ONE-XTVQI-XXSEA
+* reject according to x**1.5
+ XDTMP = XTVDI**1.5D0
+ IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
+* accept these valence partons
+ IXTV = IXTV+1
+ XTVQ(IXTV) = XTVQI
+ XTVD(IXTV) = XTVDI
+ IFROVT(IXTV) = ITT
+ ITOVT(ITT) = IXTV
+ ZUOVT(IXTV) = .TRUE.
+
+ ENDIF
+ 170 CONTINUE
+
+* (4) get valence-valence chains
+*-----------------------------------------------------------------------
+
+ NVV = 0
+ DO 240 I=1,NN
+ INTLO(I) = .TRUE.
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
+ INTLO(I) = .FALSE.
+ ZUOVP(IPVAL) = .FALSE.
+ ZUOVT(ITVAL) = .FALSE.
+ NVV = NVV+1
+ ISKPCH(8,NVV) = 0
+ INTVV1(NVV) = IPVAL
+ INTVV2(NVV) = ITVAL
+ ENDIF
+ 240 CONTINUE
+
+* (5) get sea-valence chains
+*-----------------------------------------------------------------------
+
+ NSV = 0
+ NDV = 0
+ PLW = 0.5D0
+ DO 270 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ DO 250 J=1,IXPS
+ IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
+ & ZUOVT(ITVAL)) THEN
+ ZUOSP(J) = .FALSE.
+ ZUOVT(ITVAL) = .FALSE.
+ INTLO(I) = .FALSE.
+ IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
+ IF (IREJ1.EQ.0) GOTO 260
+ ENDIF
+ NSV = NSV+1
+ ISKPCH(4,NSV) = 0
+ INTSV1(NSV) = J
+ INTSV2(NSV) = ITVAL
+
+*>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
+ AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
+* get lower mass cuts
+ IF (IPSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMAS
+ AMCHK2 = AMIS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMAU
+ AMCHK2 = AMIU
+ ENDIF
+* q-qq chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMSVQ1.GT.AMCHK1) THEN
+ XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
+C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
+ XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
+**
+ XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
+ XPSQ(J) = XPSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMSVQ1.LT.AMCHK1) THEN
+ XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
+ DXPSQ = XPSQW-XPSQ(J)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
+ XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
+ XPSQ(J) = XPSQW
+ ENDIF
+ ENDIF
+* aq-q chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMSVQ2.LT.AMCHK2) THEN
+ XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
+ DXPSQ = XPSQW-XPSAQ(J)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
+ XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
+ XPSAQ(J) = XPSQW
+ ENDIF
+ ENDIF
+*>>>end of chain mass correction
+
+ GOTO 260
+ ENDIF
+ 250 CONTINUE
+ ENDIF
+ 260 CONTINUE
+ 270 CONTINUE
+
+* (6) get valence-sea chains
+*-----------------------------------------------------------------------
+
+ NVS = 0
+ NVD = 0
+ DO 300 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ DO 280 J=1,IXTS
+ IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
+ & (IFROST(J).EQ.INTER2(I))) THEN
+ ZUOST(J) = .FALSE.
+ ZUOVP(IPVAL) = .FALSE.
+ INTLO(I) = .FALSE.
+ IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
+ IF (IREJ1.EQ.0) GOTO 290
+ ENDIF
+ NVS = NVS + 1
+ ISKPCH(6,NVS) = 0
+ INTVS1(NVS) = IPVAL
+ INTVS2(NVS) = J
+
+*>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
+ AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
+* get lower mass cuts
+ IF (ITSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMIS
+ AMCHK2 = AMAS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMIU
+ AMCHK2 = AMAU
+ ENDIF
+* q-aq chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMVSQ1.LT.AMCHK1) THEN
+ XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
+ DXTSQ = XTSQW-XTSAQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
+ XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
+ XTSAQ(J) = XTSQW
+ ENDIF
+ ENDIF
+* qq-q chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMVSQ2.GT.AMCHK2) THEN
+ XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
+C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
+ XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
+**
+ XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
+ XTSQ(J) = XTSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMVSQ2.LT.AMCHK2) THEN
+ XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
+ DXTSQ = XTSQW-XTSQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
+ XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
+ XTSQ(J) = XTSQW
+ ENDIF
+ ENDIF
+*>>>end of chain mass correction
+
+ GOTO 290
+ ENDIF
+ 280 CONTINUE
+ ENDIF
+ 290 CONTINUE
+ 300 CONTINUE
+
+* (7) get sea-sea chains
+*-----------------------------------------------------------------------
+
+ NSS = 0
+ NDS = 0
+ NSD = 0
+ DO 420 I=1,NN
+ IF (INTLO(I)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+* loop over target partons not yet matched
+ DO 400 J=1,IXTS
+ IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
+* loop over projectile partons not yet matched
+ DO 390 JJ=1,IXPS
+ IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
+ ZUOSP(JJ) = .FALSE.
+ ZUOST(J) = .FALSE.
+ INTLO(I) = .FALSE.
+ NSS = NSS+1
+ ISKPCH(1,NSS) = 0
+ INTSS1(NSS) = JJ
+ INTSS2(NSS) = J
+
+*---->chain recombination option
+ VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
+ IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
+ & THEN
+* sea-sea chains may recombine with valence-valence chains
+* only if they have the same projectile or target nucleon
+ DO 4201 IVV=1,NVV
+ IF (ISKPCH(8,IVV).NE.99) THEN
+ IXVPR = INTVV1(IVV)
+ IXVTA = INTVV2(IVV)
+ IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
+ & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
+* recombination possible, drop old v-v and s-s chains
+ ISKPCH(1,NSS) = 99
+ ISKPCH(8,IVV) = 99
+
+* (a) assign new s-v chains
+* ~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (LSEADI.AND.
+ & (DT_RNDM(VALFRA).GT.FRCDIQ))
+ & THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
+ & IREJ1)
+ IF (IREJ1.EQ.0) GOTO 4202
+ ENDIF
+ NSV = NSV+1
+ ISKPCH(4,NSV) = 0
+ INTSV1(NSV) = JJ
+ INTSV2(NSV) = IXVTA
+*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
+ & *ECM**2
+ AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
+ & *ECM**2
+* get lower mass cuts
+ IF (IPSQ(JJ).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMAS
+ AMCHK2 = AMIS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMAU
+ AMCHK2 = AMIU
+ ENDIF
+* q-qq chain
+* chain mass above minimum - resampling of sea-q x-value
+ IF (AMSVQ1.GT.AMCHK1) THEN
+ XPSQTH =
+ & AMCHK1/(XTVD(IXVTA)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+ XPSQXX =
+ & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
+C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
+C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
+**
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
+ XPSQ(JJ) = XPSQXX
+* chain mass below minimum - reset sea-q x-value and correct
+* diquark-x of the same nucleon
+ ELSEIF (AMSVQ1.LT.AMCHK1) THEN
+ XPSQW =
+ & AMCHK1/(XTVD(IXVTA)*ECM**2)
+ DXPSQ = XPSQW-XPSQ(JJ)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
+ & THEN
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)-DXPSQ
+ XPSQ(JJ) = XPSQW
+ ENDIF
+ ENDIF
+* aq-q chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMSVQ2.LT.AMCHK2) THEN
+ XPSQW =
+ & AMCHK2/(XTVQ(IXVTA)*ECM**2)
+ DXPSQ = XPSQW-XPSAQ(JJ)
+ IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
+ & THEN
+ XPVD(IPVAL) =
+ & XPVD(IPVAL)-DXPSQ
+ XPSAQ(JJ) = XPSQW
+ ENDIF
+ ENDIF
+*>>>>>>>>>>>end of chain mass correction
+ 4202 CONTINUE
+
+* (b) assign new v-s chains
+* ~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (LSEADI.AND.(
+ & DT_RNDM(AMSVQ2).GT.FRCDIQ))
+ & THEN
+* sample sea-diquark pair
+ CALL DT_SAMSDQ(ECM,IXVPR,J,1,
+ & IREJ1)
+ IF (IREJ1.EQ.0) GOTO 4203
+ ENDIF
+ NVS = NVS+1
+ ISKPCH(6,NVS) = 0
+ INTVS1(NVS) = IXVPR
+ INTVS2(NVS) = J
+*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
+ AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
+* get lower mass cuts
+ IF (ITSQ(J).EQ.3) THEN
+* q being s-quark
+ AMCHK1 = AMIS
+ AMCHK2 = AMAS
+ ELSE
+* q being u/d-quark
+ AMCHK1 = AMIU
+ AMCHK2 = AMAU
+ ENDIF
+* q-aq chain
+* chain mass below minimum - reset sea-aq x-value and correct
+* diquark-x of the same nucleon
+ IF (AMVSQ1.LT.AMCHK1) THEN
+ XTSQW =
+ & AMCHK1/(XPVQ(IXVPR)*ECM**2)
+ DXTSQ = XTSQW-XTSAQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
+ & THEN
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)-DXTSQ
+ XTSAQ(J) = XTSQW
+ ENDIF
+ ENDIF
+ IF (AMVSQ2.GT.AMCHK2) THEN
+ XTSQTH =
+ & AMCHK2/(XPVD(IXVPR)*ECM**2)
+**sr 8.4.98 (1/sqrt(x))
+ XTSQXX =
+ & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
+C & DT_SAMSQX(XTSQTH,XTSQ(J))
+C & DT_SAMPEX(XTSQTH,XTSQ(J))
+**
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)+XTSQ(J)-XTSQXX
+ XTSQ(J) = XTSQXX
+ ELSEIF (AMVSQ2.LT.AMCHK2) THEN
+ XTSQW =
+ & AMCHK2/(XPVD(IXVPR)*ECM**2)
+ DXTSQ = XTSQW-XTSQ(J)
+ IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
+ & THEN
+ XTVD(ITVAL) =
+ & XTVD(ITVAL)-DXTSQ
+ XTSQ(J) = XTSQW
+ ENDIF
+ ENDIF
+*>>>>>>>>>end of chain mass correction
+ 4203 CONTINUE
+* jump out of s-s chain loop
+ GOTO 420
+ ENDIF
+ ENDIF
+ 4201 CONTINUE
+ ENDIF
+*---->end of chain recombination option
+
+* sample sea-diquark pair (projectile)
+ IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
+ CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ ISKPCH(1,NSS) = 99
+ GOTO 410
+ ENDIF
+ ENDIF
+* sample sea-diquark pair (target)
+ IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
+ CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ ISKPCH(1,NSS) = 99
+ GOTO 410
+ ENDIF
+ ENDIF
+*>>>>>correct chain kinematics according to minimum chain masses
+* the actual chain masses
+ SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
+ SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
+* check for lower mass cuts
+ IF ((SSMA1Q.LT.SSMIMQ).OR.
+ & (SSMA2Q.LT.SSMIMQ)) THEN
+ IPVAL = ITOVP(INTER1(I))
+ ITVAL = ITOVT(INTER2(I))
+ IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
+ & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
+* maximum allowed x values for sea quarks
+ XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
+ & 1.2D0*XSSTHR
+ XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
+ & 1.2D0*XSSTHR
+* resampling of x values not possible - skip sea-sea chains
+ IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
+ & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
+* resampling of x for projectile sea quark pair
+ ICOUS = 0
+ 310 CONTINUE
+ ICOUS = ICOUS+1
+ IF (XSSTHR.GT.0.05D0) THEN
+ XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSPMAX)
+ XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSPMAX)
+ ELSE
+ 320 CONTINUE
+ XPSQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XPSQI.LT.XSSTHR).OR.
+ & (XPSQI.GT.XSPMAX)) GOTO 320
+ 330 CONTINUE
+ XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XPSAQI.LT.XSSTHR).OR.
+ & (XPSAQI.GT.XSPMAX)) GOTO 330
+ ENDIF
+* final test of remaining x for projectile diquark
+ XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
+ & +XPSQ(JJ)+XPSAQ(JJ)
+ IF (XPVDCO.LE.XDTHR) THEN
+*!!!
+C IF (ICOUS.LT.5) GOTO 310
+ IF (ICOUS.LT.0.5D0) GOTO 310
+ GOTO 380
+ ENDIF
+* resampling of x for target sea quark pair
+ ICOUS = 0
+ 350 CONTINUE
+ ICOUS = ICOUS+1
+ IF (XSSTHR.GT.0.05D0) THEN
+ XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSTMAX)
+ XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
+ & XSTMAX)
+ ELSE
+ 360 CONTINUE
+ XTSQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XTSQI.LT.XSSTHR).OR.
+ & (XTSQI.GT.XSTMAX)) GOTO 360
+ 370 CONTINUE
+ XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
+ IF ((XTSAQI.LT.XSSTHR).OR.
+ & (XTSAQI.GT.XSTMAX)) GOTO 370
+ ENDIF
+* final test of remaining x for target diquark
+ XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
+ & +XTSQ(J)+XTSAQ(J)
+ IF (XTVDCO.LT.XDTHR) THEN
+ IF (ICOUS.LT.5) GOTO 350
+ GOTO 380
+ ENDIF
+ XPVD(IPVAL) = XPVDCO
+ XTVD(ITVAL) = XTVDCO
+ XPSQ(JJ) = XPSQI
+ XPSAQ(JJ) = XPSAQI
+ XTSQ(J) = XTSQI
+ XTSAQ(J) = XTSAQI
+*>>>>>end of chain mass correction
+ GOTO 410
+ ENDIF
+* come here to discard s-s interaction
+* resampling of x values not allowed or unsuccessful
+ 380 CONTINUE
+ INTLO(I) = .FALSE.
+ ZUOST(J) = .TRUE.
+ ZUOSP(JJ) = .TRUE.
+ NSS = NSS-1
+ ENDIF
+* consider next s-s interaction
+ GOTO 410
+ ENDIF
+ 390 CONTINUE
+ ENDIF
+ 400 CONTINUE
+ ENDIF
+ 410 CONTINUE
+ 420 CONTINUE
+
+* correct x-values of valence quarks for non-matching sea quarks
+ DO 430 I=1,IXPS
+ IF (ZUOSP(I)) THEN
+ IPVAL = ITOVP(IFROSP(I))
+ XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
+ XPSQ(I) = ZERO
+ XPSAQ(I) = ZERO
+ ZUOSP(I) = .FALSE.
+ ENDIF
+ 430 CONTINUE
+ DO 440 I=1,IXTS
+ IF (ZUOST(I)) THEN
+ ITVAL = ITOVT(IFROST(I))
+ XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
+ XTSQ(I) = ZERO
+ XTSAQ(I) = ZERO
+ ZUOST(I) = .FALSE.
+ ENDIF
+ 440 CONTINUE
+ DO 450 I=1,IXPV
+ IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
+ 450 CONTINUE
+ DO 460 I=1,IXTV
+ IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
+ 460 CONTINUE
+
+ RETURN
+ END
+*
+*===samsdq=============================================================*
+*
+CDECK ID>, DT_SAMSDQ
+ SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
+
+************************************************************************
+* SAMpling of Sea-DiQuarks *
+* ECM cm-energy of the nucleon-nucleon system *
+* IDX1,2 indices of x-values of the participating *
+* partons (IDX2 is always the sea-q-pair to be *
+* changed to sea-qq-pair) *
+* MODE = 1 valence-q - sea-diq *
+* = 2 sea-diq - valence-q *
+* = 3 sea-q - sea-diq *
+* = 4 sea-diq - sea-q *
+* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
+* This version dated 17.10.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (ZERO=0.0D0)
+
+* threshold values for x-sampling (DTUNUC 1.x)
+ COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ & SSMIMQ,VVMTHR
+* 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
+
+ PARAMETER ( MAXNCL = 260,
+
+ & MAXVQU = MAXNCL,
+ & MAXSQU = 20*MAXVQU,
+ & MAXINT = MAXVQU+MAXSQU)
+* 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)
+* auxiliary common for chain system storage (DTUNUC 1.x)
+ COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+
+ IREJ = 0
+* threshold-x for valence diquarks
+ XDTHR = CDQ/ECM
+
+ GOTO (1,2,3,4) MODE
+
+*---------------------------------------------------------------------
+* proj. valence partons - targ. sea partons
+* get x-values and flavors for target sea-diquark pair
+
+ 1 CONTINUE
+ IDXVP = IDX1
+ IDXST = IDX2
+
+* index of corr. val-diquark-x in target nucleon
+ IDXVT = ITOVT(IFROST(IDXST))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the target nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXTV = XDTHR+RR1*XXD/SR123
+ XXTSQ = XDTHR+RR2*XXD/SR123
+ XXTSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXTV = XTVD(IDXVT)
+ XXTSQ = XTSQ(IDXST)
+ XXTSAQ = XTSAQ(IDXST)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
+ ITSAQ2(IDXST) = -ITSQ2(IDXST)
+* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
+ AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
+ AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
+ IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XTVD(IDXVT) = XXTV
+ XTSQ(IDXST) = XXTSQ
+ XTSAQ(IDXST) = XXTSAQ
+ NVD = NVD+1
+ INTVD1(NVD) = IDXVP
+ INTVD2(NVD) = IDXST
+ ISKPCH(7,NVD) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. valence partons
+* get x-values and flavors for projectile sea-diquark pair
+
+ 2 CONTINUE
+ IDXSP = IDX2
+ IDXVT = IDX1
+
+* index of corr. val-diquark-x in projectile nucleon
+ IDXVP = ITOVP(IFROSP(IDXSP))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the projectile nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXPV = XDTHR+RR1*XXD/SR123
+ XXPSQ = XDTHR+RR2*XXD/SR123
+ XXPSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXPV = XPVD(IDXVP)
+ XXPSQ = XPSQ(IDXSP)
+ XXPSAQ = XPSAQ(IDXSP)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
+ IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
+* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
+ AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
+ AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
+ IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XPVD(IDXVP) = XXPV
+ XPSQ(IDXSP) = XXPSQ
+ XPSAQ(IDXSP) = XXPSAQ
+ NDV = NDV+1
+ INTDV1(NDV) = IDXSP
+ INTDV2(NDV) = IDXVT
+ ISKPCH(5,NDV) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. sea partons
+* get x-values and flavors for target sea-diquark pair
+
+ 3 CONTINUE
+ IDXSP = IDX1
+ IDXST = IDX2
+
+* index of corr. val-diquark-x in target nucleon
+ IDXVT = ITOVT(IFROST(IDXST))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the target nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXTV = XDTHR+RR1*XXD/SR123
+ XXTSQ = XDTHR+RR2*XXD/SR123
+ XXTSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXTV = XTVD(IDXVT)
+ XXTSQ = XTSQ(IDXST)
+ XXTSAQ = XTSAQ(IDXST)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
+ ITSAQ2(IDXST) = -ITSQ2(IDXST)
+* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
+ AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
+ AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
+ IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XTVD(IDXVT) = XXTV
+ XTSQ(IDXST) = XXTSQ
+ XTSAQ(IDXST) = XXTSAQ
+ NSD = NSD+1
+ INTSD1(NSD) = IDXSP
+ INTSD2(NSD) = IDXST
+ ISKPCH(3,NSD) = 0
+ RETURN
+
+*---------------------------------------------------------------------
+* proj. sea partons - targ. sea partons
+* get x-values and flavors for projectile sea-diquark pair
+
+ 4 CONTINUE
+ IDXSP = IDX2
+ IDXST = IDX1
+
+* index of corr. val-diquark-x in projectile nucleon
+ IDXVP = ITOVP(IFROSP(IDXSP))
+* available x above diquark thresholds for valence- and sea-diquarks
+ XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
+
+ IF (XXD.GE.ZERO) THEN
+* x-values for the three diquarks of the projectile nucleon
+ RR1 = DT_RNDM(XXD)
+ RR2 = DT_RNDM(RR1)
+ RR3 = DT_RNDM(RR2)
+ SR123 = RR1+RR2+RR3
+ XXPV = XDTHR+RR1*XXD/SR123
+ XXPSQ = XDTHR+RR2*XXD/SR123
+ XXPSAQ = XDTHR+RR3*XXD/SR123
+ ELSE
+ XXPV = XPVD(IDXVP)
+ XXPSQ = XPSQ(IDXSP)
+ XXPSAQ = XPSAQ(IDXSP)
+ ENDIF
+* flavor of the second quarks in the sea-diquark pair
+ IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
+ IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
+* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
+ AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
+ AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
+ IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
+* ss-asas pair
+ & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
+* at least one strange quark
+ & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
+ IREJ = 1
+ RETURN
+ ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+* accept the new sea-diquark
+ XPVD(IDXVP) = XXPV
+ XPSQ(IDXSP) = XXPSQ
+ XPSAQ(IDXSP) = XXPSAQ
+ NDS = NDS+1
+ INTDS1(NDS) = IDXSP
+ INTDS2(NDS) = IDXST
+ ISKPCH(2,NDS) = 0
+ RETURN
+ END
+*
+*===difevt=============================================================*
+*
+CDECK ID>, DT_DIFEVT
+ SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
+ & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
+
+************************************************************************
+* Interface to treatment of diffractive interactions. *
+* (input) IFP1/2 PDG-indizes of projectile partons *
+* (baryon: IFP2 - adiquark) *
+* PP(4) projectile 4-momentum *
+* IFT1/2 PDG-indizes of target partons *
+* (baryon: IFT1 - adiquark) *
+* PT(4) target 4-momentum *
+* (output) JDIFF = 0 no diffraction *
+* = 1/-1 LMSD/LMDD *
+* = 2/-2 HMSD/HMDD *
+* NCSY counter for two-chain systems *
+* dumped to DTEVT1 *
+* This version dated 14.02.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,TINY10=1.0D-10,TINY5=1.0D-5,
+ & OHALF=0.5D0)
+
+* 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 diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+ DIMENSION PP(4),PT(4)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+ IREJ = 0
+ JDIFF = 0
+ IFLAGD = JDIFF
+
+* cm. energy
+ XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
+ & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
+* identities of projectile hadron / target nucleon
+ KPROJ = IDT_ICIHAD(IDHKK(MOP))
+ KTARG = IDT_ICIHAD(IDHKK(MOT))
+
+* single diffractive xsections
+ CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
+* double diffractive xsections
+**!! no double diff yet
+C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
+ DDTOT = 0.0D0
+ DDHM = 0.0D0
+**!!
+* total inelastic xsection
+C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
+ DUMZER = ZERO
+ CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
+ SIGIN = MAX(SIGTO-SIGEL,ZERO)
+
+* fraction of diffractive processes
+ FRADIF = (SDTOT+DDTOT)/SIGIN
+
+ IF (LFIRST) THEN
+ WRITE(LOUT,1000) XM,SDTOT,SIGIN
+ 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
+ & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
+ & F5.1,' mb',/)
+ LFIRST = .FALSE.
+ ENDIF
+
+ IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
+ & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
+* diffractive interaction requested by x-section or by user
+ FRASD = SDTOT/(SDTOT+DDTOT)
+ FRASDH = SDHM/SDTOT
+**sr needs to be specified!!
+C FRADDH = DDHM/DDTOT
+ FRADDH = 1.0D0
+**
+ IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
+* single diffraction
+ KDIFF = 1
+ IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
+ KP = 2
+ KT = 0
+ IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
+ & ISINGD.NE.3) THEN
+ KP = 0
+ KT = 2
+ ENDIF
+ ELSE
+ KP = 1
+ KT = 0
+ IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
+ & ISINGD.NE.3) THEN
+ KP = 0
+ KT = 1
+ ENDIF
+ ENDIF
+ ELSE
+* double diffraction
+ KDIFF = -1
+ IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
+ KP = 2
+ KT = 2
+ ELSE
+ KP = 1
+ KT = 1
+ ENDIF
+ ENDIF
+ CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
+ & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
+ IF (IREJ1.EQ.0) THEN
+ IFLAGD = 2*KDIFF
+ IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
+ ELSE
+ GOTO 9999
+ ENDIF
+ ENDIF
+ JDIFF = IFLAGD
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===difkin=============================================================*
+*
+CDECK ID>, DT_DIFFKI
+ SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
+ & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
+
+************************************************************************
+* Kinematics of diffractive nucleon-nucleon interaction. *
+* IFP1/2 PDG-indizes of projectile partons *
+* (baryon: IFP2 - adiquark) *
+* PP(4) projectile 4-momentum *
+* IFT1/2 PDG-indizes of target partons *
+* (baryon: IFT1 - adiquark) *
+* PT(4) target 4-momentum *
+* KP = 0 projectile quasi-elastically scattered *
+* = 1 excited to low-mass diff. state *
+* = 2 excited to high-mass diff. state *
+* KT = 0 target quasi-elastically scattered *
+* = 1 excited to low-mass diff. state *
+* = 2 excited to high-mass diff. state *
+* This version dated 12.02.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,TINY10=1.0D-10,TINY5=1.0D-5)
+
+ 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)
+* 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
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
+ & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
+
+ DATA LSTART /.TRUE./
+
+ IF (LSTART) THEN
+ WRITE(LOUT,2000)
+ 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
+ LSTART = .FALSE.
+ ENDIF
+
+ IREJ = 0
+
+* initialize common /DTDIKI/
+ CALL DT_DIFINI
+* store momenta of initial incoming particles for emc-check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
+ ENDIF
+
+* masses of initial particles
+ XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
+ XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
+ IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
+ XMP = SQRT(XMP2)
+ XMT = SQRT(XMT2)
+* check quark-input (used to adjust coherence cond. for M-selection)
+ IBP = 0
+ IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
+ IBT = 0
+ IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
+
+* parameter for Lorentz-transformation into nucleon-nucleon cms
+ DO 3 K=1,4
+ PITOT(K) = PP(K)+PT(K)
+ 3 CONTINUE
+ XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
+ IF (XMTOT2.LE.ZERO) THEN
+ WRITE(LOUT,1000) XMTOT2
+ 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
+ & 'XMTOT2 = ',E12.3)
+ GOTO 9999
+ ENDIF
+ XMTOT = SQRT(XMTOT2)
+ DO 4 K=1,4
+ BGTOT(K) = PITOT(K)/XMTOT
+ 4 CONTINUE
+* transformation of nucleons into cms
+ CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
+ & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
+ CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
+ & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
+* rotation angles
+ COD = PP1(3)/PPTOT
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(PP1(1)**2+PP1(2)**2)
+ SID = PPT/PPTOT
+ COF = ONE
+ SIF = ZERO
+ IF(PPTOT*SID.GT.TINY10) THEN
+ COF = PP1(1)/(SID*PPTOT)
+ SIF = PP1(2)/(SID*PPTOT)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+* check consistency
+ DO 5 K=1,4
+ DEV1(K) = ABS(PP1(K)+PT1(K))
+ 5 CONTINUE
+ DEV1(4) = ABS(DEV1(4)-XMTOT)
+ IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
+ & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
+ WRITE(LOUT,1001) DEV1
+ 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
+ & /,8X,4E12.3)
+ GOTO 9999
+ ENDIF
+
+* select x-fractions in high-mass diff. interactions
+ IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
+
+* select diffractive masses
+* - projectile
+ IF (KP.EQ.1) THEN
+ XMPF = DT_XMLMD(XMTOT)
+ CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ ELSEIF (KP.EQ.2) THEN
+ XMPF = DT_XMHMD(XMTOT,IBP,1)
+ ELSE
+ XMPF = XMP
+ ENDIF
+* - target
+ IF (KT.EQ.1) THEN
+ XMTF = DT_XMLMD(XMTOT)
+ CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+ ELSEIF (KT.EQ.2) THEN
+ XMTF = DT_XMHMD(XMTOT,IBT,2)
+ ELSE
+ XMTF = XMT
+ ENDIF
+
+* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
+ XMPF2 = XMPF**2
+ XMTF2 = XMTF**2
+ PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
+ PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
+
+* select momentum transfer (all t-values used here are <0)
+* minimum absolute value to produce diffractive masses
+ TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
+ TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
+ IF (IREJ1.GT.0) GOTO 9999
+
+* longitudinal momentum of excited/elastically scattered projectile
+ PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
+* total transverse momentum due to t-selection
+ PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
+ IF (PPBLT2.LT.ZERO) THEN
+ WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
+ 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
+ & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
+ GOTO 9999
+ ENDIF
+ CALL DT_DSFECF(SINPHI,COSPHI)
+ PPBLT = SQRT(PPBLT2)
+ PPBLOB(1) = COSPHI*PPBLT
+ PPBLOB(2) = SINPHI*PPBLT
+
+* rotate excited/elastically scattered projectile into n-n cms.
+ CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ PPBLOB(1) = XX
+ PPBLOB(2) = YY
+ PPBLOB(3) = ZZ
+
+* 4-momentum of excited/elastically scattered target and of exchanged
+* Pomeron
+ DO 6 K=1,4
+ IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
+ PPOM1(K) = PP1(K)-PPBLOB(K)
+ 6 CONTINUE
+ PTBLOB(4) = XMTOT-PPBLOB(4)
+
+* Lorentz-transformation back into system of initial diff. collision
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
+ & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
+ & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
+ CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
+ & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
+ & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
+
+* store 4-momentum of elastically scattered particle (in single diff.
+* events)
+ IF (KP.EQ.0) THEN
+ DO 7 K=1,4
+ PSC(K) = PPF(K)
+ 7 CONTINUE
+ ELSEIF (KT.EQ.0) THEN
+ DO 8 K=1,4
+ PSC(K) = PTF(K)
+ 8 CONTINUE
+ ENDIF
+
+* check consistency of kinematical treatment so far
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ DO 9 K=1,4
+ DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
+ DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
+ 9 CONTINUE
+ IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
+ & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
+ & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
+ & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
+ WRITE(LOUT,1003) DEV1,DEV2
+ 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
+ & 2(/,8X,4E12.3))
+ GOTO 9999
+ ENDIF
+
+* kinematical treatment for low-mass diffraction
+ CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+* dump diffractive chains into DTEVT1
+ CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+ RETURN
+
+ 9999 CONTINUE
+ IRDIFF(1) = IRDIFF(1)+1
+ IREJ = 1
+ RETURN
+ END
+*
+*===xmhmd==============================================================*
+*
+CDECK ID>, DT_XMHMD
+ DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
+
+************************************************************************
+* Diffractive mass in high mass single/double diffractive events. *
+* This version dated 11.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+C DATA XCOLOW /0.05D0/
+ DATA XCOLOW /0.15D0/
+
+ DT_XMHMD = ZERO
+ XH = XPH(2)
+ IF (MODE.EQ.2) XH = XTH(2)
+
+* minimum Pomeron-x for high-mass diffraction
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(XH)
+ XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
+ IF (ECM.LE.300.0D0) THEN
+ RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
+ XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
+ ENDIF
+* maximum Pomeron-x for high-mass diffraction
+* (coherence condition, adjusted to fit to experimental data)
+ IF (IB.NE.0) THEN
+* baryon-diffraction
+ XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
+ ELSE
+* meson-diffraction
+ XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
+ ENDIF
+* check boundaries
+ IF (XDIMIN.GE.XDIMAX) THEN
+ XDIMIN = OHALF*XDIMAX
+ ENDIF
+
+ KLOOP = 0
+ 1 CONTINUE
+ KLOOP = KLOOP+1
+ IF (KLOOP.GT.20) RETURN
+* sample Pomeron-x from 1/x-distribution (critical Pomeron)
+ XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
+* corr. diffr. mass
+ DT_XMHMD = ECM*SQRT(XDIFF)
+ IF (DT_XMHMD.LT.2.5D0) GOTO 1
+
+ RETURN
+ END
+*
+*===xmlmd==============================================================*
+*
+CDECK ID>, DT_XMLMD
+ DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
+
+************************************************************************
+* Diffractive mass in high mass single/double diffractive events. *
+* This version dated 11.02.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* minimum Pomeron-x for low-mass diffraction
+C AMO = 1.5D0
+ AMO = 2.0D0
+* maximum Pomeron-x for low-mass diffraction
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(AMO)
+ SAM = 1.0D0
+ IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
+ R = DT_RNDM(AMO)*SAM
+ AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
+ AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
+
+* selection of diffractive mass
+* (adjusted to get a smooth transition between HM and LM component)
+ R = DT_RNDM(AMU)
+ IF (ECM.LE.50.0D0) THEN
+ DT_XMLMD = AMO*(AMU/AMO)**R
+ ELSE
+ A = 0.7D0
+ IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
+ DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
+ ENDIF
+
+ RETURN
+ END
+*
+*===tdiff==============================================================*
+*
+CDECK ID>, DT_TDIFF
+ DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
+
+************************************************************************
+* t-selection for single/double diffractive interactions. *
+* ECM cm. energy *
+* TMIN minimum momentum transfer to produce diff. masses *
+* XM1/XM2 diffractively produced masses *
+* (for single diffraction XM2 is obsolete) *
+* K1/K2= 0 not excited *
+* = 1 low-mass excitation *
+* = 2 high-mass excitation *
+* This version dated 11.02.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)
+
+ PARAMETER ( BTP0 = 3.7D0,
+ & ALPHAP = 0.24D0 )
+
+ IREJ = 0
+ NCLOOP = 0
+ DT_TDIFF = ZERO
+
+ IF (K1.GT.0) THEN
+ XM1 = XM1I
+ XM2 = XM2I
+ ELSE
+ XM1 = XM2I
+ ENDIF
+ XDI = (XM1/ECM)**2
+ IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
+* slope for single diffraction
+ SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
+ ELSE
+* slope for double diffraction
+ SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
+ ENDIF
+
+ 1 CONTINUE
+ NCLOOP = NCLOOP+1
+ IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
+ Y = DT_RNDM(XDI)
+ T = -LOG(1.0D0-Y)/SLOPE
+ IF (ABS(T).LE.ABS(TMIN)) GOTO 1
+ DT_TDIFF = -ABS(T)
+
+ RETURN
+
+ 9999 CONTINUE
+ WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
+ 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
+ & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
+ & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
+ IREJ = 1
+ RETURN
+ END
+*
+*===xvalhm=============================================================*
+*
+CDECK ID>, DT_XVALHM
+ SUBROUTINE DT_XVALHM(KP,KT)
+
+************************************************************************
+* Sampling of parton x-values in high-mass diffractive interactions. *
+* This version dated 12.02.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,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+* 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
+
+ DATA UNON,XVQTHR /2.0D0,0.8D0/
+
+ IF (KP.EQ.2) THEN
+* x-fractions of projectile valence partons
+ 1 CONTINUE
+ XPH(1) = DT_DBETAR(OHALF,UNON)
+ IF (XPH(1).GE.XVQTHR) GOTO 1
+ XPH(2) = ONE-XPH(1)
+* x-fractions of Pomeron q-aq-pair
+ XPOLO = TINY2
+ XPOHI = ONE-TINY2
+ XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
+ XPPO(2) = ONE-XPPO(1)
+* flavors of Pomeron q-aq-pair
+ IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
+ IFPPO(1) = IFLAV
+ IFPPO(2) = -IFLAV
+ IF (DT_RNDM(UNON).GT.OHALF) THEN
+ IFPPO(1) = -IFLAV
+ IFPPO(2) = IFLAV
+ ENDIF
+ ENDIF
+
+ IF (KT.EQ.2) THEN
+* x-fractions of projectile target partons
+ 2 CONTINUE
+ XTH(1) = DT_DBETAR(OHALF,UNON)
+ IF (XTH(1).GE.XVQTHR) GOTO 2
+ XTH(2) = ONE-XTH(1)
+* x-fractions of Pomeron q-aq-pair
+ XPOLO = TINY2
+ XPOHI = ONE-TINY2
+ XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
+ XTPO(2) = ONE-XTPO(1)
+* flavors of Pomeron q-aq-pair
+ IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
+ IFTPO(1) = IFLAV
+ IFTPO(2) = -IFLAV
+ IF (DT_RNDM(XPOLO).GT.OHALF) THEN
+ IFTPO(1) = -IFLAV
+ IFTPO(2) = IFLAV
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+*
+*===lm2res=============================================================*
+*
+CDECK ID>, DT_LM2RES
+ SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
+
+************************************************************************
+* Check low-mass diffractive excitation for resonance mass. *
+* (input) IF1/2 PDG-indizes of valence partons *
+* (in/out) XM diffractive mass requested/corrected *
+* (output) IDR/IDXR id./BAMJET-index of resonance *
+* This version dated 12.02.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,OHALF=0.5D0,ONE=1.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ IREJ = 0
+ IF1B = 0
+ IF2B = 0
+ XMI = XM
+
+* BAMJET indices of partons
+ IF1A = IDT_IPDG2B(IF1,1,2)
+ IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
+ IF2A = IDT_IPDG2B(IF2,1,2)
+ IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
+
+* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
+ IDCH = 2
+ IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
+
+* check for resonance mass
+ CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+ XM = XMN
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===lmkine=============================================================*
+*
+CDECK ID>, DT_LMKINE
+ SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
+
+************************************************************************
+* Kinematical treatment of low-mass excitations. *
+* This version dated 12.02.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,OHALF=0.5D0,ONE=1.0D0)
+
+* 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
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DIMENSION P1(4),P2(4)
+
+ IREJ = 0
+
+ IF (KP.EQ.1) THEN
+ PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
+ POE = PPF(4)/PABS
+ FAC1 = OHALF*(POE+ONE)
+ FAC2 = -OHALF*(POE-ONE)
+ DO 1 K=1,3
+ PPLM1(K) = FAC1*PPF(K)
+ PPLM2(K) = FAC2*PPF(K)
+ 1 CONTINUE
+ PPLM1(4) = FAC1*PABS
+ PPLM2(4) = -FAC2*PABS
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFP1)
+ XM2 = PYMASS(IFP2)
+
+ CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 2 K=1,4
+ PPLM1(K) = P1(K)
+ PPLM2(K) = P2(K)
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+
+ IF (KT.EQ.1) THEN
+ PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
+ POE = PTF(4)/PABS
+ FAC1 = OHALF*(POE+ONE)
+ FAC2 = -OHALF*(POE-ONE)
+ DO 3 K=1,3
+ PTLM2(K) = FAC1*PTF(K)
+ PTLM1(K) = FAC2*PTF(K)
+ 3 CONTINUE
+ PTLM2(4) = FAC1*PABS
+ PTLM1(4) = -FAC2*PABS
+ IF (IMSHL.EQ.1) THEN
+
+ XM1 = PYMASS(IFT1)
+ XM2 = PYMASS(IFT2)
+
+ CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 K=1,4
+ PTLM1(K) = P1(K)
+ PTLM2(K) = P2(K)
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
+ IREJ = 1
+ RETURN
+ END
+*
+*===difini=============================================================*
+*
+CDECK ID>, DT_DIFINI
+ SUBROUTINE DT_DIFINI
+
+************************************************************************
+* Initialization of common /DTDIKI/ *
+* This version dated 12.02.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,OHALF=0.5D0,ONE=1.0D0)
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+
+ DO 1 K=1,4
+ PPOM(K) = ZERO
+ PSC(K) = ZERO
+ PPF(K) = ZERO
+ PTF(K) = ZERO
+ PPLM1(K) = ZERO
+ PPLM2(K) = ZERO
+ PTLM1(K) = ZERO
+ PTLM2(K) = ZERO
+ 1 CONTINUE
+ DO 2 K=1,2
+ XPH(K) = ZERO
+ XPPO(K) = ZERO
+ XTH(K) = ZERO
+ XTPO(K) = ZERO
+ IFPPO(K) = 0
+ IFTPO(K) = 0
+ 2 CONTINUE
+ IDPR = 0
+ IDXPR = 0
+ IDTR = 0
+ IDXTR = 0
+
+ RETURN
+ END
+*
+*===difput=============================================================*
+*
+CDECK ID>, DT_DIFPUT
+ SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
+ & IREJ)
+
+************************************************************************
+* Dump diffractive chains into DTEVT1 *
+* This version dated 12.02.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,OHALF=0.5D0,ONE=1.0D0)
+
+ LOGICAL LCHK
+
+* kinematics of diffractive interactions (DTUNUC 1.x)
+ COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
+ & PPF(4),PTF(4),
+ & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
+ & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
+* 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
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
+ & P1(4),P2(4),P3(4),P4(4)
+
+ IREJ = 0
+
+ IF (KP.EQ.1) THEN
+ DO 1 K=1,4
+ PCH(K) = PPLM1(K)+PPLM2(K)
+ 1 CONTINUE
+ ID1 = IFP1
+ ID2 = IFP2
+ IF (DT_RNDM(PT).GT.OHALF) THEN
+ ID1 = IFP2
+ ID2 = IFP1
+ ENDIF
+ CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
+ & PPLM1(4),0,0,0)
+ CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
+ & PPLM2(4),0,0,0)
+ CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
+ & IDPR,IDXPR,8)
+ ELSEIF (KP.EQ.2) THEN
+ DO 2 K=1,4
+ PP1(K) = XPH(1)*PP(K)
+ PP2(K) = XPH(2)*PP(K)
+ PT1(K) = -XPPO(1)*PPOM(K)
+ PT2(K) = -XPPO(2)*PPOM(K)
+ 2 CONTINUE
+ CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
+ XM1 = ZERO
+ XM2 = ZERO
+ IF (LCHK) THEN
+ CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 3 K=1,4
+ PP1(K) = P1(K)
+ PT1(K) = P2(K)
+ PP2(K) = P3(K)
+ PT2(K) = P4(K)
+ 3 CONTINUE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(1),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(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
+ & PT2(4),0,0,8)
+ ELSE
+ CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 4 K=1,4
+ PP1(K) = P1(K)
+ PT2(K) = P2(K)
+ PP2(K) = P3(K)
+ PT1(K) = P4(K)
+ 4 CONTINUE
+ CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFPPO(2),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(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
+ & PT1(4),0,0,8)
+ ENDIF
+ NCSY = NCSY+1
+ ELSE
+ CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
+ & 0,0,0)
+ ENDIF
+
+ IF (KT.EQ.1) THEN
+ DO 5 K=1,4
+ PCH(K) = PTLM1(K)+PTLM2(K)
+ 5 CONTINUE
+ ID1 = IFT1
+ ID2 = IFT2
+ IF (DT_RNDM(PT).GT.OHALF) THEN
+ ID1 = IFT2
+ ID2 = IFT1
+ ENDIF
+ CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
+ & PTLM1(4),0,0,0)
+ CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
+ & PTLM2(4),0,0,0)
+ CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
+ & IDTR,IDXTR,8)
+ ELSEIF (KT.EQ.2) THEN
+ DO 6 K=1,4
+ PP1(K) = XTPO(1)*PPOM(K)
+ PP2(K) = XTPO(2)*PPOM(K)
+ PT1(K) = XTH(2)*PT(K)
+ PT2(K) = XTH(1)*PT(K)
+ 6 CONTINUE
+ CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
+ XM1 = ZERO
+ XM2 = ZERO
+ IF (LCHK) THEN
+ CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 7 K=1,4
+ PP1(K) = P1(K)
+ PT1(K) = P2(K)
+ PP2(K) = P3(K)
+ PT2(K) = P4(K)
+ 7 CONTINUE
+ CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
+ & PP1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
+ & PP2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,8)
+ ELSE
+ CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ DO 8 K=1,4
+ PP1(K) = P1(K)
+ PT2(K) = P2(K)
+ PP2(K) = P3(K)
+ PT1(K) = P4(K)
+ 8 CONTINUE
+ CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
+ & PP1(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+ & 0,0,8)
+ CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
+ & PP2(4),0,0,8)
+ CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+ & 0,0,8)
+ ENDIF
+ NCSY = NCSY+1
+ ELSE
+ CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
+ & 0,0,0)
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IRDIFF(2) = IRDIFF(2)+1
+ IREJ = 1
+ RETURN
+ END
+*
+*===evtfrg=============================================================*
+*
+CDECK ID>, DT_EVTFRG
+ SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
+
+************************************************************************
+* Hadronization of chains in DTEVT1. *
+* *
+* Input: *
+* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
+* = 2 hadronization of DTUNUC-chains (id=88xxx) *
+* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
+* hadronized with one PYEXEC call *
+* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
+* with one PYEXEC call *
+* Output: *
+* NPYMEM number of entries in JETSET-common after hadronization *
+* IREJ rejection flag *
+* *
+* This version dated 17.09.00 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,TINY3=1.0D-3,TINY1=1.0D-1)
+ PARAMETER (ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LACCEP
+
+ PARAMETER (MXJOIN=200)
+
+* 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)
+* flags for diffractive interactions (DTUNUC 1.x)
+ COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* phojet
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+* jetset
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+ INTEGER PYK
+
+ DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
+
+ MODE = KMODE
+ ISTSTG = 7
+ IF (MODE.NE.1) ISTSTG = 8
+ IREJ = 0
+
+ IP = 0
+ ISH = 0
+ INIEMC = 1
+ NEND = NHKK
+ NACCEP = 0
+ IFRG = 0
+ IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
+ DO 10 I=NPOINT(3),NEND
+* sr 14.02.00: seems to be not necessary anymore, commented
+C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
+C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
+ LACCEP = .TRUE.
+* pick up chains from dtevt1
+ IDCHK = IDHKK(I)/10000
+ IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
+ IF (IDCHK.EQ.7) THEN
+ IPJE = IDHKK(I)-IDCHK*10000
+ IF (IPJE.NE.IFRG) THEN
+ IFRG = IPJE
+ IF (IFRG.GT.NFRG) GOTO 16
+ ENDIF
+ ELSE
+ IPJE = 1
+ IFRG = IFRG+1
+ IF (IFRG.GT.NFRG) THEN
+ NFRG = -1
+ GOTO 16
+ ENDIF
+ ENDIF
+* statistics counter
+c IF (IDCH(I).LE.8)
+c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
+c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
+* special treatment for small chains already corrected to hadrons
+ IF (IDRES(I).NE.0) THEN
+ IF (IDRES(I).EQ.11) THEN
+ ID = IDXRES(I)
+ ELSE
+ ID = IDT_IPDGHA(IDXRES(I))
+ ENDIF
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),INIEMC,IDUM,IDUM)
+ INIEMC = 2
+ ENDIF
+ IP = IP+1
+ IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
+ P(IP,1) = PHKK(1,I)
+ P(IP,2) = PHKK(2,I)
+ P(IP,3) = PHKK(3,I)
+ P(IP,4) = PHKK(4,I)
+ P(IP,5) = PHKK(5,I)
+ K(IP,1) = 1
+ K(IP,2) = ID
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IHIST(2,I) = 10000*IPJE+IP
+ IF (IHIST(1,I).LE.-100) THEN
+ ISH = ISH+1
+ IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
+ ISJOIN(ISH) = I
+ ENDIF
+ N = IP
+ IHISMO(IP) = I
+ ELSE
+ IJ = 0
+ DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
+ & PHKK(4,KK),INIEMC,IDUM,IDUM)
+ CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
+ INIEMC = 2
+ ENDIF
+ ID = IDHKK(KK)
+ IF (ID.EQ.0) ID = 21
+c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
+c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
+
+c AMRQ = PYMASS(ID)
+
+c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
+c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
+c & (ABS(IDIFF).EQ.0)) THEN
+cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
+c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
+c PHKK(4,KK) = PHKK(4,KK)+DELTA
+c PTOT1 = PTOT-DELTA
+c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
+c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
+c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
+c PHKK(5,KK) = AMRQ
+c ENDIF
+ IP = IP+1
+ IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
+ P(IP,1) = PHKK(1,KK)
+ P(IP,2) = PHKK(2,KK)
+ P(IP,3) = PHKK(3,KK)
+ P(IP,4) = PHKK(4,KK)
+ P(IP,5) = PHKK(5,KK)
+ K(IP,1) = 1
+ K(IP,2) = ID
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IHIST(2,KK) = 10000*IPJE+IP
+ IF (IHIST(1,KK).LE.-100) THEN
+ ISH = ISH+1
+ IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
+ ISJOIN(ISH) = KK
+ ENDIF
+ IJ = IJ+1
+ IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
+ IJOIN(IJ) = IP
+ IHISMO(IP) = I
+ 11 CONTINUE
+ N = IP
+* join the two-parton system
+
+ CALL PYJOIN(IJ,IJOIN)
+
+ ENDIF
+ IDHKK(I) = 99999
+ ENDIF
+ 10 CONTINUE
+ 16 CONTINUE
+ N = IP
+
+ IF (IP.GT.0) THEN
+
+* final state parton shower
+ DO 136 NPJE=1,IPJE
+ IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
+ IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
+ DO 130 K1=1,ISH
+ IF (ISJOIN(K1).EQ.0) GOTO 130
+ I = ISJOIN(K1)
+ IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
+ & GOTO 130
+ IH1 = IHIST(2,I)/10000
+ IF (IH1.NE.NPJE) GOTO 130
+ IH1 = IHIST(2,I)-IH1*10000
+ DO 135 K2=K1+1,ISH
+ IF (ISJOIN(K2).EQ.0) GOTO 135
+ II = ISJOIN(K2)
+ IH2 = IHIST(2,II)/10000
+ IF (IH2.NE.NPJE) GOTO 135
+ IH2 = IHIST(2,II)-IH2*10000
+ IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
+ PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
+ PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
+
+ RQLUN = MIN(PT1,PT2)
+ CALL PYSHOW(IH1,IH2,RQLUN)
+
+ ISJOIN(K1) = 0
+ ISJOIN(K2) = 0
+ GOTO 130
+ ENDIF
+ 135 CONTINUE
+ 130 CONTINUE
+ ENDIF
+ ENDIF
+ 136 CONTINUE
+
+ CALL DT_INITJS(MODE)
+* hadronization
+
+ CALL PYEXEC
+
+ IF (MSTU(24).NE.0) THEN
+ WRITE(LOUT,*) ' JETSET-reject at event',
+ & NEVHKK,MSTU(24),KMODE
+C CALL DT_EVTOUT(4)
+
+C CALL PYLIST(2)
+
+ GOTO 9999
+ ENDIF
+
+* number of entries in LUJETS
+
+ NLINES = PYK(0,1)
+
+ NPYMEM = NLINES
+
+ DO 12 I=1,NLINES
+ IFLG(I) = 0
+ 12 CONTINUE
+
+ DO 13 II=1,NLINES
+
+ IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
+
+* pick up mother resonance if possible and put it together with
+* their decay-products into the common
+ IDXMOR = K(II,3)
+ IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
+ KFMOR = K(IDXMOR,2)
+ ISMOR = K(IDXMOR,1)
+ ELSE
+ KFMOR = 91
+ ISMOR = 1
+ ENDIF
+ IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
+ & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
+ ID = K(IDXMOR,2)
+
+ MO = IHISMO(PYK(IDXMOR,15))
+ PX = PYP(IDXMOR,1)
+ PY = PYP(IDXMOR,2)
+ PZ = PYP(IDXMOR,3)
+ PE = PYP(IDXMOR,4)
+
+ CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IFLG(IDXMOR) = 1
+ MO = NHKK
+ DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
+
+ IF (PYK(JDAUG,7).EQ.1) THEN
+ ID = PYK(JDAUG,8)
+ PX = PYP(JDAUG,1)
+ PY = PYP(JDAUG,2)
+ PZ = PYP(JDAUG,3)
+ PE = PYP(JDAUG,4)
+
+ CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IF (LEMCCK) THEN
+
+ PX = -PYP(JDAUG,1)
+ PY = -PYP(JDAUG,2)
+ PZ = -PYP(JDAUG,3)
+ PE = -PYP(JDAUG,4)
+
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
+ ENDIF
+ IFLG(JDAUG) = 1
+ ENDIF
+ 15 CONTINUE
+ ELSE
+* there was no mother resonance
+
+ MO = IHISMO(PYK(II,15))
+ ID = PYK(II,8)
+ PX = PYP(II,1)
+ PY = PYP(II,2)
+ PZ = PYP(II,3)
+ PE = PYP(II,4)
+
+ CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
+ IF (LEMCCK) THEN
+
+ PX = -PYP(II,1)
+ PY = -PYP(II,2)
+ PZ = -PYP(II,3)
+ PE = -PYP(II,4)
+
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
+ ENDIF
+ ENDIF
+ ENDIF
+ 13 CONTINUE
+ IF (LEMCCK) THEN
+ CHKLEV = TINY1
+ CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
+C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
+ ENDIF
+
+* global energy-momentum & flavor conservation check
+**sr 16.5. this check is skipped in case of phojet-treatment
+ IF (MCGENE.EQ.1)
+ & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
+
+* update statistics-counter for diffraction
+c IF (IFLAGD.NE.0) THEN
+c ICDIFF(1) = ICDIFF(1)+1
+c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
+c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
+c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
+c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
+c ENDIF
+
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===decay==============================================================*
+*
+CDECK ID>, DT_DECAYS
+ SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
+
+************************************************************************
+* Resonance-decay. *
+* This subroutine replaces DDECAY/DECHKK. *
+* PIN(4) 4-momentum of resonance (input) *
+* IDXIN BAMJET-index of resonance (input) *
+* POUT(20,4) 4-momenta of decay-products (output) *
+* IDXOUT(20) BAMJET-indices of decay-products (output) *
+* NSEC number of secondaries (output) *
+* Adopted from the original version DECHKK. *
+* This version dated 09.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY17=1.0D-17)
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+* 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
+
+ DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
+ & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
+ & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
+
+* ISTAB = 1 strong and weak decays
+* = 2 strong decays only
+* = 3 strong decays, weak decays for charmed particles and tau
+* leptons only
+ DATA ISTAB /2/
+
+ IREJ = 0
+ NSEC = 0
+* put initial resonance to stack
+ NSTK = 1
+ IDXSTK(NSTK) = IDXIN
+ DO 5 I=1,4
+ PI(NSTK,I) = PIN(I)
+ 5 CONTINUE
+
+* store initial configuration for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
+ & PI(NSTK,4),1,IDUM,IDUM)
+
+ 100 CONTINUE
+* get particle from stack
+ IDXI = IDXSTK(NSTK)
+* skip stable particles
+ IF (ISTAB.EQ.1) THEN
+ IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
+ ELSEIF (ISTAB.EQ.2) THEN
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
+ IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
+ IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
+ IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
+ IF ( IDXI.EQ.109) GOTO 10
+ IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
+ ELSEIF (ISTAB.EQ.3) THEN
+ IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
+ IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
+ IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
+ IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
+ ENDIF
+
+* calculate direction cosines and Lorentz-parameter of decaying part.
+ PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
+ PTOT = MAX(PTOT,TINY17)
+ DO 1 I=1,3
+ DCOS(I) = PI(NSTK,I)/PTOT
+ 1 CONTINUE
+ GAM = PI(NSTK,4)/AAM(IDXI)
+ BGAM = PTOT/AAM(IDXI)
+
+* get decay-channel
+ KCHAN = K1(IDXI)-1
+ 2 CONTINUE
+ KCHAN = KCHAN+1
+ IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
+
+* identities of secondaries
+ IDX(1) = NZK(KCHAN,1)
+ IDX(2) = NZK(KCHAN,2)
+ IF (IDX(2).LT.1) GOTO 9999
+ IDX(3) = NZK(KCHAN,3)
+
+* handle decay in rest system of decaying particle
+ IF (IDX(3).EQ.0) THEN
+* two-particle decay
+ NDEC = 2
+ CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & AAM(IDX(1)),AAM(IDX(2)))
+ ELSE
+* three-particle decay
+ NDEC = 3
+ CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & CODF(3),COFF(3),SIFF(3),
+ & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
+ ENDIF
+ NSTK = NSTK-1
+
+* transform decay products back
+ DO 3 I=1,NDEC
+ NSTK = NSTK+1
+ CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
+ & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
+ & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
+* add particle to stack
+ IDXSTK(NSTK) = IDX(I)
+ DO 4 J=1,3
+ PI(NSTK,J) = DCOSF(J)*PFF(I)
+ 4 CONTINUE
+ 3 CONTINUE
+ GOTO 100
+
+ 10 CONTINUE
+* stable particle, put to output-arrays
+ NSEC = NSEC+1
+ DO 6 I=1,4
+ POUT(NSEC,I) = PI(NSTK,I)
+ 6 CONTINUE
+ IDXOUT(NSEC) = IDXSTK(NSTK)
+* store secondaries for energy-momentum conservation check
+ IF (LEMCCK)
+ &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
+ & -POUT(NSEC,4),2,IDUM,IDUM)
+ NSTK = NSTK-1
+ IF (NSTK.GT.0) GOTO 100
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===decay1=============================================================*
+*
+CDECK ID>, DT_DECAY1
+ SUBROUTINE DT_DECAY1
+
+************************************************************************
+* Decay of resonances stored in DTEVT1. *
+* This version dated 20.01.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
+
+ NEND = NHKK
+C DO 1 I=NPOINT(5),NEND
+ DO 1 I=NPOINT(4),NEND
+ IF (ABS(ISTHKK(I)).EQ.1) THEN
+ DO 2 K=1,4
+ PIN(K) = PHKK(K,I)
+ 2 CONTINUE
+ IDXIN = IDBAM(I)
+ CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
+ IF (NSEC.GT.1) THEN
+ DO 3 N=1,NSEC
+ IDHAD = IDT_IPDGHA(IDXOUT(N))
+ CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
+ & POUT(N,3),POUT(N,4),0,0,0)
+ 3 CONTINUE
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===decpi0=============================================================*
+*
+CDECK ID>, DT_DECPI0
+ SUBROUTINE DT_DECPI0
+
+************************************************************************
+* Decay of pi0 handled with JETSET. *
+* This version dated 18.02.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,TINY3=1.0D-3,ONE=1.0D0,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)
+
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+* 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
+
+ INTEGER PYCOMP,PYK
+
+ DIMENSION IHISMO(NMXHKK),P1(4)
+
+ TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
+
+ CALL DT_INITJS(2)
+* allow pi0 decay
+
+ KC = PYCOMP(111)
+
+ MDCY(KC,1) = 1
+
+ NN = 0
+ INI = 0
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
+ IF (INI.EQ.0) THEN
+ INI = 1
+ ELSE
+ INI = 2
+ ENDIF
+ IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),INI,IDUM,IDUM)
+ PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
+ PTOT = SQRT(PT**2+PHKK(3,I)**2)
+ COSTH = PHKK(3,I)/(PTOT+TINY10)
+ IF (COSTH.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTH.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTH)
+ ENDIF
+ PHI = ASIN(PHKK(2,I)/(PT +TINY10))
+ IF (PHKK(1,I).LT.0.0D0)
+
+ & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
+
+ ENER = PHKK(4,I)
+ NN = NN+1
+ KTEMP = MSTU(10)
+ MSTU(10)= 1
+ P(NN,5) = PHKK(5,I)
+
+ CALL PY1ENT(NN,111,ENER,THETA,PHI)
+
+ MSTU(10) = KTEMP
+ IHISMO(NN)= I
+ ENDIF
+ 1 CONTINUE
+ IF (NN.GT.0) THEN
+
+ CALL PYEXEC
+
+ NLINES = PYK(0,1)
+
+ DO 2 II=1,NLINES
+
+ IF (PYK(II,7).EQ.1) THEN
+
+ DO 3 KK=1,4
+
+ P1(KK) = PYP(II,KK)
+
+ 3 CONTINUE
+
+ ID = PYK(II,8)
+ MO = IHISMO(PYK(II,15))
+
+ CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
+ & IDUM,IDUM)
+*sr: flag with neg. sign (for HELIOS p/A-W jobs)
+ ISTHKK(MO) = -2
+ ENDIF
+ 2 CONTINUE
+ IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
+ ENDIF
+ MDCY(KC,1) = 0
+
+ RETURN
+ END
+*
+*===dtwopd=============================================================*
+*
+CDECK ID>, DT_DTWOPD
+ SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
+ & COF2,SIF2,AM1,AM2)
+
+************************************************************************
+* Two-particle decay. *
+* UMO cm-energy of the decaying system (input) *
+* AM1/AM2 masses of the decay products (input) *
+* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
+* COD,COF,SIF direction cosines of the decay prod. (output) *
+* Revised by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
+
+ IF (UMO.LT.(AM1+AM2)) THEN
+ WRITE(LOUT,1000) UMO,AM1,AM2
+ 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
+ & 3E12.3)
+ STOP
+ ENDIF
+
+ ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
+ ECM2 = UMO-ECM1
+ PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
+ PCM2 = PCM1
+ CALL DT_DSFECF(SIF1,COF1)
+ COD1 = TWO*DT_RNDM(PCM2)-ONE
+ COD2 = -COD1
+ COF2 = -COF1
+ SIF2 = -SIF1
+
+ RETURN
+ END
+*
+*===dthrep=============================================================*
+*
+CDECK ID>, DT_DTHREP
+ SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
+ & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
+
+************************************************************************
+* Three-particle decay. *
+* UMO cm-energy of the decaying system (input) *
+* AM1/2/3 masses of the decay products (input) *
+* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
+* COD,COF,SIF direction cosines of the decay prod. (output) *
+* *
+* Threpd89: slight revision by A. Ferrari *
+* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
+* Revised by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER ( ANGLSQ = 2.5D-31 )
+ PARAMETER ( AZRZRZ = 1.0D-30 )
+ PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
+
+ COMMON /HNGAMR/ REDU,AMO,AMM(15)
+* 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 F(5),XX(5)
+ DATA EPS /AZRZRZ/
+
+ UMOO=UMO+UMO
+C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
+C***J. VON NEUMANN - RANDOM - SELECTION OF S2
+C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
+ UUMO=UMO
+ AAM1=AM1
+ AAM2=AM2
+ AAM3=AM3
+ GU=(AM2+AM3)**2
+ GO=(UMO-AM1)**2
+* UFAK=1.0000000000001D0
+* IF (GU.GT.GO) UFAK=0.9999999999999D0
+ IF (GU.GT.GO) THEN
+ UFAK=ONEMNS
+ ELSE
+ UFAK=ONEPLS
+ END IF
+ OFAK=2.D0-UFAK
+ GU=GU*UFAK
+ GO=GO*OFAK
+ DS2=(GO-GU)/99.D0
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ AM33=AM3*AM3
+ UMO2=UMO*UMO
+ RHO2=0.D0
+ S22=GU
+ DO 124 I=1,100
+ S21=S22
+ S22=GU+(I-1.D0)*DS2
+ RHO1=RHO2
+ RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
+ * (S22+EPS)
+ IF(RHO2.LT.RHO1) GO TO 125
+ 124 CONTINUE
+ 125 S2SUP=(S22-S21)*.5D0+S21
+ SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
+ * (S2SUP+EPS)
+ SUPRHO=SUPRHO*1.05D0
+ XO=S21-DS2
+ IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
+ IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
+ XX(1)=XO
+ XX(3)=S22
+ X1=(XO+S22)*0.5D0
+ XX(2)=X1
+ F(3)=RHO2
+ F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
+ F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
+ DO 126 I=1,16
+ X4=(XX(1)+XX(2))*0.5D0
+ X5=(XX(2)+XX(3))*0.5D0
+ F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
+ * (X4+EPS)
+ F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
+ * (X5+EPS)
+ XX(4)=X4
+ XX(5)=X5
+ DO 128 II=1,5
+ IA=II
+ DO 128 III=IA,5
+ IF (F (II).GE.F (III)) GO TO 128
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+128 CONTINUE
+ SUPRHO=F(1)
+ S2SUP=XX(1)
+ DO 129 II=1,3
+ IA=II
+ DO 129 III=IA,3
+ IF (XX(II).GE.XX(III)) GO TO 129
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+129 CONTINUE
+126 CONTINUE
+ AM23=(AM2+AM3)**2
+ ITH=0
+ REDU=2.D0
+ 1 CONTINUE
+ ITH=ITH+1
+ IF (ITH.GT.200) REDU=-9.D0
+ IF (ITH.GT.200) GO TO 400
+ C=DT_RNDM(REDU)
+* S2=AM23+C*((UMO-AM1)**2-AM23)
+ S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
+ Y=DT_RNDM(S2)
+ Y=Y*SUPRHO
+ RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
+ IF(Y.GT.RHO) GO TO 1
+C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
+ S1=DT_RNDM(S2)
+ S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
+ &RHO*.5D0
+ S3=UMO2+AM11+AM22+AM33-S1-S2
+ ECM1=(UMO2+AM11-S2)/UMOO
+ ECM2=(UMO2+AM22-S3)/UMOO
+ ECM3=(UMO2+AM33-S1)/UMOO
+ PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
+ PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
+ PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
+ CALL DT_DSFECF(SFE,CFE)
+C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
+C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
+ PCM12 = PCM1 * PCM2
+ IF ( PCM12 .LT. ANGLSQ ) GO TO 200
+ COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
+ GO TO 300
+ 200 CONTINUE
+ UW=DT_RNDM(S1)
+ COSTH=(UW-0.5D+00)*2.D+00
+ 300 CONTINUE
+* IF(ABS(COSTH).GT.0.9999999999999999D0)
+* &COSTH=SIGN(0.9999999999999999D0,COSTH)
+ IF(ABS(COSTH).GT.ONEONE)
+ &COSTH=SIGN(ONEONE,COSTH)
+ IF (REDU.LT.1.D+00) RETURN
+ COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
+* IF(ABS(COSTH2).GT.0.9999999999999999D0)
+* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
+ IF(ABS(COSTH2).GT.ONEONE)
+ &COSTH2=SIGN(ONEONE,COSTH2)
+ SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
+ SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
+ SINTH1=COSTH2*SINTH-COSTH*SINTH2
+ COSTH1=COSTH*COSTH2+SINTH2*SINTH
+C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
+C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
+C***THE DIRECTION OF PARTICLE 3
+C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
+ CX11=-COSTH1
+ CY11=SINTH1*CFE
+ CZ11=SINTH1*SFE
+ CX22=-COSTH2
+ CY22=-SINTH2*CFE
+ CZ22=-SINTH2*SFE
+ CALL DT_DSFECF(SIF3,COF3)
+ COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
+ SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
+ 2 FORMAT(5F20.15)
+ COD1=CX11*COD3+CZ11*SID3
+ CHLP=(ONEONE-COD1)*(ONEONE+COD1)
+ IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
+ &CX11,CZ11
+ SID1=SQRT(CHLP)
+ COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
+ SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
+ COD2=CX22*COD3+CZ22*SID3
+ SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
+ COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
+ SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
+ 400 CONTINUE
+* === Energy conservation check: === *
+ EOCHCK = UMO - ECM1 - ECM2 - ECM3
+* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
+* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
+* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
+ PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
+ PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
+ & + PCM3 * COF3 * SID3
+ PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
+ & + PCM3 * SIF3 * SID3
+ EOCMPR = 1.D-12 * UMO
+ IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
+ & .GT. EOCMPR ) THEN
+**sr 5.5.95 output-unit changed
+ IF (IOULEV(1).GT.0) THEN
+ WRITE(LOUT,*)
+ & ' *** Threpd: energy/momentum conservation failure! ***',
+ & EOCHCK,PXCHCK,PYCHCK,PZCHCK
+ WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
+ ENDIF
+**
+ END IF
+ RETURN
+ END
+*
+*===dbklas=============================================================*
+*
+CDECK ID>, DT_DBKLAS
+ SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ IF (I) 20,20,10
+* baryons
+ 10 CONTINUE
+ CALL DT_INDEXD(J,K,IND)
+ I8 = IB08(I,IND)
+ I10 = IB10(I,IND)
+ IF (I8.LE.0) I8 = I10
+ RETURN
+* antibaryons
+ 20 CONTINUE
+ II = IABS(I)
+ JJ = IABS(J)
+ KK = IABS(K)
+ CALL DT_INDEXD(JJ,KK,IND)
+ I8 = IA08(II,IND)
+ I10 = IA10(II,IND)
+ IF (I8.LE.0) I8 = I10
+
+ RETURN
+ END
+*
+*===indexd=============================================================*
+*
+CDECK ID>, DT_INDEXD
+ SUBROUTINE DT_INDEXD(KA,KB,IND)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ KP = KA*KB
+ KS = KA+KB
+ IF (KP.EQ.1) IND=1
+ IF (KP.EQ.2) IND=2
+ IF (KP.EQ.3) IND=3
+ IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
+ IF (KP.EQ.5) IND=5
+ IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
+ IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
+ IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
+ IF (KP.EQ.8) IND=9
+ IF (KP.EQ.10) IND=10
+ IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
+ IF (KP.EQ.9) IND=12
+ IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
+ IF (KP.EQ.15) IND=14
+ IF (KP.EQ.18) IND=15
+ IF (KP.EQ.16) IND=16
+ IF (KP.EQ.20) IND=17
+ IF (KP.EQ.24) IND=18
+ IF (KP.EQ.25) IND=19
+ IF (KP.EQ.30) IND=20
+ IF (KP.EQ.36) IND=21
+
+ RETURN
+ END
+*
+*===dchant=============================================================*
+*
+CDECK ID>, DT_DCHANT
+ SUBROUTINE DT_DCHANT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+* 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)
+
+ DIMENSION HWT(IDMAX9)
+
+* change of weights wt from absolut values into the sum of wt of a dec.
+ DO 10 J=1,IDMAX9
+ HWT(J) = ZERO
+ 10 CONTINUE
+C DO 999 KKK=1,210
+C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
+C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
+C & K1(KKK),K2(KKK)
+C 999 CONTINUE
+C STOP
+ DO 30 I=1,210
+ IK1 = K1(I)
+ IK2 = K2(I)
+ HV = ZERO
+ DO 20 J=IK1,IK2
+ HV = HV+WT(J)
+ HWT(J) = HV
+**sr 13.1.95
+ IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
+ 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
+ 20 CONTINUE
+ 30 CONTINUE
+ DO 40 J=1,IDMAX9
+ WT(J) = HWT(J)
+ 40 CONTINUE
+
+ RETURN
+ END
+*
+*===ddatar=============================================================*
+*
+CDECK ID>, DT_DDATAR
+ SUBROUTINE DT_DDATAR
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+* 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)
+
+ DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
+
+ DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
+ & 0, 0, 36, 37, 96,127, 0, 0,126,125,
+ & 128,129,14*0/
+ DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
+ & 0, 0, 15, 24, 31,120, 0, 0,119,118,
+ & 121,122,14*0/
+ DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
+ & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
+ & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
+ & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
+ & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
+ & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
+ & 0, 0, 0,140,137,138,146, 0, 0,142,
+ & 139,147, 0, 0,145,148, 50*0/
+ DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
+ & 0,107,164, 0, 0,167, 0, 0, 0, 0,
+ & 0, 54, 55,105,162, 0, 0, 56,106,163,
+ & 0, 0,108,165, 0, 0,168, 0, 0, 0,
+ & 0, 0,104,105,107,164, 0, 0,106,108,
+ & 165, 0, 0,109,166, 0, 0,169, 0, 0,
+ & 0, 0, 0,161,162,164,167, 0, 0,163,
+ & 165,168, 0, 0,166,169, 0, 0,170,47*0/
+ DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
+ & 0,102,150, 0, 0,158, 0, 0, 0, 0,
+ & 0, 2, 9,100,149, 0, 0, 0,101,154,
+ & 0, 0,103,151, 0, 0,159, 0, 0, 0,
+ & 0, 0, 99,100,102,150, 0, 0,101,103,
+ & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
+ & 0, 0, 0,152,149,150,158, 0, 0,154,
+ & 151,159, 0, 0,157,160, 50*0/
+ DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
+ & 0,113,174, 0, 0,177, 0, 0, 0, 0,
+ & 0, 68, 69,111,172, 0, 0, 70,112,173,
+ & 0, 0,114,175, 0, 0,178, 0, 0, 0,
+ & 0, 0,110,111,113,174, 0, 0,112,114,
+ & 175, 0, 0,115,176, 0, 0,179, 0, 0,
+ & 0, 0, 0,171,172,174,177, 0, 0,173,
+ & 175,178, 0, 0,176,179, 0, 0,180,47*0/
+
+ L=0
+ DO 2 I=1,6
+ DO 1 J=1,6
+ L = L+1
+ IMPS(I,J) = IP(L)
+ IMVE(I,J) = IV(L)
+ 1 CONTINUE
+ 2 CONTINUE
+ L=0
+ DO 4 I=1,6
+ DO 3 J=1,21
+ L = L+1
+ IB08(I,J) = IB(L)
+ IB10(I,J) = IBB(L)
+ IA08(I,J) = IA(L)
+ IA10(I,J) = IAA(L)
+ 3 CONTINUE
+ 4 CONTINUE
+C A1 = 0.88D0
+C B1 = 3.0D0
+C B2 = 3.0D0
+C B3 = 8.0D0
+C LT = 0
+C LB = 0
+C BET = 12.0D0
+C AS = 0.25D0
+C B8 = 0.33D0
+C AME = 0.95D0
+C DIQ = 0.375D0
+C ISU = 4
+
+ RETURN
+ END
+*
+*===initjs=============================================================*
+*
+CDECK ID>, DT_INITJS
+ SUBROUTINE DT_INITJS(MODE)
+
+************************************************************************
+* Initialize JETSET paramters. *
+* MODE = 0 default settings *
+* = 1 PHOJET settings *
+* = 2 DTUNUC settings *
+* This version dated 16.02.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,ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LFIRST,LFIRDT,LFIRPH
+
+ INCLUDE './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(PART)'
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+* 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
+* 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
+
+ INTEGER PYCOMP
+
+ DIMENSION IDXSTA(40)
+ DATA IDXSTA
+* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
+ & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
+* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
+ & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
+* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
+ & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
+* Ksic0 aKsic+aKsic0 sig0 asig0
+ & 4132,-4232,-4132, 3212,-3212, 5*0/
+
+ DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
+
+ IF (LFIRST) THEN
+* save default settings
+ PDEF1 = PARJ(1)
+ PDEF2 = PARJ(2)
+ PDEF3 = PARJ(3)
+ PDEF5 = PARJ(5)
+ PDEF6 = PARJ(6)
+ PDEF7 = PARJ(7)
+ PDEF18 = PARJ(18)
+ PDEF19 = PARJ(19)
+ PDEF21 = PARJ(21)
+ PDEF42 = PARJ(42)
+ MDEF12 = MSTJ(12)
+* LUJETS / PYJETS array-dimensions
+
+ MSTU(4) = 4000
+
+* increase maximum number of JETSET-error prints
+ MSTU(22) = 50000
+* prevent particles decaying
+ DO 1 I=1,35
+ IF (I.LT.34) THEN
+
+ KC = PYCOMP(IDXSTA(I))
+
+ IF (I.EQ.2) THEN
+* pi0 decay
+C MDCY(KC,1) = 1
+ MDCY(KC,1) = 0
+**cr mode
+C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
+C & (I.EQ.8).OR.(I.EQ.10)) THEN
+C ELSEIF (I.EQ.4) THEN
+C MDCY(KC,1) = 1
+**
+ ELSE
+ MDCY(KC,1) = 0
+ ENDIF
+ ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
+
+ KC = PYCOMP(IDXSTA(I))
+
+ MDCY(KC,1) = 0
+ ENDIF
+ 1 CONTINUE
+*
+
+* as Fluka event-generator: allow only paprop particles to be stable
+* and let all other particles decay (i.e. those with strong decays)
+ IF (ITRSPT.EQ.1) THEN
+ DO 5 I=1,IDMAXP
+ IF (KPTOIP(I).NE.0) THEN
+ IDPDG = MPDGHA(I)
+
+ KC = PYCOMP(IDPDG)
+
+ IF (MDCY(KC,1).EQ.1) THEN
+ WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
+ & 'transport : particle should not ',
+ & 'decay : ',IDPDG,' ',ANAME(I)
+ MDCY(KC,1) = 0
+ ENDIF
+ ENDIF
+ 5 CONTINUE
+ DO 6 KC=1,500
+ IDPDG = KCHG(KC,4)
+ KP = MCIHAD(IDPDG)
+ IF (KP.GT.0) THEN
+ IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
+ & (ANAME(KP).NE.'BLANK ').AND.
+ & (ANAME(KP).NE.'RNDFLV ')) THEN
+ WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
+ & 'transport: particle should decay ',
+ & ': ',IDPDG,' ',ANAME(KP)
+ MDCY(KC,1) = 1
+ ENDIF
+ ENDIF
+ 6 CONTINUE
+ ENDIF
+
+*
+* popcorn:
+ IF (PDB.LE.ZERO) THEN
+* no popcorn-mechanism
+ MSTJ(12) = 1
+ ELSE
+ MSTJ(12) = 3
+ PARJ(5) = PDB
+ ENDIF
+* set JETSET-parameter requested by input cards
+ IF (NMSTU.GT.0) THEN
+ DO 2 I=1,NMSTU
+ MSTU(IMSTU(I)) = MSTUX(I)
+ 2 CONTINUE
+ ENDIF
+ IF (NMSTJ.GT.0) THEN
+ DO 3 I=1,NMSTJ
+ MSTJ(IMSTJ(I)) = MSTJX(I)
+ 3 CONTINUE
+ ENDIF
+ IF (NPARU.GT.0) THEN
+ DO 4 I=1,NPARU
+ PARU(IPARU(I)) = PARUX(I)
+ 4 CONTINUE
+ ENDIF
+ LFIRST = .FALSE.
+ ENDIF
+*
+* PARJ(1) suppression of qq-aqaq pair prod. compared to
+* q-aq pair prod. (default: 0.1)
+* PARJ(2) strangeness suppression (default: 0.3)
+* PARJ(3) extra suppression of strange diquarks (default: 0.4)
+* PARJ(6) extra suppression of sas-pair shared by B and
+* aB in BMaB (default: 0.5)
+* PARJ(7) extra suppression of strange meson M in BMaB
+* configuration (default: 0.5)
+* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
+* PARJ(21) width sigma in Gaussian p_x, p_y transverse
+* momentum distrib. for prim. hadrons (default: 0.35)
+* PARJ(42) b-parameter for symmetric Lund-fragmentation
+* function (default: 0.9 GeV^-2)
+*
+* PHOJET settings
+ IF (MODE.EQ.1) THEN
+* JETSET default
+C PARJ(1) = PDEF1
+C PARJ(2) = PDEF2
+C PARJ(3) = PDEF3
+C PARJ(6) = PDEF6
+C PARJ(7) = PDEF7
+C PARJ(18) = PDEF18
+C PARJ(21) = PDEF21
+C PARJ(42) = PDEF42
+**sr 18.11.98 parameter tuning
+C PARJ(1) = 0.092D0
+C PARJ(2) = 0.25D0
+C PARJ(3) = 0.45D0
+C PARJ(19) = 0.3D0
+C PARJ(21) = 0.45D0
+C PARJ(42) = 1.0D0
+**sr 28.04.99 parameter tuning (May 99 minor modifications)
+ PARJ(1) = 0.085D0
+ PARJ(2) = 0.26D0
+ PARJ(3) = 0.8D0
+ PARJ(11) = 0.38D0
+ PARJ(18) = 0.3D0
+ PARJ(19) = 0.4D0
+ PARJ(21) = 0.36D0
+ PARJ(41) = 0.3D0
+ PARJ(42) = 0.86D0
+ IF (NPARJ.GT.0) THEN
+ DO 10 I=1,NPARJ
+ IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
+ 10 CONTINUE
+ ENDIF
+ IF (LFIRPH) THEN
+C *** Commented by Chiara
+C WRITE(LOUT,'(1X,A)')
+C & 'DT_INITJS: JETSET-parameter for PHOJET'
+ CALL DT_JSPARA(0)
+ LFIRPH = .FALSE.
+ ENDIF
+* DTUNUC settings
+ ELSEIF (MODE.EQ.2) THEN
+ IF (IFRAG(2).EQ.1) THEN
+**sr parameters before 9.3.96
+C PARJ(2) = 0.27D0
+C PARJ(3) = 0.6D0
+C PARJ(6) = 0.75D0
+C PARJ(7) = 0.75D0
+C PARJ(21) = 0.55D0
+C PARJ(42) = 1.3D0
+**sr 18.11.98 parameter tuning
+C PARJ(1) = 0.05D0
+C PARJ(2) = 0.27D0
+C PARJ(3) = 0.4D0
+C PARJ(19) = 0.2D0
+C PARJ(21) = 0.45D0
+C PARJ(42) = 1.0D0
+**sr 28.04.99 parameter tuning
+ PARJ(1) = 0.11D0
+ PARJ(2) = 0.36D0
+ PARJ(3) = 0.8D0
+ PARJ(19) = 0.2D0
+ PARJ(21) = 0.3D0
+ PARJ(41) = 0.3D0
+ PARJ(42) = 0.58D0
+ IF (NPARJ.GT.0) THEN
+ DO 20 I=1,NPARJ
+ IF (IPARJ(I).LT.0) THEN
+ IDX = ABS(IPARJ(I))
+ PARJ(IDX) = PARJX(I)
+ ENDIF
+ 20 CONTINUE
+ ENDIF
+ IF (LFIRDT) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'DT_INITJS: JETSET-parameter for DTUNUC'
+ CALL DT_JSPARA(0)
+ LFIRDT = .FALSE.
+ ENDIF
+ ELSEIF (IFRAG(2).EQ.2) THEN
+ PARJ(1) = 0.11D0
+ PARJ(2) = 0.27D0
+ PARJ(3) = 0.3D0
+ PARJ(6) = 0.35D0
+ PARJ(7) = 0.45D0
+ PARJ(18) = 0.66D0
+C PARJ(21) = 0.55D0
+C PARJ(42) = 1.0D0
+ PARJ(21) = 0.60D0
+ PARJ(42) = 1.3D0
+ ELSE
+ PARJ(1) = PDEF1
+ PARJ(2) = PDEF2
+ PARJ(3) = PDEF3
+ PARJ(6) = PDEF6
+ PARJ(7) = PDEF7
+ PARJ(18) = PDEF18
+ PARJ(21) = PDEF21
+ PARJ(42) = PDEF42
+ ENDIF
+ ELSE
+ PARJ(1) = PDEF1
+ PARJ(2) = PDEF2
+ PARJ(3) = PDEF3
+ PARJ(5) = PDEF5
+ PARJ(6) = PDEF6
+ PARJ(7) = PDEF7
+ PARJ(18) = PDEF18
+ PARJ(19) = PDEF19
+ PARJ(21) = PDEF21
+ PARJ(42) = PDEF42
+ MSTJ(12) = MDEF12
+ ENDIF
+
+ RETURN
+ END
+*
+*===jspara=============================================================*
+*
+CDECK ID>, DT_JSPARA
+ SUBROUTINE DT_JSPARA(MODE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
+ & ONE=1.0D0,ZERO=0.0D0)
+
+ LOGICAL LFIRST
+
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
+
+ DATA LFIRST /.TRUE./
+
+* save the default JETSET-parameter on the first call
+ IF (LFIRST) THEN
+ DO 1 I=1,200
+ ISTU(I) = MSTU(I)
+ QARU(I) = PARU(I)
+ ISTJ(I) = MSTJ(I)
+ QARJ(I) = PARJ(I)
+ 1 CONTINUE
+ LFIRST = .FALSE.
+ ENDIF
+
+C *** Commented by Chiara
+C WRITE(LOUT,1000)
+C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
+
+* compare the default JETSET-parameter with the present values
+ DO 2 I=1,200
+C *** Commented by Chiara
+C IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
+C WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
+CC ISTU(I) = MSTU(I)
+C ENDIF
+ DIFF = ABS(PARU(I)-QARU(I))
+C *** Commented by Chiara
+C IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
+C WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
+CC QARU(I) = PARU(I)
+C ENDIF
+C *** Commented by Chiara
+C IF (MSTJ(I).NE.ISTJ(I)) THEN
+C WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
+CC ISTJ(I) = MSTJ(I)
+C ENDIF
+ DIFF = ABS(PARJ(I)-QARJ(I))
+C *** Commented by Chiara
+C IF (DIFF.GE.1.0D-5) THEN
+C WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
+CC QARJ(I) = PARJ(I)
+C ENDIF
+ 2 CONTINUE
+ 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
+ 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
+
+ RETURN
+ END
+*
+*===fozoca=============================================================*
+*
+CDECK ID>, DT_FOZOCA
+ SUBROUTINE DT_FOZOCA(LFZC,IREJ)
+
+************************************************************************
+* This subroutine treats the complete FOrmation ZOne supressed intra- *
+* nuclear CAscade. *
+* LFZC = .true. cascade has been treated *
+* = .false. cascade skipped *
+* This is a completely revised version of the original FOZOKL. *
+* This version dated 18.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
+ PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
+
+ LOGICAL LSTART,LCAS,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)
+* 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
+* Glauber formalism: collision properties
+ COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+ & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* 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
+* final state after intranuclear cascade step
+ COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+ DIMENSION NCWOUN(2)
+
+ DATA LSTART /.TRUE./
+
+ LFZC = .TRUE.
+ IREJ = 0
+
+* skip cascade if hadron-hadron interaction or if supressed by user
+ IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
+* skip cascade if not all possible chains systems are hadronized
+ DO 1 I=1,8
+ IF (.NOT.LHADRO(I)) GOTO 9999
+ 1 CONTINUE
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
+ 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
+ & 'maximum of',I4,' generations',/,10X,'formation time ',
+ & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
+ IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
+ IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
+ 1001 FORMAT(10X,'p_t dependent formation zone',/)
+ 1002 FORMAT(10X,'constant formation zone',/)
+ LSTART = .FALSE.
+ ENDIF
+
+* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
+* which may interact with final state particles are stored in a seperate
+* array - here all proj./target nucleon-indices (just for simplicity)
+ NOINC = 0
+ DO 9 I=1,NPOINT(1)-1
+ NOINC = NOINC+1
+ IDXINC(NOINC) = I
+ 9 CONTINUE
+
+* initialize Pauli-principle treatment (find wounded nucleons)
+ NWOUND(1) = 0
+ NWOUND(2) = 0
+ NCWOUN(1) = 0
+ NCWOUN(2) = 0
+ DO 2 J=1,NPOINT(1)
+ DO 3 I=1,2
+ IF (ISTHKK(J).EQ.10+I) THEN
+ NWOUND(I) = NWOUND(I)+1
+ EWOUND(I,NWOUND(I)) = PHKK(4,J)
+ IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
+ ENDIF
+ 3 CONTINUE
+ 2 CONTINUE
+
+* modify nuclear potential for wounded nucleons
+ IPRCL = IP -NWOUND(1)
+ IPZRCL = IPZ-NCWOUN(1)
+ ITRCL = IT -NWOUND(2)
+ ITZRCL = ITZ-NCWOUN(2)
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
+
+ NSTART = NPOINT(4)
+ NEND = NHKK
+
+ 7 CONTINUE
+ DO 8 I=NSTART,NEND
+
+ IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
+* select nucleus the cascade starts first (proj. - 1, target - -1)
+ NCAS = 1
+* projectile/target with probab. 1/2
+ IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
+ IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
+* in the nucleus with highest mass
+ ELSEIF (INCMOD.EQ.2) THEN
+ IF (IP.GT.IT) THEN
+ NCAS = -NCAS
+ ELSEIF (IP.EQ.IT) THEN
+ IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
+ ENDIF
+* the nucleus the cascade starts first is requested to be the one
+* moving in the direction of the secondary
+ ELSEIF (INCMOD.EQ.3) THEN
+ NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
+ ENDIF
+* check that the selected "nucleus" is not a hadron
+ IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
+
+* treat intranuclear cascade in the nucleus selected first
+ LCAS = .FALSE.
+ CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9998
+* treat intranuclear cascade in the other nucleus if this isn't a had.
+ NCAS = -NCAS
+ IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
+ IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9998
+ ENDIF
+
+ ENDIF
+
+ 8 CONTINUE
+ NSTART = NEND+1
+ NEND = NHKK
+ IF (NSTART.LE.NEND) GOTO 7
+
+ RETURN
+
+ 9998 CONTINUE
+* reject this event
+ IRINC = IRINC+1
+ IREJ = 1
+
+ 9999 CONTINUE
+* intranucl. cascade not treated because of interaction properties or
+* it is supressed by user or it was rejected or...
+ LFZC = .FALSE.
+* reset flag characterizing direction of motion in n-n-cms
+**sr14-11-95
+C DO 9990 I=NPOINT(5),NHKK
+C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
+C9990 CONTINUE
+
+ RETURN
+ END
+*
+*===inucas=============================================================*
+*
+CDECK ID>, DT_INUCAS
+ SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
+
+************************************************************************
+* Formation zone supressed IntraNUclear CAScade for one final state *
+* particle. *
+* IT, IP mass numbers of target, projectile nuclei *
+* IDXCAS index of final state particle in DTEVT1 *
+* NCAS = 1 intranuclear cascade in projectile *
+* = -1 intranuclear cascade in target *
+* This version dated 18.11.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,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
+ PARAMETER (TWOPI=6.283185307179586454D+00)
+ PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
+
+ LOGICAL LABSOR,LCAS
+
+* 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)
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+* 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
+* 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
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+* final state after intranuclear cascade step
+ COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+
+ DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
+ & PCAS1(5),PNUC(5),BGTA(4),
+ & BGCAS(2),GACAS(2),BECAS(2),
+ & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
+
+ DATA PDIF /0.545D0/
+
+ IREJ = 0
+
+* update counter
+ IF (NINCEV(1).NE.NEVHKK) THEN
+ NINCEV(1) = NEVHKK
+ NINCEV(2) = NINCEV(2)+1
+ ENDIF
+
+* "BAMJET-index" of this hadron
+ IDCAS = IDBAM(IDXCAS)
+ IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
+
+* skip gammas, electrons, etc..
+ IF (AAM(IDCAS).LT.TINY2) RETURN
+
+* Lorentz-trsf. into projectile rest system
+ IF (IP.GT.1) THEN
+ CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
+ & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
+ & PCAS(1,4),IDCAS,-2)
+ PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
+ PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
+ IF (PCAS(1,5).GT.ZERO) THEN
+ PCAS(1,5) = SQRT(PCAS(1,5))
+ ELSE
+ PCAS(1,5) = AAM(IDCAS)
+ ENDIF
+ DO 20 K=1,3
+ COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
+ 20 CONTINUE
+* Lorentz-parameters
+* particle rest system --> projectile rest system
+ BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
+ GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
+ BECAS(1) = BGCAS(1)/GACAS(1)
+ ELSE
+ DO 21 K=1,5
+ PCAS(1,K) = ZERO
+ IF (K.LE.3) COSCAS(1,K) = ZERO
+ 21 CONTINUE
+ PTOCAS(1) = ZERO
+ BGCAS(1) = ZERO
+ GACAS(1) = ZERO
+ BECAS(1) = ZERO
+ ENDIF
+* Lorentz-trsf. into target rest system
+ IF (IT.GT.1) THEN
+* LEPTO: final state particles are already in target rest frame
+C IF (MCGENE.EQ.3) THEN
+C PCAS(2,1) = PHKK(1,IDXCAS)
+C PCAS(2,2) = PHKK(2,IDXCAS)
+C PCAS(2,3) = PHKK(3,IDXCAS)
+C PCAS(2,4) = PHKK(4,IDXCAS)
+C ELSE
+ CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
+ & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
+ & PCAS(2,4),IDCAS,-3)
+C ENDIF
+ PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
+ PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
+ IF (PCAS(2,5).GT.ZERO) THEN
+ PCAS(2,5) = SQRT(PCAS(2,5))
+ ELSE
+ PCAS(2,5) = AAM(IDCAS)
+ ENDIF
+ DO 22 K=1,3
+ COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
+ 22 CONTINUE
+* Lorentz-parameters
+* particle rest system --> target rest system
+ BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
+ GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
+ BECAS(2) = BGCAS(2)/GACAS(2)
+ ELSE
+ DO 23 K=1,5
+ PCAS(2,K) = ZERO
+ IF (K.LE.3) COSCAS(2,K) = ZERO
+ 23 CONTINUE
+ PTOCAS(2) = ZERO
+ BGCAS(2) = ZERO
+ GACAS(2) = ZERO
+ BECAS(2) = ZERO
+ ENDIF
+
+* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
+* potential (see CONUCL)
+ RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
+ RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
+* impact parameter (the projectile moving along z)
+ BIMPC(1) = ZERO
+ BIMPC(2) = BIMPAC*FM2MM
+
+* get position of initial hadron in projectile/target rest-syst.
+ DO 3 K=1,4
+ VTXCAS(1,K) = WHKK(K,IDXCAS)
+ VTXCAS(2,K) = VHKK(K,IDXCAS)
+ 3 CONTINUE
+
+ ICAS = 1
+ I2 = 2
+ IF (NCAS.EQ.-1) THEN
+ ICAS = 2
+ I2 = 1
+ ENDIF
+
+ IF (PTOCAS(ICAS).LT.TINY10) THEN
+ WRITE(LOUT,1000) PTOCAS
+ 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
+ & ' hadron ',/,20X,2E12.4)
+ GOTO 9999
+ ENDIF
+
+* reset spectator flags
+ NSPE = 0
+ IDXSPE(1) = 0
+ IDXSPE(2) = 0
+ IDSPE(1) = 0
+ IDSPE(2) = 0
+
+* formation length (in fm)
+C IF (LCAS) THEN
+C DEL0 = ZERO
+C ELSE
+ DEL0 = TAUFOR*BGCAS(ICAS)
+ IF (ITAUVE.EQ.1) THEN
+ AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
+ DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
+ ENDIF
+C ENDIF
+* sample from exp(-del/del0)
+ DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
+* save formation time
+ TAUSA1 = DEL1/BGCAS(ICAS)
+ REL1 = TAUSA1*BGCAS(I2)
+
+ DEL = DEL1
+ TAUSAM = DEL/BGCAS(ICAS)
+ REL = TAUSAM*BGCAS(I2)
+
+* special treatment for negative particles unable to escape
+* nuclear potential (implemented for ap, pi-, K- only)
+ LABSOR = .FALSE.
+ IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
+* threshold energy = nuclear potential + Coulomb potential
+* (nuclear potential for hadron-nucleus interactions only)
+ ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
+ IF (PCAS(ICAS,4).LT.ETHR) THEN
+ DO 4 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ 4 CONTINUE
+* "absorb" negative particle in nucleus
+ CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (NSPE.GE.1) LABSOR = .TRUE.
+ ENDIF
+ ENDIF
+
+* if the initial particle has not been absorbed proceed with
+* "normal" cascade
+ IF (.NOT.LABSOR) THEN
+
+* calculate coordinates of hadron at the end of the formation zone
+* transport-time and -step in the rest system where this step is
+* treated
+ DSTEP = DEL*FM2MM
+ DTIME = DSTEP/BECAS(ICAS)
+ RSTEP = REL*FM2MM
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME = RSTEP/BECAS(I2)
+ ELSE
+ RTIME = ZERO
+ ENDIF
+* save step whithout considering the overlapping region
+ DSTEP1 = DEL1*FM2MM
+ DTIME1 = DSTEP1/BECAS(ICAS)
+ RSTEP1 = REL1*FM2MM
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME1 = RSTEP1/BECAS(I2)
+ ELSE
+ RTIME1 = ZERO
+ ENDIF
+* transport to the end of the formation zone in this system
+ DO 5 K=1,3
+ VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
+ VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
+ VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
+ VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
+ 5 CONTINUE
+ VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
+ VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
+ VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
+ VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
+
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ XCAS = VTXCAS(ICAS,1)
+ YCAS = VTXCAS(ICAS,2)
+ XNCLTA = BIMPAC*FM2MM
+ RNCLPR = (RPROJ+RNUCLE)*FM2MM
+ RNCLTA = (RTARG+RNUCLE)*FM2MM
+C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
+C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
+C RNCLPR = (RPROJ)*FM2MM
+C RNCLTA = (RTARG)*FM2MM
+ RCASPR = SQRT( XCAS**2 +YCAS**2)
+ RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
+ IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
+ IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
+ ENDIF
+ ENDIF
+
+* check if particle is already outside of the corresp. nucleus
+ RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
+ & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
+ IF (RDIST.GE.RNUC(ICAS)) THEN
+* here: IDCH is the generation of the final state part. starting
+* with zero for hadronization products
+* flag particles of generation 0 being outside the nuclei after
+* formation time (to be used for excitation energy calculation)
+ IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
+ & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
+ GOTO 9997
+ ENDIF
+ DIST = DLARGE
+ DISTP = DLARGE
+ DISTN = DLARGE
+ IDXP = 0
+ IDXN = 0
+
+* already here: skip particles being outside HADRIN "energy-window"
+* to avoid wasting of time
+ NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
+ IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
+ NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
+C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
+C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
+C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
+C & E12.4,', above or below HADRIN-thresholds',I6)
+ NSPE = 0
+ GOTO 9997
+ ENDIF
+
+ DO 7 IDXHKK=1,NOINC
+ I = IDXINC(IDXHKK)
+* scan DTEVT1 for unwounded or excited nucleons
+ IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
+ DO 8 K=1,3
+ IF (ICAS.EQ.1) THEN
+ VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
+ ELSEIF (ICAS.EQ.2) THEN
+ VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
+ ENDIF
+ 8 CONTINUE
+ POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
+ & VTXDST(2)*COSCAS(ICAS,2)+
+ & VTXDST(3)*COSCAS(ICAS,3)
+* check if nucleon is situated in forward direction
+ IF (POSNUC.GT.ZERO) THEN
+* distance between hadron and this nucleon
+ DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+ & VTXDST(3)**2)
+* impact parameter
+ BIMNU2 = DISTNU**2-POSNUC**2
+ IF (BIMNU2.LT.ZERO) THEN
+ WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
+ 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
+ & ' parameter ',/,20X,3E12.4)
+ GOTO 7
+ ENDIF
+ BIMNU = SQRT(BIMNU2)
+* maximum impact parameter to have interaction
+ IDNUC = IDT_ICIHAD(IDHKK(I))
+ IDNUC1 = IDT_MCHAD(IDNUC)
+ IDCAS1 = IDT_MCHAD(IDCAS)
+ DO 19 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ PNUC(K) = PHKK(K,I)
+ 19 CONTINUE
+* Lorentz-parameter for trafo into rest-system of target
+ DO 18 K=1,4
+ BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
+ 18 CONTINUE
+* transformation of projectile into rest-system of target
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+ & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
+ & PPTOT,PX,PY,PZ,PE)
+**
+C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
+C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
+ DUMZER = ZERO
+ CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
+ CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
+ IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
+ & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
+ SIGIN = SIGTOT-SIGEL-SIGAB
+C SIGTOT = SIGIN+SIGEL+SIGAB
+**
+ BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
+* check if interaction is possible
+ IF (BIMNU.LE.BIMMAX) THEN
+* get nucleon with smallest distance and kind of interaction
+* (elastic/inelastic)
+ IF (DISTNU.LT.DIST) THEN
+ DIST = DISTNU
+ BINT = BIMNU
+ IF (IDNUC.NE.IDSPE(1)) THEN
+ IDSPE(2) = IDSPE(1)
+ IDXSPE(2) = IDXSPE(1)
+ IDSPE(1) = IDNUC
+ ENDIF
+ IDXSPE(1) = I
+ NSPE = 1
+**sr
+ SELA = SIGEL
+ SABS = SIGAB
+ STOT = SIGTOT
+C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
+C SELA = SIGEL
+C STOT = SIGIN+SIGEL
+C ELSE
+C SELA = SIGEL+0.75D0*SIGIN
+C STOT = 0.25D0*SIGIN+SELA
+C ENDIF
+**
+ ENDIF
+ ENDIf
+ ENDIF
+ DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+ & VTXDST(3)**2)
+ IDNUC = IDT_ICIHAD(IDHKK(I))
+ IF (IDNUC.EQ.1) THEN
+ IF (DISTNU.LT.DISTP) THEN
+ DISTP = DISTNU
+ IDXP = I
+ POSP = POSNUC
+ ENDIF
+ ELSEIF (IDNUC.EQ.8) THEN
+ IF (DISTNU.LT.DISTN) THEN
+ DISTN = DISTNU
+ IDXN = I
+ POSN = POSNUC
+ ENDIF
+ ENDIF
+ ENDIF
+ 7 CONTINUE
+
+* there is no nucleon for a secondary interaction
+ IF (NSPE.EQ.0) GOTO 9997
+
+C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
+C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
+ IF (IDXSPE(2).EQ.0) THEN
+ IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
+C DO 80 K=1,3
+C IF (ICAS.EQ.1) THEN
+C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
+C ELSEIF (ICAS.EQ.2) THEN
+C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
+C ENDIF
+C 80 CONTINUE
+C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+C & VTXDST(3)**2)
+C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
+ IDXSPE(2) = IDXN
+ IDSPE(2) = 8
+C ELSE
+C STOT = STOT-SABS
+C SABS = ZERO
+C ENDIF
+ ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
+C DO 81 K=1,3
+C IF (ICAS.EQ.1) THEN
+C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
+C ELSEIF (ICAS.EQ.2) THEN
+C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
+C ENDIF
+C 81 CONTINUE
+C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
+C & VTXDST(3)**2)
+C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
+ IDXSPE(2) = IDXP
+ IDSPE(2) = 1
+C ELSE
+C STOT = STOT-SABS
+C SABS = ZERO
+C ENDIF
+ ELSE
+ STOT = STOT-SABS
+ SABS = ZERO
+ ENDIF
+ ENDIF
+ RR = DT_RNDM(DIST)
+ IF (RR.LT.SELA/STOT) THEN
+ IPROC = 2
+ ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
+ IPROC = 3
+ ELSE
+ IPROC = 1
+ ENDIF
+
+ DO 9 K=1,5
+ PCAS1(K) = PCAS(ICAS,K)
+ PNUC(K) = PHKK(K,IDXSPE(1))
+ 9 CONTINUE
+ IF (IPROC.EQ.3) THEN
+* 2-nucleon absorption of pion
+ NSPE = 2
+ CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ IF (NSPE.GE.1) LABSOR = .TRUE.
+ ELSE
+* sample secondary interaction
+ IDNUC = IDBAM(IDXSPE(1))
+ CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
+ IF (IREJ1.EQ.1) GOTO 9999
+ IF (IREJ1.GT.1) GOTO 9998
+ ENDIF
+ ENDIF
+
+* update arrays to include Pauli-principle
+ DO 10 I=1,NSPE
+ IF (NWOUND(ICAS).LE.299) THEN
+ NWOUND(ICAS) = NWOUND(ICAS)+1
+ EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
+ ENDIF
+ 10 CONTINUE
+
+* dump initial hadron for energy-momentum conservation check
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
+ & PCAS(ICAS,4),1,IDUM,IDUM)
+
+* dump final state particles into DTEVT1
+
+* check if Pauli-principle is fulfilled
+ NPAULI = 0
+ NWTMP(1) = NWOUND(1)
+ NWTMP(2) = NWOUND(2)
+ DO 111 I=1,NFSP
+ NPAULI = 0
+ J1 = 2
+ IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
+ DO 117 J=1,J1
+ IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
+ IF (J.EQ.1) THEN
+ IDX = ICAS
+ PE = PFSP(4,I)
+ ELSE
+ IDX = I2
+ MODE = 1
+ IF (IDX.EQ.1) MODE = -1
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
+ ENDIF
+* first check if cascade step is forbidden due to Pauli-principle
+* (in case of absorpion this step is forced)
+ IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
+ & (IDFSP(I).EQ.8))) THEN
+* get nuclear potential barrier
+ POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
+ IF (IDFSP(I).EQ.1) THEN
+ POTLOW = POT-EBINDP(IDX)
+ ELSE
+ POTLOW = POT-EBINDN(IDX)
+ ENDIF
+* final state particle not able to escape nucleus
+ IF (PE.LE.POTLOW) THEN
+* check if there are wounded nucleons
+ IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
+ & EWOUND(IDX,NWOUND(IDX)))) THEN
+ NPAULI = NPAULI+1
+ NWOUND(IDX) = NWOUND(IDX)-1
+ ELSE
+* interaction prohibited by Pauli-principle
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+ GOTO 9997
+ ENDIF
+ ENDIF
+ ENDIF
+ 117 CONTINUE
+ 111 CONTINUE
+
+ NPAULI = 0
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+
+ DO 11 I=1,NFSP
+
+ IST = ISTHKK(IDXCAS)
+
+ NPAULI = 0
+ J1 = 2
+ IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
+ & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
+ DO 17 J=1,J1
+ IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
+ IDX = ICAS
+ PE = PFSP(4,I)
+ IF (J.EQ.2) THEN
+ IDX = I2
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
+ ENDIF
+* first check if cascade step is forbidden due to Pauli-principle
+* (in case of absorpion this step is forced)
+ IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
+ & (IDFSP(I).EQ.8))) THEN
+* get nuclear potential barrier
+ POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
+ IF (IDFSP(I).EQ.1) THEN
+ POTLOW = POT-EBINDP(IDX)
+ ELSE
+ POTLOW = POT-EBINDN(IDX)
+ ENDIF
+* final state particle not able to escape nucleus
+ IF (PE.LE.POTLOW) THEN
+* check if there are wounded nucleons
+ IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
+ & EWOUND(IDX,NWOUND(IDX)))) THEN
+ NWOUND(IDX) = NWOUND(IDX)-1
+ NPAULI = NPAULI+1
+ IST = 14+IDX
+ ELSE
+* interaction prohibited by Pauli-principle
+ NWOUND(1) = NWTMP(1)
+ NWOUND(2) = NWTMP(2)
+ GOTO 9997
+ ENDIF
+**sr
+c ELSEIF (PE.LE.POT) THEN
+cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
+cC NWOUND(IDX) = NWOUND(IDX)-1
+c**
+c NPAULI = NPAULI+1
+c IST = 14+IDX
+ ENDIF
+ ENDIF
+ 17 CONTINUE
+
+* dump final state particles for energy-momentum conservation check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
+ & -PFSP(4,I),2,IDUM,IDUM)
+
+ PX = PFSP(1,I)
+ PY = PFSP(2,I)
+ PZ = PFSP(3,I)
+ PE = PFSP(4,I)
+ IF (ABS(IST).EQ.1) THEN
+* transform particles back into n-n cms
+* LEPTO: leave final state particles in target rest frame
+C IF (MCGENE.EQ.3) THEN
+C PFSP(1,I) = PX
+C PFSP(2,I) = PY
+C PFSP(3,I) = PZ
+C PFSP(4,I) = PE
+C ELSE
+ IMODE = ICAS+1
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),IMODE)
+C ENDIF
+ ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
+* target cascade but fsp got stuck in proj. --> transform it into
+* proj. rest system
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),-1)
+ ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
+* proj. cascade but fsp got stuck in target --> transform it into
+* target rest system
+ CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I),IDFSP(I),1)
+ ENDIF
+
+* dump final state particles into DTEVT1
+ IGEN = IDCH(IDXCAS)+1
+ ID = IDT_IPDGHA(IDFSP(I))
+ IXR = 0
+ IF (LABSOR) IXR = 99
+ CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
+ & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
+
+* update the counter for particles which got stuck inside the nucleus
+ IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
+ NOINC = NOINC+1
+ IDXINC(NOINC) = NHKK
+ ENDIF
+ IF (LABSOR) THEN
+* in case of absorption the spatial treatment is an approximate
+* solution anyway (the positions of the nucleons which "absorb" the
+* cascade particle are not taken into consideration) therefore the
+* particles are produced at the position of the cascade particle
+ DO 12 K=1,4
+ WHKK(K,NHKK) = WHKK(K,IDXCAS)
+ VHKK(K,NHKK) = VHKK(K,IDXCAS)
+ 12 CONTINUE
+ ELSE
+* DDISTL - distance the cascade particle moves to the intera. point
+* (the position where impact-parameter = distance to the interacting
+* nucleon), DIST - distance to the interacting nucleon at the time of
+* formation of the cascade particle, BINT - impact-parameter of this
+* cascade-interaction
+ DDISTL = SQRT(DIST**2-BINT**2)
+ DTIME = DDISTL/BECAS(ICAS)
+ DTIMEL = DDISTL/BGCAS(ICAS)
+ RDISTL = DTIMEL*BGCAS(I2)
+ IF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ RTIME = RDISTL/BECAS(I2)
+ ELSE
+ RTIME = ZERO
+ ENDIF
+* RDISTL, RTIME are this step and time in the rest system of the other
+* nucleus
+ DO 13 K=1,3
+ VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
+ VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
+ 13 CONTINUE
+ VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
+ VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
+* position of particle production is half the impact-parameter to
+* the interacting nucleon
+ DO 14 K=1,3
+ WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
+ VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
+ 14 CONTINUE
+* time of production of secondary = time of interaction
+ WHKK(4,NHKK) = VTXCA1(1,4)
+ VHKK(4,NHKK) = VTXCA1(2,4)
+ ENDIF
+
+ 11 CONTINUE
+
+* modify status and position of cascade particle (the latter for
+* statistics reasons only)
+ ISTHKK(IDXCAS) = 2
+ IF (LABSOR) ISTHKK(IDXCAS) = 19
+ IF (.NOT.LABSOR) THEN
+ DO 15 K=1,4
+ WHKK(K,IDXCAS) = VTXCA1(1,K)
+ VHKK(K,IDXCAS) = VTXCA1(2,K)
+ 15 CONTINUE
+ ENDIF
+
+ DO 16 I=1,NSPE
+ IS = IDXSPE(I)
+* dump interacting nucleons for energy-momentum conservation check
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
+ & 2,IDUM,IDUM)
+* modify entry for interacting nucleons
+ IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
+ IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
+ IF (I.GE.2) THEN
+ JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
+ JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
+ ENDIF
+ 16 CONTINUE
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+* update counter
+ IF (LABSOR) THEN
+ NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
+ ELSE
+ IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
+ IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
+ ENDIF
+
+ RETURN
+
+ 9997 CONTINUE
+ 9998 CONTINUE
+* transport-step but no cascade step due to configuration (i.e. there
+* is no nucleon for interaction etc.)
+ IF (LCAS) THEN
+ DO 100 K=1,4
+C WHKK(K,IDXCAS) = VTXCAS(1,K)
+C VHKK(K,IDXCAS) = VTXCAS(2,K)
+ WHKK(K,IDXCAS) = VTXCA1(1,K)
+ VHKK(K,IDXCAS) = VTXCA1(2,K)
+ 100 CONTINUE
+ ENDIF
+
+C9998 CONTINUE
+* no cascade-step because of configuration
+* (i.e. hadron outside nucleus etc.)
+ LCAS = .TRUE.
+ RETURN
+
+ 9999 CONTINUE
+* rejection
+ IREJ = 1
+ RETURN
+ END
+*
+*===absorp=============================================================*
+*
+CDECK ID>, DT_ABSORP
+ SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
+
+************************************************************************
+* Two-nucleon absorption of antiprotons, pi-, and K-. *
+* Antiproton absorption is handled by HADRIN. *
+* The following channels for meson-absorption are considered: *
+* pi- + p + p ---> n + p *
+* pi- + p + n ---> n + n *
+* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
+* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
+* K- + p + p ---> sigma- + n *
+* IDCAS, PCAS identity, momentum of particle to be absorbed *
+* NCAS = 1 intranuclear cascade in projectile *
+* = -1 intranuclear cascade in target *
+* NSPE number of spectator nucleons involved *
+* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
+* Revised version of the original STOPIK written by HJM and J. Ranft. *
+* This version dated 24.02.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,TINY5=1.0D-5,ONE=1.0D0,
+ & ONETHI=0.3333D0,TWOTHI=0.6666D0)
+
+* 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
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+* 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)
+
+ DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
+ & PTOT3P(4),BG3P(4),
+ & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
+
+ IREJ = 0
+ NFSP = 0
+
+* skip particles others than ap, pi-, K- for mode=0
+ IF ((MODE.EQ.0).AND.
+ & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
+* skip particles others than pions for mode=1
+* (2-nucleon absorption in intranuclear cascade)
+ IF ((MODE.EQ.1).AND.
+ & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
+
+ NUCAS = NCAS
+ IF (NUCAS.EQ.-1) NUCAS = 2
+
+ IF (MODE.EQ.0) THEN
+* scan spectator nucleons for nucleons being able to "absorb"
+ NSPE = 0
+ IDXSPE(1) = 0
+ IDXSPE(2) = 0
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
+ NSPE = NSPE+1
+ IDXSPE(NSPE) = I
+ IDSPE(NSPE) = IDBAM(I)
+ IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
+ IF (NSPE.EQ.2) THEN
+ IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
+ & (IDSPE(2).EQ.8)) THEN
+* there is no pi-+n+n channel
+ NSPE = 1
+ GOTO 1
+ ELSE
+ GOTO 2
+ ENDIF
+ ENDIF
+ ENDIF
+ 1 CONTINUE
+
+ 2 CONTINUE
+ ENDIF
+* transform excited projectile nucleons (status=15) into proj. rest s.
+ DO 3 I=1,NSPE
+ DO 4 K=1,5
+ PSPE(I,K) = PHKK(K,IDXSPE(I))
+ 4 CONTINUE
+ 3 CONTINUE
+
+* antiproton absorption
+ IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
+ DO 5 K=1,5
+ PSPE1(K) = PSPE(1,K)
+ 5 CONTINUE
+ CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+
+* meson absorption
+ ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
+ & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
+ IF (IDCAS.EQ.14) THEN
+* pi- absorption
+ IDFSP(1) = 8
+ IDFSP(2) = 8
+ IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
+ ELSEIF (IDCAS.EQ.13) THEN
+* pi+ absorption
+ IDFSP(1) = 1
+ IDFSP(2) = 1
+ IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
+ ELSEIF (IDCAS.EQ.23) THEN
+* pi0 absorption
+ IDFSP(1) = IDSPE(1)
+ IDFSP(2) = IDSPE(2)
+ ELSEIF (IDCAS.EQ.16) THEN
+* K- absorption
+ R = DT_RNDM(PCAS)
+ IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
+ IF (R.LT.ONETHI) THEN
+ IDFSP(1) = 21
+ IDFSP(2) = 8
+ ELSEIF (R.LT.TWOTHI) THEN
+ IDFSP(1) = 17
+ IDFSP(2) = 1
+ ELSE
+ IDFSP(1) = 22
+ IDFSP(2) = 1
+ ENDIF
+ ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
+ IDFSP(1) = 20
+ IDFSP(2) = 8
+ ELSE
+ IF (R.LT.ONETHI) THEN
+ IDFSP(1) = 20
+ IDFSP(2) = 1
+ ELSEIF (R.LT.TWOTHI) THEN
+ IDFSP(1) = 17
+ IDFSP(2) = 8
+ ELSE
+ IDFSP(1) = 22
+ IDFSP(2) = 8
+ ENDIF
+ ENDIF
+ ENDIF
+* dump initial particles for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
+ & IDUM,IDUM)
+ CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
+ & IDUM,IDUM)
+ ENDIF
+* get Lorentz-parameter of 3 particle initial state
+ DO 6 K=1,4
+ PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
+ 6 CONTINUE
+ P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
+ AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
+ DO 7 K=1,4
+ BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
+ 7 CONTINUE
+* 2-particle decay of the 3-particle compound system
+ CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
+ & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
+ & AAM(IDFSP(1)),AAM(IDFSP(2)))
+ DO 8 I=1,2
+ SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
+ PX = PCMF(I)*COFF(I)*SDF
+ PY = PCMF(I)*SIFF(I)*SDF
+ PZ = PCMF(I)*CODF(I)
+ CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
+ & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
+ & PFSP(4,I))
+ PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
+* check consistency of kinematics
+ IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
+ WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
+ 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
+ & ' tree-particle kinematics',/,20X,'id: ',I3,
+ & ' AAM = ',E10.4,' MFSP = ',E10.4)
+ ENDIF
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
+ & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
+ 8 CONTINUE
+ NFSP = 2
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
+ & AM3P
+ GOTO 9999
+ ENDIF
+ ENDIF
+ ELSE
+ IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
+ 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
+ & ' impossible',/,20X,'too few spectators (',I2,')')
+ NSPE = 0
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
+ IREJ = 1
+ RETURN
+ END
+*
+*===hadrin=============================================================*
+*
+CDECK ID>, DT_HADRIN
+ SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
+
+************************************************************************
+* Interface to the HADRIN-routines for inelastic and elastic *
+* scattering. *
+* IDPR,PPR(5) identity, momentum of projectile *
+* IDTA,PTA(5) identity, momentum of target *
+* MODE = 1 inelastic interaction *
+* = 2 elastic interaction *
+* Revised version of the original FHAD. *
+* This version dated 27.10.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,TINY5=1.0D-5,TINY3=1.0D-3,
+ & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
+
+ LOGICAL LCORR,LMSSG
+
+* 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
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+* 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)
+* output-common for DHADRI/ELHAIN
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+ DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
+ & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
+
+ DATA LMSSG /.TRUE./
+
+ IREJ = 0
+ NFSP = 0
+ KCORR = 0
+ IMCORR(1) = 0
+ IMCORR(2) = 0
+ LCORR = .FALSE.
+
+* dump initial particles for energy-momentum cons. check
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
+ CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
+ ENDIF
+
+ AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
+ AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
+ IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
+ & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
+ & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
+ IF (LMSSG.AND.(IOULEV(3).GT.0))
+ & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
+ 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
+ & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
+ & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
+ LMSSG = .FALSE.
+ LCORR = .TRUE.
+ ENDIF
+
+* convert initial state particles into particles which can be
+* handled by HADRIN
+ IDHPR = IDPR
+ IDHTA = IDTA
+ IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
+ IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
+ DO 1 K=1,4
+ P1IN(K) = PPR(K)
+ P2IN(K) = PTA(K)
+ 1 CONTINUE
+ XM1 = AAM(IDHPR)
+ XM2 = AAM(IDHTA)
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
+ GOTO 9999
+ ENDIF
+ DO 2 K=1,4
+ PPR(K) = P1OUT(K)
+ PTA(K) = P2OUT(K)
+ 2 CONTINUE
+ PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
+ PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
+ ENDIF
+
+* Lorentz-parameter for trafo into rest-system of target
+ DO 3 K=1,4
+ BGTA(K) = PTA(K)/PTA(5)
+ 3 CONTINUE
+* transformation of projectile into rest-system of target
+ CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
+ & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
+ & PPR1(4))
+
+* direction cosines of projectile in target rest system
+ CX = PPR1(1)/PPRTO1
+ CY = PPR1(2)/PPRTO1
+ CZ = PPR1(3)/PPRTO1
+
+* sample inelastic interaction
+ IF (MODE.EQ.1) THEN
+ CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
+ IF (IRH.EQ.1) GOTO 9998
+* sample elastic interaction
+ ELSEIF (MODE.EQ.2) THEN
+ CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
+ IF (IREJ1.NE.0) THEN
+ IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
+ GOTO 9999
+ ENDIF
+ IF (IRH.EQ.1) GOTO 9998
+ ELSE
+ WRITE(LOUT,1001) MODE,INTHAD
+ 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
+ & I4,' (INTHAD =',I4,')')
+ GOTO 9999
+ ENDIF
+
+* transform final state particles back into Lab.
+ DO 4 I=1,IRH
+ NFSP = NFSP+1
+ PX = CXRH(I)*PLRH(I)
+ PY = CYRH(I)*PLRH(I)
+ PZ = CZRH(I)*PLRH(I)
+ CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
+ & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
+ & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
+ IDFSP(NFSP) = ITRH(I)
+ AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
+ & PFSP(3,NFSP)**2
+ IF (AMFSP2.LT.-TINY3) THEN
+ WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
+ & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
+ 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
+ & I2,') with negative mass^2',/,1X,5E12.4)
+ GOTO 9999
+ ELSE
+ PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
+ IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
+ WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
+ & PFSP(5,NFSP)
+ 1003 FORMAT(1X,'HADRIN: warning! final state particle',
+ & ' (id = ',I2,') with inconsistent mass',/,1X,
+ & 2E12.4)
+ KCORR = KCORR+1
+ IF (KCORR.GT.2) GOTO 9999
+ IMCORR(KCORR) = NFSP
+ ENDIF
+ ENDIF
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
+ & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
+ 4 CONTINUE
+
+* transform momenta on mass shell in case of inconsistencies in
+* HADRIN
+ IF (KCORR.GT.0) THEN
+ IF (KCORR.EQ.2) THEN
+ I1 = IMCORR(1)
+ I2 = IMCORR(2)
+ ELSE
+ IF (IMCORR(1).EQ.1) THEN
+ I1 = 1
+ I2 = 2
+ ELSE
+ I1 = 1
+ I2 = IMCORR(1)
+ ENDIF
+ ENDIF
+ IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
+ & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
+ IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
+ & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
+ DO 5 K=1,4
+ P1IN(K) = PFSP(K,I1)
+ P2IN(K) = PFSP(K,I2)
+ 5 CONTINUE
+ XM1 = AAM(IDFSP(I1))
+ XM2 = AAM(IDFSP(I2))
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
+C GOTO 9999
+ ENDIF
+ DO 6 K=1,4
+ PFSP(K,I1) = P1OUT(K)
+ PFSP(K,I2) = P2OUT(K)
+ 6 CONTINUE
+ PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
+ & -PFSP(2,I1)**2-PFSP(3,I1)**2)
+ PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
+ & -PFSP(2,I2)**2-PFSP(3,I2)**2)
+* dump final state particles for energy-momentum cons. check
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
+ & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
+ IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
+ & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
+ ENDIF
+
+* check energy-momentum conservation
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+
+ RETURN
+
+ 9998 CONTINUE
+ IREJ = 2
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===hadcol=============================================================*
+*
+CDECK ID>, DT_HADCOL
+ SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
+
+************************************************************************
+* Interface to the HADRIN-routines for inelastic and elastic *
+* scattering. This subroutine samples hadron-nucleus interactions *
+* below DPM-threshold. *
+* IDPROJ BAMJET-index of projectile hadron *
+* PPN projectile momentum in target rest frame *
+* IDXTAR DTEVT1-index of target nucleon undergoing *
+* interaction with projectile hadron *
+* This subroutine replaces HADHAD. *
+* This version dated 5.5.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,TINY3=1.0D-3,ONE=1.0D0)
+
+ 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)
+* 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
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+* final state after inc step
+ PARAMETER (MAXFSP=10)
+ COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
+* 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)
+
+ DIMENSION PPROJ(5),PNUC(5)
+
+ DATA LSTART /.TRUE./
+
+ IREJ = 0
+
+ NPOINT(1) = NHKK+1
+
+ TAUSAV = TAUFOR
+**sr 6/9/01 commented
+C TAUFOR = TAUFOR/2.0D0
+**
+ IF (LSTART) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
+ WRITE(LOUT,1001) TAUFOR
+ 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
+ & F5.1,' fm/c')
+ LSTART = .FALSE.
+ ENDIF
+
+ IDNUC = IDBAM(IDXTAR)
+ IDNUC1 = IDT_MCHAD(IDNUC)
+ IDPRO1 = IDT_MCHAD(IDPROJ)
+
+ IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
+ IPROC = INTHAD
+ ELSE
+**
+C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
+C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
+ DUMZER = ZERO
+ CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
+ SIGIN = SIGTOT-SIGEL
+C SIGTOT = SIGIN+SIGEL
+**
+ IPROC = 1
+ IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
+ ENDIF
+
+ PPROJ(1) = ZERO
+ PPROJ(2) = ZERO
+ PPROJ(3) = PPN
+ PPROJ(5) = AAM(IDPROJ)
+ PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
+ DO 1 K=1,5
+ PNUC(K) = PHKK(K,IDXTAR)
+ 1 CONTINUE
+
+ ILOOP = 0
+ 2 CONTINUE
+ ILOOP = ILOOP+1
+ IF (ILOOP.GT.100) GOTO 9999
+
+ CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
+ IF (IREJ1.EQ.1) GOTO 9999
+
+ IF (IREJ1.GT.1) THEN
+* no interaction possible
+* require Pauli blocking
+ IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
+ IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
+ IF ((IIBAR(IDPROJ).NE.1).AND.
+ & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
+* store incoming particle as final state particle
+ CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
+ CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
+ NPOINT(4) = NHKK
+ ELSE
+* require Pauli blocking for final state nucleons
+ DO 4 I=1,NFSP
+ IF ((IDFSP(I).EQ.1).AND.
+ & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
+ IF ((IDFSP(I).EQ.8).AND.
+ & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
+ IF ((IIBAR(IDFSP(I)).NE.1).AND.
+ & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
+ 4 CONTINUE
+* store final state particles
+ DO 5 I=1,NFSP
+ IST = 1
+ IF ((IIBAR(IDFSP(I)).EQ.1).AND.
+ & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
+ IDHAD = IDT_IPDGHA(IDFSP(I))
+ CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
+ CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
+ & PCMS,ECMS,0,0,0)
+ IF (I.EQ.1) NPOINT(4) = NHKK
+ VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
+ VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
+ VHKK(3,NHKK) = VHKK(3,IDXTAR)
+ VHKK(4,NHKK) = VHKK(4,IDXTAR)
+ WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
+ WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
+ WHKK(3,NHKK) = WHKK(3,1)
+ WHKK(4,NHKK) = WHKK(4,1)
+ 5 CONTINUE
+ ENDIF
+ TAUFOR = TAUSAV
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ TAUFOR = TAUSAV
+ RETURN
+ END
+*
+*===getemu=============================================================*
+*
+CDECK ID>, DT_GETEMU
+ SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
+
+************************************************************************
+* Sampling of emulsion component to be considered as target-nucleus. *
+* This version dated 6.5.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,TINY3=1.0D-3,TINY10=1.0D-10)
+
+ 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
+
+ IF (MODE.EQ.0) THEN
+ SUMFRA = ZERO
+ RR = DT_RNDM(SUMFRA)
+ IT = 0
+ ITZ = 0
+ DO 1 ICOMP=1,NCOMPO
+ SUMFRA = SUMFRA+EMUFRA(ICOMP)
+ IF (SUMFRA.GT.RR) THEN
+ IT = IEMUMA(ICOMP)
+ ITZ = IEMUCH(ICOMP)
+ KKMAT = ICOMP
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ IF (IT.LE.0) THEN
+ WRITE(LOUT,'(1X,A,E12.3)')
+ & 'Warning! norm. failure within emulsion fractions',
+ & SUMFRA
+ STOP
+ ENDIF
+ ELSEIF (MODE.EQ.1) THEN
+ NDIFF = 10000
+ DO 3 I=1,NCOMPO
+ IDIFF = ABS(IT-IEMUMA(I))
+ IF (IDIFF.LT.NDIFF) THEN
+ KKMAT = I
+ NDIFF = IDIFF
+ ENDIF
+ 3 CONTINUE
+ ELSE
+ STOP 'DT_GETEMU'
+ ENDIF
+
+* bypass for variable projectile/target/energy runs: the correct
+* Glauber data will be always loaded on kkmat=1
+ IF (IOGLB.EQ.100) THEN
+ KKMAT = 1
+ ENDIF
+
+ RETURN
+ END
+*
+*===nclpot=============================================================*
+*
+CDECK ID>, DT_NCLPOT
+ SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
+
+************************************************************************
+* Calculation of Coulomb and nuclear potential for a given configurat. *
+* IPZ, IP charge/mass number of proj. *
+* ITZ, IT charge/mass number of targ. *
+* AFERP,AFERT factors modifying proj./target pot. *
+* if =0, FERMOD is used *
+* MODE = 0 calculation of binding energy *
+* = 1 pre-calculated binding energy is used *
+* This version dated 16.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,TINY3=1.0D-3,TINY2=1.0D-2,
+ & TINY10=1.0D-10)
+
+ 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
+
+ DIMENSION IDXPOT(14)
+* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
+ DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
+* asig0 asig+ atet0 atet+
+ & 100, 101, 102, 103/
+
+ DATA AN /0.4D0/
+ DATA LSTART /.TRUE./
+
+ IF (MODE.EQ.0) THEN
+ EBINDP(1) = ZERO
+ EBINDN(1) = ZERO
+ EBINDP(2) = ZERO
+ EBINDN(2) = ZERO
+ ENDIF
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+ FERMIP = AFERP
+ IF (AFERP.LE.ZERO) FERMIP = FERMOD
+ FERMIT = AFERT
+ IF (AFERT.LE.ZERO) FERMIT = FERMOD
+
+* Fermi momenta and binding energy for projectile
+ IF ((IP.GT.1).AND.LFERMI) THEN
+ IF (MODE.EQ.0) THEN
+C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
+C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
+ BIP = AIP -ONE
+ BIPZ = AIPZ-ONE
+
+ EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
+ & -ENERGY(BIP,BIPZ))
+
+ IF (AIP.LE.AIPZ) THEN
+ EBINDN(1) = EBINDP(1)
+ WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
+ ELSE
+
+ EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
+ & -ENERGY(BIP,AIPZ))
+
+ ENDIF
+ ENDIF
+ PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
+ PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
+ ELSE
+ PFERMP(1) = ZERO
+ PFERMN(1) = ZERO
+ ENDIF
+* effective nuclear potential for projectile
+C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
+C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
+ EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
+ EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
+
+* Fermi momenta and binding energy for target
+ IF ((IT.GT.1).AND.LFERMI) THEN
+ IF (MODE.EQ.0) THEN
+C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
+C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
+ BIT = AIT -ONE
+ BITZ = AITZ-ONE
+
+ EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
+ & -ENERGY(BIT,BITZ))
+
+ IF (AIT.LE.AITZ) THEN
+ EBINDN(2) = EBINDP(2)
+ WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
+ ELSE
+
+ EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
+ & -ENERGY(BIT,AITZ))
+
+ ENDIF
+ ENDIF
+ PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
+ PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
+ ELSE
+ PFERMP(2) = ZERO
+ PFERMN(2) = ZERO
+ ENDIF
+* effective nuclear potential for target
+C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
+C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
+ EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
+ EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
+
+ DO 2 I=1,14
+ EPOT(1,IDXPOT(I)) = EPOT(1,8)
+ EPOT(2,IDXPOT(I)) = EPOT(2,8)
+ 2 CONTINUE
+
+* Coulomb energy
+ ETACOU(1) = ZERO
+ ETACOU(2) = ZERO
+ IF (ICOUL.EQ.1) THEN
+ IF (IP.GT.1)
+ & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
+ IF (IT.GT.1)
+ & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
+ ENDIF
+
+ IF (LSTART) THEN
+ WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
+ & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
+ & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
+ & FERMOD,ETACOU
+ 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
+ & ,' effects',/,12X,'---------------------------',
+ & '----------------',/,/,38X,'projectile',
+ & ' target',/,/,1X,'Mass number / charge',
+ & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
+ & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
+ & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
+ & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
+ & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
+ & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
+ LSTART = .FALSE.
+ ENDIF
+
+ RETURN
+ END
+*
+*===resncl=============================================================*
+*
+CDECK ID>, DT_RESNCL
+ SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
+
+************************************************************************
+* Treatment of residual nuclei and nuclear effects. *
+* MODE = 1 initializations *
+* = 2 treatment of final state *
+* This version dated 16.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.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
+ & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
+ & ONETHI=ONE/THREE)
+ PARAMETER (AMUAMU = 0.93149432D0,
+ & FM2MM = 1.0D-12,
+ & RNUCLE = 1.12D0)
+
+* 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)
+* 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
+* 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
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+* treatment of residual nuclei: wounded nucleons
+ COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+
+ DIMENSION PFSP(4),PSEC(4),PSEC0(4)
+ DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
+ & IDXCOR(15000),IDXOTH(NMXHKK)
+
+ GOTO (1,2) MODE
+
+*------- initializations
+ 1 CONTINUE
+
+* initialize arrays for residual nuclei
+ DO 10 K=1,5
+ IF (K.LE.4) THEN
+ PFSP(K) = ZERO
+ ENDIF
+ PINIPR(K) = ZERO
+ PINITA(K) = ZERO
+ PRCLPR(K) = ZERO
+ PRCLTA(K) = ZERO
+ TRCLPR(K) = ZERO
+ TRCLTA(K) = ZERO
+ 10 CONTINUE
+ SCPOT = ONE
+ NLOOP = 0
+
+* correction of projectile 4-momentum for effective target pot.
+* and Coulomb-energy (in case of hadron-nucleus interaction only)
+ IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
+ EPNI = EPN
+* Coulomb-energy:
+* positively charged hadron - check energy for Coloumb pot.
+ IF (IICH(IJPROJ).EQ.1) THEN
+ THRESH = ETACOU(2)+AAM(IJPROJ)
+ IF (EPNI.LE.THRESH) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
+ & ' below Coulomb threshold - event rejected',/)
+ ISTHKK(1) = 1
+ RETURN
+ ENDIF
+* negatively charged hadron - increase energy by Coulomb energy
+ ELSEIF (IICH(IJPROJ).EQ.-1) THEN
+ EPNI = EPNI+ETACOU(2)
+ ENDIF
+ IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
+* Effective target potential
+*sr 6.6. binding energy only (to avoid negative exc. energies)
+C EPNI = EPNI+EPOT(2,IJPROJ)
+ EBIPOT = EBINDP(2)
+ IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
+ & EBIPOT = EBINDN(2)
+ EPNI = EPNI+ABS(EBIPOT)
+* re-initialization of DTLTRA
+ DUM1 = ZERO
+ DUM2 = ZERO
+ CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
+ ENDIF
+ ENDIF
+
+* projectile in n-n cms
+ IF ((IP.LE.1).AND.(IT.GT.1)) THEN
+ PMASS1 = AAM(IJPROJ)
+C* VDM assumption
+C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
+ IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
+ PMASS2 = AAM(1)
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
+ PINIPR(5) = PMASS1
+ IF (PMASS1.GT.ZERO) THEN
+ PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
+ & *(PINIPR(4)+PINIPR(5)))
+ ELSE
+ PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
+ ENDIF
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+ PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
+
+ CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
+ ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
+ PMASS1 = AAM(1)
+ PMASS2 = AAM(IJTARG)
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
+ PINITA(5) = PMASS2
+ PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
+ & *(PINITA(4)+PINITA(5)))
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+
+ PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
+
+ CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
+ ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
+ AIP = DBLE(IP)
+ AIPZ = DBLE(IPZ)
+
+ PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
+
+ CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
+ AIT = DBLE(IT)
+ AITZ = DBLE(ITZ)
+
+ PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
+
+ CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
+ ENDIF
+
+ RETURN
+
+*------- treatment of final state
+ 2 CONTINUE
+
+ NLOOP = NLOOP+1
+ IF (NLOOP.GT.1) SCPOT = 0.10D0
+C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
+
+ JPW = NPW
+ JPCW = NPCW
+ JTW = NTW
+ JTCW = NTCW
+ DO 40 K=1,4
+ PFSP(K) = ZERO
+ 40 CONTINUE
+
+ NOB = 0
+ NOM = 0
+ DO 900 I=NPOINT(4),NHKK
+ IDXOTH(I) = -1
+ IF (ISTHKK(I).EQ.1) THEN
+ IF (IDBAM(I).EQ.7) GOTO 900
+ IPOT = 0
+ IOTHER = 0
+* particle moving into forward direction
+ IF (PHKK(3,I).GE.ZERO) THEN
+* most likely to be effected by projectile potential
+ IPOT = 1
+* there is no projectile nucleus, try target
+ IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
+ IPOT = 2
+ IF (IP.GT.1) IOTHER = 1
+* there is no target nucleus --> skip
+ IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
+ ENDIF
+* particle moving into backward direction
+ ELSE
+* most likely to be effected by target potential
+ IPOT = 2
+* there is no target nucleus, try projectile
+ IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
+ IPOT = 1
+ IF (IT.GT.1) IOTHER = 1
+* there is no projectile nucleus --> skip
+ IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
+ ENDIF
+ ENDIF
+ IFLG = -IPOT
+* nobam=3: particle is in overlap-region or neither inside proj. nor target
+* =1: particle is not in overlap-region AND is inside target (2)
+* =2: particle is not in overlap-region AND is inside projectile (1)
+* flag particles which are inside the nucleus ipot but not in its
+* overlap region
+ IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
+* baryons: keep all nucleons and all others where flag is set
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
+ & THEN
+ NOB = NOB+1
+ PMOMB(NOB) = PHKK(3,I)
+ IDXB(NOB) = SIGN(1000000*IABS(IFLG)
+ & +100000*IOTHER+I,IFLG)
+ ENDIF
+* mesons: keep only those mesons where flag is set
+ ELSE
+ IF (IFLG.GT.0) THEN
+ NOM = NOM+1
+ PMOMM(NOM) = PHKK(3,I)
+ IDXM(NOM) = 1000000*IFLG+100000*IOTHER+I
+ ENDIF
+ ENDIF
+ ENDIF
+ 900 CONTINUE
+*
+* sort particles in the arrays according to increasing long. momentum
+ CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
+ CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
+*
+* shuffle indices into one and the same array according to the later
+* sequence of correction
+ NCOR = 0
+ IF (IT.GT.1) THEN
+ DO 910 I=1,NOB
+ IF (PMOMB(I).GT.ZERO) GOTO 911
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 910 CONTINUE
+ 911 CONTINUE
+ IF (IP.GT.1) THEN
+ DO 912 J=1,NOB
+ I = NOB+1-J
+ IF (PMOMB(I).LT.ZERO) GOTO 913
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 912 CONTINUE
+ 913 CONTINUE
+ ELSE
+ DO 914 I=1,NOB
+ IF (PMOMB(I).GT.ZERO) THEN
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ ENDIF
+ 914 CONTINUE
+ ENDIF
+ ELSE
+ DO 915 J=1,NOB
+ I = NOB+1-J
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXB(I)
+ 915 CONTINUE
+ ENDIF
+ DO 925 I=1,NOM
+ IF (PMOMM(I).GT.ZERO) GOTO 926
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXM(I)
+ 925 CONTINUE
+ 926 CONTINUE
+ DO 927 J=1,NOM
+ I = NOM+1-J
+ IF (PMOMM(I).LT.ZERO) GOTO 928
+ NCOR = NCOR+1
+ IDXCOR(NCOR) = IDXM(I)
+ 927 CONTINUE
+ 928 CONTINUE
+*
+C IF (NEVHKK.EQ.484) THEN
+C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
+C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
+C WRITE(LOUT,9001) NOB,NOM,NCOR
+C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
+C WRITE(LOUT,'(/,A)') ' baryons '
+C DO 950 I=1,NOB
+CC J = IABS(IDXB(I))
+CC INDEX = J-IABS(J/1000000)*1000000
+C IPOT = IABS(IDXB(I))/1000000
+C IOTHER = IABS(IDXB(I))/100000-IPOT*10
+C INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
+C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
+C 950 CONTINUE
+C WRITE(LOUT,'(/,A)') ' mesons '
+C DO 951 I=1,NOM
+CC INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
+C IPOT = IABS(IDXM(I))/1000000
+C IOTHER = IABS(IDXM(I))/100000-IPOT*10
+C INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
+C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
+C 951 CONTINUE
+C 9002 FORMAT(1X,4I14,E14.5)
+C WRITE(LOUT,'(/,A)') ' all '
+C DO 952 I=1,NCOR
+CC J = IABS(IDXCOR(I))
+CC INDEX = J-IABS(J/1000000)*1000000
+CC IPOT = IABS(IDXCOR(I))/1000000
+C IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
+C INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
+C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
+C 952 CONTINUE
+C 9003 FORMAT(1X,4I14)
+C ENDIF
+*
+ DO 20 ICOR=1,NCOR
+ IPOT = IABS(IDXCOR(ICOR))/1000000
+ IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
+ I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
+ IDXOTH(I) = 1
+
+ IDSEC = IDBAM(I)
+
+* reduction of particle momentum by corresponding nuclear potential
+* (this applies only if Fermi-momenta are requested)
+
+ IF (LFERMI) THEN
+
+* Lorentz-transformation into the rest system of the selected nucleus
+ IMODE = -IPOT-1
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
+ PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
+ AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
+ JPMOD = 0
+
+ CHKLEV = TINY3
+ IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
+ IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
+ IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
+ 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
+ & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
+ & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
+ GOTO 23
+ ENDIF
+
+ DO 21 K=1,4
+ PSEC0(K) = PSEC(K)
+ 21 CONTINUE
+
+* the correction for nuclear potential effects is applied to as many
+* p/n as many nucleons were wounded; the momenta of other final state
+* particles are corrected only if they materialize inside the corresp.
+* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
+* = 3 part. outside proj. and targ., >=10 in overlapping region)
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
+ IF (IPOT.EQ.1) THEN
+ IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
+* this is most likely a wounded nucleon
+**test
+C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
+C & +(VHKK(2,IPW(JPW))/FM2MM)**2
+C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
+C RAD = RNUCLE*DBLE(IP)**ONETHI
+C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
+C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
+**
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPW = JPW-1
+ JPMOD = 1
+ ELSE
+* correct only if part. was materialized inside nucleus
+* and if it is ouside the overlapping region
+ IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+ ELSEIF (IPOT.EQ.2) THEN
+ IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
+* this is most likely a wounded nucleon
+**test
+C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
+C & +(VHKK(2,ITW(JTW))/FM2MM)**2
+C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
+C RAD = RNUCLE*DBLE(IT)**ONETHI
+C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
+C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
+**
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JTW = JTW-1
+ JPMOD = 1
+ ELSE
+* correct only if part. was materialized inside nucleus
+ IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
+ PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+
+ IF (NLOOP.EQ.1) THEN
+* Coulomb energy correction:
+* the treatment of Coulomb potential correction is similar to the
+* one for nuclear potential
+ IF (IDSEC.EQ.1) THEN
+ IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
+ JPCW = JPCW-1
+ ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
+ JTCW = JTCW-1
+ ELSE
+ IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
+ ENDIF
+ ELSE
+ IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
+ ENDIF
+ IF (IICH(IDSEC).EQ.1) THEN
+* pos. particles: check if they are able to escape Coulomb potential
+ IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
+ ISTHKK(I) = 14+IPOT
+ IF (ISTHKK(I).EQ.15) THEN
+ DO 26 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)
+ 26 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
+ IF (IDSEC.EQ.1) NPCW = NPCW-1
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ DO 27 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)
+ 27 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
+ IF (IDSEC.EQ.1) NTCW = NTCW-1
+ ENDIF
+ GOTO 20
+ ENDIF
+ ELSEIF (IICH(IDSEC).EQ.-1) THEN
+* neg. particles: decrease energy by Coulomb-potential
+ PSEC(4) = PSEC(4)-ETACOU(IPOT)
+ JPMOD = 1
+ ENDIF
+ ENDIF
+
+ 25 CONTINUE
+
+ IF (PSEC(4).LT.AMSEC) THEN
+ IF (IOULEV(6).GT.0)
+ & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
+ 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
+ & ' is not allowed to escape nucleus',/,
+ & 8X,'id : ',I3,' reduced energy: ',E15.4,
+ & ' mass: ',E12.3)
+ ISTHKK(I) = 14+IPOT
+ IF (ISTHKK(I).EQ.15) THEN
+ DO 28 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)
+ 28 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
+ IF (IDSEC.EQ.1) NPCW = NPCW-1
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ DO 29 K=1,4
+ PHKK(K,I) = PSEC0(K)
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)
+ 29 CONTINUE
+ IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
+ IF (IDSEC.EQ.1) NTCW = NTCW-1
+ ENDIF
+ GOTO 20
+ ENDIF
+
+ IF (JPMOD.EQ.1) THEN
+ PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
+* 4-momentum after correction for nuclear potential
+ DO 22 K=1,3
+ PSEC(K) = PSEC(K)*PSECN/PSECO
+ 22 CONTINUE
+
+* store recoil momentum from particles escaping the nuclear potentials
+ DO 30 K=1,4
+ IF (IPOT.EQ.1) THEN
+ TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
+ ELSEIF (IPOT.EQ.2) THEN
+ TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
+ ENDIF
+ 30 CONTINUE
+
+* transform momentum back into n-n cms
+ IMODE = IPOT+1
+ CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & IDSEC,IMODE)
+ ENDIF
+
+ ENDIF
+
+ 23 CONTINUE
+ DO 31 K=1,4
+ PFSP(K) = PFSP(K)+PHKK(K,I)
+ 31 CONTINUE
+
+ 20 CONTINUE
+
+ DO 33 I=NPOINT(4),NHKK
+ IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
+ PFSP(1) = PFSP(1)+PHKK(1,I)
+ PFSP(2) = PFSP(2)+PHKK(2,I)
+ PFSP(3) = PFSP(3)+PHKK(3,I)
+ PFSP(4) = PFSP(4)+PHKK(4,I)
+ ENDIF
+ 33 CONTINUE
+
+ DO 34 K=1,5
+ PRCLPR(K) = TRCLPR(K)
+ PRCLTA(K) = TRCLTA(K)
+ 34 CONTINUE
+
+ IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
+* hadron-nucleus interactions: get residual momentum from energy-
+* momentum conservation
+ DO 32 K=1,4
+ PRCLPR(K) = ZERO
+ PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
+ 32 CONTINUE
+ ELSE
+* nucleus-hadron, nucleus-nucleus: get residual momentum from
+* accumulated recoil momenta of particles leaving the spectators
+* transform accumulated recoil momenta of residual nuclei into
+* n-n cms
+ PZI = PRCLPR(3)
+ PEI = PRCLPR(4)
+ CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
+ PZI = PRCLTA(3)
+ PEI = PRCLTA(4)
+ CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
+C IF (IP.GT.1) THEN
+ PRCLPR(3) = PRCLPR(3)+PINIPR(3)
+ PRCLPR(4) = PRCLPR(4)+PINIPR(4)
+C ENDIF
+ IF (IT.GT.1) THEN
+ PRCLTA(3) = PRCLTA(3)+PINITA(3)
+ PRCLTA(4) = PRCLTA(4)+PINITA(4)
+ ENDIF
+ ENDIF
+
+* check momenta of residual nuclei
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
+ & 1,IDUM,IDUM)
+ CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
+ & 2,IDUM,IDUM)
+ CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
+**sr 19.12. changed to avoid output when used with phojet
+C CHKLEV = TINY3
+ CHKLEV = TINY1
+ CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
+C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
+C & CALL DT_EVTOUT(4)
+ IF (IREJ1.GT.0) RETURN
+ ENDIF
+
+ RETURN
+ END
+*
+*===scn4ba=============================================================*
+*
+CDECK ID>, DT_SCN4BA
+ SUBROUTINE DT_SCN4BA
+
+************************************************************************
+* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
+* This version dated 12.12.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,TINY3=1.0D-3,TINY2=1.0D-2,
+ & 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)
+* 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
+* nuclear potential
+ LOGICAL LFERMI
+ COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+ & EBINDP(2),EBINDN(2),EPOT(2,210),
+ & ETACOU(2),ICOUL,LFERMI
+* treatment of residual nuclei: wounded nucleons
+ COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+
+ DIMENSION PLAB(2,5),PCMS(4)
+
+ IREJ = 0
+
+* get number of wounded nucleons
+ NPW = 0
+ NPW0 = 0
+ NPCW = 0
+ NPSTCK = 0
+ NTW = 0
+ NTW0 = 0
+ NTCW = 0
+ NTSTCK = 0
+
+ ISGLPR = 0
+ ISGLTA = 0
+ LRCLPR = .FALSE.
+ LRCLTA = .FALSE.
+
+C DO 2 I=1,NHKK
+ DO 2 I=1,NPOINT(1)
+* projectile nucleons wounded in primary interaction and in fzc
+ IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
+ NPW = NPW+1
+ IPW(NPW) = I
+ NPSTCK = NPSTCK+1
+ IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
+ IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
+C IF (IP.GT.1) THEN
+ DO 5 K=1,4
+ TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
+ 5 CONTINUE
+C ENDIF
+* target nucleons wounded in primary interaction and in fzc
+ ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
+ NTW = NTW+1
+ ITW(NTW) = I
+ NTSTCK = NTSTCK+1
+ IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
+ IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
+ IF (IT.GT.1) THEN
+ DO 6 K=1,4
+ TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
+ 6 CONTINUE
+ ENDIF
+ ELSEIF (ISTHKK(I).EQ.13) THEN
+ ISGLPR = I
+ ELSEIF (ISTHKK(I).EQ.14) THEN
+ ISGLTA = I
+ ENDIF
+ 2 CONTINUE
+
+ DO 11 I=NPOINT(4),NHKK
+* baryons which are unable to escape the nuclear potential of proj.
+ IF (ISTHKK(I).EQ.15) THEN
+ ISGLPR = I
+ NPSTCK = NPSTCK-1
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ NPW = NPW-1
+ IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
+ ENDIF
+ DO 7 K=1,4
+ TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
+ 7 CONTINUE
+* baryons which are unable to escape the nuclear potential of targ.
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ ISGLTA = I
+ NTSTCK = NTSTCK-1
+ IF (IIBAR(IDBAM(I)).NE.0) THEN
+ NTW = NTW-1
+ IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
+ ENDIF
+ DO 8 K=1,4
+ TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
+ 8 CONTINUE
+ ENDIF
+ 11 CONTINUE
+
+* residual nuclei so far
+ IRESP = IP-NPSTCK
+ IREST = IT-NTSTCK
+
+* ckeck for "residual nuclei" consisting of one nucleon only
+* treat it as final state particle
+ IF (IRESP.EQ.1) THEN
+ ID = IDBAM(ISGLPR)
+ IST = ISTHKK(ISGLPR)
+ CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
+ & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
+ IF (IST.EQ.13) THEN
+ ISTHKK(ISGLPR) = 11
+ ELSE
+ ISTHKK(ISGLPR) = 2
+ ENDIF
+ CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
+ & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
+ NOBAM(NHKK) = NOBAM(ISGLPR)
+ JDAHKK(1,ISGLPR) = NHKK
+ DO 21 K=1,4
+ TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
+ 21 CONTINUE
+ ENDIF
+ IF (IREST.EQ.1) THEN
+ ID = IDBAM(ISGLTA)
+ IST = ISTHKK(ISGLTA)
+ CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
+ & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
+ IF (IST.EQ.14) THEN
+ ISTHKK(ISGLTA) = 12
+ ELSE
+ ISTHKK(ISGLTA) = 2
+ ENDIF
+ CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
+ & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
+ & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
+ NOBAM(NHKK) = NOBAM(ISGLTA)
+ JDAHKK(1,ISGLTA) = NHKK
+ DO 22 K=1,4
+ TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
+ 22 CONTINUE
+ ENDIF
+
+* get nuclear potential corresp. to the residual nucleus
+ IPRCL = IP -NPW
+ IPZRCL = IPZ-NPCW
+ ITRCL = IT -NTW
+ ITZRCL = ITZ-NTCW
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
+
+* baryons unable to escape the nuclear potential are treated as
+* excited nucleons (ISTHKK=15,16)
+ DO 3 I=NPOINT(4),NHKK
+ IF (ISTHKK(I).EQ.1) THEN
+ ID = IDBAM(I)
+ IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
+* final state n and p not being outside of both nuclei are considered
+ NPOTP = 1
+ NPOTT = 1
+ IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
+ & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
+* Lorentz-trsf. into proj. rest sys. for those being inside proj.
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
+ & PLAB(1,4),ID,-2)
+ PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
+ PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
+ & (PLAB(1,4)+PLABT) ))
+ EKIN = PLAB(1,4)-PLAB(1,5)
+ IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
+ IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
+ ENDIF
+ IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
+ & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
+* Lorentz-trsf. into targ. rest sys. for those being inside targ.
+ CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
+ & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
+ & PLAB(2,4),ID,-3)
+ PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
+ PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
+ & (PLAB(2,4)+PLABT) ))
+ EKIN = PLAB(2,4)-PLAB(2,5)
+ IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
+ IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
+ ENDIF
+ IF (PHKK(3,I).GE.ZERO) THEN
+ ISTHKK(I) = NPOTT
+ IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
+ ELSE
+ ISTHKK(I) = NPOTP
+ IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
+ ENDIF
+ IF (ISTHKK(I).NE.1) THEN
+ J = ISTHKK(I)-14
+ DO 4 K=1,5
+ PHKK(K,I) = PLAB(J,K)
+ 4 CONTINUE
+ IF (ISTHKK(I).EQ.15) THEN
+ NPW = NPW-1
+ IF (ID.EQ.1) NPCW = NPCW-1
+ DO 9 K=1,4
+ TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
+ 9 CONTINUE
+ ELSEIF (ISTHKK(I).EQ.16) THEN
+ NTW = NTW-1
+ IF (ID.EQ.1) NTCW = NTCW-1
+ DO 10 K=1,4
+ TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
+ 10 CONTINUE
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+
+* again: get nuclear potential corresp. to the residual nucleus
+ IPRCL = IP -NPW
+ IPZRCL = IPZ-NPCW
+ ITRCL = IT -NTW
+ ITZRCL = ITZ-NTCW
+c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
+cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
+c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
+C AFERP = 0.0D0
+c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
+cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
+c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
+C AFERT = 0.0D0
+C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
+C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
+C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
+C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
+ AFERP = FERMOD+0.1D0
+ AFERT = FERMOD+0.1D0
+
+ CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
+
+ RETURN
+ END
+*
+*===ficonf=============================================================*
+*
+CDECK ID>, DT_FICONF
+ SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
+
+************************************************************************
+* Treatment of FInal CONFiguration including evaporation, fission and *
+* Fermi-break-up (for light nuclei only). *
+* Adopted from the original routine FINALE and extended to residual *
+* projectile nuclei. *
+* This version dated 12.12.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,TINY3=1.0D-3,TINY10=1.0D-10)
+ PARAMETER (ANGLGB=5.0D-16)
+
+* 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
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+* 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)
+* treatment of residual nuclei: 4-momenta
+ LOGICAL LRCLPR,LRCLTA
+ COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
+ & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
+* treatment of residual nuclei: properties of residual nuclei
+ COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
+ & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
+ & NTOTFI(2),NPROFI(2)
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+* 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
+
+ INCLUDE './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(FINUC)'
+ INCLUDE './flukapro/(RESNUC)'
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMPRTN = 0.93827231 D+00 )
+ PARAMETER ( AMNTRN = 0.93956563 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( ELCCGS = 4.8032068 D-10 )
+ PARAMETER ( ELCMKS = 1.60217733 D-19 )
+ PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
+ & * 1.D-09 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( FERTHO = 14.33 D-09 )
+ PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
+ PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
+ PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
+ INCLUDE './flukapro/(NUCDAT)'
+ INCLUDE './flukapro/(PAREVT)'
+ INCLUDE './flukapro/(FHEAVY)'
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
+ & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
+ & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
+
+ DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
+ DATA EXC,NEXC /520*ZERO,520*0/
+ DATA EXPNUC /4.0D-3,4.0D-3/
+
+ IREJ = 0
+ LRCLPR = .FALSE.
+ LRCLTA = .FALSE.
+
+* skip residual nucleus treatment if not requested or in case
+* of central collisions
+ IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
+
+ DO 1 K=1,2
+ IDPAR(K) = 0
+ IDXPAR(K)= 0
+ NTOT(K) = 0
+ NTOTFI(K)= 0
+ NPRO(K) = 0
+ NPROFI(K)= 0
+ NN(K) = 0
+ NH(K) = 0
+ NHPOS(K) = 0
+ NQ(K) = 0
+ EEXC(K) = ZERO
+ MO1(K) = 0
+ MO2(K) = 0
+ DO 2 I=1,4
+ VRCL(K,I) = ZERO
+ WRCL(K,I) = ZERO
+ 2 CONTINUE
+ 1 CONTINUE
+ NFSP = 0
+ INUC(1) = IP
+ INUC(2) = IT
+
+ DO 3 I=1,NHKK
+
+* number of final state particles
+ IF (ABS(ISTHKK(I)).EQ.1) THEN
+ NFSP = NFSP+1
+ IDFSP = IDBAM(I)
+ ENDIF
+
+* properties of remaining nucleon configurations
+ KF = 0
+ IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
+ IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
+ IF (KF.GT.0) THEN
+ IF (MO1(KF).EQ.0) MO1(KF) = I
+ MO2(KF) = I
+* position of residual nucleus = average position of nucleons
+ DO 4 K=1,4
+ VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
+ WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
+ 4 CONTINUE
+* total number of particles contributing to each residual nucleus
+ NTOT(KF) = NTOT(KF)+1
+ IDTMP = IDBAM(I)
+ IDXTMP = I
+* total charge of residual nuclei
+ NQ(KF) = NQ(KF)+IICH(IDTMP)
+* number of protons
+ IF (IDHKK(I).EQ.2212) THEN
+ NPRO(KF) = NPRO(KF)+1
+* number of neutrons
+ ELSEIF (IDHKK(I).EQ.2112) THEN
+ NN(KF) = NN(KF)+1
+ ELSE
+* number of baryons other than n, p
+ IF (IIBAR(IDTMP).EQ.1) THEN
+ NH(KF) = NH(KF)+1
+ IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
+ ELSE
+* any other mesons (status set to 1)
+C WRITE(LOUT,1002) KF,IDTMP
+C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
+C & ' containing meson ',I4,', status set to 1')
+ ISTHKK(I) = 1
+ IDTMP = IDPAR(KF)
+ IDXTMP = IDXPAR(KF)
+ NTOT(KF) = NTOT(KF)-1
+ ENDIF
+ ENDIF
+ IDPAR(KF) = IDTMP
+ IDXPAR(KF) = IDXTMP
+ ENDIF
+ 3 CONTINUE
+
+* reject elastic events (def: one final state particle = projectile)
+ IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
+ IREXCI(3) = IREXCI(3)+1
+ GOTO 9999
+C RETURN
+ ENDIF
+
+* check if one nucleus disappeared..
+C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
+C DO 5 K=1,4
+C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
+C PRCLPR(K) = ZERO
+C 5 CONTINUE
+C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
+C DO 6 K=1,4
+C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
+C PRCLTA(K) = ZERO
+C 6 CONTINUE
+C ENDIF
+
+ ICOR = 0
+ INORCL = 0
+ DO 7 I=1,2
+ DO 8 K=1,4
+* get the average of the nucleon positions
+ VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
+ WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
+ IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
+ IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
+ 8 CONTINUE
+* mass number and charge of residual nuclei
+ AIF(I) = DBLE(NTOT(I))
+ AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
+ IF (NTOT(I).GT.1) THEN
+* masses of residual nuclei in ground state
+
+C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
+ AMRCL0(I) = AIF(I)*AMUC12
+ & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
+
+* masses of residual nuclei
+ PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
+ AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
+ IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
+ IF (AMRCL(I).LE.ZERO) THEN
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
+ & PRCL(I,4),NTOT
+ 1000 FORMAT(1X,'warning! negative excitation energy',/,
+ & I4,4E15.4,2I4)
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(2) = IREXCI(2)+1
+ GOTO 9999
+ ENDIF
+ ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
+ & THEN
+**sr
+C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
+**
+**sr 3.3
+C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
+ M = MIN(NTOT(I),260)
+ IF (NEXC(I,M).GT.0) THEN
+ AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
+ ELSE
+ 70 CONTINUE
+ M = M+1
+ IF (M.GE.INUC(I)) THEN
+ AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
+ ELSE
+ IF (NEXC(I,M).GT.0) THEN
+ AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
+ ELSE
+ GOTO 70
+ ENDIF
+ ENDIF
+ ENDIF
+**
+ EEXC(I) = AMRCL(I)-AMRCL0(I)
+ ICOR = ICOR+I
+ ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
+ IF (IOULEV(3).GT.0)
+& WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
+ 1004 FORMAT(1X,'warning! too high excitation energy',/,
+ & I4,1P,2E15.4,3I5)
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(2) = IREXCI(2)+1
+ GOTO 9999
+ ENDIF
+ ELSE
+* excitation energies of residual nuclei
+ EEXC(I) = AMRCL(I)-AMRCL0(I)
+ IF (ICASCA.EQ.0) THEN
+**sr 15.1.
+C EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
+ EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
+ M = MIN(NTOT(I),260)
+ EXC(I,M) = EXC(I,M)+EEXC(I)
+ NEXC(I,M) = NEXC(I,M)+1
+ ENDIF
+ ENDIF
+ ELSEIF (NTOT(I).EQ.1) THEN
+ WRITE(LOUT,1003) I
+ 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
+ GOTO 9999
+ ELSE
+ AMRCL0(I) = ZERO
+ AMRCL(I) = ZERO
+ EEXC(I) = ZERO
+ INORCL = INORCL+I
+ ENDIF
+ 7 CONTINUE
+
+ PRCLPR(5) = AMRCL(1)
+ PRCLTA(5) = AMRCL(2)
+
+ IF (ICOR.GT.0) THEN
+ IF (INORCL.EQ.0) THEN
+* one or both residual nuclei consist of one nucleon only, transform
+* this nucleon on mass shell
+ DO 9 K=1,4
+ P1IN(K) = PRCL(1,K)
+ P2IN(K) = PRCL(2,K)
+ 9 CONTINUE
+ XM1 = AMRCL(1)
+ XM2 = AMRCL(2)
+ CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
+ IF (IREJ1.GT.0) THEN
+ WRITE(LOUT,*) 'ficonf-mashel rejection'
+ GOTO 9999
+ ENDIF
+ DO 10 K=1,4
+ PRCL(1,K) = P1OUT(K)
+ PRCL(2,K) = P2OUT(K)
+ PRCLPR(K) = P1OUT(K)
+ PRCLTA(K) = P2OUT(K)
+ 10 CONTINUE
+ PRCLPR(5) = AMRCL(1)
+ PRCLTA(5) = AMRCL(2)
+ ELSE
+ IF (IOULEV(3).GT.0)
+ & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
+ & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
+ & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
+ & AMRCL(2),AMRCL(2)-AMRCL0(2)
+ 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
+ & ' correction',/,11X,'at event',I8,
+ & ', nucleon config. 1:',2I4,' 2:',2I4,
+ & 2(/,11X,3E12.3))
+ IF (NLOOP.LE.500) THEN
+ GOTO 9998
+ ELSE
+ IREXCI(1) = IREXCI(1)+1
+ ENDIF
+ ENDIF
+ ENDIF
+
+* update counter
+C IF (NRESEV(1).NE.NEVHKK) THEN
+C NRESEV(1) = NEVHKK
+C NRESEV(2) = NRESEV(2)+1
+C ENDIF
+ NRESEV(2) = NRESEV(2)+1
+ DO 15 I=1,2
+ EXCDPM(I) = EXCDPM(I)+EEXC(I)
+ EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
+ NRESTO(I) = NRESTO(I)+NTOT(I)
+ NRESPR(I) = NRESPR(I)+NPRO(I)
+ NRESNU(I) = NRESNU(I)+NN(I)
+ NRESBA(I) = NRESBA(I)+NH(I)
+ NRESPB(I) = NRESPB(I)+NHPOS(I)
+ NRESCH(I) = NRESCH(I)+NQ(I)
+ 15 CONTINUE
+
+* evaporation
+ IF (LEVPRT) THEN
+ DO 13 I=1,2
+* initialize evaporation counter
+ NP = 0
+ EEXCFI(I) = ZERO
+ IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
+ & (EEXC(I).GT.ZERO)) THEN
+* put residual nuclei into DTEVT1
+ IDRCL = 80000
+ JMASS = INT( AIF(I))
+ JCHAR = INT(AIZF(I))
+* the following patch is required to transmit the correct excitation
+* energy to Eventd
+ IF (ITRSPT.EQ.1) THEN
+ PRCL0 = PRCL(I,4)
+ PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
+ & +PRCL(I,3)**2)
+ IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
+ WRITE(LOUT,*)
+ & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
+ ENDIF
+ ENDIF
+ CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
+ & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
+**sr 22.6.97
+ NOBAM(NHKK) = I
+**
+ DO 14 J=1,4
+ VHKK(J,NHKK) = VRCL(I,J)
+ WHKK(J,NHKK) = WRCL(I,J)
+ 14 CONTINUE
+* interface to evaporation module - fill final residual nucleus into
+* common FKRESN
+* fill resnuc only if code is not used as event generator in Fluka
+ IF (ITRSPT.NE.1) THEN
+ PXRES = PRCL(I,1)
+ PYRES = PRCL(I,2)
+ PZRES = PRCL(I,3)
+ IBRES = NPRO(I)+NN(I)+NH(I)
+ ICRES = NPRO(I)+NHPOS(I)
+ ANOW = DBLE(IBRES)
+ ZNOW = DBLE(ICRES)
+ PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
+* ground state mass of the residual nucleus (should be equal to AM0T)
+
+ AMNRES = AMRCL0(I)
+ AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
+
+* common FKFINU
+ TV = ZERO
+* kinetic energy of residual nucleus
+ TVRECL = PRCL(I,4)-AMRCL(I)
+* excitation energy of residual nucleus
+ TVCMS = EEXC(I)
+ PTOLD = PTRES
+ PTRES = SQRT(ABS(TVRECL*(TVRECL+
+ & 2.0D0*(AMMRES+TVCMS))))
+ IF (PTOLD.LT.ANGLGB) THEN
+ CALL DT_RACO(PXRES,PYRES,PZRES)
+ PTOLD = ONE
+ ENDIF
+ PXRES = PXRES*PTRES/PTOLD
+ PYRES = PYRES*PTRES/PTOLD
+ PZRES = PZRES*PTRES/PTOLD
+* evaporation
+ WE = ONE
+
+ NPHEAV = 0
+ LRNFSS = .FALSE.
+ LFRAGM = .FALSE.
+ CALL EVEVAP(WE)
+
+* put evaporated particles and residual nuclei to DTEVT1
+ MO = NHKK
+ CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
+ ENDIF
+ EEXCFI(I) = EXCITF
+ EXCEVA(I) = EXCEVA(I)+EXCITF
+ ENDIF
+ 13 CONTINUE
+ ENDIF
+
+ RETURN
+
+C9998 IREXCI(1) = IREXCI(1)+1
+ 9998 IREJ = IREJ+1
+ 9999 CONTINUE
+ LRCLPR = .TRUE.
+ LRCLTA = .TRUE.
+ IREJ = IREJ+1
+ RETURN
+ END
+* *
+*====eva2he============================================================*
+* *
+CDECK ID>, DT_EVA2HE
+ SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
+
+************************************************************************
+* Interface between common's of evaporation module (FKFINU,FKFHVY) *
+* and DTEVT1. *
+* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
+* EEXCF exitation energy of residual nucleus after evaporation *
+* IRCL = 1 projectile residual nucleus *
+* = 2 target residual nucleus *
+* This version dated 19.04.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,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)
+* Note: DTEVT2 - special use for heavy fragments !
+* (IDRES(I) = mass number, IDXRES(I) = charge)
+* 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)
+* 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: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+* treatment of residual nuclei: properties of residual nuclei
+ COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
+ & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
+ & NTOTFI(2),NPROFI(2)
+
+ INCLUDE './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(FINUC)'
+ INCLUDE './flukapro/(RESNUC)'
+ INCLUDE './flukapro/(FHEAVY)'
+
+ DIMENSION IPTOKP(39)
+ DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
+ & 100, 101, 97, 102, 98, 103, 109, 115 /
+
+ IREJ = 0
+
+* skip if evaporation package is not included
+ IF (.NOT.LEVAPO) RETURN
+
+* update counter
+ IF (NRESEV(3).NE.NEVHKK) THEN
+ NRESEV(3) = NEVHKK
+ NRESEV(4) = NRESEV(4)+1
+ ENDIF
+
+ IF (LEMCCK)
+ & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
+ & IDUM,IDUM)
+* mass number/charge of residual nucleus before evaporation
+ IBTOT = IDRES(MO)
+ IZTOT = IDXRES(MO)
+
+* protons/neutrons/gammas
+ DO 1 I=1,NP
+ PX = CXR(I)*PLR(I)
+ PY = CYR(I)*PLR(I)
+ PZ = CZR(I)*PLR(I)
+ ID = IPTOKP(KPART(I))
+ IDPDG = IDT_IPDGHA(ID)
+ AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
+ & (2.0D0*MAX(TKI(I),TINY10))
+ IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
+ WRITE(LOUT,1000) ID,AM,AAM(ID)
+ 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
+ & 'particle',I3,2E10.3)
+ ENDIF
+ PE = TKI(I)+AM
+ CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
+ NOBAM(NHKK) = IRCL
+ IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+ IBTOT = IBTOT-IIBAR(ID)
+ IZTOT = IZTOT-IICH(ID)
+ 1 CONTINUE
+
+* heavy fragments
+ DO 2 I=1,NPHEAV
+ PX = CXHEAV(I)*PHEAVY(I)
+ PY = CYHEAV(I)*PHEAVY(I)
+ PZ = CZHEAV(I)*PHEAVY(I)
+ IDHEAV = 80000
+ AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
+ & (2.0D0*MAX(TKHEAV(I),TINY10))
+ PE = TKHEAV(I)+AM
+ CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
+ & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
+ NOBAM(NHKK) = IRCL
+ IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+ IBTOT = IBTOT-IBHEAV(KHEAVY(I))
+ IZTOT = IZTOT-ICHEAV(KHEAVY(I))
+ 2 CONTINUE
+
+ IF (IBRES.GT.0) THEN
+* residual nucleus after evaporation
+ IDNUC = 80000
+ CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
+ & IBRES,ICRES,0)
+ NOBAM(NHKK) = IRCL
+ ENDIF
+ EEXCF = TVCMS
+ NTOTFI(IRCL) = IBRES
+ NPROFI(IRCL) = ICRES
+ IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
+ IBTOT = IBTOT-IBRES
+ IZTOT = IZTOT-ICRES
+
+* count events with fission
+ NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
+ IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
+
+* energy-momentum conservation check
+ IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
+C IF (IREJ.GT.0) THEN
+C CALL DT_EVTOUT(4)
+C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
+C ENDIF
+* baryon-number/charge conservation check
+ IF (IBTOT+IZTOT.NE.0) THEN
+ WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
+ 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
+ & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
+ ENDIF
+
+ RETURN
+ END
+*
+*===ebind==============================================================*
+*
+CDECK ID>, DT_EBIND
+ DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
+
+************************************************************************
+* Binding energy for nuclei. *
+* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
+* IA mass number *
+* IZ atomic number *
+* This version dated 5.5.95 is updated by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0)
+
+ DATA A1, A2, A3, A4, A5
+ & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
+
+ IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
+ WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
+ DT_EBIND = ZERO
+ RETURN
+ ENDIF
+ AA = IA
+ DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
+ & -A4*(IA-2*IZ)**2/AA
+ IF (MOD(IA,2).EQ.1) THEN
+ IA5 = 0
+ ELSEIF (MOD(IZ,2).EQ.1) THEN
+ IA5 = 1
+ ELSE
+ IA5 = -1
+ ENDIF
+ DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* DPMJET 3.0: cross section routines *
+* *
+************************************************************************
+*
+*
+* SUBROUTINE DT_SHNDIF
+* diffractive cross sections (all energies)
+* SUBROUTINE DT_PHOXS
+* total and inel. cross sections from PHOJET interpol. tables
+* SUBROUTINE DT_XSHN
+* total and el. cross sections for all energies
+* SUBROUTINE DT_SIHNAB
+* pion 2-nucleon absorption cross sections
+* SUBROUTINE DT_SIGEMU
+* cross section for target "compounds"
+* SUBROUTINE DT_SIGGA
+* photon nucleus cross sections
+* SUBROUTINE DT_SIGGAT
+* photon nucleus cross sections from tables
+* SUBROUTINE DT_SANO
+* anomalous hard photon-nucleon cross sections from tables
+* SUBROUTINE DT_SIGGP
+* photon nucleon cross sections
+* SUBROUTINE DT_SIGVEL
+* quasi-elastic vector meson prod. cross sections
+* DOUBLE PRECISION FUNCTION DT_SIGVP
+* sigma_VN(tilde)
+* DOUBLE PRECISION FUNCTION DT_RRM2
+* DOUBLE PRECISION FUNCTION DT_RM2
+* DOUBLE PRECISION FUNCTION DT_SAM2
+* SUBROUTINE DT_CKMT
+* SUBROUTINE DT_CKMTX
+* SUBROUTINE DT_PDF0
+* SUBROUTINE DT_CKMTQ0
+* SUBROUTINE DT_CKMTDE
+* SUBROUTINE DT_CKMTPR
+* FUNCTION DT_CKMTFF
+*
+* SUBROUTINE DT_FLUINI
+* total nucleon cross section fluctuation treatment
+*
+* SUBROUTINE DT_SIGTBL
+* pre-tabulation of low-energy elastic x-sec. using SIHNEL
+* SUBROUTINE DT_XSTABL
+* service routines
+*
+*
+*
+*===shndif===============================================================*
+*
+CDECK ID>, DT_SHNDIF
+ SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
+
+**********************************************************************
+* Single diffractive hadron-nucleon cross sections *
+* S.Roesler 14/1/93 *
+* *
+* The cross sections are calculated from extrapolated single *
+* diffractive antiproton-proton cross sections (DTUJET92) using *
+* scaling relations between total and single diffractive cross *
+* sections. *
+**********************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.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)
+*
+ CSD1 = 4.201483727D0
+ CSD4 = -0.4763103556D-02
+ CSD5 = 0.4324148297D0
+*
+ CHMSD1 = 0.8519297242D0
+ CHMSD4 = -0.1443076599D-01
+ CHMSD5 = 0.4014954567D0
+*
+ EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
+ PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
+*
+ SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
+ SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
+ FRAC = SHMSD/SDIAPP
+*
+ GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
+ & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
+ & 10, 10, 20, 20, 20) KPROJ
+*
+ 10 CONTINUE
+*---------------------------- p - p , n - p , sigma0+- - p ,
+* Lambda - p
+ CSD1 = 6.004476070D0
+ CSD4 = -0.1257784606D-03
+ CSD5 = 0.2447335720D0
+ SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
+ SIGDIH = FRAC*SIGDIF
+ RETURN
+*
+ 20 CONTINUE
+*
+ KPSCAL = 2
+ KTSCAL = 1
+C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
+ DUMZER = ZERO
+ CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
+ F = SDIAPP/SIGTO
+ KT = 1
+C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
+ CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
+ SIGDIF = SIGTO*F
+ SIGDIH = FRAC*SIGDIF
+ RETURN
+*
+ 999 CONTINUE
+*-------------------------- leptons..
+ SIGDIF = 1.D-10
+ SIGDIH = 1.D-10
+ RETURN
+ END
+*
+*===phoxs================================================================*
+*
+CDECK ID>, DT_PHOXS
+ SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
+
+************************************************************************
+* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
+* interpolation tables. *
+* This version dated 05.11.97 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)
+ PARAMETER (TWOPI = 6.283185307179586454D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+ LOGICAL LFIRST
+ DATA LFIRST /.TRUE./
+
+* 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)
+
+**PHOJET105a
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+
+ IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
+ WRITE(LOUT,*) MCGENE
+ 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
+ STOP
+ ENDIF
+
+ IF (ECM.LE.ZERO) THEN
+ EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
+ ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
+ ENDIF
+
+ IF (MODE.EQ.1) THEN
+* DL
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = ECM*ECM
+ STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
+ ALPHAP= 0.25D0
+ BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
+ SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
+ SINE = STOT-SIGEL
+ SDIF1 = ZERO
+ ELSE
+* Phojet
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 1 I=2,ISIMAX
+ IF (ECM.LE.SIGECM(IP,I)) GOTO 2
+ 1 CONTINUE
+ 2 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ IF (LFIRST) THEN
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'PHOXS: warning! energy above initialization limit (',
+ & ECM,SIGECM(IP,ISIMAX)
+ LFIRST = .FALSE.
+ ENDIF
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+ STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
+ & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
+ BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
+ ENDIF
+
+ RETURN
+ END
+*
+*===xshn===============================================================*
+*
+CDECK ID>, DT_XSHN
+ SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
+
+************************************************************************
+* Total and elastic hadron-nucleon cross section. *
+* Below 500GeV cross sections are based on the '98 data compilation *
+* of the PDG. At higher energies PHOJET results are used (patched to *
+* the low energy data at 500GeV). *
+* IP projectile index (BAMJET numbering scheme) *
+* (should be in the range 1..25) *
+* IT target index (BAMJET numbering scheme) *
+* (1 = proton, 8 = neutron) *
+* PL laboratory momentum *
+* ECM cm. energy (ignored if PL>0) *
+* STOT total cross section *
+* SELA elastic cross section *
+* Last change: 24.4.99 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)
+
+ PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
+ & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
+ PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
+
+ LOGICAL LFIRST
+* 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)
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+**PHOJET105a
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
+ DIMENSION IDXDAT(25,2)
+*
+ DATA APL /
+ &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
+ &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
+ &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
+ &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
+ & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
+ & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
+ & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
+*
+* total cross sections:
+* p p
+ DATA (ASIGTO(1,K),K=1,NPOINT) /
+ & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
+ & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
+ & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
+ & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
+ & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
+ & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
+ & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
+* pbar p
+ DATA (ASIGTO(2,K),K=1,NPOINT) /
+ & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
+ & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
+ & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
+ & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
+ & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
+ & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
+ & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
+* n p
+ DATA (ASIGTO(3,K),K=1,NPOINT) /
+ & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
+ & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
+ & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
+ & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
+ & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
+ & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
+ & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
+* pi+ p
+ DATA (ASIGTO(4,K),K=1,NPOINT) /
+ & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
+ & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
+ & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
+ & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
+ & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
+ & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
+ & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
+* pi- p
+ DATA (ASIGTO(5,K),K=1,NPOINT) /
+ & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
+ & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
+ & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
+ & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
+ & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
+ & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
+ & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
+* K+ p
+ DATA (ASIGTO(6,K),K=1,NPOINT) /
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
+ & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
+ & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
+ & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
+ & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
+ & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
+* K- p
+ DATA (ASIGTO(7,K),K=1,NPOINT) /
+ & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
+ & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
+ & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
+ & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
+ & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
+ & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
+ & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
+* K+ n
+ DATA (ASIGTO(8,K),K=1,NPOINT) /
+ & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
+ & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
+ & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
+ & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
+ & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
+ & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
+ & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
+* K- n
+ DATA (ASIGTO(9,K),K=1,NPOINT) /
+ & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
+ & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
+ & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
+ & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
+ & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
+ & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
+ & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
+* Lambda p
+ DATA (ASIGTO(10,K),K=1,NPOINT) /
+ & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
+ & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
+ & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
+ & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
+ & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
+ & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
+ & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
+*
+* elastic cross sections:
+* p p
+ DATA (ASIGEL(1,K),K=1,NPOINT) /
+ & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
+ & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
+ & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
+ & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
+ & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
+ & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
+ & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
+* pbar p
+ DATA (ASIGEL(2,K),K=1,NPOINT) /
+ & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
+ & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
+ & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
+ & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
+ & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
+ & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
+ & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
+* n p
+ DATA (ASIGEL(3,K),K=1,NPOINT) /
+ & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
+ & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
+ & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
+ & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
+ & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
+ & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
+ & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
+* pi+ p
+ DATA (ASIGEL(4,K),K=1,NPOINT) /
+ & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
+ & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
+ & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
+ & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
+ & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
+ & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
+ & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
+* pi- p
+ DATA (ASIGEL(5,K),K=1,NPOINT) /
+ & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
+ & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
+ & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
+ & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
+ & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
+ & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
+ & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
+* K+ p
+ DATA (ASIGEL(6,K),K=1,NPOINT) /
+ & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
+ & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
+ & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
+ & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
+ & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
+ & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
+ & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
+* K- p
+ DATA (ASIGEL(7,K),K=1,NPOINT) /
+ & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
+ & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
+ & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
+ & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
+ & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
+ & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
+ & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
+* K+ n
+ DATA (ASIGEL(8,K),K=1,NPOINT) /
+ & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
+ & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
+ & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
+ & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
+ & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
+ & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
+ & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
+* K- n
+ DATA (ASIGEL(9,K),K=1,NPOINT) /
+ & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
+ & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
+ & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
+ & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
+ & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
+ & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
+ & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
+* Lambda p
+ DATA (ASIGEL(10,K),K=1,NPOINT) /
+ & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
+ & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
+ & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
+ & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
+ & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
+ & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
+ & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
+
+ DATA (IDXDAT(K,1),K=1,25) /
+ & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
+ & 1, 3,45, 8, 9/
+ DATA (IDXDAT(K,2),K=1,25) /
+ & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
+ & 3, 1,45, 6, 7/
+
+ DATA LFIRST /.TRUE./
+
+ IF (LFIRST) THEN
+ APLABL = LOG10(PLABLO)
+ APLABH = LOG10(PLABHI)
+ APTHRE = LOG10(PTHRE)
+ ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
+ ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
+ DUM0 = ZERO
+ PHOPLA = PLABHI
+ PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
+ ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
+ IF (MCGENE.EQ.2) THEN
+ IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ ELSE
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
+ ENDIF
+ ELSE
+ CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
+ ENDIF
+ PHOSEL = PHOSTO-PHOSIN
+ APHOST = LOG10(PHOSTO)
+ APHOSE = LOG10(PHOSEL)
+ LFIRST = .FALSE.
+ ENDIF
+ STOT = ZERO
+ SELA = ZERO
+ PLAB = PL
+ ECMS = ECM
+ IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
+ WRITE(LOUT,1000) IP,IT
+ 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
+ & 'proj/target',2I4)
+ STOP
+ ENDIF
+
+ IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
+ ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
+ PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
+ ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
+ WRITE(LOUT,1001) PLAB,ECMS
+ 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
+ STOP
+ ENDIF
+
+* index of spectrum
+ IDXP = IP
+ IF (IP.GT.25) THEN
+ IF (AAM(IP).GT.ZERO) THEN
+ IF (ABS(IIBAR(IP)).GT.0) THEN
+ IDXP = 1
+ ELSE
+ IDXP = 13
+ ENDIF
+ ELSE
+ IDXP = 7
+ ENDIF
+ ENDIF
+ IDXT = 1
+ IF (IT.EQ.8) IDXT = 2
+ IDXS = IDXDAT(IDXP,IDXT)
+ IF (IDXS.EQ.0) RETURN
+
+* compute momentum bin indices
+ IF (PLAB.LT.PLABLO) THEN
+ IDX0 = 1
+ IDX1 = 1
+ ELSEIF (PLAB.GE.PLABHI) THEN
+ IDX0 = NPOINT
+ IDX1 = NPOINT
+ ELSE
+ APLAB = LOG10(PLAB)
+ IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
+ IDX0 = INT((APLAB-APLABL)/ADP1)+1
+ ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
+ IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
+ ENDIF
+ IDX1 = IDX0+1
+ ENDIF
+
+* interpolate cross section
+ IF (IDXS.GT.10) THEN
+ IDXS1 = IDXS/10
+ IDXS2 = IDXS-10*IDXS1
+ IF (IDX0.EQ.IDX1) THEN
+ IF (IDX0.EQ.1) THEN
+ ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
+ ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
+ ELSE
+ DUM0 = ZERO
+ CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ PHOSEL = PHOSTO-PHOSIN
+ ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ASTOT = 0.5D0*(ASTOT1+ASTOT2)
+ ASELA = 0.5D0*(ASELA1+ASELA2)
+ ENDIF
+ ELSE
+ FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
+ ASTOT1 = ASIGTO(IDXS1,IDX0)+
+ & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
+ ASTOT2 = ASIGTO(IDXS2,IDX0)+
+ & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
+ ASTOT = 0.5D0*(ASTOT1+ASTOT2)
+ ASELA1 = ASIGEL(IDXS1,IDX0)+
+ & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
+ ASELA2 = ASIGEL(IDXS2,IDX0)+
+ & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
+ ASELA = 0.5D0*(ASELA1+ASELA2)
+ ENDIF
+ ELSE
+ IF (IDX0.EQ.IDX1) THEN
+ IF (IDX0.EQ.1) THEN
+ ASTOT = ASIGTO(IDXS,IDX0)
+ ASELA = ASIGEL(IDXS,IDX0)
+ ELSE
+ DUM0 = ZERO
+ CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
+ PHOSEL = PHOSTO-PHOSIN
+ ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
+ ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
+ ENDIF
+ ELSE
+ FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
+ ASTOT = ASIGTO(IDXS,IDX0)+
+ & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
+ ASELA = ASIGEL(IDXS,IDX0)+
+ & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
+ ENDIF
+ ENDIF
+ STOT = 10.0D0**ASTOT
+ SELA = 10.0D0**ASELA
+
+ RETURN
+ END
+*
+*===sihnab===============================================================*
+*
+CDECK ID>, DT_SIHNAB
+ SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
+
+**********************************************************************
+* Pion 2-nucleon absorption cross sections. *
+* (sigma_tot for pi+ d --> p p, pi- d --> n n *
+* taken from Ritchie PRC 28 (1983) 926 ) *
+* This version dated 18.05.96 is written by S. Roesler *
+**********************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
+ PARAMETER (AMPR = 938.0D0,
+ & AMPI = 140.0D0,
+ & AMDE = TWO*AMPR,
+ & A = -1.2D0,
+ & B = 3.5D0,
+ & C = 7.4D0,
+ & D = 5600.0D0,
+ & ER = 2136.0D0)
+
+ SIGABS = ZERO
+ IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
+ & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
+ PTOT = PLAB*1.0D3
+ EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
+ IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
+ ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
+ SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
+* approximate 3N-abs., I=1-abs. etc.
+ SIGABS = SIGABS/0.40D0
+* pi0-absorption (rough approximation!!)
+ IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
+
+ RETURN
+ END
+*
+*===sigemu=============================================================*
+*
+CDECK ID>, DT_SIGEMU
+ SUBROUTINE DT_SIGEMU
+
+************************************************************************
+* Combined cross section for target compounds. *
+* This version dated 6.4.98 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,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+ IF (MCGENE.NE.4) THEN
+ WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
+ WRITE(LOUT,'(15X,A)') '-----------------------'
+ ENDIF
+ DO 1 IE=1,NEBINI
+ DO 2 IQ=1,NQBINI
+ SIGTOT = ZERO
+ SIGELA = ZERO
+ SIGQEP = ZERO
+ SIGQET = ZERO
+ SIGQE2 = ZERO
+ SIGPRO = ZERO
+ SIGDEL = ZERO
+ SIGDQE = ZERO
+ ERRTOT = ZERO
+ ERRELA = ZERO
+ ERRQEP = ZERO
+ ERRQET = ZERO
+ ERRQE2 = ZERO
+ ERRPRO = ZERO
+ ERRDEL = ZERO
+ ERRDQE = ZERO
+ IF (NCOMPO.GT.0) THEN
+ DO 3 IC=1,NCOMPO
+ SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
+ SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
+ SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
+ SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
+ SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
+ SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
+ SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
+ SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
+ ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
+ ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
+ ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
+ ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
+ ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
+ ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
+ ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
+ ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
+ 3 CONTINUE
+ ERRTOT = SQRT(ERRTOT)
+ ERRELA = SQRT(ERRELA)
+ ERRQEP = SQRT(ERRQEP)
+ ERRQET = SQRT(ERRQET)
+ ERRQE2 = SQRT(ERRQE2)
+ ERRPRO = SQRT(ERRPRO)
+ ERRDEL = SQRT(ERRDEL)
+ ERRDQE = SQRT(ERRDQE)
+ ELSE
+ SIGTOT = XSTOT(IE,IQ,1)
+ SIGELA = XSELA(IE,IQ,1)
+ SIGQEP = XSQEP(IE,IQ,1)
+ SIGQET = XSQET(IE,IQ,1)
+ SIGQE2 = XSQE2(IE,IQ,1)
+ SIGPRO = XSPRO(IE,IQ,1)
+ SIGDEL = XSDEL(IE,IQ,1)
+ SIGDQE = XSDQE(IE,IQ,1)
+ ERRTOT = XETOT(IE,IQ,1)
+ ERRELA = XEELA(IE,IQ,1)
+ ERRQEP = XEQEP(IE,IQ,1)
+ ERRQET = XEQET(IE,IQ,1)
+ ERRQE2 = XEQE2(IE,IQ,1)
+ ERRPRO = XEPRO(IE,IQ,1)
+ ERRDEL = XEDEL(IE,IQ,1)
+ ERRDQE = XEDQE(IE,IQ,1)
+ ENDIF
+ IF (MCGENE.NE.4) THEN
+ WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
+ 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
+ WRITE(LOUT,1001) SIGTOT,ERRTOT
+ 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1002) SIGELA,ERRELA
+ 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1003) SIGQEP,ERRQEP
+ 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
+ & F11.5,' mb')
+ WRITE(LOUT,1004) SIGQET,ERRQET
+ 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
+ & F11.5,' mb')
+ WRITE(LOUT,1005) SIGQE2,ERRQE2
+ 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
+ & ' +-',F11.5,' mb')
+ WRITE(LOUT,1006) SIGPRO,ERRPRO
+ 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1007) SIGDEL,ERRDEL
+ 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
+ WRITE(LOUT,1008) SIGDQE,ERRDQE
+ 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
+ ENDIF
+
+ 2 CONTINUE
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===sigga==============================================================*
+*
+CDECK ID>, DT_SIGGA
+ SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
+
+************************************************************************
+* Total/inelastic photon-nucleus cross sections. *
+* !!!! Overwrites SHMAKI-initialization. Do not use it during *
+* production runs !!!! *
+* This version dated 27.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,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (AMPROT = 0.938D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+
+ NT = NTI
+ X = XI
+ Q2 = Q2I
+ ECM = ECMI
+ XNU = XNUI
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
+ CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
+ STOT = XSTOT(1,1,1)
+ ETOT = XETOT(1,1,1)
+ SIN = XSPRO(1,1,1)
+ EIN = XEPRO(1,1,1)
+
+ RETURN
+ END
+*
+*===siggat=============================================================*
+*
+CDECK ID>, DT_SIGGAT
+ SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
+
+************************************************************************
+* Total/inelastic photon-nucleus cross sections. *
+* Uses pre-tabulated cross section. *
+* This version dated 29.07.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,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+
+ NTARG = ABS(NT)
+ I1 = 1
+ I2 = 1
+ RATE = ONE
+ IF (NEBINI.GT.1) THEN
+ IF (ECMI.GE.ECMNN(NEBINI)) THEN
+ I1 = NEBINI
+ I2 = NEBINI
+ RATE = ONE
+ ELSEIF (ECMI.GT.ECMNN(1)) THEN
+ DO 1 I=2,NEBINI
+ IF (ECMI.LT.ECMNN(I)) THEN
+ I1 = I-1
+ I2 = I
+ RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+ J1 = 1
+ J2 = 1
+ RATQ = ONE
+ IF (NQBINI.GT.1) THEN
+ IF (Q2I.GE.Q2G(NQBINI)) THEN
+ J1 = NQBINI
+ J2 = NQBINI
+ RATQ = ONE
+ ELSEIF (Q2I.GT.Q2G(1)) THEN
+ DO 3 I=2,NQBINI
+ IF (Q2I.LT.Q2G(I)) THEN
+ J1 = I-1
+ J2 = I
+ RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
+ & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
+C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
+ GOTO 4
+ ENDIF
+ 3 CONTINUE
+ 4 CONTINUE
+ ENDIF
+ ENDIF
+
+ STOT = XSTOT(I1,J1,NTARG)+
+ & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
+ & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
+ & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
+ & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
+
+ RETURN
+ END
+*
+*===sigano=============================================================*
+*
+CDECK ID>, DT_SANO
+ DOUBLE PRECISION FUNCTION DT_SANO(ECM)
+
+************************************************************************
+* This version dated 31.07.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,TINY14=1.0D-14,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (NE = 8)
+
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+
+ DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
+ DATA ECMANO /
+ & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
+ & 0.100D+04,0.200D+04,0.500D+04
+ & /
+* fixed cut (3 GeV/c)
+ DATA FRAANO /
+ & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
+ & 0.062D+00,0.054D+00,0.042D+00
+ & /
+ DATA SIGHRD /
+ & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
+ & 3.3086D-01,7.6255D-01,2.1319D+00
+ & /
+* running cut (based on obsolete Phojet-caluclations, bugs..)
+C DATA FRAANO /
+C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
+C & 0.167E+00,0.150E+00,0.131E+00
+C & /
+C DATA SIGHRD /
+C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
+C & 2.5736E-01,4.5593E-01,8.2550E-01
+C & /
+
+ DT_SANO = ZERO
+ IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
+ J1 = 0
+ J2 = 0
+ RATE = ONE
+ IF (ECM.GE.ECMANO(NE)) THEN
+ J1 = NE
+ J2 = NE
+ ELSEIF (ECM.GT.ECMANO(1)) THEN
+ DO 1 IE=2,NE
+ IF (ECM.LT.ECMANO(IE)) THEN
+ J1 = IE-1
+ J2 = IE
+ RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
+ GOTO 2
+ ENDIF
+ 1 CONTINUE
+ 2 CONTINUE
+ ENDIF
+ IF ((J1.GT.0).AND.(J2.GT.0)) THEN
+ AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
+ AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
+ DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
+ ENDIF
+
+ RETURN
+ END
+*
+*===siggp==============================================================*
+*
+CDECK ID>, DT_SIGGP
+ SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
+
+************************************************************************
+* Total/inelastic photon-nucleon cross sections. *
+* This version dated 30.04.96 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,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & ALPHEM = ONE/137.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)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+**PHOJET105a
+C CHARACTER*8 MDLNA
+C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C PARAMETER (IEETAB=10)
+C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
+**PHOJET110
+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 energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+**
+
+C PARAMETER (NPOINT=80)
+ PARAMETER (NPOINT=16)
+ DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+
+ STOT = ZERO
+ SINE = ZERO
+ SDIR = ZERO
+
+ W2 = ECMI**2
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
+ Q2 = Q2I
+ X = XI
+* photoprod.
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(W2+Q2-AAM(1)**2)
+* DIS
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
+ X = Q2/(W2+Q2-AAM(1)**2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = (W2-AAM(1)**2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ W2 = Q2*(ONE-X)/X+AAM(1)**2
+ ELSE
+ WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
+ STOP
+ ENDIF
+ ECM = SQRT(W2)
+
+ IF (MODEGA.EQ.1) THEN
+ SCALE = SQRT(Q2)
+ CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
+ & IDPDF)
+C W = SQRT(W2)
+
+C ALLMF2 = PHO_ALLM97(Q2,W)
+
+C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
+ STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
+ SINE = ZERO
+ SDIR = ZERO
+ ELSEIF (MODEGA.EQ.2) THEN
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = W2/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = W2/4.0D0
+ ELSE
+ AMHI2 = W2
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+ XAMLO = LOG( AMLO2+Q2 )
+ XAMHI = LOG( AMHI2+Q2 )
+**PHOJET105a
+C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+ CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
+
+**
+ SUM = ZERO
+ DO 1 J=1,NPOINT
+ AM2 = EXP(ABSZX(J))-Q2
+ IF (AM2.LT.16.0D0) THEN
+ R = TWO
+ ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
+ R = 10.0D0/3.0D0
+ ELSE
+ R = 11.0D0/3.0D0
+ ENDIF
+C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
+ FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
+ & * (ONE+EPSPOL*Q2/AM2)
+ SUM = SUM+WEIGHT(J)*FAC
+ 1 CONTINUE
+ SINE = SUM
+ SDIR = DT_SIGVP(X,Q2)
+ STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
+ SDIR = SDIR/(0.588D0+RL2+Q2)
+C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
+ ELSEIF (MODEGA.EQ.3) THEN
+ CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
+ ELSEIF (MODEGA.EQ.4) THEN
+* load cross sections from PHOJET interpolation table
+ IP = 1
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 2 I=2,ISIMAX
+ IF (ECM.LE.SIGECM(IP,I)) GOTO 3
+ 2 CONTINUE
+ 3 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LOUT,'(/1X,A,2E12.3)')
+ & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
+ I1 = ISIMAX
+ I2 = ISIMAX
+ ENDIF
+ FAC2 = ZERO
+ IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1 = ONE-FAC2
+* cross section dependence on photon virtuality
+ FSUP1 = ZERO
+ DO 4 I=1,3
+ FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
+ & /(1.D0+Q2/PARMDL(30+I))**2
+ 4 CONTINUE
+ FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
+ FAC1 = FAC1*FSUP1
+ FAC2 = FAC2*FSUP1
+ FSUP2 = 1.0D0
+ STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
+ SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+**re:
+ STOT = STOT-SDIR
+**
+ SDIR = SDIR/(FSUP1*FSUP2)
+**re:
+ STOT = STOT+SDIR
+**
+ ENDIF
+
+ RETURN
+ END
+*
+*===sigvel=============================================================*
+*
+CDECK ID>, DT_SIGVEL
+ SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
+
+************************************************************************
+* Cross section for elastic vector meson production *
+* This version dated 10.05.96 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,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & ALPHEM = ONE/137.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)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ W2 = ECMI**2
+ IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
+ & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
+ Q2 = Q2I
+ X = XI
+* photoprod.
+ IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = 0.0001D0
+ X = Q2/(W2+Q2-AAM(1)**2)
+* DIS
+ ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
+ X = Q2/(W2+Q2-AAM(1)**2)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
+ Q2 = (W2-AAM(1)**2)*X/(ONE-X)
+ ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
+ W2 = Q2*(ONE-X)/X+AAM(1)**2
+ ELSE
+ WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
+ STOP
+ ENDIF
+ ECM = SQRT(W2)
+
+ AMV = AAM(IDXV)
+ AMV2 = AMV**2
+
+ BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
+ & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
+ ROSH = 0.1D0
+ STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
+ SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
+
+ IF (IDXV.EQ.33) THEN
+ COUPL = 0.00365D0
+ ELSE
+ STOP
+ ENDIF
+ SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
+ SIG2 = SELVP
+ SVEL = COUPL * (AMV2/(AMV2+Q2))**2
+ & * (ONE+EPSPOL*Q2/AMV2) * SELVP
+
+ RETURN
+ END
+*
+*===sigvp==============================================================*
+*
+CDECK ID>, DT_SIGVP
+ DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
+
+************************************************************************
+* sigma_Vp *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0,
+ & AMPROT = 0.938D0,
+ & ALPHEM = ONE/137.0D0)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ X = XI
+ Q2 = Q2I
+ IF (XI.LE.ZERO) X = 0.0001D0
+ IF (Q2I.LE.ZERO) Q2 = 0.0001D0
+
+ ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
+
+ SCALE = SQRT(Q2)
+ IF (MODEGA.EQ.1) THEN
+ CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
+ & IDPDF)
+C W = ECM
+
+C ALLMF2 = PHO_ALLM97(Q2,W)
+
+C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
+C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
+C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
+ DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
+ ELSEIF (MODEGA.EQ.4) THEN
+ CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
+C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
+ DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
+ ELSE
+ STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
+ ENDIF
+
+ RETURN
+
+ END
+*
+*===RRM2===============================================================*
+*
+CDECK ID>, DT_RRM2
+ DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+* 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)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ S = Q2*(ONE-X)/X+AAM(1)**2
+ ECM = SQRT(S)
+
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+
+ AM1C2 = 16.0D0
+ AM2C2 = 121.0D0
+ IF (AMHI2.LE.AM1C2) THEN
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
+ ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
+ & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
+ ELSE
+ DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
+ & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
+ & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
+ ENDIF
+
+ RETURN
+ END
+*
+*===RM2================================================================*
+*
+CDECK ID>, DT_RM2
+ DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ IF (RL2.LE.ZERO) THEN
+ DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
+ & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
+ & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
+ ELSE
+ TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
+ TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
+ DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
+ & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
+ & +EPSPOL*(
+ & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
+ & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
+ ENDIF
+
+ RETURN
+ END
+*
+*===SAM2===============================================================*
+*
+CDECK ID>, DT_SAM2
+ DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
+ & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
+ PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
+ & PI = TWOPI/TWO,
+ & GEV2MB = 0.38938D0)
+
+* 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)
+* VDM parameter for photon-nucleus interactions
+ COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+
+ S = ECM**2
+ IF (INTRGE(1).EQ.1) THEN
+ AMLO2 = (3.0D0*AAM(13))**2
+ ELSEIF (INTRGE(1).EQ.2) THEN
+ AMLO2 = AAM(33)**2
+ ELSE
+ AMLO2 = AAM(96)**2
+ ENDIF
+ IF (INTRGE(2).EQ.1) THEN
+ AMHI2 = S/TWO
+ ELSEIF (INTRGE(2).EQ.2) THEN
+ AMHI2 = S/4.0D0
+ ELSE
+ AMHI2 = S
+ ENDIF
+ AMHI20 = (ECM-AAM(1))**2
+ IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
+
+ AM1C2 = 16.0D0
+ AM2C2 = 121.0D0
+ YLO = LOG(AMLO2+Q2)
+ YC1 = LOG(AM1C2+Q2)
+ YC2 = LOG(AM2C2+Q2)
+ YHI = LOG(AMHI2+Q2)
+ IF (AMHI2.LE.AM1C2) THEN
+ FACHI = TWO
+ ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
+ FACHI = TENTRD
+ ELSE
+ FACHI = ELVTRD
+ ENDIF
+
+ 1 CONTINUE
+ YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
+ IF (YSAM2.LE.YC1) THEN
+ FAC = TWO
+ ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
+ FAC = TENTRD
+ ELSE
+ FAC = ELVTRD
+ ENDIF
+ WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
+ XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
+ IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
+
+ DT_SAM2 = EXP(YSAM2)-Q2
+
+ RETURN
+ END
+*
+*===ckmt===============================================================*
+*
+CDECK ID>, DT_CKMT
+ SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
+ & F2,IPAR)
+
+************************************************************************
+* This version dated 31.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
+
+ PARAMETER (Q02 = 2.0D0,
+ & DQ2 = 10.05D0,
+ & Q12 = Q02+DQ2)
+
+ DIMENSION PD(-6:6),SEA(3),VAL(2)
+
+ CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
+ CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
+ ADQ2 = LOG10(Q12)-LOG10(Q02)
+ F2P = (F2Q1-F2Q0)/ADQ2
+ CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
+ CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
+ F2PP = (F2PQ1-F2PQ0)/ADQ2
+ FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
+
+ Q2 = MAX(SCALE**2.0D0,TINY10)
+ SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
+ IF (Q2.LT.Q02) THEN
+ CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
+ UPV = VAL(1)
+ DNV = VAL(2)
+ USEA = SEA(1)
+ DSEA = SEA(2)
+ STR = SEA(3)
+ CHM = 0.0D0
+ BOT = 0.0D0
+ TOP = 0.0D0
+ GL = GLU
+ ELSE
+ CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
+ F2 = F2*SMOOTH
+ UPV = PD(2)-PD(3)
+ DNV = PD(1)-PD(3)
+ USEA = PD(3)
+ DSEA = PD(3)
+ STR = PD(3)
+ CHM = PD(4)
+ BOT = PD(5)
+ TOP = PD(6)
+ GL = PD(0)
+C UPV = UPV*SMOOTH
+C DNV = DNV*SMOOTH
+C USEA = USEA*SMOOTH
+C DSEA = DSEA*SMOOTH
+C STR = STR*SMOOTH
+C CHM = CHM*SMOOTH
+C GL = GL*SMOOTH
+ ENDIF
+
+ RETURN
+ END
+C
+CDECK ID>, DT_CKMTX
+ SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 45 Pomeron
+C 100 Deuteron
+C
+C output: PD(-6:6) x*f(x) parton distribution functions
+C (PDFLIB convention: d = PD(1), u = PD(2) )
+C
+C**********************************************************************
+
+ SAVE
+ DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION QQ(7)
+C
+ Q2=SNGL(SCALE2)
+ Q1S=Q2
+ XX=SNGL(X)
+C QCD lambda for evolution
+ OWLAM = 0.23D0
+ OWLAM2=OWLAM**2
+C Q0**2 for evolution
+ Q02 = 2.D0
+C
+C
+C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
+C q(6)=x*charm, q(7)=x*gluon
+C
+ SB=0.
+ IF(Q2-Q02) 1,1,2
+ 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
+ 1 CONTINUE
+ IF(IPAR.EQ.2212) THEN
+ CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
+ CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
+ CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
+ CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
+ CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
+ CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
+ CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
+C ELSEIF (IPAR.EQ.45) THEN
+C CALL CKMTPO(1,0,XX,SB,QQ(1))
+C CALL CKMTPO(2,0,XX,SB,QQ(2))
+C CALL CKMTPO(3,0,XX,SB,QQ(3))
+C CALL CKMTPO(4,0,XX,SB,QQ(4))
+C CALL CKMTPO(5,0,XX,SB,QQ(5))
+C CALL CKMTPO(8,0,XX,SB,QQ(6))
+C CALL CKMTPO(7,0,XX,SB,QQ(7))
+ ELSEIF (IPAR.EQ.100) THEN
+ CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
+ CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
+ CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
+ CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
+ CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
+ CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
+ CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'CKMTX: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+C
+ PD(-6) = 0.D0
+ PD(-5) = 0.D0
+ PD(-4) = DBLE(QQ(6))
+ PD(-3) = DBLE(QQ(3))
+ PD(-2) = DBLE(QQ(4))
+ PD(-1) = DBLE(QQ(5))
+ PD(0) = DBLE(QQ(7))
+ PD(1) = DBLE(QQ(2))
+ PD(2) = DBLE(QQ(1))
+ PD(3) = DBLE(QQ(3))
+ PD(4) = DBLE(QQ(6))
+ PD(5) = 0.D0
+ PD(6) = 0.D0
+ IF(IPAR.EQ.45) THEN
+ CDN = (PD(1)-PD(-1))/2.D0
+ CUP = (PD(2)-PD(-2))/2.D0
+ PD(-1) = PD(-1) + CDN
+ PD(-2) = PD(-2) + CUP
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
+ & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
+ & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
+ END
+C
+*
+*===pdf0===============================================================*
+*
+CDECK ID>, DT_PDF0
+ SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
+
+************************************************************************
+* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
+* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
+* IPAR = 2212 proton *
+* = 100 deuteron *
+* This version dated 31.01.96 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,TINY9=1.0D-9)
+
+ PARAMETER (
+ & AA = 0.1502D0,
+ & BBDEU = 1.2D0,
+ & BUD = 0.754D0,
+ & BDD = 0.4495D0,
+ & BUP = 1.2064D0,
+ & BDP = 0.1798D0,
+ & DELTA0 = 0.07684D0,
+ & D = 1.117D0,
+ & C = 3.5489D0,
+ & A = 0.2631D0,
+ & B = 0.6452D0,
+ & ALPHAR = 0.415D0,
+ & E = 0.1D0
+ & )
+
+ PARAMETER (NPOINT=16)
+C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
+ DIMENSION SEA(3),VAL(2)
+
+ DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
+ AN = 1.5D0*(1.0D0+Q2/(Q2+C))
+* proton, deuteron
+ IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
+ CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
+ SEA(1) = 0.75D0*SEA0
+ SEA(2) = SEA(1)
+ SEA(3) = SEA(1)
+ VAL(1) = 9.0D0/4.0D0*VALU0
+ VAL(2) = 9.0D0*VALD0
+ GLU0 = SEA(1)/(1.0D0-X)
+ F2 = SEA0+VALU0+VALD0
+ F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
+ & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
+ & 1.0D0/9.0D0*(2.0D0*SEA(3))
+ IF (ABS(F2-F2PDF).GT.TINY9) THEN
+ WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
+ STOP
+ ENDIF
+**PHOJET105a
+C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
+**PHOJET112
+
+C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
+
+**
+C SUMQ = ZERO
+C SUMG = ZERO
+C DO 1 J=1,NPOINT
+C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
+C VALU0 = 9.0D0/4.0D0*VALU0
+C VALD0 = 9.0D0*VALD0
+C SEA0 = 0.75D0*SEA0
+C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
+C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
+C 1 CONTINUE
+C GLU = GLU0*(1.0D0-SUMQ)/SUMG
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'PDF0: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+
+ RETURN
+ END
+*
+*===ckmtq0=============================================================*
+*
+CDECK ID>, DT_CKMTQ0
+ SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
+
+************************************************************************
+* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
+* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
+* IPAR = 2212 proton *
+* = 100 deuteron *
+* This version dated 31.01.96 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,TINY9=1.0D-9)
+
+ PARAMETER (
+ & AA = 0.1502D0,
+ & BBDEU = 1.2D0,
+ & BUD = 0.754D0,
+ & BDD = 0.4495D0,
+ & BUP = 1.2064D0,
+ & BDP = 0.1798D0,
+ & DELTA0 = 0.07684D0,
+ & D = 1.117D0,
+ & C = 3.5489D0,
+ & A = 0.2631D0,
+ & B = 0.6452D0,
+ & ALPHAR = 0.415D0,
+ & E = 0.1D0
+ & )
+
+ DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
+ AN = 1.5D0*(1.0D0+Q2/(Q2+C))
+* proton, deuteron
+ IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
+ IF (IPAR.EQ.2212) THEN
+ BU = BUP
+ BD = BDP
+ ELSE
+ BU = BUD
+ BD = BDD
+ ENDIF
+ SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
+ & (Q2/(Q2+A))**(1.0D0+DELTA)
+ VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
+ & (Q2/(Q2+B))**(ALPHAR)
+ VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
+ & (Q2/(Q2+B))**(ALPHAR)
+ ELSE
+ WRITE(LOUT,'(1X,A,I4,A)')
+ & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
+ STOP
+ ENDIF
+ RETURN
+ END
+C
+C
+CDECK ID>, DT_CKMTDE
+ SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
+C
+C**********************************************************************
+C Deuteron - PDFs
+C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
+C ANS = PDF(I)
+C This version by S. Roesler, 30.01.96
+C**********************************************************************
+
+ SAVE
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.13/
+C
+ DATA (DL(K),K= 1, 85) /
+ &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
+ &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
+ &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
+ &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
+ &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
+ &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
+ &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
+ &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
+ &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
+ &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
+ &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
+ &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
+ &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
+ &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
+ &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
+ &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
+ &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
+ DATA (DL(K),K= 86, 170) /
+ &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
+ &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
+ &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
+ &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
+ &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
+ &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
+ &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
+ &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
+ DATA (DL(K),K= 171, 255) /
+ &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
+ &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
+ &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
+ &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
+ &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
+ &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
+ &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
+ &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
+ &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
+ &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
+ &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
+ &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
+ &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
+ &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
+ &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
+ &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
+ &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
+ DATA (DL(K),K= 256, 340) /
+ &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
+ &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
+ &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
+ &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
+ &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
+ &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
+ &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
+ &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
+ DATA (DL(K),K= 341, 425) /
+ &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
+ &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
+ &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
+ &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
+ &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
+ &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
+ &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
+ &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
+ &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
+ &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
+ &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
+ &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
+ &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
+ &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
+ &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
+ &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
+ &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
+ DATA (DL(K),K= 426, 510) /
+ &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
+ &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
+ &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
+ &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
+ &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
+ &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
+ &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
+ &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
+ DATA (DL(K),K= 511, 595) /
+ &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
+ &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
+ &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
+ &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
+ &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
+ &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
+ &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
+ &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
+ &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
+ &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
+ &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
+ &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
+ &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
+ &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
+ &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
+ &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
+ &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
+ DATA (DL(K),K= 596, 680) /
+ &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
+ &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
+ &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
+ &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
+ &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
+ &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
+ &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
+ &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
+ DATA (DL(K),K= 681, 765) /
+ &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
+ &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
+ &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
+ &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
+ &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
+ &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
+ &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
+ &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
+ &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
+ &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
+ &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
+ &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
+ &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
+ &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
+ &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
+ &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 766, 850) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
+ &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
+ &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
+ &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
+ &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
+ &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
+ &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
+ &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
+ &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
+ &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
+ DATA (DL(K),K= 851, 935) /
+ &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
+ &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
+ &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
+ &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
+ &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
+ &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
+ &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
+ &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
+ &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
+ &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
+ &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
+ &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
+ &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
+ &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 936, 1020) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
+ &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
+ &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
+ &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
+ &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
+ &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
+ &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
+ &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
+ &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
+ &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
+ &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
+ &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
+ DATA (DL(K),K= 1021, 1105) /
+ &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
+ &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
+ &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
+ &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
+ &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
+ &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
+ &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
+ &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
+ &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
+ &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
+ &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
+ &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
+ &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
+ &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
+ &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
+ &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
+ &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
+ &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
+ &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
+ &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
+ &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
+ &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
+ &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
+ &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
+ &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
+ &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
+ &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
+ &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
+ &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
+ &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
+ &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
+ &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
+ &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
+ &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
+ &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
+ &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
+ &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
+ &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
+ &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
+ &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
+ &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
+ &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
+ &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
+ &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
+ &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
+ &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
+ &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
+ &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
+ &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
+ &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
+ &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
+ &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
+ &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
+ &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
+ &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
+ &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
+ DATA (DL(K),K= 1446, 1530) /
+ &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
+ &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
+ &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
+ &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
+ &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
+ &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
+ &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
+ &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
+ &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
+ &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
+ &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
+ &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
+ &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
+ &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
+ &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
+ &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
+ &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
+ DATA (DL(K),K= 1531, 1615) /
+ &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
+ &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
+ &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
+ &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
+ &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
+ &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
+ &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
+ &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
+ &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
+ &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
+ &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
+ &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
+ &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
+ &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
+ &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
+ &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
+ &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
+ &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
+ &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
+ &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
+ &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
+ &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
+ &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
+ &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
+ DATA (DL(K),K= 1701, 1785) /
+ &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
+ &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
+ &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
+ &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
+ &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
+ &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
+ &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
+ &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
+ DATA (DL(K),K= 1786, 1870) /
+ &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
+ &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
+ &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
+ &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
+ &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
+ &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
+ &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
+ &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
+ &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
+ &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
+ &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
+ &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
+ &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
+ &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
+ &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
+ &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
+ &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
+ DATA (DL(K),K= 1871, 1955) /
+ &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
+ &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
+ &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
+ &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
+ &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
+ &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
+ &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
+ &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
+ &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
+ &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
+ &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
+ &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
+ &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
+ &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
+ &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
+ &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
+ &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
+ &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
+ &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
+ &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
+ &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
+ &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
+ &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
+ &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
+ DATA (DL(K),K= 2041, 2125) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
+ &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
+ &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
+ &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
+ &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
+ &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
+ &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
+ &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
+ &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
+ &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
+ &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
+ &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
+ &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
+ &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
+ &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
+ &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
+ &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
+ &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
+ &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
+ &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
+ &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
+ &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
+ &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2211, 2295) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
+ &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
+ &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
+ &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
+ &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
+ &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
+ &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
+ &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
+ &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
+ &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
+ &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
+ DATA (DL(K),K= 2296, 2380) /
+ &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
+ &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
+ &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
+ &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
+ &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
+ &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
+ &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
+ &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
+ &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
+ &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
+ &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
+ &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
+ &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2381, 2465) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
+ &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
+ &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
+ &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
+ &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
+ &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
+ &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
+ &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
+ &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
+ &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
+ &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
+ &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
+ &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
+ DATA (DL(K),K= 2466, 2550) /
+ &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
+ &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
+ &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
+ &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
+ &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
+ &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
+ &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
+ &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
+ &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
+ &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
+ &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2551, 2635) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
+ &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
+ &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
+ &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
+ &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
+ &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
+ &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
+ &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
+ &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
+ &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
+ &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
+ &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
+ &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
+ &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
+ &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
+ DATA (DL(K),K= 2636, 2720) /
+ &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
+ &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
+ &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
+ &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
+ &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
+ &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
+ &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
+ &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
+ &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
+ &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
+ &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
+ &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
+ &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
+ &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
+ &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
+ &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
+ &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
+ &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
+ &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
+ &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
+ &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
+ &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
+ &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
+ &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
+ &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
+ DATA (DL(K),K= 2806, 2890) /
+ &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
+ &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
+ &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
+ &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
+ &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
+ &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
+ &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
+ &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
+ DATA (DL(K),K= 2891, 2975) /
+ &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
+ &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
+ &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
+ &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
+ &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
+ &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
+ &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
+ &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
+ &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
+ &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
+ &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
+ &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
+ &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
+ &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
+ &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
+ &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
+ &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
+ DATA (DL(K),K= 2976, 3060) /
+ &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
+ &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
+ &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
+ &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
+ &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
+ &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
+ &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
+ &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
+ DATA (DL(K),K= 3061, 3145) /
+ &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
+ &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
+ &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
+ &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
+ &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
+ &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
+ &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
+ &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
+ &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
+ &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
+ &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
+ &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
+ &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
+ &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
+ &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
+ &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
+ &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
+ &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
+ &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
+ &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
+ &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
+ &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
+ &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
+ &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
+ DATA (DL(K),K= 3231, 3315) /
+ &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
+ &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
+ &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
+ &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
+ &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
+ &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
+ &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
+ &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
+ &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
+ &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
+ &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
+ &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
+ &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
+ &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
+ &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
+ &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
+ &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
+ DATA (DL(K),K= 3316, 3400) /
+ &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
+ &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
+ &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
+ &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
+ &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
+ &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
+ &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
+ &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
+ DATA (DL(K),K= 3401, 3485) /
+ &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
+ &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
+ &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
+ &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
+ &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
+ &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
+ &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
+ &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
+ &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
+ &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
+ &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
+ &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
+ &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
+ &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
+ &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
+ &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3486, 3570) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
+ &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
+ &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
+ &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
+ &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
+ &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
+ &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
+ &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
+ &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
+ &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
+ DATA (DL(K),K= 3571, 3655) /
+ &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
+ &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
+ &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
+ &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
+ &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
+ &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
+ &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
+ &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
+ &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
+ &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
+ &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
+ &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
+ &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
+ &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3656, 3740) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
+ &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
+ &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
+ &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
+ &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
+ &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
+ &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
+ &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
+ &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
+ &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
+ &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
+ &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
+ DATA (DL(K),K= 3741, 3825) /
+ &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
+ &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
+ &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
+ &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
+ &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
+ &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
+ &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
+ &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
+ &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
+ &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
+ &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
+ &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3826, 3910) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
+ &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
+ &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
+ &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
+ &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
+ &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
+ &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
+ &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
+ &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
+ &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
+ &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
+ &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
+ &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
+ &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
+ DATA (DL(K),K= 3911, 3995) /
+ &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
+ &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
+ &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
+ &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
+ &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
+ &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
+ &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
+ &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
+ &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
+ &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+C
+ ANS = 0.
+ IF (X.GT.0.9985) RETURN
+ IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
+C
+ IS = S/DELTA+1
+ IS1 = IS+1
+ DO 1 L=1,25
+ KL = L+NDRV*25
+ F1(L) = GF(I,IS,KL)
+ F2(L) = GF(I,IS1,KL)
+ 1 CONTINUE
+ A1 = DT_CKMTFF(X,F1)
+ A2 = DT_CKMTFF(X,F2)
+C A1=ALOG(A1)
+C A2=ALOG(A2)
+ S1 = (IS-1)*DELTA
+ S2 = S1+DELTA
+ ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
+C ANS=EXP(ANS)
+ RETURN
+ END
+C
+C
+CDECK ID>, DT_CKMTPR
+ SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
+C
+C**********************************************************************
+C Proton - PDFs
+C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
+C ANS = PDF(I)
+C This version by S. Roesler, 31.01.96
+C**********************************************************************
+
+ SAVE
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.10/
+C
+ DATA (DL(K),K= 1, 85) /
+ &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
+ &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
+ &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
+ &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
+ &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
+ &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
+ &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
+ &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
+ &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
+ &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
+ &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
+ &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
+ &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
+ &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
+ &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
+ &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
+ &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
+ DATA (DL(K),K= 86, 170) /
+ &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
+ &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
+ &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
+ &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
+ &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
+ &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
+ &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
+ &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
+ &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
+ &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
+ &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
+ &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
+ &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
+ &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
+ &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
+ DATA (DL(K),K= 171, 255) /
+ &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
+ &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
+ &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
+ &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
+ &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
+ &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
+ &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
+ &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
+ &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
+ &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
+ &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
+ &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
+ &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
+ &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
+ &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
+ &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
+ &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
+ DATA (DL(K),K= 256, 340) /
+ &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
+ &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
+ &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
+ &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
+ &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
+ &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
+ &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
+ &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
+ &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
+ &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
+ &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
+ &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
+ &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
+ &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
+ &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
+ DATA (DL(K),K= 341, 425) /
+ &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
+ &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
+ &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
+ &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
+ &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
+ &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
+ &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
+ &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
+ &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
+ &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
+ &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
+ &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
+ &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
+ &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
+ &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
+ &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
+ &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
+ DATA (DL(K),K= 426, 510) /
+ &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
+ &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
+ &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
+ &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
+ &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
+ &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
+ &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
+ &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
+ &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
+ &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
+ &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
+ &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
+ &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
+ &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
+ &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
+ DATA (DL(K),K= 511, 595) /
+ &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
+ &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
+ &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
+ &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
+ &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
+ &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
+ &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
+ &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
+ &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
+ &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
+ &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
+ &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
+ &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
+ &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
+ &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
+ &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
+ &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
+ DATA (DL(K),K= 596, 680) /
+ &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
+ &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
+ &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
+ &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
+ &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
+ &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
+ &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
+ &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
+ &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
+ &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
+ &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
+ &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
+ &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
+ &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
+ &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
+ DATA (DL(K),K= 681, 765) /
+ &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
+ &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
+ &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
+ &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
+ &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
+ &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
+ &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
+ &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
+ &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
+ &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
+ &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
+ &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
+ &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
+ &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
+ &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
+ &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
+ &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
+ DATA (DL(K),K= 766, 850) /
+ &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
+ &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
+ &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
+ &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
+ &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
+ &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
+ &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
+ &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
+ &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
+ &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
+ &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
+ &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
+ &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
+ &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
+ &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
+ DATA (DL(K),K= 851, 935) /
+ &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
+ &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
+ &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
+ &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
+ &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
+ &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
+ &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
+ &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
+ &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
+ &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
+ &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
+ &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
+ &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
+ &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
+ &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
+ &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
+ &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
+ DATA (DL(K),K= 936, 1020) /
+ &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
+ &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
+ &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
+ &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
+ &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
+ &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
+ &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
+ &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
+ &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
+ &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
+ &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
+ &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
+ &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
+ &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
+ &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
+ DATA (DL(K),K= 1021, 1105) /
+ &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
+ &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
+ &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
+ &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
+ &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
+ &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
+ &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
+ &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
+ &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
+ &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
+ &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
+ &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
+ &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
+ &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
+ &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
+ &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
+ &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
+ &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
+ &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
+ &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
+ &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
+ &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
+ &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
+ &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
+ &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
+ &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
+ &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
+ &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
+ &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
+ &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
+ &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
+ &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
+ &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
+ &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
+ &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
+ &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
+ &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
+ &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
+ &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
+ &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
+ &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
+ &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
+ &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
+ &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
+ &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
+ &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
+ &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
+ &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
+ &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
+ &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
+ &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
+ &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
+ &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
+ &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
+ &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
+ &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
+ &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
+ &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
+ &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
+ &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
+ &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
+ &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
+ &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
+ &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
+ &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
+ &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
+ &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
+ &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
+ &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
+ &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
+ &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
+ &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
+ &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
+ &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
+ &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
+ &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
+ DATA (DL(K),K= 1446, 1530) /
+ &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
+ &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
+ &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
+ &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
+ &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
+ &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
+ &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
+ &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
+ &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
+ &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
+ &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
+ &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
+ &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
+ &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
+ &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
+ &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
+ &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
+ DATA (DL(K),K= 1531, 1615) /
+ &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
+ &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
+ &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
+ &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
+ &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
+ &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
+ &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
+ &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
+ &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
+ &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
+ &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
+ &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
+ &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
+ &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
+ &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
+ &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
+ &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
+ &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
+ &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
+ &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
+ &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
+ &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
+ &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
+ &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
+ &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
+ &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
+ &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
+ &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
+ &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
+ &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
+ &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
+ DATA (DL(K),K= 1701, 1785) /
+ &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
+ &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
+ &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
+ &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
+ &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
+ &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
+ &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
+ &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
+ &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
+ &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
+ &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
+ &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
+ &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
+ &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
+ &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
+ DATA (DL(K),K= 1786, 1870) /
+ &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
+ &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
+ &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
+ &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
+ &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
+ &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
+ &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
+ &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
+ &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
+ &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
+ &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
+ &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
+ &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
+ &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
+ &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
+ &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
+ &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
+ DATA (DL(K),K= 1871, 1955) /
+ &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
+ &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
+ &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
+ &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
+ &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
+ &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
+ &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
+ &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
+ &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
+ &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
+ &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
+ &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
+ &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
+ &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
+ &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
+ &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
+ &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
+ &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
+ &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
+ &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
+ &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
+ &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
+ &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
+ &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
+ &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
+ &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
+ &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
+ &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
+ &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
+ &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
+ &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
+ DATA (DL(K),K= 2041, 2125) /
+ &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
+ &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
+ &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
+ &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
+ &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
+ &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
+ &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
+ &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
+ &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
+ &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
+ &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
+ &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
+ &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
+ &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
+ &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
+ &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
+ &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
+ &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
+ &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
+ &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
+ &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
+ &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
+ &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
+ &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
+ &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
+ &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
+ &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
+ &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
+ &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
+ &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
+ &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
+ DATA (DL(K),K= 2211, 2295) /
+ &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
+ &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
+ &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
+ &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
+ &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
+ &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
+ &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
+ &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
+ &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
+ &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
+ &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
+ &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
+ &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
+ &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
+ &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
+ DATA (DL(K),K= 2296, 2380) /
+ &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
+ &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
+ &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
+ &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
+ &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
+ &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
+ &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
+ &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
+ &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
+ &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
+ &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
+ &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
+ &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
+ &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
+ &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
+ &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
+ &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
+ DATA (DL(K),K= 2381, 2465) /
+ &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
+ &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
+ &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
+ &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
+ &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
+ &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
+ &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
+ &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
+ &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
+ &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
+ &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
+ &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
+ &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
+ &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
+ &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
+ DATA (DL(K),K= 2466, 2550) /
+ &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
+ &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
+ &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
+ &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
+ &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
+ &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
+ &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
+ &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
+ &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
+ &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
+ &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
+ &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
+ &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
+ &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
+ &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
+ &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
+ &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
+ DATA (DL(K),K= 2551, 2635) /
+ &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
+ &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
+ &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
+ &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
+ &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
+ &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
+ &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
+ &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
+ &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
+ &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
+ &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
+ &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
+ &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
+ &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
+ &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
+ DATA (DL(K),K= 2636, 2720) /
+ &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
+ &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
+ &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
+ &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
+ &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
+ &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
+ &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
+ &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
+ &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
+ &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
+ &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
+ &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
+ &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
+ &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
+ &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
+ &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
+ &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
+ &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
+ &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
+ &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
+ &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
+ &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
+ &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
+ &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
+ &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
+ &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
+ &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
+ &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
+ &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
+ &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
+ &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
+ &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
+ DATA (DL(K),K= 2806, 2890) /
+ &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
+ &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
+ &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
+ &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
+ &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
+ &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
+ &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
+ &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
+ &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
+ &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
+ &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
+ &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
+ &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
+ &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
+ &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
+ DATA (DL(K),K= 2891, 2975) /
+ &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
+ &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
+ &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
+ &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
+ &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
+ &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
+ &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
+ &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
+ &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
+ &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
+ &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
+ &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
+ &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
+ &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
+ &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
+ &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
+ &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
+ DATA (DL(K),K= 2976, 3060) /
+ &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
+ &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
+ &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
+ &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
+ &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
+ &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
+ &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
+ &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
+ &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
+ &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
+ &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
+ &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
+ &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
+ &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
+ &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
+ DATA (DL(K),K= 3061, 3145) /
+ &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
+ &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
+ &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
+ &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
+ &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
+ &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
+ &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
+ &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
+ &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
+ &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
+ &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
+ &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
+ &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
+ &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
+ &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
+ &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
+ &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
+ &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
+ &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
+ &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
+ &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
+ &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
+ &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
+ &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
+ &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
+ &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
+ &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
+ &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
+ &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
+ &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
+ &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
+ DATA (DL(K),K= 3231, 3315) /
+ &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
+ &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
+ &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
+ &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
+ &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
+ &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
+ &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
+ &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
+ &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
+ &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
+ &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
+ &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
+ &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
+ &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
+ &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
+ &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
+ &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
+ DATA (DL(K),K= 3316, 3400) /
+ &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
+ &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
+ &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
+ &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
+ &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
+ &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
+ &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
+ &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
+ &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
+ &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
+ &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
+ &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
+ &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
+ &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
+ &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
+ DATA (DL(K),K= 3401, 3485) /
+ &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
+ &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
+ &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
+ &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
+ &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
+ &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
+ &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
+ &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
+ &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
+ &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
+ &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
+ &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
+ &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
+ &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
+ &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
+ &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
+ &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
+ DATA (DL(K),K= 3486, 3570) /
+ &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
+ &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
+ &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
+ &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
+ &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
+ &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
+ &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
+ &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
+ &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
+ &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
+ &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
+ &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
+ &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
+ &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
+ &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
+ DATA (DL(K),K= 3571, 3655) /
+ &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
+ &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
+ &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
+ &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
+ &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
+ &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
+ &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
+ &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
+ &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
+ &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
+ &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
+ &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
+ &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
+ &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
+ &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
+ &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
+ &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
+ DATA (DL(K),K= 3656, 3740) /
+ &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
+ &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
+ &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
+ &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
+ &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
+ &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
+ &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
+ &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
+ &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
+ &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
+ &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
+ &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
+ &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
+ &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
+ &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
+ DATA (DL(K),K= 3741, 3825) /
+ &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
+ &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
+ &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
+ &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
+ &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
+ &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
+ &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
+ &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
+ &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
+ &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
+ &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
+ &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
+ &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
+ &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
+ &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
+ &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
+ &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
+ DATA (DL(K),K= 3826, 3910) /
+ &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
+ &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
+ &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
+ &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
+ &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
+ &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
+ &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
+ &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
+ &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
+ &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
+ &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
+ &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
+ &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
+ &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
+ &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
+ &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
+ DATA (DL(K),K= 3911, 3995) /
+ &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
+ &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
+ &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
+ &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
+ &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
+ &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
+ &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
+ &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
+ &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
+ &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
+ &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
+ &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
+ &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
+ &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
+ &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
+ &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
+ &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
+C
+ ANS = 0.
+ IF (X.GT.0.9985) RETURN
+ IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
+C
+ IS = S/DELTA+1
+ IS1 = IS+1
+ DO 1 L=1,25
+ KL = L+NDRV*25
+ F1(L) = GF(I,IS,KL)
+ F2(L) = GF(I,IS1,KL)
+ 1 CONTINUE
+ A1 = DT_CKMTFF(X,F1)
+ A2 = DT_CKMTFF(X,F2)
+C A1=ALOG(A1)
+C A2=ALOG(A2)
+ S1 = (IS-1)*DELTA
+ S2 = S1+DELTA
+ ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
+C ANS=EXP(ANS)
+ RETURN
+ END
+C
+CDECK ID>, DT_CKMTFF
+ FUNCTION DT_CKMTFF(X,FVL)
+C**********************************************************************
+C
+C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
+C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
+C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
+C IN MAIN ROUTINE.
+C
+C**********************************************************************
+
+ SAVE
+ DIMENSION FVL(25),XGRID(25)
+ DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
+ *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
+C
+ DT_CKMTFF=0.
+ DO 1 I=1,NX
+ IF(X.LT.XGRID(I)) GO TO 2
+ 1 CONTINUE
+ 2 I=I-1
+ IF(I.EQ.0) THEN
+ I=I+1
+ ELSE IF(I.GT.23) THEN
+ I=23
+ ENDIF
+ J=I+1
+ K=J+1
+ AXI=LOG(XGRID(I))
+ BXI=LOG(1.-XGRID(I))
+ AXJ=LOG(XGRID(J))
+ BXJ=LOG(1.-XGRID(J))
+ AXK=LOG(XGRID(K))
+ BXK=LOG(1.-XGRID(K))
+ FI=LOG(ABS(FVL(I)) +1.E-15)
+ FJ=LOG(ABS(FVL(J)) +1.E-16)
+ FK=LOG(ABS(FVL(K)) +1.E-17)
+ DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
+ ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
+ $ BXI))/DET
+ ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
+ BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
+ IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
+ 1RETURN
+C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
+C WRITE(6,2001) X,FVL
+C 2001 FORMAT(8E12.4)
+C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
+C ENDIF
+ DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
+ RETURN
+ END
+*
+*===fluini=============================================================*
+*
+CDECK ID>, DT_FLUINI
+ SUBROUTINE DT_FLUINI
+
+************************************************************************
+* Initialisation of the nucleon-nucleon cross section fluctuation *
+* treatment. The original version by J. Ranft. *
+* This version dated 21.04.95 is revised 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,ONE=1.0D0,TWO=2.0D0)
+
+ PARAMETER ( A = 0.1D0,
+ & B = 0.893D0,
+ & OM = 1.1D0,
+ & N = 6,
+ & DX = 0.003D0)
+
+* n-n cross section fluctuations
+ PARAMETER (NBINS = 1000)
+ COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+ DIMENSION FLUSI(NBINS),FLUIX(NBINS)
+
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
+ & 'treated')
+
+ FLUSU = ZERO
+ FLUSUU = ZERO
+
+ DO 1 I=1,NBINS
+ X = DBLE(I)*DX
+ FLUIX(I) = X
+ FLUS = ((X-B)/(OM*B))**N
+ IF (FLUS.LE.20.0D0) THEN
+ FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
+ ELSE
+ FLUSI(I) = ZERO
+ ENDIF
+ FLUSU = FLUSU+FLUSI(I)
+ 1 CONTINUE
+ DO 2 I=1,NBINS
+ FLUSUU = FLUSUU+FLUSI(I)/FLUSU
+ FLUSI(I) = FLUSUU
+ 2 CONTINUE
+
+C WRITE(LOUT,1001)
+C1001 FORMAT(1X,'FLUCTUATIONS')
+C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
+
+ DO 3 I=1,NBINS
+ AF = DBLE(I)*0.001D0
+ DO 4 J=1,NBINS
+ IF (AF.LE.FLUSI(J)) THEN
+ FLUIXX(I) = FLUIX(J)
+ GOTO 5
+ ENDIF
+ 4 CONTINUE
+ 5 CONTINUE
+ 3 CONTINUE
+ FLUIXX(1) = FLUIX(1)
+ FLUIXX(NBINS) = FLUIX(NBINS)
+
+ RETURN
+ END
+*
+*===sigtab=============================================================*
+*
+CDECK ID>, DT_SIGTBL
+ SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
+
+************************************************************************
+* This version dated 18.11.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,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0)
+ PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
+
+ LOGICAL LINIT
+
+* 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)
+
+ DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
+ DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
+ & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 5/
+ DATA LINIT /.FALSE./
+
+* precalculation and tabulation of elastic cross sections
+ IF (ABS(MODE).EQ.1) THEN
+ IF (MODE.EQ.1)
+ & OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
+ PLABLX = LOG10(PLO)
+ PLABHX = LOG10(PHI)
+ DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
+ DO 1 I=1,NBINS+1
+ PLAB = PLABLX+DBLE(I-1)*DPLAB
+ PLAB = 10**PLAB
+ DO 2 IPROJ=1,23
+ IDX = IDSIG(IPROJ)
+ IF (IDX.GT.0) THEN
+C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
+C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
+ DUMZER = ZERO
+ CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
+ CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
+ ENDIF
+ 2 CONTINUE
+ IF (MODE.EQ.1) THEN
+ WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
+ & (SIGEN(IDX,I),IDX=1,5)
+ 1000 FORMAT(F5.1,10F7.2)
+ ENDIF
+ 1 CONTINUE
+ IF (MODE.EQ.1) CLOSE(LDAT)
+ LINIT = .TRUE.
+ ELSE
+ SIGE = -ONE
+ IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
+ & .AND.(PTOT.LE.PHI) ) THEN
+ IDX = IDSIG(JP)
+ IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
+ PLABX = LOG10(PTOT)
+ IF (PLABX.LE.PLABLX) THEN
+ I1 = 1
+ I2 = 1
+ ELSEIF (PLABX.GE.PLABHX) THEN
+ I1 = NBINS+1
+ I2 = NBINS+1
+ ELSE
+ I1 = INT((PLABX-PLABLX)/DPLAB)+1
+ I2 = I1+1
+ ENDIF
+ PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
+ PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
+ PBIN = PLAB2X-PLAB1X
+ IF (PBIN.GT.TINY10) THEN
+ RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
+ ELSE
+ RATX = ZERO
+ ENDIF
+ IF (JT.EQ.1) THEN
+ SIG1 = SIGEP(IDX,I1)
+ SIG2 = SIGEP(IDX,I2)
+ ELSE
+ SIG1 = SIGEN(IDX,I1)
+ SIG2 = SIGEN(IDX,I2)
+ ENDIF
+ SIGE = SIG1+RATX*(SIG2-SIG1)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+*
+*===xstabl=============================================================*
+*
+CDECK ID>, DT_XSTABL
+ SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
+ & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
+ LOGICAL LLAB,LELOG,LQLOG
+
+* 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
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+ DIMENSION WHAT(6)
+
+ LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
+ ELO = ABS(WHAT(1))
+ EHI = ABS(WHAT(2))
+ IF (ELO.GT.EHI) ELO = EHI
+ LELOG = WHAT(3).LT.ZERO
+ NEBINS = MAX(INT(ABS(WHAT(3))),1)
+ DEBINS = (EHI-ELO)/DBLE(NEBINS)
+ IF (LELOG) THEN
+ AELO = LOG10(ELO)
+ AEHI = LOG10(EHI)
+ ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
+ ENDIF
+ Q2LO = WHAT(4)
+ Q2HI = WHAT(5)
+ IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
+ LQLOG = WHAT(6).LT.ZERO
+ NQBINS = MAX(INT(ABS(WHAT(6))),1)
+ DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
+ IF (LQLOG) THEN
+ AQ2LO = LOG10(Q2LO)
+ AQ2HI = LOG10(Q2HI)
+ ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
+ ENDIF
+
+ IF ( ELO.EQ. EHI) NEBINS = 0
+ IF (Q2LO.EQ.Q2HI) NQBINS = 0
+
+ WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
+ 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
+ & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
+ & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
+ & ' A_p = ',I3,' A_t = ',I3,/)
+
+C IF (IJPROJ.NE.7) THEN
+ WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
+* normalize fractions of emulsion components
+ IF (NCOMPO.GT.0) THEN
+ SUMFRA = ZERO
+ DO 10 I=1,NCOMPO
+ SUMFRA = SUMFRA+EMUFRA(I)
+ 10 CONTINUE
+ IF (SUMFRA.GT.ZERO) THEN
+ DO 11 I=1,NCOMPO
+ EMUFRA(I) = EMUFRA(I)/SUMFRA
+ 11 CONTINUE
+ ENDIF
+ ENDIF
+C ELSE
+C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
+C ENDIF
+ DO 1 I=1,NEBINS+1
+ IF (LELOG) THEN
+ E = 10**(AELO+DBLE(I-1)*ADEBIN)
+ ELSE
+ E = ELO+DBLE(I-1)*DEBINS
+ ENDIF
+ DO 2 J=1,NQBINS+1
+ IF (LQLOG) THEN
+ Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
+ ELSE
+ Q2 = Q2LO+DBLE(J-1)*DQBINS
+ ENDIF
+c IF (IJPROJ.NE.7) THEN
+ IF (LLAB) THEN
+ PLAB = ZERO
+ ECM = ZERO
+ CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
+ ELSE
+ ECM = E
+ ENDIF
+ XI = ZERO
+ Q2I = ZERO
+ IF (IJPROJ.EQ.7) Q2I = Q2
+ IF (NCOMPO.GT.0) THEN
+ DO 20 IC=1,NCOMPO
+ IIT = IEMUMA(IC)
+ CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
+ 20 CONTINUE
+ ELSE
+ CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
+C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
+ ENDIF
+ IF (NCOMPO.GT.0) THEN
+ XTOT = ZERO
+ ETOT = ZERO
+ XELA = ZERO
+ EELA = ZERO
+ XQEP = ZERO
+ EQEP = ZERO
+ XQET = ZERO
+ EQET = ZERO
+ XQE2 = ZERO
+ EQE2 = ZERO
+ XPRO = ZERO
+ EPRO = ZERO
+ XPRO1= ZERO
+ XDEL = ZERO
+ EDEL = ZERO
+ XDQE = ZERO
+ EDQE = ZERO
+ DO 21 IC=1,NCOMPO
+ XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
+ ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
+ XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
+ EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
+ XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
+ EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
+ XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
+ EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
+ XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
+ EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
+ XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
+ EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
+ XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
+ EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
+ XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
+ EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
+ YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
+ & -XSQEP(1,1,IC)-XSQET(1,1,IC)
+ & -XSQE2(1,1,IC)
+ XPRO1= XPRO1+EMUFRA(IC)*YPRO
+ 21 CONTINUE
+ ETOT = SQRT(ETOT)
+ EELA = SQRT(EELA)
+ EQEP = SQRT(EQEP)
+ EQET = SQRT(EQET)
+ EQE2 = SQRT(EQE2)
+ EPRO = SQRT(EPRO)
+ EDEL = SQRT(EDEL)
+ EDQE = SQRT(EDQE)
+ WRITE(LOUT,'(8E9.3)')
+ & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
+C WRITE(LOUT,'(4E9.3)')
+C & E,XDEL,XDQE,XDEL+XDQE
+ ELSE
+ WRITE(LOUT,'(11E10.3)')
+ & E,
+ & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
+ & XSQE2(1,1,1),XSPRO(1,1,1),
+ & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
+ & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
+ & XSDEL(1,1,1)+XSDQE(1,1,1)
+C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
+C & XSDEL(1,1,1)+XSDQE(1,1,1)
+ ENDIF
+c ELSE
+c IF (LLAB) THEN
+c IF (IT.GT.1) THEN
+c IF (IXSQEL.EQ.0) THEN
+cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
+cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
+c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
+c & STOT,ETOT,SIN,EIN,STOT0)
+c IF (IRATIO.EQ.1) THEN
+c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
+cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
+cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
+c*!! save cross sections
+c STOTA = STOT
+c ETOTA = ETOT
+c STOTP = STGP
+c*!!
+c STOT = STOT/(DBLE(IT)*STGP)
+c SIN = SIN/(DBLE(IT)*SIGP)
+c STOT0 = STGP
+c ETOT = ZERO
+c EIN = ZERO
+c ENDIF
+c ELSE
+c WRITE(LOUT,*)
+c & ' XSTABL: qel. xs. not implemented for nuclei'
+c STOP
+c ENDIF
+c ELSE
+c ETOT = ZERO
+c EIN = ZERO
+c STOT0= ZERO
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
+c ELSE
+c SIN = ZERO
+c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
+c ENDIF
+c ENDIF
+c ELSE
+c IF (IT.GT.1) THEN
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
+c & STOT,ETOT,SIN,EIN,STOT0)
+c IF (IRATIO.EQ.1) THEN
+c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
+c*!! save cross sections
+c STOTA = STOT
+c ETOTA = ETOT
+c STOTP = STGP
+c*!!
+c STOT = STOT/(DBLE(IT)*STGP)
+c SIN = SIN/(DBLE(IT)*SIGP)
+c STOT0 = STGP
+c ETOT = ZERO
+c EIN = ZERO
+c ENDIF
+c ELSE
+c WRITE(LOUT,*)
+c & ' XSTABL: qel. xs. not implemented for nuclei'
+c STOP
+c ENDIF
+c ELSE
+c ETOT = ZERO
+c EIN = ZERO
+c STOT0= ZERO
+c IF (IXSQEL.EQ.0) THEN
+c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
+c ELSE
+c SIN = ZERO
+c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
+c ENDIF
+c ENDIF
+c ENDIF
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
+cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
+c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
+c ENDIF
+ 2 CONTINUE
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===testxs=============================================================*
+*
+CDECK ID>, DT_TESTXS
+ SUBROUTINE DT_TESTXS
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XSTOT(26,2),XSELA(26,2)
+
+ OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
+ OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
+ OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
+ OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
+ DUMECM = 0.0D0
+ PLABL = 0.01D0
+ PLABH = 10000.0D0
+ NBINS = 120
+ APLABL = LOG10(PLABL)
+ APLABH = LOG10(PLABH)
+ ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
+ DO 1 I=1,NBINS+1
+ ADP = APLABL+DBLE(I-1)*ADPLAB
+ P = 10.0D0**ADP
+ DO 2 J=1,26
+ CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
+ CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
+ 2 CONTINUE
+ WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
+ WRITE(11,1000) P,(XSELA(K,1),K=1,26)
+ WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
+ WRITE(13,1000) P,(XSELA(K,2),K=1,26)
+ 1 CONTINUE
+ 1000 FORMAT(F8.3,26F9.3)
+
+ RETURN
+ END
+************************************************************************
+* *
+* DTUNUC 2.0: library routines *
+* processed by S. Roesler, 6.5.95 *
+* *
+************************************************************************
+*
+* 1) Handling of parton momenta
+* SUBROUTINE MASHEL
+* SUBROUTINE DFERMI
+*
+* 2) Handling of parton flavors and particle indices
+* INTEGER FUNCTION IPDG2B
+* INTEGER FUNCTION IB2PDG
+* INTEGER FUNCTION IQUARK
+* INTEGER FUNCTION IBJQUA
+* INTEGER FUNCTION ICIHAD
+* INTEGER FUNCTION IPDGHA
+* INTEGER FUNCTION MCHAD
+* SUBROUTINE FLAHAD
+*
+* 3) Energy-momentum and quantum number conservation check routines
+* SUBROUTINE EMC1
+* SUBROUTINE EMC2
+* SUBROUTINE EVTEMC
+* SUBROUTINE EVTFLC
+* SUBROUTINE EVTCHG
+*
+* 4) Transformations
+* SUBROUTINE LTINI
+* SUBROUTINE LTRANS
+* SUBROUTINE LTNUC
+* SUBROUTINE DALTRA
+* SUBROUTINE DTRAFO
+* SUBROUTINE STTRAN
+* SUBROUTINE MYTRAN
+* SUBROUTINE LT2LAO
+* SUBROUTINE LT2LAB
+*
+* 5) Sampling from distributions
+* INTEGER FUNCTION NPOISS
+* DOUBLE PRECISION FUNCTION SAMPXB
+* DOUBLE PRECISION FUNCTION SAMPEX
+* DOUBLE PRECISION FUNCTION SAMSQX
+* DOUBLE PRECISION FUNCTION BETREJ
+* DOUBLE PRECISION FUNCTION DGAMRN
+* DOUBLE PRECISION FUNCTION DBETAR
+* SUBROUTINE RANNOR
+* SUBROUTINE DPOLI
+* SUBROUTINE DSFECF
+* SUBROUTINE RACO
+*
+* 6) Special functions, algorithms and service routines
+* DOUBLE PRECISION FUNCTION YLAMB
+* SUBROUTINE SORT
+* SUBROUTINE SORT1
+* SUBROUTINE DT_XTIME
+*
+* 7) Random number generator package
+* DOUBLE PRECISION FUNCTION DT_RNDM
+* SUBROUTINE DT_RNDMST
+* SUBROUTINE DT_RNDMIN
+* SUBROUTINE DT_RNDMOU
+* SUBROUTINE DT_RNDMTE
+*
+************************************************************************
+* *
+* 1) Handling of parton momenta *
+* *
+************************************************************************
+*
+*===mashel=============================================================*
+*
+CDECK ID>, DT_MASHEL
+ SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
+
+************************************************************************
+* *
+* rescaling of momenta of two partons to put both *
+* on mass shell *
+* *
+* input: PA1,PA2 input momentum vectors *
+* XM1,2 desired masses of particles afterwards *
+* P1,P2 changed momentum vectors *
+* *
+* The original version is written by R. Engel. *
+* This version dated 12.12.94 is modified by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
+
+ DIMENSION PA1(4),PA2(4),P1(4),P2(4)
+
+ IREJ = 0
+
+* Lorentz transformation into system CMS
+ PX = PA1(1)+PA2(1)
+ PY = PA1(2)+PA2(2)
+ PZ = PA1(3)+PA2(3)
+ EE = PA1(4)+PA2(4)
+ XPTOT = SQRT(PX**2+PY**2+PZ**2)
+ XMS = (EE-XPTOT)*(EE+XPTOT)
+ IF(XMS.LT.(XM1+XM2)**2) THEN
+C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
+ GOTO 9999
+ ENDIF
+ XMS = SQRT(XMS)
+ BGX = PX/XMS
+ BGY = PY/XMS
+ BGZ = PZ/XMS
+ GAM = EE/XMS
+ CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
+ & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
+* rotation angles
+ COD = P1(3)/PTOT1
+C SID = SQRT((ONE-COD)*(ONE+COD))
+ PPT = SQRT(P1(1)**2+P1(2)**2)
+ SID = PPT/PTOT1
+ COF = ONE
+ SIF = ZERO
+ IF(PTOT1*SID.GT.TINY10) THEN
+ COF = P1(1)/(SID*PTOT1)
+ SIF = P1(2)/(SID*PTOT1)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+* new CM momentum and energies (for masses XM1,XM2)
+ XM12 = SIGN(XM1**2,XM1)
+ XM22 = SIGN(XM2**2,XM2)
+ SS = XMS**2
+ PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
+ EE1 = SQRT(XM12+PCMP**2)
+ EE2 = XMS-EE1
+* back rotation
+ MODE = 1
+ CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
+ & PTOT1,P1(1),P1(2),P1(3),P1(4))
+ CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
+ & PTOT2,P2(1),P2(2),P2(3),P2(4))
+* check consistency
+ DEL = XMS*0.0001D0
+ IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
+ IDEV = 1
+ ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
+ IDEV = 2
+ ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
+ IDEV = 3
+ ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
+ IDEV = 4
+ ELSE
+ IDEV = 0
+ ENDIF
+ IF (IDEV.NE.0) THEN
+ WRITE(LOUT,'(/1X,A,I3)')
+ & 'MASHEL: inconsistent transformation',IDEV
+ WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
+ WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
+ WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
+ WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
+ WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===dfermi=============================================================*
+*
+CDECK ID>, DT_DFERMI
+ SUBROUTINE DT_DFERMI(GPART)
+
+************************************************************************
+* Find largest of three random numbers. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION G(3)
+
+ DO 10 I=1,3
+ G(I)=DT_RNDM(GPART)
+ 10 CONTINUE
+ IF (G(3).LT.G(2)) GOTO 40
+ IF (G(3).LT.G(1)) GOTO 30
+ GPART = G(3)
+ 20 RETURN
+ 30 GPART = G(1)
+ GOTO 20
+ 40 IF (G(2).LT.G(1)) GOTO 30
+ GPART = G(2)
+ GOTO 20
+
+ END
+
+************************************************************************
+* *
+* 2) Handling of parton flavors and particle indices *
+* *
+************************************************************************
+*
+*===ipdg2b=============================================================*
+*
+CDECK ID>, IDT_IPDG2B
+ INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
+
+************************************************************************
+* *
+* conversion of quark numbering scheme *
+* *
+* input: PDG parton numbering *
+* for diquarks: NN number of the constituent quark *
+* (e.g. ID=2301,NN=1 -> ICONV2=1) *
+* *
+* output: BAMJET particle codes *
+* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
+* 2 d 8 a-d -2 a-d *
+* 3 s 9 a-s -3 a-s *
+* 4 c 10 a-c -4 a-c *
+* *
+* This is a modified version of ICONV2 written by R. Engel. *
+* This version dated 13.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ IDA = ABS(ID)
+* diquarks
+ IF (IDA.GT.6) THEN
+ KF = 3
+ IF (IDA.GE.1000) KF = 4
+ IDA = IDA/(10**(KF-NN))
+ IDA = MOD(IDA,10)
+ ENDIF
+* exchange up and dn quarks
+ IF (IDA.EQ.1) THEN
+ IDA = 2
+ ELSEIF (IDA.EQ.2) THEN
+ IDA = 1
+ ENDIF
+* antiquarks
+ IF (ID.LT.0) THEN
+ IF (MODE.EQ.1) THEN
+ IDA = IDA+6
+ ELSE
+ IDA = -IDA
+ ENDIF
+ ENDIF
+ IDT_IPDG2B = IDA
+
+ RETURN
+ END
+*
+*===ib2pdg=============================================================*
+*
+CDECK ID>, IDT_IB2PDG
+ INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
+
+************************************************************************
+* *
+* conversion of quark numbering scheme *
+* *
+* input: BAMJET particle codes *
+* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
+* 2 d 8 a-d -2 a-d *
+* 3 s 9 a-s -3 a-s *
+* 4 c 10 a-c -4 a-c *
+* *
+* output: PDG parton numbering *
+* *
+* This version dated 13.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
+ DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
+ DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
+ &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
+ &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
+
+ IDA = ID1
+ IDB = ID2
+ IF (MODE.EQ.1) THEN
+ IF (ID1.GT.6) IDA = -(ID1-6)
+ IF (ID2.GT.6) IDB = -(ID2-6)
+ ENDIF
+ IF (ID2.EQ.0) THEN
+ IDT_IB2PDG = IHKKQ(IDA)
+ ELSE
+ IDT_IB2PDG = IHKKQQ(IDA,IDB)
+ ENDIF
+
+ RETURN
+ END
+*
+*===ipdgqu=============================================================*
+*
+CDECK ID>, IDT_IQUARK
+ INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
+
+************************************************************************
+* *
+* quark contents according to PDG conventions *
+* (random selection in case of quark mixing) *
+* *
+* input: IDBAMJ BAMJET particle code *
+* K 1..3 quark number *
+* *
+* output: 1 d (anti --> neg.) *
+* 2 u *
+* 3 s *
+* 4 c *
+* *
+* This version written by R. Engel. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IQ = IDT_IBJQUA(K,IDBAMJ)
+* quark-antiquark
+ IF (IQ.GT.6) THEN
+ IQ = 6-IQ
+ ENDIF
+* exchange of up and down
+ IF (ABS(IQ).EQ.1) THEN
+ IQ = SIGN(2,IQ)
+ ELSEIF (ABS(IQ).EQ.2) THEN
+ IQ = SIGN(1,IQ)
+ ENDIF
+ IDT_IQUARK = IQ
+
+ RETURN
+ END
+*
+*===ibamq==============================================================*
+*
+CDECK ID>, IDT_IBJQUA
+ INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
+
+************************************************************************
+* *
+* quark contents according to BAMJET conventions *
+* (random selection in case of quark mixing) *
+* *
+* input: IDBAMJ BAMJET particle code *
+* K 1..3 quark number *
+* *
+* output: 1 u 7 u bar *
+* 2 d 8 d bar *
+* 3 s 9 s bar *
+* 4 c 10 c bar *
+* *
+* This version written by R. Engel. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ITAB(3,210)
+ DATA ((ITAB(I,K),I=1,3),K=1,30) /
+ & 1, 1, 2, 7, 7, 8, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 2, 2, 7, 8, 8,
+*sr 10.1.94
+C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 3, 8, 0,
+*
+ & 1, 8, 0, 2, 7, 0, 1, 9, 0,
+*sr 10.1.94
+C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
+ & 3, 7, 0, 3, 1, 2, 9, 7, 8,
+*sr 10.1.94
+C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
+ & 2, 9, 0, 2, 2, 3, 1, 1, 3,
+*
+ & 1, 2, 3, 201,202, 0, 2, 9, 0,
+ & 3, 8, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=31,60) /
+ & 3, 9, 0, 1, 8, 0, 203,204, 0,
+ & 2, 7, 0, 0, 0, 0, 1, 9, 0,
+ & 2, 9, 0, 3, 7, 0, 3, 8, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 1, 1, 1, 1, 2,
+ & 1, 2, 2, 2, 2, 2, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=61,90) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 7, 7, 7, 7, 7, 8, 7, 8, 8,
+ & 8, 8, 8, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=91,120) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 3, 9, 0,
+ & 1, 3, 3, 2, 3, 3, 7, 7, 9,
+ & 7, 8, 9, 8, 8, 9, 7, 9, 9,
+ & 8, 9, 9, 1, 1, 3, 1, 2, 3,
+ & 2, 2, 3, 1, 3, 3, 2, 3, 3,
+ & 3, 3, 3, 7, 7, 9, 7, 8, 9,
+ & 8, 8, 9, 7, 9, 9, 8, 9, 9,
+ & 9, 9, 9, 4, 7, 0, 4, 8, 0,
+ & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
+ DATA ((ITAB(I,K),I=1,3),K=121,150) /
+ & 3, 10, 0, 4, 10, 0, 4, 7, 0,
+ & 4, 8, 0, 2, 10, 0, 1, 10, 0,
+ & 4, 9, 0, 3, 10, 0, 4, 10, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 2, 4, 1, 3, 4,
+ & 2, 3, 4, 1, 1, 4, 0, 0, 0,
+ & 2, 2, 4, 0, 0, 0, 0, 0, 0,
+ & 3, 3, 4, 1, 4, 4, 2, 4, 4,
+ & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
+ DATA ((ITAB(I,K),I=1,3),K=151,180) /
+ & 8, 9, 10, 7, 7, 10, 0, 0, 0,
+ & 8, 8, 10, 0, 0, 0, 0, 0, 0,
+ & 9, 9, 10, 7, 10, 10, 8, 10, 10,
+ & 9, 10, 10, 1, 1, 4, 1, 2, 4,
+ & 2, 2, 4, 1, 3, 4, 2, 3, 4,
+ & 3, 3, 4, 1, 4, 4, 2, 4, 4,
+ & 3, 4, 4, 4, 4, 4, 7, 7, 10,
+ & 7, 8, 10, 8, 8, 10, 7, 9, 10,
+ & 8, 9, 10, 9, 9, 10, 7, 10, 10,
+ & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
+ DATA ((ITAB(I,K),I=1,3),K=181,210) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1, 7, 0,
+ & 2, 8, 0, 1, 7, 0, 2, 8, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA IDOLD /0/
+
+ ONE = 1.0D0
+ IF (ITAB(1,IDBAMJ).LE.200) THEN
+ ID = ITAB(K,IDBAMJ)
+ ELSE
+ IF(IDOLD.NE.IDBAMJ) THEN
+ IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
+ & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
+ ELSE
+ IDOLD = 0
+ ENDIF
+ ID = ITAB(K,IT)
+ ENDIF
+ IDOLD = IDBAMJ
+ IDT_IBJQUA = ID
+
+ RETURN
+ END
+*
+*===icihad=============================================================*
+*
+CDECK ID>, IDT_ICIHAD
+ INTEGER FUNCTION IDT_ICIHAD(MCIND)
+
+************************************************************************
+* Conversion of particle index PDG proposal --> BAMJET-index scheme *
+* This is a completely new version dated 25.10.95. *
+* Renamed to be not in conflict with the modified PHOJET-version *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+
+ IDT_ICIHAD = 0
+ KPDG = ABS(MCIND)
+ IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
+ IF (MCIND.LT.0) THEN
+ JSIGN = 1
+ ELSE
+ JSIGN = 2
+ ENDIF
+ IF (KPDG.GE.10000) THEN
+ DO 1 I=1,19
+ IDT_ICIHAD = IBAM5(JSIGN,I)
+ IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 1 CONTINUE
+ ELSEIF (KPDG.GE.1000) THEN
+ DO 2 I=1,29
+ IDT_ICIHAD = IBAM4(JSIGN,I)
+ IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 2 CONTINUE
+ ELSEIF (KPDG.GE.100) THEN
+ DO 3 I=1,22
+ IDT_ICIHAD = IBAM3(JSIGN,I)
+ IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 3 CONTINUE
+ ELSEIF (KPDG.GE.10) THEN
+ DO 4 I=1,7
+ IDT_ICIHAD = IBAM2(JSIGN,I)
+ IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
+ IDT_ICIHAD = 0
+ 4 CONTINUE
+ ENDIF
+ 5 CONTINUE
+
+ RETURN
+ END
+*
+*===ipdgha=============================================================*
+*
+CDECK ID>, IDT_IPDGHA
+ INTEGER FUNCTION IDT_IPDGHA(MCIND)
+
+************************************************************************
+* Conversion of particle index BAMJET-index scheme --> PDG proposal *
+* Adopted from the original by S. Roesler. This version dated 12.5.95 *
+* Renamed to be not in conflict with the modified PHOJET-version *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+
+ IDT_IPDGHA = IAMCIN(MCIND)
+
+ RETURN
+ END
+*
+*===flahad=============================================================*
+*
+CDECK ID>, DT_FLAHAD
+ SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
+
+************************************************************************
+* sampling of FLAvor composition for HADrons/photons *
+* ID BAMJET-id of hadron *
+* IF1,2,3 flavor content *
+* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
+* Note: - u,d numbering as in BAMJET *
+* - ID .le. 30 !! *
+* This version dated 12.03.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+
+ DIMENSION JSEL(3,6)
+ DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
+
+ ONE = 1.0D0
+ IF (ID.EQ.7) THEN
+* photon (charge dependent flavour sampling)
+ K = INT(DT_RNDM(ONE)*6.D0+1.D0)
+ IF (K.LE.4) THEN
+ IF1 = 2
+ IF2 = -2
+ ELSE IF(K.EQ.5) THEN
+ IF1 = 1
+ IF2 = -1
+ ELSE
+ IF1 = 3
+ IF2 = -3
+ ENDIF
+ IF(DT_RNDM(ONE).LT.0.5D0) THEN
+ K = IF1
+ IF1 = IF2
+ IF2 = K
+ ENDIF
+ IF3 = 0
+ ELSE
+* hadron
+ IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
+ IF1 = MQUARK(JSEL(1,IX),ID)
+ IF2 = MQUARK(JSEL(2,IX),ID)
+ IF3 = MQUARK(JSEL(3,IX),ID)
+ IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
+ IF1 = IF3
+ IF3 = 0
+ ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
+ IF2 = IF3
+ IF3 = 0
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+*
+*===mchad==============================================================*
+*
+CDECK ID>, IDT_MCHAD
+ INTEGER FUNCTION IDT_MCHAD(ITDTU)
+
+************************************************************************
+* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
+* Adopted from the original by S. Roesler. This version dated 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ITRANS(210)
+ DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
+ &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
+ &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
+ &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
+ &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
+ &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
+ &9, 9, 9, 85*- 1,7*-1,1,8,-1/
+
+ IDT_MCHAD = ITRANS(ITDTU)
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 3) Energy-momentum and quantum number conservation check routines *
+* *
+************************************************************************
+*
+*===emc1===============================================================*
+*
+CDECK ID>, DT_EMC1
+ SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
+
+************************************************************************
+* This version dated 15.12.94 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)
+
+ DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
+
+ IREJ = 0
+
+ IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
+ & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
+
+ IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
+ IF (MODE.EQ.1) THEN
+ CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
+ ELSEIF (MODE.EQ.2) THEN
+ CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
+ ENDIF
+ CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
+ ELSEIF (MODE.LT.0) THEN
+ IF (MODE.EQ.-1) THEN
+ CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
+ ELSEIF (MODE.EQ.-2) THEN
+ CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
+ ENDIF
+ CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
+ CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
+ ENDIF
+
+ IF (ABS(MODE).EQ.3) THEN
+ CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
+ IF (IREJ1.NE.0) GOTO 9999
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===emc2===============================================================*
+*
+CDECK ID>, DT_EMC2
+ SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
+ & MODE,IPOS,IREJ)
+
+************************************************************************
+* MODE = 1 energy-momentum cons. check *
+* = 2 flavor-cons. check *
+* = 3 energy-momentum & flavor cons. check *
+* = 4 energy-momentum & charge cons. check *
+* = 5 energy-momentum & flavor & charge cons. check *
+* 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)
+
+ IREJ = 0
+ IREJ1 = 0
+ IREJ2 = 0
+ IREJ3 = 0
+
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
+ DO 1 I=1,NHKK
+ IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
+ & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
+ & (ISTHKK(I).EQ.IP5)) THEN
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
+ & .OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & 2,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
+ ENDIF
+ IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
+ & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
+ & (ISTHKK(I).EQ.IN5)) THEN
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
+ & .OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
+ & 2,IDUM,IDUM)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
+ ENDIF
+ 1 CONTINUE
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
+ & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
+ IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
+ & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
+ IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
+ IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===evtemc=============================================================*
+*
+CDECK ID>, DT_EVTEMC
+ SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
+
+************************************************************************
+* This version dated 13.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,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)
+* 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
+
+ IREJ = 0
+
+ MODE = IMODE
+ CHKLEV = TINY10
+ IF (MODE.EQ.4) THEN
+ CHKLEV = TINY2
+ MODE = 3
+ ELSEIF (MODE.EQ.5) THEN
+ CHKLEV = TINY1
+ MODE = 3
+ ELSEIF (MODE.EQ.-1) THEN
+ CHKLEV = EIO
+ MODE = 3
+ ENDIF
+
+ IF (ABS(MODE).EQ.3) THEN
+ PXDEV = PX
+ PYDEV = PY
+ PZDEV = PZ
+ EDEV = E
+ IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
+ IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
+ & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
+ IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
+ & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
+ & ' event ',NEVHKK,
+ & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ GOTO 9999
+ ENDIF
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.1) THEN
+ PX = 0.0D0
+ PY = 0.0D0
+ PZ = 0.0D0
+ E = 0.0D0
+ ENDIF
+
+ PX = PX+PXIO
+ PY = PY+PYIO
+ PZ = PZ+PZIO
+ E = E+EIO
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===evtflc=============================================================*
+*
+CDECK ID>, DT_EVTFLC
+ SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
+
+************************************************************************
+* Flavor conservation check. *
+* ID identity of particle *
+* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
+* = 2 ID for particle/resonance in BAMJET numbering scheme *
+* = 3 ID for particle/resonance in PDG numbering scheme *
+* MODE = 1 initialization and add ID *
+* =-1 initialization and subtract ID *
+* = 2 add ID *
+* =-2 subtract ID *
+* = 3 check flavor cons. *
+* IPOS flag to give position of call of EVTFLC to output *
+* unit in case of violation *
+* This version dated 10.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)
+
+ IREJ = 0
+
+ IF (MODE.EQ.3) THEN
+ IF (IFL.NE.0) THEN
+ WRITE(LOUT,'(1X,A,I3,A,I3)')
+ & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
+ & ' ! IFL = ',IFL
+ IFL = 0
+ GOTO 9999
+ ENDIF
+ IFL = 0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.1) IFL = 0
+ IF (ID.EQ.0) RETURN
+
+ IF (ID1.EQ.1) THEN
+ IDD = ABS(ID)
+ NQ = 1
+ IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
+ IF (IDD.GE.1000) NQ = 3
+ DO 1 I=1,NQ
+ IFBAM = IDT_IPDG2B(ID,I,2)
+ IF (ABS(IFBAM).EQ.1) THEN
+ IFBAM = SIGN(2,IFBAM)
+ ELSEIF (ABS(IFBAM).EQ.2) THEN
+ IFBAM = SIGN(1,IFBAM)
+ ENDIF
+ IF (MODE.GT.0) THEN
+ IFL = IFL+IFBAM
+ ELSE
+ IFL = IFL-IFBAM
+ ENDIF
+ 1 CONTINUE
+ RETURN
+ ENDIF
+
+ IDD = ID
+ IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
+ IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
+ DO 2 I=1,3
+ IF (MODE.GT.0) THEN
+ IFL = IFL+IDT_IQUARK(I,IDD)
+ ELSE
+ IFL = IFL-IDT_IQUARK(I,IDD)
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+*
+*===evtchg=============================================================*
+*
+CDECK ID>, DT_EVTCHG
+ SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
+
+************************************************************************
+* Charge conservation check. *
+* ID identity of particle (PDG-numbering scheme) *
+* MODE = 1 initialization *
+* =-2 subtract ID-charge *
+* = 2 add ID-charge *
+* = 3 check charge cons. *
+* IPOS flag to give position of call of EVTCHG to output *
+* unit in case of violation *
+* This version dated 10.01.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 )
+
+* 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)
+* 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)
+
+ IREJ = 0
+
+ IF (MODE.EQ.1) THEN
+ ICH = 0
+ IBAR = 0
+ RETURN
+ ENDIF
+
+ IF (MODE.EQ.3) THEN
+ IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
+ WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
+ & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
+ & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
+ ICH = 0
+ IBAR = 0
+ GOTO 9999
+ ENDIF
+ ICH = 0
+ IBAR = 0
+ RETURN
+ ENDIF
+
+ IF (ID.EQ.0) RETURN
+
+ IDD = IDT_ICIHAD(ID)
+* modification 21.1.01: use intrinsic phojet-functions to determine charge
+* and baryon number
+C IF (IDD.GT.0) THEN
+C IF (MODE.EQ.2) THEN
+C ICH = ICH+IICH(IDD)
+C IBAR = IBAR+IIBAR(IDD)
+C ELSEIF (MODE.EQ.-2) THEN
+C ICH = ICH-IICH(IDD)
+C IBAR = IBAR-IIBAR(IDD)
+C ENDIF
+C ELSE
+C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
+C CALL DT_EVTOUT(4)
+C STOP
+C ENDIF
+ IF (MODE.EQ.2) THEN
+ ICH = ICH+IPHO_CHR3(ID,1)/3
+ IBAR = IBAR+IPHO_BAR3(ID,1)/3
+ ELSEIF (MODE.EQ.-2) THEN
+ ICH = ICH-IPHO_CHR3(ID,1)/3
+ IBAR = IBAR-IPHO_BAR3(ID,1)/3
+ ENDIF
+
+ RETURN
+
+ 9999 CONTINUE
+ IREJ = 1
+ RETURN
+ END
+
+************************************************************************
+* *
+* 4) Transformations *
+* *
+************************************************************************
+*
+*===ltini==============================================================*
+*
+CDECK ID>, DT_LTINI
+ SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
+
+************************************************************************
+* Initializations of Lorentz-transformations, calculation of Lorentz- *
+* parameters. *
+* This version dated 13.11.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,TINY3=1.0D-3,
+ & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+* 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)
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+
+ Q2 = VIRT
+ IDP = IDPR
+ IF (MCGENE.NE.3) THEN
+* lepton-projectiles and PHOJET: initialize real photon instead
+ IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
+ & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
+ & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
+ IDP = 7
+ Q2 = ZERO
+ ENDIF
+ ENDIF
+ IDT = IDTA
+ EPN = EPN0
+ PPN = PPN0
+ ECM = ECM0
+ AMP = AAM(IDP)-SQRT(ABS(Q2))
+ AMT = AAM(IDT)
+ AMP2 = SIGN(AMP**2,AMP)
+ AMT2 = AMT**2
+ IF (ECM0.GT.ZERO) THEN
+ EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
+ IF (AMP2.GT.ZERO) THEN
+ PPN = SQRT((EPN+AMP)*(EPN-AMP))
+ ELSE
+ PPN = SQRT(EPN**2-AMP2)
+ ENDIF
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ IF (IDP.EQ.7) EPN = ABS(EPN)
+ IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
+ IF (AMP2.GT.ZERO) THEN
+ PPN = SQRT((EPN+AMP)*(EPN-AMP))
+ ELSE
+ PPN = SQRT(EPN**2-AMP2)
+ ENDIF
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ IF (AMP2.GT.ZERO) THEN
+ EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
+ ELSE
+ EPN = SQRT(PPN**2+AMP2)
+ ENDIF
+ ENDIF
+ ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
+ ENDIF
+ UMO = ECM
+ EPROJ = EPN
+ PPROJ = PPN
+ IF (AMP2.GT.ZERO) THEN
+ ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
+ PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
+ ELSE
+ ETARG = TINY10
+ PTARG = TINY10
+ ENDIF
+* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
+ IF (IDP.EQ.7) THEN
+ PGAMM(1) = ZERO
+ PGAMM(2) = ZERO
+ AMGAM = AMP
+ AMGAM2 = AMP2
+ IF (ECM0.GT.ZERO) THEN
+ S = ECM0**2
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
+ ENDIF
+ ENDIF
+ PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
+ & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
+ PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
+ IF (MODE.EQ.1) THEN
+ PNUCL(1) = ZERO
+ PNUCL(2) = ZERO
+ PNUCL(3) = -PGAMM(3)
+ PNUCL(4) = SQRT(S)-PGAMM(4)
+ ENDIF
+ ENDIF
+ IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
+ & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
+ PLEPT0(1) = ZERO
+ PLEPT0(2) = ZERO
+* neglect lepton masses
+C AMLPT2 = AAM(IDPR)**2
+ AMLPT2 = ZERO
+*
+ IF (ECM0.GT.ZERO) THEN
+ S = ECM0**2
+ ELSE
+ IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
+ S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
+ ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
+ S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
+ ENDIF
+ ENDIF
+ PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
+ & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
+ PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
+ PNUCL(1) = ZERO
+ PNUCL(2) = ZERO
+ PNUCL(3) = -PLEPT0(3)
+ PNUCL(4) = SQRT(S)-PLEPT0(4)
+ ENDIF
+* Lorentz-parameter for transformation Lab. - projectile rest system
+ IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
+ GALAB = TINY10
+ BGLAB = TINY10
+ BLAB = TINY10
+ ELSE
+ GALAB = EPROJ/AMP
+ BGLAB = PPROJ/AMP
+ BLAB = BGLAB/GALAB
+ ENDIF
+* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
+ IF (IDP.EQ.7) THEN
+ GACMS(1) = TINY10
+ BGCMS(1) = TINY10
+ ELSE
+ GACMS(1) = (ETARG+AMP)/UMO
+ BGCMS(1) = PTARG/UMO
+ ENDIF
+* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
+ GACMS(2) = (EPROJ+AMT)/UMO
+ BGCMS(2) = PPROJ/UMO
+ PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
+
+ EPN0 = EPN
+ PPN0 = PPN
+ ECM0 = ECM
+
+ RETURN
+ END
+*
+*===ltrans=============================================================*
+*
+CDECK ID>, DT_LTRANS
+ SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
+
+************************************************************************
+* Lorentz-transformations. *
+* MODE = 1(-1) projectile rest syst. --> Lab (back) *
+* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
+* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
+* This version dated 01.11.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
+
+ PARAMETER (SQTINF=1.0D+15)
+
+* 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)
+
+ PXO = PXI
+ PYO = PYI
+ CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
+
+* check particle mass for consistency (numerical rounding errors)
+ PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
+ AMO2 = (PEO-PO)*(PEO+PO)
+ AMORQ2 = AAM(ID)**2
+ AMDIF2 = ABS(AMO2-AMORQ2)
+ IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
+ DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
+ PEO = PEO+DELTA
+ PO1 = PO -DELTA
+ PXO = PXO*PO1/PO
+ PYO = PYO*PO1/PO
+ PZO = PZO*PO1/PO
+C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
+ ENDIF
+
+ RETURN
+ END
+*
+*===ltnuc==============================================================*
+*
+CDECK ID>, DT_LTNUC
+ SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
+
+************************************************************************
+* Lorentz-transformations. *
+* PIN longitudnal momentum (input) *
+* EIN energy (input) *
+* POUT transformed long. momentum (output) *
+* EOUT transformed energy (output) *
+* MODE = 1(-1) projectile rest syst. --> Lab (back) *
+* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
+* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
+* This version dated 01.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)
+
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+ BDUM1 = ZERO
+ BDUM2 = ZERO
+ PDUM1 = ZERO
+ PDUM2 = ZERO
+ IF (ABS(MODE).EQ.1) THEN
+ BG = -SIGN(BGLAB,DBLE(MODE))
+ CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSEIF (ABS(MODE).EQ.2) THEN
+ BG = SIGN(BGCMS(1),DBLE(MODE))
+ CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSEIF (ABS(MODE).EQ.3) THEN
+ BG = -SIGN(BGCMS(2),DBLE(MODE))
+ CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
+ & DUM1,DUM2,DUM3,POUT,EOUT)
+ ELSE
+ WRITE(LOUT,1000) MODE
+ 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
+ EOUT = EIN
+ POUT = PIN
+ ENDIF
+
+ RETURN
+ END
+*
+*===daltra=============================================================*
+*
+CDECK ID>, DT_DALTRA
+ SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
+
+************************************************************************
+* Arbitrary Lorentz-transformation. *
+* Adopted from the original by S. Roesler. This version dated 15.01.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ EP = PCX*BGX+PCY*BGY+PCZ*BGZ
+ PE = EP/(GA+ONE)+EC
+ PX = PCX+BGX*PE
+ PY = PCY+BGY*PE
+ PZ = PCZ+BGZ*PE
+ P = SQRT(PX*PX+PY*PY+PZ*PZ)
+ E = GA*EC+EP
+
+ RETURN
+ END
+*
+*====dtrafo============================================================*
+*
+CDECK ID>, DT_DTRAFO
+ SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
+ & PL,CXL,CYL,CZL,EL)
+
+C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
+ SID = SQRT(1.D0-COD*COD)
+ PLX = P*SID*COF
+ PLY = P*SID*SIF
+ PCMZ = P*COD
+ PLZ = GAM*PCMZ+BGAM*ECM
+ PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
+ EL = GAM*ECM+BGAM*PCMZ
+C ROTATION INTO THE ORIGINAL DIRECTION
+ COZ = PLZ/PL
+ SIZ = SQRT(1.D0-COZ**2)
+ CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
+
+ RETURN
+ END
+*
+*====sttran============================================================*
+*
+CDECK ID>, DT_STTRAN
+ SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ DATA ANGLSQ/1.D-30/
+************************************************************************
+* VERSION BY J. RANFT *
+* LEIPZIG *
+* *
+* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
+* *
+* INPUT VARIABLES: *
+* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
+* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
+* ANGLE OF "SCATTERING" *
+* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
+* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
+* OF "SCATTERING" *
+* *
+* OUTPUT VARIABLES: *
+* X,Y,Z = NEW DIRECTION COSINES *
+* *
+* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
+************************************************************************
+*
+*
+* Changed by A. Ferrari
+*
+* IF (ABS(XO)-0.0001D0) 1,1,2
+* 1 IF (ABS(YO)-0.0001D0) 3,3,2
+* 3 CONTINUE
+ A = XO**2 + YO**2
+ IF ( A .LT. ANGLSQ ) THEN
+ X=SDE*CFE
+ Y=SDE*SFE
+ Z=CDE*ZO
+ ELSE
+ XI=SDE*CFE
+ YI=SDE*SFE
+ ZI=CDE
+ A=SQRT(A)
+ X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
+ Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
+ Z=A*YI+ZO*ZI
+ ENDIF
+
+ RETURN
+ END
+*
+*===mytran=============================================================*
+*
+CDECK ID>, DT_MYTRAN
+ SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+
+************************************************************************
+* This subroutine rotates the coordinate frame *
+* a) theta around y *
+* b) phi around z if IMODE = 1 *
+* *
+* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
+* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
+* z' 0 0 1 -sin(th) 0 cos(th) z *
+* *
+* and vice versa if IMODE = 0. *
+* This version dated 5.4.94 is based on the original version DTRAN *
+* by J. Ranft and is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ IF (IMODE.EQ.1) THEN
+ X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
+ Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
+ Z=-SDE *XO +CDE *ZO
+ ELSE
+ X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
+ Y= -SFE*XO+CFE*YO
+ Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
+ ENDIF
+ RETURN
+ END
+*
+*===lt2lab=============================================================*
+*
+CDECK ID>, DT_LT2LAO
+ SUBROUTINE DT_LT2LAO
+
+************************************************************************
+* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
+* for final state particles/fragments defined in nucleon-nucleon-cms *
+* and transforms them back to the lab. *
+* This version dated 16.11.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ NEND = NHKK
+ NPOINT(5) = NHKK+1
+ IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
+ DO 1 I=NPOINT(4),NEND
+C DO 1 I=1,NEND
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
+ NOB = NOBAM(I)
+ CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
+ & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
+ IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
+ ISTHKK(I) = 3*ISTHKK(I)
+ NOBAM(NHKK) = NOB
+ ELSE
+ IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
+ ISTHKK(I) = SIGN(3,ISTHKK(I))
+ ENDIF
+ JDAHKK(1,I) = NHKK
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===lt2lab=============================================================*
+*
+CDECK ID>, DT_LT2LAB
+ SUBROUTINE DT_LT2LAB
+
+************************************************************************
+* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
+* for final state particles/fragments defined in nucleon-nucleon-cms *
+* and transforms them to the lab. *
+* This version dated 07.01.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+ DO 1 I=NPOINT(4),NHKK
+ IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+ & (ISTHKK(I).EQ.1001)) THEN
+ CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
+ PHKK(3,I) = PZ
+ PHKK(4,I) = PE
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 5) Sampling from distributions *
+* *
+************************************************************************
+*
+*===npoiss=============================================================*
+*
+CDECK ID>, IDT_NPOISS
+ INTEGER FUNCTION IDT_NPOISS(AVN)
+
+************************************************************************
+* Sample according to Poisson distribution with Poisson parameter AVN. *
+* The original version written by J. Ranft. *
+* This version dated 11.1.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ EXPAVN = EXP(-AVN)
+ K = 1
+ A = 1.0D0
+
+ 10 CONTINUE
+ A = DT_RNDM(A)*A
+ IF (A.GE.EXPAVN) THEN
+ K = K+1
+ GOTO 10
+ ENDIF
+ IDT_NPOISS = K-1
+
+ RETURN
+ END
+*
+*===sampxb=============================================================*
+*
+CDECK ID>, DT_SAMPXB
+ DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
+
+************************************************************************
+* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0)
+
+ A1 = LOG(X1+SQRT(X1**2+B**2))
+ A2 = LOG(X2+SQRT(X2**2+B**2))
+ AN = A2-A1
+ A = AN*DT_RNDM(A1)+A1
+ BB = EXP(A)
+ DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
+
+ RETURN
+ END
+*
+*===sampex=============================================================*
+*
+CDECK ID>, DT_SAMPEX
+ DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
+
+************************************************************************
+* Sampling from f(x)=1./x between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(X1)
+ AL1 = LOG(X1)
+ AL2 = LOG(X2)
+ DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
+
+ RETURN
+ END
+*
+*===samsqx=============================================================*
+*
+CDECK ID>, DT_SAMSQX
+ DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
+
+************************************************************************
+* Sampling from f(x)=1./x^0.5 between x1 and x2. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(X1)
+ DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
+
+ RETURN
+ END
+*
+*===samplw=============================================================*
+*
+CDECK ID>, DT_SAMPLW
+ DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
+
+************************************************************************
+* Sampling from f(x)=1/x^b between x_min and x_max. *
+* S. Roesler, 18.4.98 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ONE=1.0D0)
+
+ R = DT_RNDM(B)
+ IF (B.EQ.ONE) THEN
+ DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
+ ELSE
+ ONEMB = ONE-B
+ DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
+ ENDIF
+
+ RETURN
+ END
+*
+*===betrej=============================================================*
+*
+CDECK ID>, DT_BETREJ
+ DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ONE=1.0D0)
+
+ IF (XMIN.GE.XMAX)THEN
+ WRITE (LOUT,500) XMIN,XMAX
+ 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
+ STOP
+ ENDIF
+
+ 10 CONTINUE
+ XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
+ BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
+ YY = BETMAX*DT_RNDM(XX)
+ BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
+ IF (YY.GT.BETXX) GOTO 10
+ DT_BETREJ = XX
+
+ RETURN
+ END
+*
+*===dgamrn=============================================================*
+*
+CDECK ID>, DT_DGAMRN
+ DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
+
+************************************************************************
+* Sampling from Gamma-distribution. *
+* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
+
+ NCOU = 0
+ N = INT(ETA)
+ F = ETA-DBLE(N)
+ IF (F.EQ.ZERO) GOTO 20
+ 10 R = DT_RNDM(F)
+ NCOU = NCOU+1
+ IF (NCOU.GE.11) GOTO 20
+ IF (R.LT.F/(F+2.71828D0)) GOTO 30
+ YYY = LOG(DT_RNDM(R)+TINY9)/F
+ IF (ABS(YYY).GT.50.0D0) GOTO 20
+ Y = EXP(YYY)
+ IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
+ GOTO 40
+ 20 Y = 0.0D0
+ GOTO 50
+ 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
+ IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
+ 40 IF (N.EQ.0) GOTO 70
+ 50 Z = 1.0D0
+ DO 60 I = 1,N
+ 60 Z = Z*DT_RNDM(Z)
+ Y = Y-LOG(Z+TINY9)
+ 70 DT_DGAMRN = Y/ALAM
+
+ RETURN
+ END
+*
+*===dbetar=============================================================*
+*
+CDECK ID>, DT_DBETAR
+ DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
+
+************************************************************************
+* Sampling from Beta -distribution between 0.0 and 1.0 *
+* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ Y = DT_DGAMRN(1.0D0,GAM)
+ Z = DT_DGAMRN(1.0D0,ETA)
+ DT_DBETAR = Y/(Y+Z)
+
+ RETURN
+ END
+*
+*===rannor=============================================================*
+*
+CDECK ID>, DT_RANNOR
+ SUBROUTINE DT_RANNOR(X,Y)
+
+************************************************************************
+* Sampling from Gaussian distribution. *
+* Processed by S. Roesler, 6.5.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TINY10=1.0D-10)
+
+ CALL DT_DSFECF(SFE,CFE)
+ V = MAX(TINY10,DT_RNDM(X))
+ A = SQRT(-2.D0*LOG(V))
+ X = A*SFE
+ Y = A*CFE
+
+ RETURN
+ END
+*
+*===dpoli==============================================================*
+*
+CDECK ID>, DT_DPOLI
+ SUBROUTINE DT_DPOLI(CS,SI)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ U = DT_RNDM(CS)
+ CS = DT_RNDM(U)
+ IF (U.LT.0.5D0) CS=-CS
+ SI = SQRT(1.0D0-CS*CS+1.0D-10)
+
+ RETURN
+ END
+*
+*===dsfecf=============================================================*
+*
+CDECK ID>, DT_DSFECF
+ SUBROUTINE DT_DSFECF(SFE,CFE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
+
+ 1 CONTINUE
+ X = DT_RNDM(SFE)
+ Y = DT_RNDM(X)
+ XX = X*X
+ YY = Y*Y
+ XY = XX+YY
+ IF (XY.GT.ONE) GOTO 1
+ CFE = (XX-YY)/XY
+ SFE = TWO*X*Y/XY
+ IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
+ RETURN
+ END
+*
+*===raco===============================================================*
+*
+CDECK ID>, DT_RACO
+ SUBROUTINE DT_RACO(WX,WY,WZ)
+
+************************************************************************
+* Direction cosines of random uniform (isotropic) direction in three *
+* dimensional space *
+* Processed by S. Roesler, 20.11.95 *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
+
+ 10 CONTINUE
+ X = TWO*DT_RNDM(WX)-ONE
+ Y = DT_RNDM(X)
+ X2 = X*X
+ Y2 = Y*Y
+ IF (X2+Y2.GT.ONE) GOTO 10
+
+ CFE = (X2-Y2)/(X2+Y2)
+ SFE = TWO*X*Y/(X2+Y2)
+* z = 1/2 [ 1 + cos (theta) ]
+ Z = DT_RNDM(X)
+* 1/2 sin (theta)
+ WZ = SQRT(Z*(ONE-Z))
+ WX = TWO*WZ*CFE
+ WY = TWO*WZ*SFE
+ WZ = TWO*Z-ONE
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 6) Special functions, algorithms and service routines *
+* *
+************************************************************************
+*
+*===ylamb==============================================================*
+*
+CDECK ID>, DT_YLAMB
+ DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
+
+************************************************************************
+* *
+* auxiliary function for three particle decay mode *
+* (standard LAMBDA**(1/2) function) *
+* *
+* Adopted from an original version written by R. Engel. *
+* This version dated 12.12.94 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ YZ = Y-Z
+ XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
+ IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
+ DT_YLAMB = SQRT(XLAM)
+
+ RETURN
+ END
+*
+*===sort1==============================================================*
+*
+CDECK ID>, DT_SORT
+ SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
+
+************************************************************************
+* This subroutine sorts entries in A in increasing/decreasing order *
+* of A(3,i). *
+* MODE = 1 increasing in A(3,i=1..N) *
+* = 2 decreasing in A(3,i=1..N) *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION A(3,N)
+
+ M = I1
+ 10 CONTINUE
+ M = I1-1
+ IF (M.LE.0) RETURN
+ L = 0
+ DO 20 I=I0,M
+ J = I+1
+ IF (MODE.EQ.1) THEN
+ IF (A(3,I).LE.A(3,J)) GOTO 20
+ ELSE
+ IF (A(3,I).GE.A(3,J)) GOTO 20
+ ENDIF
+ B = A(3,I)
+ C = A(1,I)
+ D = A(2,I)
+ A(3,I) = A(3,J)
+ A(2,I) = A(2,J)
+ A(1,I) = A(1,J)
+ A(3,J) = B
+ A(1,J) = C
+ A(2,J) = D
+ L = 1
+ 20 CONTINUE
+ IF (L.EQ.1) GOTO 10
+
+ RETURN
+ END
+*
+*===sort1==============================================================*
+*
+CDECK ID>, DT_SORT1
+ SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
+
+************************************************************************
+* This subroutine sorts entries in A in increasing/decreasing order *
+* of A(i). *
+* MODE = 1 increasing in A(i=1..N) *
+* = 2 decreasing in A(i=1..N) *
+* This version dated 21.04.95 is revised by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION A(N),IDX(N)
+
+ M = I1
+ 10 CONTINUE
+ M = I1-1
+ IF (M.LE.0) RETURN
+ L = 0
+ DO 20 I=I0,M
+ J = I+1
+ IF (MODE.EQ.1) THEN
+ IF (A(I).LE.A(J)) GOTO 20
+ ELSE
+ IF (A(I).GE.A(J)) GOTO 20
+ ENDIF
+ B = A(I)
+ A(I) = A(J)
+ A(J) = B
+ IX = IDX(I)
+ IDX(I) = IDX(J)
+ IDX(J) = IX
+ L = 1
+ 20 CONTINUE
+ IF (L.EQ.1) GOTO 10
+
+ RETURN
+ END
+*
+*===xtime==============================================================*
+*
+CDECK ID>, DT_XTIME
+ SUBROUTINE DT_XTIME
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER DAT*9,TIM*11
+
+ DAT = ' '
+ TIM = ' '
+C CALL GETDAT(IYEAR,IMONTH,IDAY)
+C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
+
+C CALL DATE(DAT)
+C CALL TIME(TIM)
+C WRITE(LOUT,1000) DAT,TIM
+ 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
+
+ RETURN
+ END
+
+************************************************************************
+* *
+* 7) Random number generator package *
+* *
+* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
+* SERVICE ROUTINES. *
+* THE ALGORITHM IS FROM *
+* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
+* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
+* IMPLEMENTATION BY K. HAHN DEC. 88, *
+* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
+* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
+* THE PERIOD IS ABOUT 2**144, *
+* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
+* THE PACKAGE CONTAINS *
+* FUNCTION DT_RNDM(I) : GENERATOR *
+* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
+* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
+* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
+* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
+*--- *
+* FUNCTION DT_RNDM(I) *
+* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
+* I - DUMMY VARIABLE, NOT USED *
+* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
+* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
+* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
+* NA? MUST BE IN 1..178 AND NOT ALL 1 *
+* 12,34,56 ARE THE STANDARD VALUES *
+* NB1 MUST BE IN 1..168 *
+* 78 IS THE STANDARD VALUE *
+* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
+* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
+* AS AFTER THE LAST DT_RNDMOU CALL ) *
+* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
+* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
+* TAKES SEED FROM GENERATOR *
+* U(97),C,CD,CM,I,J - SEED VALUES *
+* SUBROUTINE DT_RNDMTE(IO) *
+* TEST OF THE GENERATOR *
+* IO - DEFINES OUTPUT *
+* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
+* = 1 OUTPUT INDEPENDEND ON AN ERROR *
+* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
+* SAME STATUS *
+* AS BEFORE CALL OF DT_RNDMTE *
+************************************************************************
+*
+*===rndm===============================================================*
+*
+CDECK ID>, DT_RNDM
+ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* counter of calls to random number generator
+* uncomment if needed
+C COMMON /DTRNCT/ IRNCT0,IRNCT1
+C LOGICAL LFIRST
+C DATA LFIRST /.TRUE./
+
+* counter of calls to random number generator
+* uncomment if needed
+C IF (LFIRST) THEN
+C IRNCT0 = 0
+C IRNCT1 = 0
+C LFIRST = .FALSE.
+C ENDIF
+
+ DT_RNDM = FLRNDM(VDUMMY)
+* counter of calls to random number generator
+* uncomment if needed
+C IRNCT1 = IRNCT1+1
+
+ RETURN
+ END
+*
+*===rndmst=============================================================*
+*
+CDECK ID>, DT_RNDMST
+ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* random number generator
+ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+
+ MA1 = NA1
+ MA2 = NA2
+ MA3 = NA3
+ MB1 = NB1
+ I = 97
+ J = 33
+ DO 20 II2 = 1,97
+ S = 0
+ T = 0.5D0
+ DO 10 II1 = 1,24
+ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
+ MA1 = MA2
+ MA2 = MA3
+ MA3 = MAT
+ MB1 = MOD(53*MB1+1,169)
+ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
+ 10 T = 0.5D0*T
+ 20 U(II2) = S
+ C = 362436.0D0/16777216.0D0
+ CD = 7654321.0D0/16777216.0D0
+ CM = 16777213.0D0/16777216.0D0
+ RETURN
+ END
+*
+*===rndmin=============================================================*
+*
+CDECK ID>, DT_RNDMIN
+ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* random number generator
+ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+
+ DIMENSION UIN(97)
+
+ DO 10 KKK = 1,97
+ 10 U(KKK) = UIN(KKK)
+ C = CIN
+ CD = CDIN
+ CM = CMIN
+ I = IIN
+ J = JIN
+
+ RETURN
+ END
+*
+*===rndmou=============================================================*
+*
+CDECK ID>, DT_RNDMOU
+ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* random number generator
+ COMMON /DTRAND/ U(97),C,CD,CM,I,J
+
+ DIMENSION UOUT(97)
+
+ DO 10 KKK = 1,97
+ 10 UOUT(KKK) = U(KKK)
+ COUT = C
+ CDOUT = CD
+ CMOUT = CM
+ IOUT = I
+ JOUT = J
+
+ RETURN
+ END
+*
+*===rndmte=============================================================*
+*
+CDECK ID>, DT_RNDMTE
+ SUBROUTINE DT_RNDMTE(IO)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION UU(97),U(6),X(6),D(6)
+ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
+ +8354498.D0, 10633180.D0/
+
+ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
+ CALL DT_RNDMST(12,34,56,78)
+ DO 10 II1 = 1,20000
+ 10 XX = DT_RNDM(XX)
+ SD = 0.0D0
+ DO 20 II2 = 1,6
+ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
+ D(II2) = X(II2)-U(II2)
+ 20 SD = SD+D(II2)
+ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
+**sr 24.01.95
+C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
+ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
+C WRITE(6,1000)
+ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
+ & ' passed')
+ ENDIF
+**
+ RETURN
+ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
+ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
+ &1,F20.1,F15.3,/), ' === END OF TEST ;',
+ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
+ END
+*
+*
+*===title==============================================================*
+*
+CDECK ID>, DT_TITLE
+ SUBROUTINE DT_TITLE
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*6 CVERSI
+ CHARACTER*11 CCHANG
+ DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
+
+ CALL DT_XTIME
+ WRITE(LOUT,1000) CVERSI,CCHANG
+ 1000 FORMAT(1X,'+-------------------------------------------------',
+ & '----------------------+',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
+ & 1X,'|',21X,'Ralph Engel (Bartol Res. Inst.)',14X,'|',/,
+ & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
+ & 17X,'|',/,
+ & 1X,'|',71X,'|',/,
+ & 1X,'+-------------------------------------------------',
+ & '----------------------+',/,
+ & 1X,'| Please send suggestions, bug reports, etc. to: ',
+ & 'Stefan.Roesler@cern.ch |',/,
+ & 1X,'+-------------------------------------------------',
+ & '----------------------+',/)
+
+ RETURN
+ END
+*
+*===evtini=============================================================*
+*
+CDECK ID>, DT_EVTINI
+ SUBROUTINE DT_EVTINI
+
+************************************************************************
+* Initialization of DTEVT1. *
+* This version dated 15.01.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* initialization of DTEVT1/DTEVT2
+ NEND = NHKK
+ IF (NEVENT.EQ.1) NEND = NMXHKK
+ NHKK = 0
+ NEVHKK = NEVENT
+ DO 1 I=1,NEND
+ ISTHKK(I) = 0
+ IDHKK(I) = 0
+ JMOHKK(1,I) = 0
+ JMOHKK(2,I) = 0
+ JDAHKK(1,I) = 0
+ JDAHKK(2,I) = 0
+ IDRES(I) = 0
+ IDXRES(I) = 0
+ NOBAM(I) = 0
+ IDCH(I) = 0
+ IHIST(1,I) = 0
+ IHIST(2,I) = 0
+ DO 2 J=1,4
+ PHKK(J,I) = 0.0D0
+ VHKK(J,I) = 0.0D0
+ WHKK(J,I) = 0.0D0
+ 2 CONTINUE
+ PHKK(5,I) = 0.0D0
+ 1 CONTINUE
+ DO 3 I=1,10
+ NPOINT(I) = 0
+ 3 CONTINUE
+ CALL DT_CHASTA(-1)
+
+C* initialization of DTLTRA
+C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
+
+ RETURN
+ END
+*
+*===statis=============================================================*
+*
+CDECK ID>, DT_STATIS
+ SUBROUTINE DT_STATIS(MODE)
+
+************************************************************************
+* Initialization and output of run-statistics. *
+* MODE = 1 initialization *
+* = 2 output *
+* This version dated 23.01.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY3=1.0D-3)
+
+* 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
+* central particle production, impact parameter biasing
+ COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+* 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
+* nucleon-nucleon event-generator
+ CHARACTER*8 CMODEL
+ LOGICAL LPHOIN
+ COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* 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
+
+ DIMENSION PP(4),PT(4)
+
+ GOTO (1,2) MODE
+
+* initialization
+ 1 CONTINUE
+
+* initialize statistics counter
+ ICREQU = 0
+ ICSAMP = 0
+ ICCPRO = 0
+ ICDPR = 0
+ ICDTA = 0
+ ICRJSS = 0
+ ICVV2S = 0
+ DO 10 I=1,9
+ ICRES(I) = 0
+ ICCHAI(1,I) = 0
+ ICCHAI(2,I) = 0
+ 10 CONTINUE
+* initialize rejection counter
+ IRPT = 0
+ IRHHA = 0
+ LOMRES = 0
+ LOBRES = 0
+ IRFRAG = 0
+ IREVT = 0
+ IRRES(1) = 0
+ IRRES(2) = 0
+ IRCHKI(1) = 0
+ IRCHKI(2) = 0
+ IRCRON(1) = 0
+ IRCRON(2) = 0
+ IRCRON(3) = 0
+ IRDIFF(1) = 0
+ IRDIFF(2) = 0
+ IRINC = 0
+ DO 11 I=1,5
+ ICDIFF(I) = 0
+ 11 CONTINUE
+ DO 12 I=1,8
+ DO 13 J=0,30
+ ICEVTG(I,J) = 0
+ 13 CONTINUE
+ 12 CONTINUE
+
+ RETURN
+
+* output
+ 2 CONTINUE
+
+* statistics counter
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
+ & 28X,'---------------------')
+ WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
+ 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
+ & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
+ & 'event',11X,F9.1)
+ IF (ICDIFF(1).NE.0) THEN
+ WRITE(LOUT,1009) ICDIFF
+ 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
+ & 'low mass high mass',/,24X,'single diffraction',
+ & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
+ ENDIF
+ IF (ICENTR.GT.0) THEN
+ WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
+ & DBLE(ICSAMP)/DBLE(ICCPRO)
+ 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
+ & ' of sampled Glauber-events per event',9X,F9.1,/,
+ & 2X,'fraction of production cross section',21X,F10.6)
+ ENDIF
+ WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
+ & DBLE(ICDTA)/DBLE(ICSAMP)
+ 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
+ & ' nucleons after x-sampling',2(4X,F6.2))
+
+ IF (MCGENE.EQ.1) THEN
+ WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
+ 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
+ & ' event',3X,F9.1)
+ IF (ISICHA.EQ.1) THEN
+ WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
+ 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
+ & 'of single chains per event',13X,F9.1)
+ ENDIF
+ WRITE(LOUT,1006)
+ 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
+ & 23X,'mean number of chains mean number of chains',/,
+ & 23X,'sampled hadronized having mass of a reso.')
+ WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
+ & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
+ & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
+ & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
+ 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
+ & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
+ WRITE(LOUT,1008)
+ & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
+ & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
+ & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
+ & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
+ & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
+ & DBLE(IRHHA)/DBLE(ICREQU),
+ & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
+ & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
+ 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
+ & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
+ & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
+ & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
+ & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
+ & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
+ & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
+ & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
+ & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
+ & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
+ & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
+ & F7.2,/,1X,'Total no. of rej.',
+ & ' in chain-systems treatment (GETCSY)',/,43X,
+ & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
+ & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
+ & 1X,'Total no. of rej. in DPM-treatment of one event',
+ & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
+ & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
+ & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
+ & 'IREXCI(3) = ',I5,/)
+ ELSEIF (MCGENE.EQ.2) THEN
+C *** Commented by Chiara
+C WRITE(LOUT,1010) ELOJET
+C 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
+C & F4.1,' GeV')
+C WRITE(LOUT,1011)
+C 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
+C & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
+C & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
+C WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
+C & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
+C & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
+C & ((ICEVTG(I,J),I=1,8),J=3,7),
+C & ((ICEVTG(I,J),I=1,8),J=19,21),
+C & (ICEVTG(I,8),I=1,8),
+C & ((ICEVTG(I,J),I=1,8),J=22,24),
+C & (ICEVTG(I,9),I=1,8),
+C & ((ICEVTG(I,J),I=1,8),J=25,28),
+C & ((ICEVTG(I,J),I=1,8),J=10,18)
+C 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
+C & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
+C & ' no-dif.',8I8,/,
+C & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
+C & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
+C & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
+C & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
+C & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
+C & ' hi-lo ',8I8,/,
+C & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
+C & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
+C & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
+C WRITE(LOUT,1013)
+C 1013 FORMAT(/,1X,'2. chain system statistics -',
+C & ' mean numbers per evt:',/,30X,'---------------------',
+C & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
+C WRITE(LOUT,1014)
+C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
+C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
+C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
+C 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
+C & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
+C & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
+C & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
+C & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
+C & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
+C & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
+C & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
+C & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
+C & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
+C WRITE(LOUT,1015)
+C 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
+C WRITE(LOUT,1016)
+C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
+C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
+C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
+C 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
+C & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
+C & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
+C & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
+C & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
+C & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
+C & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
+C & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
+C & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
+C & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
+
+ ENDIF
+ CALL DT_CHASTA(1)
+
+ IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
+ & .OR.(PDBSEA(3).GT.0.0D0)) THEN
+ WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
+ & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
+ & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
+ WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
+ & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
+ & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
+ WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
+ & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
+ & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
+ WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
+ & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
+ & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
+ WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
+ & DBRKA(3,1),DBRKA(3,2),
+ & DBRKA(3,3),DBRKA(3,4)
+ WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
+ & DBRKR(3,1),DBRKR(3,2),
+ & DBRKR(3,3),DBRKR(3,4)
+ WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
+ & DBRKA(3,5),DBRKA(3,6),
+ & DBRKA(3,7),DBRKA(3,8)
+ WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
+ & DBRKR(3,5),DBRKR(3,6),
+ & DBRKR(3,7),DBRKR(3,8)
+ ENDIF
+
+ FAC = 1.0D0
+ IF (MCGENE.EQ.2) THEN
+
+C CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
+
+ ENDIF
+
+ CALL DT_XTIME
+
+ RETURN
+ END
+*
+*===evtout=============================================================*
+*
+CDECK ID>, DT_EVTOUT
+ SUBROUTINE DT_EVTOUT(MODE)
+
+************************************************************************
+* MODE = 1 plot content of complete DTEVT1 to out. unit *
+* 3 plot entries of extended DTEVT1 (DTEVT2) *
+* 4 plot entries of DTEVT1 and DTEVT2 *
+* This version dated 11.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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)
+
+ DIMENSION IRANGE(NMXHKK)
+
+ IF (MODE.EQ.2) RETURN
+
+ CALL DT_EVTPLO(IRANGE,MODE)
+
+ RETURN
+ END
+*
+*===evtplo=============================================================*
+*
+CDECK ID>, DT_EVTPLO
+ SUBROUTINE DT_EVTPLO(IRANGE,MODE)
+
+************************************************************************
+* MODE = 1 plot content of complete DTEVT1 to out. unit *
+* 2 plot entries of DTEVT1 given by IRANGE *
+* 3 plot entries of extended DTEVT1 (DTEVT2) *
+* 4 plot entries of DTEVT1 and DTEVT2 *
+* 5 plot rejection counter *
+* This version dated 11.12.94 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*16 CHAU
+
+* 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
+
+ DIMENSION IRANGE(NMXHKK)
+
+ IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
+ WRITE(LOUT,1000)
+ 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
+ & 15X,' --------------------------',/,/,
+ & ' ST ID M1 M2 D1 D2 PX PY',
+ & ' PZ E M',/)
+ DO 1 I=1,NHKK
+ WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PHKK(5,I)
+C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+C & PHKK(3,I),PHKK(4,I)
+C WRITE(LOUT,'(4E15.4)')
+C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
+ 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
+ 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
+ 1 CONTINUE
+ WRITE(LOUT,*)
+C DO 4 I=1,NHKK
+C WRITE(LOUT,1006) I,ISTHKK(I),
+C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
+C & WHKK(2,I),WHKK(3,I)
+C1006 FORMAT(1X,I4,I6,6E10.3)
+C 4 CONTINUE
+ ENDIF
+
+ IF (MODE.EQ.2) THEN
+ WRITE(LOUT,1000)
+ NC = 0
+ 2 CONTINUE
+ NC = NC+1
+ IF (IRANGE(NC).EQ.-100) GOTO 9999
+ I = IRANGE(NC)
+ WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+ & PHKK(5,I)
+ GOTO 2
+ ENDIF
+
+ IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
+ WRITE(LOUT,1002)
+ 1002 FORMAT(/,1X,'EVTPLO:',14X,
+ & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
+ & 15X,' -----------------------------------',/,/,
+ & ' ST ID M1 M2 D1 D2 IDR IDXR',
+ & ' NOBAM IDCH M',/)
+ DO 3 I=1,NHKK
+C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
+ KF = IDHKK(I)
+ IDCHK = KF/10000
+ IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
+ & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
+
+ CALL PYNAME(KF,CHAU)
+
+ WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
+ & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
+ & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
+ & PHKK(5,I),CHAU
+ 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
+C ENDIF
+ 3 CONTINUE
+ ENDIF
+
+ IF (MODE.EQ.5) THEN
+ WRITE(LOUT,1004)
+ 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
+ & 15X,' --------------------------',/)
+ WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
+ & IRSEA,IRCRON
+ 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
+ & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
+ & 1X,'IREMC = ',10I5,/,
+ & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
+ ENDIF
+
+ 9999 RETURN
+ END
+*
+*===evtput=============================================================*
+*
+CDECK ID>, DT_EVTPUT
+ SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
+ & TINY2=1.0D-2,SQTINF=1.0D+15,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)
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+* 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)
+
+C IF (MODE.GT.100) THEN
+C WRITE(LOUT,'(1X,A,I5,A,I5)')
+C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
+C NHKK = NHKK-MODE+100
+C RETURN
+C ENDIF
+ MO1 = M1
+ MO2 = M2
+ NHKK = NHKK+1
+
+ IF (NHKK.GT.NMXHKK) THEN
+ WRITE(LOUT,1000) NHKK
+ 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
+ & '! program execution stopped..')
+ STOP
+ ENDIF
+ IF (M1.LT.0) MO1 = NHKK+M1
+ IF (M2.LT.0) MO2 = NHKK+M2
+ ISTHKK(NHKK) = IST
+ IDHKK(NHKK) = ID
+ JMOHKK(1,NHKK) = MO1
+ JMOHKK(2,NHKK) = MO2
+ JDAHKK(1,NHKK) = 0
+ JDAHKK(2,NHKK) = 0
+ IDRES(NHKK) = IDR
+ IDXRES(NHKK) = IDXR
+ IDCH(NHKK) = IDC
+** here we need to do something..
+ IF (ID.EQ.88888) THEN
+ IDMO1 = ABS(IDHKK(MO1))
+ IDMO2 = ABS(IDHKK(MO2))
+ IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
+ IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
+ IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
+ IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
+ ELSE
+ NOBAM(NHKK) = 0
+ ENDIF
+ IDBAM(NHKK) = IDT_ICIHAD(ID)
+ IF (MO1.GT.0) THEN
+ IF (JDAHKK(1,MO1).NE.0) THEN
+ JDAHKK(2,MO1) = NHKK
+ ELSE
+ JDAHKK(1,MO1) = NHKK
+ ENDIF
+ ENDIF
+ IF (MO2.GT.0) THEN
+ IF (JDAHKK(1,MO2).NE.0) THEN
+ JDAHKK(2,MO2) = NHKK
+ ELSE
+ JDAHKK(1,MO2) = NHKK
+ ENDIF
+ ENDIF
+C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
+C PTOT = SQRT(PX**2+PY**2+PZ**2)
+C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
+C AMRQ = AAM(IDBAM(NHKK))
+C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
+C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
+C & (PTOT.GT.ZERO)) THEN
+C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
+CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
+C E = E+DELTA
+C PTOT1 = PTOT-DELTA
+C PX = PX*PTOT1/PTOT
+C PY = PY*PTOT1/PTOT
+C PZ = PZ*PTOT1/PTOT
+C ENDIF
+C ENDIF
+ PHKK(1,NHKK) = PX
+ PHKK(2,NHKK) = PY
+ PHKK(3,NHKK) = PZ
+ PHKK(4,NHKK) = E
+ PTOT = SQRT( PX**2+PY**2+PZ**2 )
+ IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
+ PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
+ PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
+ ELSE
+ PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
+C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
+C & WRITE(LOUT,'(1X,A,G10.3)')
+C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
+ PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
+ ENDIF
+ IDCHK = ID/10000
+ IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
+* special treatment for chains:
+* z coordinate of chain in Lab = pos. of target nucleon
+* time of chain-creation in Lab = time of passage of projectile
+* nucleus at pos. of taget nucleus
+C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
+C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
+ VHKK(1,NHKK) = VHKK(1,MO2)
+ VHKK(2,NHKK) = VHKK(2,MO2)
+ VHKK(3,NHKK) = VHKK(3,MO2)
+ VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
+C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
+C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
+ WHKK(1,NHKK) = WHKK(1,MO1)
+ WHKK(2,NHKK) = WHKK(2,MO1)
+ WHKK(3,NHKK) = WHKK(3,MO1)
+ WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
+ ELSE
+ IF (MO1.GT.0) THEN
+ DO 1 I=1,4
+ VHKK(I,NHKK) = VHKK(I,MO1)
+ WHKK(I,NHKK) = WHKK(I,MO1)
+ 1 CONTINUE
+ ELSE
+ DO 2 I=1,4
+ VHKK(I,NHKK) = ZERO
+ WHKK(I,NHKK) = ZERO
+ 2 CONTINUE
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+*
+*===chasta=============================================================*
+*
+CDECK ID>, DT_CHASTA
+ SUBROUTINE DT_CHASTA(MODE)
+
+************************************************************************
+* This subroutine performs CHAin STAtistics and checks sequence of *
+* partons in dtevt1 and sorts them with projectile partons coming *
+* first if necessary. *
+* *
+* This version dated 8.5.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*5 CCHTYP
+
+* 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)
+* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
+ PARAMETER (MAXCHN=10000)
+ COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
+
+ DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
+ & CCHTYP(9),ICHSTA(10),ITOT(10)
+ DATA ICHCFG /1800*0/
+ DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
+ DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
+ DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
+ DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
+ DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
+ DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
+ DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
+ & 'ad aq',' d ad','ad d ',' g g '/
+*
+* initialization
+*
+ IF (MODE.EQ.-1) THEN
+ NCHAIN = 0
+*
+* loop over DTEVT1 and analyse chain configurations
+*
+ ELSEIF (MODE.EQ.0) THEN
+ DO 21 IDX=NPOINT(3),NHKK
+ IDCHK = IDHKK(IDX)/10000
+ IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
+ & (IDHKK(IDX).NE.80000).AND.
+ & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
+ IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
+ WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
+ & ' at entry ',IDX
+ GOTO 21
+ ENDIF
+*
+ IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
+ IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
+ IMO1 = IST1/10
+ IMO1 = IST1-10*IMO1
+ IMO2 = IST2/10
+ IMO2 = IST2-10*IMO2
+* swop parton entries if necessary since we need projectile partons
+* to come first in the common
+ IF (IMO1.GT.IMO2) THEN
+ NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
+ DO 22 K=1,NPTN/2
+ I0 = JMOHKK(1,IDX)-1+K
+ I1 = JMOHKK(2,IDX)+1-K
+ ITMP = ISTHKK(I0)
+ ISTHKK(I0) = ISTHKK(I1)
+ ISTHKK(I1) = ITMP
+ ITMP = IDHKK(I0)
+ IDHKK(I0) = IDHKK(I1)
+ IDHKK(I1) = ITMP
+ IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
+ & JDAHKK(1,JMOHKK(1,I0)) = I1
+ IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
+ & JDAHKK(2,JMOHKK(1,I0)) = I1
+ IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
+ & JDAHKK(1,JMOHKK(2,I0)) = I1
+ IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
+ & JDAHKK(2,JMOHKK(2,I0)) = I1
+ IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
+ & JDAHKK(1,JMOHKK(1,I1)) = I0
+ IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
+ & JDAHKK(2,JMOHKK(1,I1)) = I0
+ IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
+ & JDAHKK(1,JMOHKK(2,I1)) = I0
+ IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
+ & JDAHKK(2,JMOHKK(2,I1)) = I0
+ ITMP = JMOHKK(1,I0)
+ JMOHKK(1,I0) = JMOHKK(1,I1)
+ JMOHKK(1,I1) = ITMP
+ ITMP = JMOHKK(2,I0)
+ JMOHKK(2,I0) = JMOHKK(2,I1)
+ JMOHKK(2,I1) = ITMP
+ ITMP = JDAHKK(1,I0)
+ JDAHKK(1,I0) = JDAHKK(1,I1)
+ JDAHKK(1,I1) = ITMP
+ ITMP = JDAHKK(2,I0)
+ JDAHKK(2,I0) = JDAHKK(2,I1)
+ JDAHKK(2,I1) = ITMP
+ DO 23 J=1,4
+ RTMP1 = PHKK(J,I0)
+ RTMP2 = VHKK(J,I0)
+ RTMP3 = WHKK(J,I0)
+ PHKK(J,I0) = PHKK(J,I1)
+ VHKK(J,I0) = VHKK(J,I1)
+ WHKK(J,I0) = WHKK(J,I1)
+ PHKK(J,I1) = RTMP1
+ VHKK(J,I1) = RTMP2
+ WHKK(J,I1) = RTMP3
+ 23 CONTINUE
+ RTMP1 = PHKK(5,I0)
+ PHKK(5,I0) = PHKK(5,I1)
+ PHKK(5,I1) = RTMP1
+ ITMP = IDRES(I0)
+ IDRES(I0) = IDRES(I1)
+ IDRES(I1) = ITMP
+ ITMP = IDXRES(I0)
+ IDXRES(I0) = IDXRES(I1)
+ IDXRES(I1) = ITMP
+ ITMP = NOBAM(I0)
+ NOBAM(I0) = NOBAM(I1)
+ NOBAM(I1) = ITMP
+ ITMP = IDBAM(I0)
+ IDBAM(I0) = IDBAM(I1)
+ IDBAM(I1) = ITMP
+ ITMP = IDCH(I0)
+ IDCH(I0) = IDCH(I1)
+ IDCH(I1) = ITMP
+ ITMP = IHIST(1,I0)
+ IHIST(1,I0) = IHIST(1,I1)
+ IHIST(1,I1) = ITMP
+ ITMP = IHIST(2,I0)
+ IHIST(2,I0) = IHIST(2,I1)
+ IHIST(2,I1) = ITMP
+ 22 CONTINUE
+ ENDIF
+ IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
+ IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
+*
+* parton 1 (projectile side)
+ IF (IST1.EQ.21) THEN
+ IDX1 = 1
+ ELSEIF (IST1.EQ.22) THEN
+ IDX1 = 2
+ ELSEIF (IST1.EQ.31) THEN
+ IDX1 = 3
+ ELSEIF (IST1.EQ.32) THEN
+ IDX1 = 4
+ ELSEIF (IST1.EQ.41) THEN
+ IDX1 = 5
+ ELSEIF (IST1.EQ.42) THEN
+ IDX1 = 6
+ ELSEIF (IST1.EQ.51) THEN
+ IDX1 = 7
+ ELSEIF (IST1.EQ.52) THEN
+ IDX1 = 8
+ ELSEIF (IST1.EQ.61) THEN
+ IDX1 = 9
+ ELSEIF (IST1.EQ.62) THEN
+ IDX1 = 10
+ ELSE
+c WRITE(LOUT,*)
+c & ' CHASTA: unknown parton status flag (',
+c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+ ID = IDHKK(JMOHKK(1,IDX))
+ IF (ABS(ID).LE.4) THEN
+ IF (ID.GT.0) THEN
+ ITYP1 = 1
+ ELSE
+ ITYP1 = 2
+ ENDIF
+ ELSEIF (ABS(ID).GE.1000) THEN
+ IF (ID.GT.0) THEN
+ ITYP1 = 3
+ ELSE
+ ITYP1 = 4
+ ENDIF
+ ELSEIF (ID.EQ.21) THEN
+ ITYP1 = 5
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent parton identity (',
+ & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+*
+* parton 2 (target side)
+ IF (IST2.EQ.21) THEN
+ IDX2 = 1
+ ELSEIF (IST2.EQ.22) THEN
+ IDX2 = 2
+ ELSEIF (IST2.EQ.31) THEN
+ IDX2 = 3
+ ELSEIF (IST2.EQ.32) THEN
+ IDX2 = 4
+ ELSEIF (IST2.EQ.41) THEN
+ IDX2 = 5
+ ELSEIF (IST2.EQ.42) THEN
+ IDX2 = 6
+ ELSEIF (IST2.EQ.51) THEN
+ IDX2 = 7
+ ELSEIF (IST2.EQ.52) THEN
+ IDX2 = 8
+ ELSEIF (IST2.EQ.61) THEN
+ IDX2 = 9
+ ELSEIF (IST2.EQ.62) THEN
+ IDX2 = 10
+ ELSE
+c WRITE(LOUT,*)
+c & ' CHASTA: unknown parton status flag (',
+c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+ ID = IDHKK(JMOHKK(2,IDX))
+ IF (ABS(ID).LE.4) THEN
+ IF (ID.GT.0) THEN
+ ITYP2 = 1
+ ELSE
+ ITYP2 = 2
+ ENDIF
+ ELSEIF (ABS(ID).GE.1000) THEN
+ IF (ID.GT.0) THEN
+ ITYP2 = 3
+ ELSE
+ ITYP2 = 4
+ ENDIF
+ ELSEIF (ID.EQ.21) THEN
+ ITYP2 = 5
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent parton identity (',
+ & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
+ GOTO 21
+ ENDIF
+*
+* fill counter
+ ITYPE = ICHTYP(ITYP1,ITYP2)
+ IF (ITYPE.NE.0) THEN
+ ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
+ NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
+ ICHCFG(IDX1,IDX2,ITYPE,2) =
+ & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
+
+ NCHAIN = NCHAIN+1
+ IF (NCHAIN.GT.MAXCHN) THEN
+ WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
+ & NCHAIN,MAXCHN
+ STOP
+ ENDIF
+ IDXCHN(1,NCHAIN) = IDX
+ IDXCHN(2,NCHAIN) = ITYPE
+ ELSE
+ WRITE(LOUT,*)
+ & ' CHASTA: inconsistent chain at entry ',IDX
+ GOTO 21
+ ENDIF
+ ENDIF
+ 21 CONTINUE
+*
+* write statistics to output unit
+*
+ ELSEIF (MODE.EQ.1) THEN
+C *** Commented by Chiara
+C WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
+ DO 31 I=1,10
+C WRITE(LOUT,'(/,2A)')
+C & ' -----------------------------------------',
+C & '------------------------------------'
+C WRITE(LOUT,'(2A)')
+C & ' p\\t 21 22 31 32 41',
+C & ' 42 51 52 61 62'
+C WRITE(LOUT,'(2A)')
+C & ' -----------------------------------------',
+C & '------------------------------------'
+ DO 32 J=1,10
+ ITOT(J) = 0
+ DO 33 K=1,9
+ ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
+ 33 CONTINUE
+ 32 CONTINUE
+C *** Commented by Chiara
+c WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
+ DO 34 K=1,9
+ ISUM = 0
+ DO 35 J=1,10
+ ISUM = ISUM+ICHCFG(I,J,K,1)
+ 35 CONTINUE
+C *** Commented by Chiara
+C IF (ISUM.GT.0)
+C & WRITE(LOUT,'(1X,A5,2X,10I7)')
+C & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
+ 34 CONTINUE
+C WRITE(LOUT,'(2A)')
+C & ' -----------------------------------------',
+C & '-------------------------------'
+ 31 CONTINUE
+*
+ ELSE
+ WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
+ STOP
+ ENDIF
+
+ RETURN
+ END
+*
+*===pohist=============================================================*
+*
+
+CDECK ID>, PHO_PHIST
+ SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+
+ ILAB = 0
+ IF (IMODE.EQ.10) THEN
+ IMODE = 1
+ ILAB = 1
+ ENDIF
+ IF (ABS(IMODE).LT.1000) THEN
+* PHOJET-statistics
+C CALL POHISX(IMODE,WEIGHT)
+ IF (IMODE.EQ.-1) THEN
+ MODE = 1
+ XSTOT(1,1,1) = WEIGHT
+ ENDIF
+ IF (IMODE.EQ. 1) MODE = 2
+ IF (IMODE.EQ.-2) MODE = 3
+ IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
+C IF (MODE.EQ.3) WRITE(LOUT,*)
+C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
+ CALL DT_HISTOG(MODE)
+ CALL DT_USRHIS(MODE)
+ ELSE
+* DTUNUC-statistics
+ MODE = IMODE/1000
+C IF (MODE.EQ.3) WRITE(LOUT,*)
+C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
+ CALL DT_HISTOG(MODE)
+ CALL DT_USRHIS(MODE)
+ ENDIF
+
+ RETURN
+ END
+*
+*===swppho=============================================================*
+*
+CDECK ID>, DT_SWPPHO
+ SUBROUTINE DT_SWPPHO(ILAB)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+
+ 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
+* properties of photon/lepton projectiles
+ COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+
+**PHOJET105a
+C PARAMETER (NMXHEP=2000)
+C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
+C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C COMMON /PLASAV/ PLAB
+**PHOJET110
+
+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 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)
+**
+ DATA ICOUNT/0/
+
+ DATA LSTART /.TRUE./
+
+C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
+ IF ((IFRAME.EQ.1).AND.LSTART) THEN
+ UMO = ECM
+ ELA = ZERO
+ PLA = ZERO
+ IDP = IDT_ICIHAD(IFPAP(1))
+ IDT = IDT_ICIHAD(IFPAP(2))
+ VIRT = PVIRT(1)
+ CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
+ PLAB = PLA
+ LSTART = .FALSE.
+ ENDIF
+
+ NHKK = 0
+ ICOUNT = ICOUNT+1
+C NEVHKK = NEVHEP
+ NEVHKK = ICOUNT
+ IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
+ DO 1 I=3,NHEP
+ IF (ISTHEP(I).EQ.1) THEN
+ NHKK = NHKK+1
+ ISTHKK(NHKK) = 1
+ IDHKK(NHKK) = IDHEP(I)
+ JMOHKK(1,NHKK) = 0
+ JMOHKK(2,NHKK) = 0
+ JDAHKK(1,NHKK) = 0
+ JDAHKK(2,NHKK) = 0
+ DO 2 K=1,4
+ PHKK(K,NHKK) = PHEP(K,I)
+ VHKK(K,NHKK) = ZERO
+ WHKK(K,NHKK) = ZERO
+ 2 CONTINUE
+ IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
+ & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
+ & PHKK(3,NHKK),PHKK(4,NHKK),-3)
+ PHKK(5,NHKK) = PHEP(5,I)
+ IDRES(NHKK) = 0
+ IDXRES(NHKK) = 0
+ NOBAM(NHKK) = 0
+ IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
+ IDCH(NHKK) = 0
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===histog=============================================================*
+*
+CDECK ID>, DT_HISTOG
+ SUBROUTINE DT_HISTOG(MODE)
+
+************************************************************************
+* This version dated 25.03.96 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LFSP,LRNL
+
+* 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)
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+* flags for activated histograms
+ COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+
+ IEVHKK = NEVHKK
+ GOTO (1,2,3) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+ ICEVT = 0
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ ICEVT = ICEVT+1
+
+ DO 20 I=1,NHKK
+ CALL DT_SWPFSP(I,LFSP,LRNL)
+ IF (LFSP) THEN
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
+ ENDIF
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
+ 20 CONTINUE
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
+
+ RETURN
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+ IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
+ IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
+
+ RETURN
+ END
+*
+*===swpfsp=============================================================*
+*
+CDECK ID>, DT_SWPFSP
+ SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
+ PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
+ & PI =TWOPI/TWO,
+ & BOG =TWOPI/360.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)
+* 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
+* 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
+
+ INCLUDE './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(PAREVT)'
+
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+
+ LOGICAL LFSP,LRNL
+
+ LFSP = .FALSE.
+ LRNL = .FALSE.
+ ISTRNL = 1000
+ MULDEF = 1
+ IF (LEVPRT) ISTRNL = 1001
+
+ IF (ABS(ISTHKK(IDX)).EQ.1) THEN
+ IST = ISTHKK(IDX)
+ IDPDG = IDHKK(IDX)
+ LFRAG = .FALSE.
+ IF (IDHKK(IDX).LT.80000) THEN
+ IDBJT = IDBAM(IDX)
+ IBARY = IIBAR(IDBJT)
+ ICHAR = IICH(IDBJT)
+ AMASS = AAM(IDBJT)
+ ELSEIF (IDHKK(IDX).EQ.80000) THEN
+ IDBJT = 0
+ IBARY = IDRES(IDX)
+ ICHAR = IDXRES(IDX)
+ AMASS = PHKK(5,IDX)
+ INUT = IBARY-ICHAR
+ IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
+ IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
+ IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
+ IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
+ IF (IDBJT.EQ.0) LFRAG = .TRUE.
+ ELSE
+ GOTO 9999
+ ENDIF
+ PE = PHKK(4,IDX)
+ PX = PHKK(1,IDX)
+ PY = PHKK(2,IDX)
+ PZ = PHKK(3,IDX)
+ PT2 = PX**2+PY**2
+ PT = SQRT(PT2)
+ PTOT = SQRT(PT2+PZ**2)
+ SINTHE = PT/MAX(PTOT,TINY14)
+ COSTHE = PZ/MAX(PTOT,TINY14)
+ IF (COSTHE.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTHE.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTHE)
+ ENDIF
+ EKIN = PE-AMASS
+**sr 15.4.96 new E_t-definition
+ IF (IBARY.GT.0) THEN
+ ET = EKIN*SINTHE
+ ELSEIF (IBARY.LT.0) THEN
+ ET = (EKIN+TWO*AMASS)*SINTHE
+ ELSE
+ ET = PE*SINTHE
+ ENDIF
+**
+ XLAB = PZ/MAX(PPROJ,TINY14)
+C XLAB = PE/MAX(EPROJ,TINY14)
+ BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
+ & *(ONE+AMASS/MAX(PE,TINY14)) ))
+ PPLUS = PE+PZ
+ PMINUS = PE-PZ
+ IF (PMINUS.GT.TINY14) THEN
+ YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
+ ELSE
+ YY = 100.0D0
+ ENDIF
+ IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
+ ETA = -LOG(TAN(THETA/TWO))
+ ELSE
+ ETA = 100.0D0
+ ENDIF
+ IF (IFRAME.EQ.1) THEN
+ CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
+ PPLUS = EECMS+PZCMS
+ PMINUS = EECMS-PZCMS
+ IF ((PPLUS*PMINUS).GT.TINY14) THEN
+ YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
+ ELSE
+ YYCMS = 100.0D0
+ ENDIF
+ PTOTCM = SQRT(PT2+PZCMS**2)
+ COSTH = PZCMS/MAX(PTOTCM,TINY14)
+ IF (COSTH.GT.ONE) THEN
+ THECMS = ZERO
+ ELSEIF (COSTH.LT.-ONE) THEN
+ THECMS = TWOPI/2.0D0
+ ELSE
+ THECMS = ACOS(COSTH)
+ ENDIF
+ IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
+ ETACMS = -LOG(TAN(THECMS/TWO))
+ ELSE
+ ETACMS = 100.0D0
+ ENDIF
+ XF = PZCMS/MAX(PPCM,TINY14)
+ THECMS = THECMS/BOG
+ ELSE
+ PZCMS = PZ
+ EECMS = PE
+ YYCMS = YY
+ ETACMS = ETA
+ XF = XLAB
+ THECMS = THETA/BOG
+ ENDIF
+ THETA = THETA/BOG
+
+* set flag for "grey/black"
+ LGREY = .FALSE.
+ LBLACK = .FALSE.
+ EK = EKIN
+ IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
+ IF (MULDEF.EQ.1) THEN
+* EMU01-Def.
+ IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
+ & (EK.LE.375.0D-3) ).OR.
+ & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
+ & (EK.LE. 56.0D-3) ).OR.
+ & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
+ & (EK.LE. 56.0D-3) ).OR.
+ & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
+ & (EK.LE.198.0D-3) ).OR.
+ & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
+ & (EK.LE.198.0D-3) ).OR.
+ & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
+ & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
+ & (IDBJT.NE.16).AND.
+ & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
+ & LGREY = .TRUE.
+ IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
+ & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
+ & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
+ & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
+ & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
+ & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
+ & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
+ & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
+ & LBLACK = .TRUE.
+ ELSE
+* common Def.
+ IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
+ IF (BETA.LE.0.23D0) LBLACK=.TRUE.
+ ENDIF
+ LFSP = .TRUE.
+ ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
+ IST = ISTHKK(IDX)
+ IDPDG = IDHKK(IDX)
+ LFRAG = .TRUE.
+ IDBJT = 0
+ IBARY = IDRES(IDX)
+ ICHAR = IDXRES(IDX)
+ AMASS = PHKK(5,IDX)
+ PE = PHKK(4,IDX)
+ PX = PHKK(1,IDX)
+ PY = PHKK(2,IDX)
+ PZ = PHKK(3,IDX)
+ PT2 = PX**2+PY**2
+ PT = SQRT(PT2)
+ PTOT = SQRT(PT2+PZ**2)
+ SINTHE = PT/MAX(PTOT,TINY14)
+ COSTHE = PZ/MAX(PTOT,TINY14)
+ IF (COSTHE.GT.ONE) THEN
+ THETA = ZERO
+ ELSEIF (COSTHE.LT.-ONE) THEN
+ THETA = TWOPI/2.0D0
+ ELSE
+ THETA = ACOS(COSTHE)
+ ENDIF
+ EKIN = PE-AMASS
+**sr 15.4.96 new E_t-definition
+C ET = PE*SINTHE
+ ET = EKIN*SINTHE
+**
+ IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
+ ETA = -LOG(TAN(THETA/TWO))
+ ELSE
+ ETA = 100.0D0
+ ENDIF
+ THETA = THETA/BOG
+ LRNL = .TRUE.
+ ENDIF
+
+ 9999 CONTINUE
+ RETURN
+ END
+*
+*===himult=============================================================*
+*
+CDECK ID>, DT_HIMULT
+ SUBROUTINE DT_HIMULT(MODE)
+
+************************************************************************
+* Tables of average energies/multiplicities. *
+* This version dated 30.08.2000 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,TINY14=1.0D-14)
+
+ PARAMETER (SWMEXP=1.7D0)
+
+ CHARACTER*8 ANAMEH(4)
+
+* 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)
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+* Lorentz-parameters of the current interaction
+ COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+ & UMO,PPCM,EPROJ,PPROJ
+
+ PARAMETER (NOPART=210)
+ DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
+ & AVPT(4,NOPART),IAVPT(4,NOPART)
+ DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
+
+ GOTO (1,2,3) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+ DO 10 I=1,NOPART
+ DO 11 J=1,4
+ AVMULT(J,I) = ZERO
+ AVE(J,I) = ZERO
+ AVSWM(J,I) = ZERO
+ AVPT(J,I) = ZERO
+ IAVPT(J,I) = 0
+ 11 CONTINUE
+ 10 CONTINUE
+
+ RETURN
+
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ IF (PE.LT.0.0D0) THEN
+ WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
+ RETURN
+ ENDIF
+ IF (.NOT.LFRAG) THEN
+ IVEL = 2
+ IF (LGREY) IVEL = 3
+ IF (LBLACK) IVEL = 4
+ AVE(1,IDBJT) = AVE(1,IDBJT) +PE
+ AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
+ AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
+ AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
+ IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
+ IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
+ AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
+ AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
+ AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
+ AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
+ IF (IDBJT.LT.116) THEN
+* total energy, multiplicity
+ AVE(1,30) = AVE(1,30) +PE
+ AVE(IVEL,30) = AVE(IVEL,30)+PE
+ AVPT(1,30) = AVPT(1,30) +PT
+ AVPT(IVEL,30) = AVPT(IVEL,30)+PT
+ IAVPT(1,30) = IAVPT(1,30) +1
+ IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
+ AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
+ AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
+ AVMULT(1,30) = AVMULT(1,30) +ONE
+ AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
+* charged energy, multiplicity
+ IF (ICHAR.LT.0) THEN
+ AVE(1,26) = AVE(1,26) +PE
+ AVE(IVEL,26) = AVE(IVEL,26)+PE
+ AVPT(1,26) = AVPT(1,26) +PT
+ AVPT(IVEL,26) = AVPT(IVEL,26)+PT
+ IAVPT(1,26) = IAVPT(1,26) +1
+ IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
+ AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
+ AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
+ AVMULT(1,26) = AVMULT(1,26) +ONE
+ AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
+ ENDIF
+ IF (ICHAR.NE.0) THEN
+ AVE(1,27) = AVE(1,27) +PE
+ AVE(IVEL,27) = AVE(IVEL,27)+PE
+ AVPT(1,27) = AVPT(1,27) +PT
+ AVPT(IVEL,27) = AVPT(IVEL,27)+PT
+ IAVPT(1,27) = IAVPT(1,27) +1
+ IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
+ AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
+ AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
+ AVMULT(1,27) = AVMULT(1,27) +ONE
+ AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
+ ENDIF
+ ENDIF
+ ENDIF
+
+ RETURN
+
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+ WRITE(LOUT,3000)
+ 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
+ & 29X,'---------------------',/)
+ PRINT*,' MULDEF = ',MULDEF
+ IF (MULDEF.EQ.1) THEN
+ WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
+ ELSE
+ BETGRE = 0.7D0
+ BETBLC = 0.23D0
+ WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
+ 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
+ & ,F4.2,' black: beta < ',F4.2,/)
+ ENDIF
+ WRITE(LOUT,3003) SWMEXP
+ 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
+ & 13X,'| total fast',
+C & ' grey black K f(',F3.1,')',/,1X,
+ & ' grey black <pt> f(',F3.1,')',/,1X,
+ & '------------+--------------',
+ & '-------------------------------------------------')
+ DO 30 I=1,NOPART
+ DO 31 J=1,4
+ AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
+ AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
+ AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
+ AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
+ 31 CONTINUE
+ IF (I.LE.115) THEN
+ WRITE(LOUT,3004) ANAME(I),I,
+ & AVMULT(1,I),AVMULT(2,I),
+ & AVMULT(3,I),AVMULT(4,I),
+C & AVE(1,I),AVSWM(1,I)
+ & AVPT(1,I),AVSWM(1,I)
+ ELSEIF (I.LE.119) THEN
+ WRITE(LOUT,3004) ANAMEH(I-115),I,
+ & AVMULT(1,I),AVMULT(2,I),
+ & AVMULT(3,I),AVMULT(4,I),
+C & AVE(1,I),AVSWM(1,I)
+ & AVPT(1,I),AVSWM(1,I)
+ ENDIF
+ 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
+ 30 CONTINUE
+**temporary
+C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
+C & AVMULT(3,27)+AVMULT(4,27)
+**
+
+ RETURN
+ END
+*
+*===histat=============================================================*
+*
+CDECK ID>, DT_HISTAT
+ SUBROUTINE DT_HISTAT(IDX,MODE)
+
+************************************************************************
+* This version dated 26.02.96 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,TINY14=1.0D-14)
+ PARAMETER (NDIM=199)
+
+* 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)
+
+ PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* 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
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+* properties of interacting particles
+ COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* rejection counter
+ COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+ & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+ & IREXCI(3),IRDIFF(2),IRINC
+* statistics: residual nuclei
+ COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
+ & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
+ & NINCST(2,4),NINCEV(2),
+ & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
+ & NRESPB(2),NRESCH(2),NRESEV(4),
+ & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
+ & NEVAFI(2,2)
+* parameter for intranuclear cascade
+ LOGICAL LPAULI
+ COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+
+ INCLUDE './flukapro/(DIMPAR)'
+ INCLUDE './flukapro/(PAREVT)'
+ INCLUDE './flukapro/(FRBKCM)'
+ INCLUDE './flukapro/(EVAPAR)'
+
+* temporary storage for one final state particle
+ LOGICAL LFRAG,LGREY,LBLACK
+ COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
+ & SINTHE,COSTHE,THETA,THECMS,
+ & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
+ & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
+ & LFRAG,LGREY,LBLACK
+* event flag used for histograms
+ COMMON /DTNORM/ ICEVT,IEVHKK
+* statistics: double-Pomeron exchange
+ COMMON /DTFLG2/ INTFLG,IPOPO
+
+ DIMENSION EMUSAM(NCOMPX)
+
+ CHARACTER*13 CMSG(3)
+ DATA CMSG /'not requested','not requested','not requested'/
+
+ GOTO (1,2,3,4,5) MODE
+
+*------------------------------------------------------------------
+* initialization
+ 1 CONTINUE
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ DO 10 I=1,NCOMPX
+ EMUSAM(I) = ZERO
+ 10 CONTINUE
+ ENDIF
+* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
+ NINCGE = 0
+ DO 11 I=1,2
+ EXCDPM(I) = ZERO
+ EXCDPM(I+2) = ZERO
+ EXCEVA(I) = ZERO
+ NINCWO(I) = 0
+ NINCEV(I) = 0
+ NRESTO(I) = 0
+ NRESPR(I) = 0
+ NRESNU(I) = 0
+ NRESBA(I) = 0
+ NRESPB(I) = 0
+ NRESCH(I) = 0
+ NRESEV(I) = 0
+ NRESEV(I+2) = 0
+ NEVAGA(I) = 0
+ NEVAHT(I) = 0
+ NEVAFI(1,I) = 0
+ NEVAFI(2,I) = 0
+ DO 12 J=1,6
+ IF (J.LE.2) NINCHR(I,J) = 0
+ IF (J.LE.3) NINCCO(I,J) = 0
+ IF (J.LE.4) NINCST(I,J) = 0
+ NEVA(I,J) = 0
+ 12 CONTINUE
+ DO 13 J=1,210
+ NEVAHY(1,I,J) = 0
+ NEVAHY(2,I,J) = 0
+ 13 CONTINUE
+ 11 CONTINUE
+ MAXGEN = 0
+**dble Po statistics.
+ KPOPO = 0
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 2 CONTINUE
+ IF (IST.EQ.-1) THEN
+ IF (.NOT.LFRAG) THEN
+ IF (IDPDG.EQ.2212) THEN
+ NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
+ ELSEIF (IDPDG.EQ.2112) THEN
+ NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
+ ELSEIF (IDPDG.EQ.22) THEN
+ NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
+ ELSEIF (IDPDG.EQ.80000) THEN
+ IF (IDBJT.EQ.116) THEN
+ NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
+ ELSEIF (IDBJT.EQ.117) THEN
+ NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
+ ELSEIF (IDBJT.EQ.118) THEN
+ NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
+ ELSEIF (IDBJT.EQ.119) THEN
+ NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
+ ENDIF
+ ENDIF
+ ELSE
+* heavy fragments (here: fission products only)
+ NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
+ NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
+ NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
+ ENDIF
+ ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
+ IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
+ ENDIF
+
+ RETURN
+*------------------------------------------------------------------
+* output
+ 3 CONTINUE
+
+**dble Po statistics.
+C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
+C & '# evts. / # dble-Po. evts / s_in / s_popo :',
+C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
+
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ WRITE(LOUT,3000)
+ 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
+ & 22X,'----------------------------',/,/,19X,
+ & 'mass charge fraction',/,39X,
+ & 'input treated',/)
+ DO 30 I=1,NCOMPO
+ WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
+ & EMUSAM(I)/DBLE(ICEVT)
+ 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
+ 30 CONTINUE
+ ENDIF
+
+* i.n.c. statistics: output
+ WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
+ 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
+ & 22X,'---------------------------------',/,/,1X,
+ & 'no. of events for normalization: (accepted final events,',
+ & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
+ & /,1X,'no. of rejected events due to intranuclear',
+ & ' cascade',15X,I6,/)
+ ICEV = MAX(ICEVT,1)
+ ICEV1 = ICEV
+ IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
+ WRITE(LOUT,3002)
+ & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
+ & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
+ & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
+ & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
+ 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
+ & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
+ & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
+ & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
+ & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
+ & /,1X,'maximum no. of generations treated (maximum allowed:'
+ & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
+ & ' interactions in proj./ target (mean per evt1)',
+ & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
+ & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
+ & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
+ & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
+ WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
+ & IREXCI(1)+IREXCI(2)+IREXCI(3)
+ 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
+ & 'evaporation',/,22X,'-----------------------------',
+ & '------------',/,/,1X,'no. of events for normal.: ',
+ & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
+ & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
+ & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
+
+ WRITE(LOUT,3004)
+ 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
+ ICEV = MAX(NRESEV(2),1)
+ WRITE(LOUT,3005)
+ & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
+ & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
+ & (EXCDPM(I)/DBLE(ICEV),I=1,2),
+ & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
+ 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
+ & 'proj. / target',/,/,8X,'total number of particles',15X,
+ & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
+ & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
+ & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
+ & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
+ & 8X,'excitation energy per nucleon ',2E11.3,/,/)
+
+* evaporation / fission / fragmentation statistics: output
+ ICEV = MAX(NRESEV(2),1)
+ ICEV1 = MAX(NRESEV(4),1)
+ NTEVA1 =
+ & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
+ NTEVA2 =
+ & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
+ IF (LEVPRT) THEN
+ IF (IFISS.EQ.1) CMSG(1) = 'requested '
+ IF (LFRMBK) CMSG(2) = 'requested '
+ IF (LDEEXG) CMSG(3) = 'requested '
+ WRITE(LOUT,3006)
+ & CMSG,
+ & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
+ & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
+ & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
+ 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
+ & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
+ & 'deexcitation:',2X,A13,/,/,
+ & 1X,'evaporation/deexcitation: (mean values per evt1) ',
+ & 'proj. / target',/,/,8X,'total number of evap. particles',
+ & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
+ & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
+ & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
+ & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
+ & 'heavy fragments',25X,2F9.3,/)
+ IF (IFISS.EQ.1) THEN
+ WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
+ & NEVAFI(2,1),NEVAFI(2,2),
+ & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
+ & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
+ 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
+ & 12X,'out of which fission occured',8X,2I9,/,
+ & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
+ ENDIF
+C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
+C WRITE(LOUT,3008)
+C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
+C & ' proj. / target',/)
+C DO 31 I=1,210
+C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
+C WRITE(LOUT,3009) I,
+C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
+C3009 FORMAT(38X,I3,3X,2E12.3)
+C ENDIF
+C 31 CONTINUE
+C WRITE(LOUT,3010)
+C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
+C & ' proj. / target',/)
+C DO 32 I=1,210
+C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
+C WRITE(LOUT,3011) I,
+C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
+C3011 FORMAT(38X,I3,3X,2E12.3)
+C ENDIF
+C 32 CONTINUE
+C WRITE(LOUT,*)
+C ENDIF
+ ELSE
+ WRITE(LOUT,3012)
+ 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
+ & 'Evaporation: not requested',/)
+ ENDIF
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 4 CONTINUE
+* emulsion treatment
+ IF (NCOMPO.GT.0) THEN
+ DO 40 I=1,NCOMPO
+ IF (IT.EQ.IEMUMA(I)) THEN
+ EMUSAM(I) = EMUSAM(I)+ONE
+ ENDIF
+ 40 CONTINUE
+ ENDIF
+ NINCGE = NINCGE+MAXGEN
+ MAXGEN = 0
+**dble Po statistics.
+ IF (IPOPO.EQ.1) KPOPO = KPOPO+1
+
+ RETURN
+*------------------------------------------------------------------
+* filling of histogram with event-record
+ 5 CONTINUE
+ IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
+ IB = IIBAR(IDBAM(IDX))
+ IC = IICH(IDBAM(IDX))
+ J = ISTHKK(IDX)-14
+ IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
+ NINCST(J,1) = NINCST(J,1)+1
+ ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
+ NINCST(J,2) = NINCST(J,2)+1
+ ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
+ NINCST(J,3) = NINCST(J,3)+1
+ ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
+ NINCST(J,4) = NINCST(J,4)+1
+ ENDIF
+ ELSEIF (ISTHKK(IDX).EQ.17) THEN
+ NINCWO(1) = NINCWO(1)+1
+ ELSEIF (ISTHKK(IDX).EQ.18) THEN
+ NINCWO(2) = NINCWO(2)+1
+ ELSEIF (ISTHKK(IDX).EQ.1001) THEN
+ IB = IDRES(IDX)
+ IC = IDXRES(IDX)
+ IF (IC.GT.0) THEN
+ NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
+ NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
+ ENDIF
+ NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
+ ENDIF
+
+ RETURN
+ END
+*
+*===newhgr=============================================================*
+*
+CDECK ID>, DT_NEWHGR
+ SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
+
+************************************************************************
+* *
+* Histogram initialization. *
+* *
+* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
+* XLIM3 bin size *
+* IBIN > 0 number of bins in equidistant lin. binning *
+* = -1 reset histograms *
+* < -1 |IBIN| number of bins in equidistant log. *
+* binning or log. binning in user def. struc. *
+* XLIMB(*) user defined bin structure *
+* *
+* The bin structure is sensitive to *
+* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
+* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
+* XLIMB, IBIN if XLIM3 < 0 *
+* *
+* *
+* output: IREFN histogram index *
+* (= -1 for inconsistent histogr. request) *
+* *
+* This subroutine is based on a original version by R. Engel. *
+* This version dated 22.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LSTART
+
+ PARAMETER (ZERO = 0.0D0,
+ & TINY = 1.0D-10)
+
+ DIMENSION XLIMB(*)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA LSTART /.TRUE./
+
+* reset histogram counter
+ IF (LSTART.OR.(IBIN.EQ.-1)) THEN
+ IHISL = 0
+ IF (IBIN.EQ.-1) RETURN
+ LSTART = .FALSE.
+ ENDIF
+
+ IHIS = IHISL+1
+* check for maximum number of allowed histograms
+ IF (IHIS.GT.NHIS) THEN
+ WRITE(LOUT,1003) IHIS,NHIS,IHIS
+ 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
+ & I4,') exceeds array size (',I4,')',/,21X,
+ & 'histogram',I3,' skipped!')
+ GOTO 9999
+ ENDIF
+
+ IREFN = IHIS
+ IBINS(IHIS) = ABS(IBIN)
+* check requested number of bins
+ IF (IBINS(IHIS).GE.NDIM) THEN
+ WRITE(LOUT,1000) IBIN,NDIM,NDIM
+ 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
+ & I3,') exceeds array size (',I3,')',/,21X,
+ & 'and will be reset to ',I3)
+ IBINS(IHIS) = NDIM
+ ENDIF
+ IF (IBINS(IHIS).EQ.0) THEN
+ WRITE(LOUT,1001) IBIN,IHIS
+ 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
+ & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
+ GOTO 9999
+ ENDIF
+
+* initialize arrays
+ DO 1 I=1,NDIM
+ DO 2 K=1,3
+ HIST(K,IHIS,I) = ZERO
+ HIST(K+3,IHIS,I) = ZERO
+ TMPHIS(K,IHIS,I) = ZERO
+ 2 CONTINUE
+ HIST(7,IHIS,I) = ZERO
+ 1 CONTINUE
+ DENTRY(1,IHIS)= ZERO
+ DENTRY(2,IHIS)= ZERO
+ OVERF(IHIS) = ZERO
+ UNDERF(IHIS) = ZERO
+ TMPUFL(IHIS) = ZERO
+ TMPOFL(IHIS) = ZERO
+
+* bin str. sensitive to lower edge, bin size, and numb. of bins
+ IF (XLIM3.GT.ZERO) THEN
+ DO 3 K=1,IBINS(IHIS)+1
+ HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
+ 3 CONTINUE
+ ISWI(IHIS) = 1
+* bin str. sensitive to lower/upper edge and numb. of bins
+ ELSEIF (XLIM3.EQ.ZERO) THEN
+* linear binning
+ IF (IBIN.GT.0) THEN
+ XLOW = XLIM1
+ XHI = XLIM2
+ IF (XLIM2.LE.XLIM1) THEN
+ WRITE(LOUT,1002) XLIM1,XLIM2
+ 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
+ & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ ISWI(IHIS) = 1
+ ELSEIF (IBIN.LT.-1) THEN
+* logarithmic binning
+ IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
+ WRITE(LOUT,1004) XLIM1,XLIM2
+ 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
+ & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ IF (XLIM2.LE.XLIM1) THEN
+ WRITE(LOUT,1005) XLIM1,XLIM2
+ 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
+ & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
+ GOTO 9999
+ ENDIF
+ XLOW = LOG10(XLIM1)
+ XHI = LOG10(XLIM2)
+ ISWI(IHIS) = 3
+ ENDIF
+ DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
+ DO 4 K=1,IBINS(IHIS)+1
+ HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
+ 4 CONTINUE
+ ELSE
+* user defined bin structure
+ DO 5 K=1,IBINS(IHIS)+1
+ IF (IBIN.GT.0) THEN
+ HIST(1,IHIS,K) = XLIMB(K)
+ ISWI(IHIS) = 2
+ ELSEIF (IBIN.LT.-1) THEN
+ HIST(1,IHIS,K) = LOG10(XLIMB(K))
+ ISWI(IHIS) = 4
+ ENDIF
+ 5 CONTINUE
+ ENDIF
+
+* histogram accepted
+ IHISL = IHIS
+
+ RETURN
+
+ 9999 CONTINUE
+ IREFN = -1
+ RETURN
+ END
+*
+*===filhgr=============================================================*
+*
+CDECK ID>, DT_FILHGR
+ SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
+
+************************************************************************
+* *
+* Scoring for histogram IHIS. *
+* *
+* This subroutine is based on a original version by R. Engel. *
+* This version dated 23.4.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,
+ & TINY = 1.0D-10)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA NCEVT /1/
+
+ X = XI
+ Y = YI
+
+* dump content of temorary arrays into histograms
+ IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
+ CALL DT_EVTHIS(IDUM)
+ NCEVT = NEVT
+ ENDIF
+
+* check histogram index
+ IF (IHIS.EQ.-1) RETURN
+ IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
+C WRITE(LOUT,1000) IHIS,IHISL
+ 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
+ & ' out of range (1..',I3,')')
+ RETURN
+ ENDIF
+
+ IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
+* bin structure not explicitly given
+ IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
+ DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
+ IF (X.LT.HIST(1,IHIS,1)) THEN
+ I1 = 0
+ ELSE
+ I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
+ ENDIF
+
+ ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
+* user defined bin structure
+ IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
+ IF (X.LT.HIST(1,IHIS,1)) THEN
+ I1 = 0
+ ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
+ I1 = IBINS(IHIS)+1
+ ELSE
+* binary sort algorithm
+ KMIN = 0
+ KMAX = IBINS(IHIS)+1
+ 1 CONTINUE
+ IF ((KMAX-KMIN).EQ.1) GOTO 2
+ KK = (KMAX+KMIN)/2
+ IF (X.LE.HIST(1,IHIS,KK)) THEN
+ KMAX=KK
+ ELSE
+ KMIN=KK
+ ENDIF
+ GOTO 1
+ 2 CONTINUE
+ I1 = KMIN
+ ENDIF
+
+ ELSE
+ WRITE(LOUT,1001)
+ 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
+ RETURN
+ ENDIF
+
+* scoring
+ IF (I1.LE.0) THEN
+ TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
+ ELSEIF (I1.LE.IBINS(IHIS)) THEN
+ TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
+ IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
+ TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
+ ELSE
+ TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
+ ENDIF
+ TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
+ ELSE
+ TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
+ ENDIF
+
+ RETURN
+ END
+*
+*===evthis=============================================================*
+*
+CDECK ID>, DT_EVTHIS
+ SUBROUTINE DT_EVTHIS(NEVT)
+
+************************************************************************
+* Dump content of temorary histograms into /DTHIS1/. This subroutine *
+* is called after each event and for the last event before any call *
+* to OUTHGR. *
+* NEVT number of events dumped, this is only needed to *
+* get the normalization after the last event *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ LOGICAL LNOETY
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & TINY = 1.0D-10)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+* auxiliary common for histograms
+ COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
+
+ DATA NCEVT /0/
+
+ NCEVT = NCEVT+1
+ NEVT = NCEVT
+
+ DO 1 I=1,IHISL
+ LNOETY = .TRUE.
+ DO 2 J=1,IBINS(I)
+ IF (TMPHIS(1,I,J).GT.ZERO) THEN
+ LNOETY = .FALSE.
+ HIST(2,I,J) = HIST(2,I,J)+ONE
+ HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
+ DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
+ AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
+ HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
+ HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
+ HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
+ HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
+ TMPHIS(1,I,J) = ZERO
+ TMPHIS(2,I,J) = ZERO
+ TMPHIS(3,I,J) = ZERO
+ ENDIF
+ 2 CONTINUE
+ IF (LNOETY) THEN
+ IF (TMPUFL(I).GT.ZERO) THEN
+ UNDERF(I) = UNDERF(I)+ONE
+ TMPUFL(I) = ZERO
+ ELSEIF (TMPOFL(I).GT.ZERO) THEN
+ OVERF(I) = OVERF(I)+ONE
+ TMPOFL(I) = ZERO
+ ENDIF
+ ELSE
+ DENTRY(1,I) = DENTRY(1,I)+ONE
+ ENDIF
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===outhgr=============================================================*
+*
+CDECK ID>, DT_OUTHGR
+ SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
+ & ILOGY,INORM,NMODE)
+
+************************************************************************
+* *
+* Plot histogram(s) to standard output unit *
+* *
+* I1..6 indices of histograms to be plotted *
+* CHEAD,IHEAD header string,integer *
+* NEVTS number of events *
+* FAC scaling factor *
+* ILOGY = 1 logarithmic y-axis *
+* INORM normalization *
+* = 0 no further normalization (FAC is obsolete) *
+* = 1 per event and bin width *
+* = 2 per entry and bin width *
+* = 3 per bin entry *
+* = 4 per event and "bin width" x1^2...x2^2 *
+* = 5 per event and "log. bin width" ln x1..ln x2 *
+* = 6 per event *
+* MODE = 0 no output but normalization applied *
+* = 1 all valid histograms separately (small frame) *
+* all valid histograms separately (small frame) *
+* = -1 and tables as histograms *
+* = 2 all valid histograms (one plot, wide frame) *
+* all valid histograms (one plot, wide frame) *
+* = -2 and tables as histograms *
+* *
+* *
+* Note: All histograms to be plotted with one call to this *
+* subroutine and |MODE|=2 must have the same bin structure! *
+* There is no test included ensuring this fact. *
+* *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER*72 CHEAD
+
+ PARAMETER (ZERO = 0.0D0,
+ & IZERO = 0,
+ & ONE = 1.0D0,
+ & TWO = 2.0D0,
+ & OHALF = 0.5D0,
+ & EPS = 1.0D-5,
+ & TINY = 1.0D-8,
+ & SMALL = -1.0D8,
+ & RLARGE = 1.0D8 )
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ PARAMETER (NDIM2 = 2*NDIM)
+ DIMENSION XX(NDIM2),YY(NDIM2)
+
+ PARAMETER (NHISTO = 6)
+ DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
+ & IDX(NHISTO)
+
+ CHARACTER*43 CNORM(0:8)
+ DATA CNORM /'no further normalization ',
+ & 'per event and bin width ',
+ & 'per entry1 and bin width ',
+ & 'per bin entry ',
+ & 'per event and "bin width" x1^2...x2^2 ',
+ & 'per event and "log. bin width" ln x1..ln x2',
+ & 'per event ',
+ & 'per bin entry1 ',
+ & 'per entry2 and bin width '/
+
+ IDX1(1) = I1
+ IDX1(2) = I2
+ IDX1(3) = I3
+ IDX1(4) = I4
+ IDX1(5) = I5
+ IDX1(6) = I6
+
+ MODE = NMODE
+
+* initialization if "wide frame" is requested
+ IF (ABS(MODE).EQ.2) THEN
+ DO 1 I=1,NHISTO
+ DO 2 J=1,NDIM
+ XX1(J,I) = ZERO
+ YY1(J,I) = ZERO
+ 2 CONTINUE
+ 1 CONTINUE
+ ENDIF
+
+* plot header
+ WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
+
+* check histogram indices
+ NHI = 0
+ DO 3 I=1,NHISTO
+ IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
+ IF (ISWI(IDX1(I)).NE.0) THEN
+ IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
+ WRITE(LOUT,1000)
+ & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
+ 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
+ & ' histogram ',I3,/,21X,'underflows:',F10.0,
+ & ' overflows: ',F10.0)
+ ELSE
+ NHI = NHI+1
+ IDX(NHI) = IDX1(I)
+ ENDIF
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+ IF (NHI.EQ.0) THEN
+ WRITE(LOUT,1001)
+ 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
+ RETURN
+ ENDIF
+
+* check normalization request
+ IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
+ & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
+ & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
+ & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
+ WRITE(LOUT,1002) NEVTS,INORM,FAC
+ 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
+ & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
+ & 'FAC = ',E11.4)
+ RETURN
+ ENDIF
+
+ WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
+
+* apply normalization
+ DO 4 N=1,NHI
+
+ I = IDX(N)
+
+ IF (ISWI(I).EQ.1) THEN
+ WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
+ 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
+ & ' to',2X,E10.4,',',2X,I3,' bins')
+ ELSEIF (ISWI(I).EQ.2) THEN
+ WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
+ WRITE(LOUT,1007)
+ 1007 FORMAT(1X,'user defined bin structure')
+ ELSEIF (ISWI(I).EQ.3) THEN
+ WRITE(LOUT,1004)
+ & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
+ 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
+ & ' to',2X,E10.4,',',2X,I3,' bins')
+ ELSEIF (ISWI(I).EQ.4) THEN
+ WRITE(LOUT,1004)
+ & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
+ WRITE(LOUT,1007)
+ ELSE
+ WRITE(LOUT,1008) ISWI(I)
+ 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
+ ENDIF
+ WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
+ 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
+ & ' overfl.:',F8.0)
+ WRITE(LOUT,1009) CNORM(INORM)
+ 1009 FORMAT(1X,'normalization: ',A,/)
+
+ DO 5 K=1,IBINS(I)
+ CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
+ YMEAN = FAC*YMEAN
+ YERR = FAC*YERR
+ WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
+ WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
+ 1006 FORMAT(1X,5E11.3)
+* small frame
+ II = 2*K
+ XX(II-1) = HIST(1,I,K)
+ XX(II) = HIST(1,I,K+1)
+ YY(II-1) = YMEAN
+ YY(II) = YMEAN
+* wide frame
+ XX1(K,N) = XMEAN
+ IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
+ & XX1(K,N) = LOG10(XMEAN)
+ YY1(K,N) = YMEAN
+ 5 CONTINUE
+
+* plot small frame
+ IF (ABS(MODE).EQ.1) THEN
+ IBIN2 = 2*IBINS(I)
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ IF(ILOGY.EQ.1) THEN
+ CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
+ ELSE
+ CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
+ ENDIF
+ ENDIF
+
+ 4 CONTINUE
+
+* plot wide frame
+ IF (ABS(MODE).EQ.2) THEN
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ NSIZE = NDIM*NHISTO
+ DXLOW = HIST(1,IDX(1),1)
+ DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
+ YLOW = RLARGE
+ YHI = SMALL
+ DO 6 I=1,NHISTO
+ DO 7 J=1,NDIM
+ IF (YY1(J,I).LT.YLOW) THEN
+ IF (ILOGY.EQ.1) THEN
+ IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
+ ELSE
+ YLOW = YY1(J,I)
+ ENDIF
+ ENDIF
+ IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
+ 7 CONTINUE
+ 6 CONTINUE
+ DY = (YHI-YLOW)/DBLE(NDIM)
+ IF (DY.LE.ZERO) THEN
+ WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
+ & 'OUTHGR: warning! zero bin width for histograms ',
+ & IDX,': ',YLOW,YHI
+ RETURN
+ ENDIF
+ IF (ILOGY.EQ.1) THEN
+ YLOW = LOG10(YLOW)
+ DY = (LOG10(YHI)-YLOW)/100.0D0
+ DO 8 I=1,NHISTO
+ DO 9 J=1,NDIM
+ IF (YY1(J,I).LE.ZERO) THEN
+ YY1(J,I) = YLOW
+ ELSE
+ YY1(J,I) = LOG10(YY1(J,I))
+ ENDIF
+ 9 CONTINUE
+ 8 CONTINUE
+ ENDIF
+ CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
+ ENDIF
+
+ RETURN
+ END
+*
+*===getbin=============================================================*
+*
+CDECK ID>, DT_GETBIN
+ SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
+ & XMEAN,YMEAN,YERR)
+
+************************************************************************
+* This version dated 23.4.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,
+ & TINY35 = 1.0D-35)
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ XLOW = HIST(1,IHIS,IBIN)
+ XHI = HIST(1,IHIS,IBIN+1)
+ IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
+ XLOW = 10**XLOW
+ XHI = 10**XHI
+ ENDIF
+ IF (NORM.EQ.2) THEN
+ DX = XHI-XLOW
+ NEVT = INT(DENTRY(1,IHIS))
+ ELSEIF (NORM.EQ.3) THEN
+ DX = ONE
+ NEVT = INT(HIST(2,IHIS,IBIN))
+ ELSEIF (NORM.EQ.4) THEN
+ DX = XHI**2-XLOW**2
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.5) THEN
+ DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.6) THEN
+ DX = ONE
+ NEVT = KEVT
+ ELSEIF (NORM.EQ.7) THEN
+ DX = ONE
+ NEVT = INT(HIST(7,IHIS,IBIN))
+ ELSEIF (NORM.EQ.8) THEN
+ DX = XHI-XLOW
+ NEVT = INT(DENTRY(2,IHIS))
+ ELSE
+ DX = ABS(XHI-XLOW)
+ NEVT = KEVT
+ ENDIF
+ IF (ABS(DX).LT.TINY35) DX = ONE
+ NEVT = MAX(NEVT,1)
+ YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
+ YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
+ YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
+ YSUM = HIST(5,IHIS,IBIN)
+ IF (ABS(YSUM).LT.TINY35) YSUM = ONE
+C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
+ XMEAN = HIST(3,IHIS,IBIN)/YSUM
+ IF (XMEAN.EQ.ZERO) XMEAN = XLOW
+
+ RETURN
+ END
+*
+*===joihis=============================================================*
+*
+CDECK ID>, DT_JOIHIS
+ SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
+
+************************************************************************
+* *
+* Operation on histograms. *
+* *
+* input: IH1,IH2 histogram indices to be joined *
+* COPER character defining the requested operation, *
+* i.e. '+', '-', '*', '/' *
+* FAC1,FAC2 factors for joining, i.e. *
+* FAC1*histo1 COPER FAC2*histo2 *
+* *
+* This version dated 23.4.95 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ CHARACTER COPER*1
+
+ PARAMETER (ZERO = 0.0D0,
+ & ONE = 1.0D0,
+ & OHALF = 0.5D0,
+ & TINY8 = 1.0D-8,
+ & SMALL = -1.0D8,
+ & RLARGE = 1.0D8 )
+
+* histograms
+
+ PARAMETER (NHIS=150, NDIM=250)
+
+ COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
+ & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
+
+ PARAMETER (NDIM2 = 2*NDIM)
+ DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
+
+ CHARACTER*43 CNORM(0:6)
+ DATA CNORM /'no further normalization ',
+ & 'per event and bin width ',
+ & 'per entry and bin width ',
+ & 'per bin entry ',
+ & 'per event and "bin width" x1^2...x2^2 ',
+ & 'per event and "log. bin width" ln x1..ln x2',
+ & 'per event '/
+
+* check histogram indices
+ IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
+ & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
+ WRITE(LOUT,1000) IH1,IH2,IHISL
+ 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
+ & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
+ GOTO 9999
+ ENDIF
+
+* check bin structure of histograms to be joined
+ IF (IBINS(IH1).NE.IBINS(IH2)) THEN
+ WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
+ 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
+ & ' and ',I3,' failed',/,21X,
+ & 'due to different numbers of bins (',I3,',',I3,')')
+ GOTO 9999
+ ENDIF
+ DO 1 K=1,IBINS(IH1)+1
+ IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
+ WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
+ 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
+ & ' and ',I3,' failed at bin edge ',I3,/,21X,
+ & 'X1,X2 = ',2E11.4)
+ GOTO 9999
+ ENDIF
+ 1 CONTINUE
+
+ WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
+ 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
+ & 'operation ',A,/,11X,'and factors ',2E11.4)
+ WRITE(LOUT,1004) CNORM(NORM)
+ 1004 FORMAT(1X,'normalization: ',A,/)
+
+ DO 2 K=1,IBINS(IH1)
+ CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
+ CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
+ XLOW = XLOW1
+ XHI = XHI1
+ XMEAN = OHALF*(XMEAN1+XMEAN2)
+ IF (COPER.EQ.'+') THEN
+ YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
+ ELSEIF (COPER.EQ.'*') THEN
+ YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
+ ELSEIF (COPER.EQ.'/') THEN
+ IF (YMEAN2.EQ.ZERO) THEN
+ YMEAN = ZERO
+ ELSE
+ IF (FAC2.EQ.ZERO) FAC2 = ONE
+ YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
+ ENDIF
+ ELSE
+ GOTO 9998
+ ENDIF
+ WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
+ WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
+ 1006 FORMAT(1X,5E11.3)
+* small frame
+ II = 2*K
+ XX(II-1) = HIST(1,IH1,K)
+ XX(II) = HIST(1,IH1,K+1)
+ YY(II-1) = YMEAN
+ YY(II) = YMEAN
+* wide frame
+ XX1(K) = XMEAN
+ IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
+ YY1(K) = YMEAN
+ 2 CONTINUE
+
+* plot small frame
+ IF (ABS(MODE).EQ.1) THEN
+ IBIN2 = 2*IBINS(IH1)
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ IF(ILOGY.EQ.1) THEN
+ CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
+ ELSE
+ CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
+ ENDIF
+ ENDIF
+
+* plot wide frame
+ IF (ABS(MODE).EQ.2) THEN
+ WRITE(LOUT,'(/,1X,A)') 'Preview:'
+ NSIZE = NDIM
+ DXLOW = HIST(1,IH1,1)
+ DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
+ YLOW = RLARGE
+ YHI = SMALL
+ DO 3 I=1,NDIM
+ IF (YY1(I).LT.YLOW) THEN
+ IF (ILOGY.EQ.1) THEN
+ IF (YY1(I).GT.ZERO) YLOW = YY1(I)
+ ELSE
+ YLOW = YY1(I)
+ ENDIF
+ ENDIF
+ IF (YY1(I).GT.YHI) YHI = YY1(I)
+ 3 CONTINUE
+ DY = (YHI-YLOW)/DBLE(NDIM)
+ IF (DY.LE.ZERO) THEN
+ WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
+ & 'JOIHIS: warning! zero bin width for histograms ',
+ & IH1,IH2,': ',YLOW,YHI
+ RETURN
+ ENDIF
+ IF (ILOGY.EQ.1) THEN
+ YLOW = LOG10(YLOW)
+ DY = (LOG10(YHI)-YLOW)/100.0D0
+ DO 4 I=1,NDIM
+ IF (YY1(I).LE.ZERO) THEN
+ YY1(I) = YLOW
+ ELSE
+ YY1(I) = LOG10(YY1(I))
+ ENDIF
+ 4 CONTINUE
+ ENDIF
+ CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
+ ENDIF
+
+ RETURN
+
+ 9998 CONTINUE
+ WRITE(LOUT,1005) COPER
+ 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
+
+ 9999 CONTINUE
+ RETURN
+ END
+*
+*===qgraph=============================================================*
+*
+CDECK ID>, DT_XGRAPH
+ SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
+C***********************************************************************
+C
+C calculate quasi graphic picture with 25 lines and 79 columns
+C ranges will be chosen automatically
+C
+C input N dimension of input fields
+C IARG number of curves (fields) to plot
+C X field of X
+C Y1 field of Y1
+C Y2 field of Y2
+C
+C This subroutine is written by R. Engel.
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C
+ DIMENSION X(N),Y1(N),Y2(N)
+ PARAMETER (EPS=1.D-30)
+ PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
+ CHARACTER SYMB(5)
+ CHARACTER COL(0:149,0:49)
+C
+ DATA SYMB /'0','e','z','#','x'/
+C
+ ISPALT=IBREIT-10
+C
+C*** automatic range fitting
+C
+ XMAX=X(1)
+ XMIN=X(1)
+ DO 600 I=1,N
+ XMAX=MAX(X(I),XMAX)
+ XMIN=MIN(X(I),XMIN)
+ 600 CONTINUE
+ XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
+C
+ ITEST=0
+ DO 1100 K=0,IZEIL-1
+ ITEST=ITEST+1
+ IF (ITEST.EQ.IYRAST) THEN
+ DO 1010 L=1,ISPALT-1
+ COL(L,K)='-'
+1010 CONTINUE
+ COL(ISPALT,K)='+'
+ ITEST=0
+ DO 1020 L=0,ISPALT-1,IXRAST
+ COL(L,K)='+'
+1020 CONTINUE
+ ELSE
+ DO 1030 L=1,ISPALT-1
+ COL(L,K)=' '
+1030 CONTINUE
+ DO 1040 L=0,ISPALT-1,IXRAST
+ COL(L,K)='|'
+1040 CONTINUE
+ COL(ISPALT,K)='|'
+ ENDIF
+1100 CONTINUE
+C
+C*** plot curve Y1
+C
+ YMAX=Y1(1)
+ YMIN=Y1(1)
+ DO 500 I=1,N
+ YMAX=MAX(Y1(I),YMAX)
+ YMIN=MIN(Y1(I),YMIN)
+500 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 550 I=1,N
+ YMAX=MAX(Y2(I),YMAX)
+ YMIN=MIN(Y2(I),YMIN)
+550 CONTINUE
+ ENDIF
+ YMAX=(YMAX-YMIN)/40.0D0+YMAX
+ YMIN=YMIN-(YMAX-YMIN)/40.0D0
+ YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
+ IF(YZOOM.LT.EPS) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+C*** plot curve Y1
+C
+ ILAST=-1
+ LLAST=-1
+ DO 1200 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMAX-Y1(K))/YZOOM)
+ IF(ILAST.GE.0) THEN
+ LD = L-LLAST
+ ID = I-ILAST
+ DO 55 II=0,LD,SIGN(1,LD)
+ DO 66 KK=0,ID,SIGN(1,ID)
+ COL(II+LLAST,KK+ILAST)=SYMB(1)
+ 66 CONTINUE
+ 55 CONTINUE
+ ELSE
+ COL(L,I)=SYMB(1)
+ ENDIF
+ ILAST = I
+ LLAST = L
+1200 CONTINUE
+C
+ IF(IARG.GT.1) THEN
+C
+C*** plot curve Y2
+C
+ DO 1250 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMAX-Y2(K))/YZOOM)
+ COL(L,I)=SYMB(2)
+1250 CONTINUE
+ ENDIF
+C
+C*** write it
+C
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+C
+C*** write range of X
+C
+ XZOOM = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
+C
+ DO 1300 K=0,IZEIL-1
+ YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
+ WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
+ 110 FORMAT(1X,1PE9.2,70A1)
+1300 CONTINUE
+C
+C*** write range of X
+C
+ XZOOM = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+ 120 FORMAT(6X,7(1PE10.3))
+ END
+*
+*===qglogy=============================================================*
+*
+CDECK ID>, DT_XGLOGY
+ SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
+C***********************************************************************
+C
+C calculate quasi graphic picture with 25 lines and 79 columns
+C logarithmic y axis
+C ranges will be chosen automatically
+C
+C input N dimension of input fields
+C IARG number of curves (fields) to plot
+C X field of X
+C Y1 field of Y1
+C Y2 field of Y2
+C
+C This subroutine is written by R. Engel.
+C***********************************************************************
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ DIMENSION X(N),Y1(N),Y2(N)
+ PARAMETER (EPS=1.D-30)
+ PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
+ CHARACTER SYMB(5)
+ CHARACTER COL(0:149,0:49)
+ PARAMETER (DEPS = 1.D-10)
+C
+ DATA SYMB /'0','e','z','#','x'/
+C
+ ISPALT=IBREIT-10
+C
+C*** automatic range fitting
+C
+ XMAX=X(1)
+ XMIN=X(1)
+ DO 600 I=1,N
+ XMAX=MAX(X(I),XMAX)
+ XMIN=MIN(X(I),XMIN)
+ 600 CONTINUE
+ XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
+C
+ ITEST=0
+ DO 1100 K=0,IZEIL-1
+ ITEST=ITEST+1
+ IF (ITEST.EQ.IYRAST) THEN
+ DO 1010 L=1,ISPALT-1
+ COL(L,K)='-'
+1010 CONTINUE
+ COL(ISPALT,K)='+'
+ ITEST=0
+ DO 1020 L=0,ISPALT-1,IXRAST
+ COL(L,K)='+'
+1020 CONTINUE
+ ELSE
+ DO 1030 L=1,ISPALT-1
+ COL(L,K)=' '
+1030 CONTINUE
+ DO 1040 L=0,ISPALT-1,IXRAST
+ COL(L,K)='|'
+1040 CONTINUE
+ COL(ISPALT,K)='|'
+ ENDIF
+1100 CONTINUE
+C
+C*** plot curve Y1
+C
+ YMAX=Y1(1)
+ YMIN=MAX(Y1(1),EPS)
+ DO 500 I=1,N
+ YMAX =MAX(Y1(I),YMAX)
+ IF(Y1(I).GT.EPS) THEN
+ IF(YMIN.EQ.EPS) THEN
+ YMIN = Y1(I)/10.D0
+ ELSE
+ YMIN = MIN(Y1(I),YMIN)
+ ENDIF
+ ENDIF
+500 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 550 I=1,N
+ YMAX=MAX(Y2(I),YMAX)
+ IF(Y2(I).GT.EPS) THEN
+ IF(YMIN.EQ.EPS) THEN
+ YMIN = Y2(I)
+ ELSE
+ YMIN = MIN(Y2(I),YMIN)
+ ENDIF
+ ENDIF
+550 CONTINUE
+ ENDIF
+C
+ DO 560 I=1,N
+ Y1(I) = MAX(Y1(I),YMIN)
+ 560 CONTINUE
+ IF(IARG.GT.1) THEN
+ DO 570 I=1,N
+ Y2(I) = MAX(Y2(I),YMIN)
+ 570 CONTINUE
+ ENDIF
+C
+ IF(YMAX.LE.YMIN) THEN
+ WRITE(LOUT,'(/1X,A,2E12.3,/)')
+ & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
+ WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+ YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
+ YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
+ YZOOM=(YMA-YMI)/DBLE(IZEIL)
+ IF(YZOOM.LT.EPS) THEN
+ WRITE(LOUT,'(1X,A)')
+ & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
+ RETURN
+ ENDIF
+C
+C*** plot curve Y1
+C
+ ILAST=-1
+ LLAST=-1
+ DO 1200 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
+ IF(ILAST.GE.0) THEN
+ LD = L-LLAST
+ ID = I-ILAST
+ DO 55 II=0,LD,SIGN(1,LD)
+ DO 66 KK=0,ID,SIGN(1,ID)
+ COL(II+LLAST,KK+ILAST)=SYMB(1)
+ 66 CONTINUE
+ 55 CONTINUE
+ ELSE
+ COL(L,I)=SYMB(1)
+ ENDIF
+ ILAST = I
+ LLAST = L
+1200 CONTINUE
+C
+ IF(IARG.GT.1) THEN
+C
+C*** plot curve Y2
+C
+ DO 1250 K=1,N
+ L=NINT((X(K)-XMIN)/XZOOM)
+ I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
+ COL(L,I)=SYMB(2)
+1250 CONTINUE
+ ENDIF
+C
+C*** write it
+C
+ WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+C
+C*** write range of X
+C
+ XZOOM1 = (XMAX-XMIN)/DBLE(7)
+ WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
+C
+ DO 1300 K=0,IZEIL-1
+ YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
+ WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
+ 110 FORMAT(1X,1PE9.2,70A1)
+1300 CONTINUE
+C
+C*** write range of X
+C
+ WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
+ WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
+ 120 FORMAT(6X,7(1PE10.3))
+C
+ END
+*
+*===plot===============================================================*
+*
+CDECK ID>, DT_SRPLOT
+ SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+*
+* initial version
+* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
+* This is a subroutine of fluka to plot Y across the page
+* as a function of X down the page. Up to 37 curves can be
+* plotted in the same picture with different plotting characters.
+* Output of first 10 overprinted characters addad by FB 88
+* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+*
+* Input Variables:
+* X = array containing the values of X
+* Y = array containing the values of Y
+* N = number of values in X and in Y
+* can exceed the fixed number of lines
+* M = number of different curves X,Y are containing
+* MM = number of points in each curve i.e. N=M*MM
+* XO = smallest value of X to be plotted
+* DX = increment of X between subsequent lines
+* YO = smallest value of Y to be plotted
+* DY = increment of Y between subsequent character spaces
+*
+* other variables used inside:
+* XX = numbers along the X-coordinate axis
+* YY = numbers along the Y-coordinate axis
+* LL = ten lines temporary storage for the plot
+* L = character set used to plot different curves
+* LOV = memorizes overprinted symbols
+* the first 10 overprinted symbols are printed on
+* the end of the line to avoid ambiguities
+* (added by FB as considered quite helpful)
+*
+*********************************************************************
+*
+ DIMENSION XX(61),YY(61),LL(101,10)
+ DIMENSION X(N),Y(N),L(40),LOV(40,10)
+ DATA L/
+ 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
+ 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
+ 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
+ 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
+*
+*
+ MN=51
+ DO 10 I=1,MN
+ AI=I-1
+ 10 XX(I)=XO+AI*DX
+ DO 20 I=1,11
+ AI=I-1
+ 20 YY(I)=YO+10.0D0*AI*DY
+ WRITE(LOUT, 500) (YY(I),I=1,11)
+ MMN=MN-1
+*
+*
+ DO 90 JJ=1,MMN,10
+ JJJ=JJ-1
+ DO 30 I=1,101
+ DO 30 J=1,10
+ 30 LL(I,J)=L(40)
+ DO 40 I=1,101
+ 40 LL(I,1)=L(39)
+ DO 50 I=1,101,10
+ DO 50 J=1,10
+ 50 LL(I,J)=L(38)
+ DO 60 I=1,40
+ DO 60 J=1,10
+ 60 LOV(I,J)=L(40)
+*
+*
+ DO 70 I=1,M
+ DO 70 J=1,MM
+ II=J+(I-1)*MM
+ AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
+ AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
+ AIX=AIX-DBLE(JJJ)
+* changed Sept.88 by FB to avoid INTEGER OVERFLOW
+ IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
+ + . AIY .LT. 102.D0) THEN
+ IX=INT(AIX)
+ IY=INT(AIY)
+ IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
+ + THEN
+ IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
+ + =LL(IY,IX)
+ LL(IY,IX)=L(I)
+ ENDIF
+ ENDIF
+ 70 CONTINUE
+*
+*
+ DO 80 I=1,10
+ II=I+JJJ
+ III=II+1
+ WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
+ & (LOV(J,I),J=1,10)
+ 80 CONTINUE
+ 90 CONTINUE
+*
+*
+ WRITE(LOUT, 520)
+ WRITE(LOUT, 500) (YY(I),I=1,11)
+ RETURN
+*
+ 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
+ 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
+ 520 FORMAT(20X,10('1---------'),'1')
+ END
+*
+*===defset=============================================================*
+*
+CDECK ID>, DT_DEFSET
+ BLOCK DATA DT_DEFSET
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* 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 (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+
+* emulsion treatment
+ COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+ & NCOMPO,IEMUL
+
+* / DTFLG1 /
+ DATA IFRAG / 2, 1 /
+ DATA IRESCO / 1 /
+ DATA IMSHL / 1 /
+ DATA IRESRJ / 0 /
+ DATA IOULEV / -1, -1, -1, -1, -1, -1 /
+ DATA LEMCCK / .FALSE. /
+ DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
+ & .TRUE.,.TRUE.,.TRUE./
+ DATA LSEADI / .TRUE. /
+ DATA LEVAPO / .TRUE. /
+ DATA IFRAME / 1 /
+* Introduced by Chiara -> Forcing CMS-system
+* DATA IFRAME / 2 /
+ DATA ITRSPT / 0 /
+
+* / DTCOMP /
+ DATA EMUFRA / NCOMPX*0.0D0 /
+ DATA IEMUMA / NCOMPX*1 /
+ DATA IEMUCH / NCOMPX*1 /
+ DATA NCOMPO / 0 /
+ DATA IEMUL / 0 /
+
+ END
+*
+*
+*===hadprp=============================================================*
+*
+CDECK ID>, DT_HADPRP
+ BLOCK DATA DT_HADPRP
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* auxiliary common for reggeon exchange (DTUNUC 1.x)
+ COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
+ & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
+ & IQTCHR(-6:6),MQUARK(3,39)
+* hadron index conversion (BAMJET <--> PDG)
+ COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
+ & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
+ & IAMCIN(210)
+* names of hadrons used in input-cards
+ CHARACTER*8 BTYPE
+ COMMON /DTPAIN/ BTYPE(30)
+
+* / DTQUAR /
+*----------------------------------------------------------------------*
+* *
+* Quark content of particles: *
+* index quark el. charge bar. charge isospin isospin3 *
+* 1 = u 2/3 1/3 1/2 1/2 *
+* -1 = ubar -2/3 -1/3 1/2 -1/2 *
+* 2 = d -1/3 1/3 1/2 -1/2 *
+* -2 = dbar 1/3 -1/3 1/2 1/2 *
+* 3 = s -1/3 1/3 0 0 *
+* -3 = sbar 1/3 -1/3 0 0 *
+* 4 = c 2/3 1/3 0 0 *
+* -4 = cbar -2/3 -1/3 0 0 *
+* 5 = b -1/3 1/3 0 0 *
+* -5 = bbar 1/3 -1/3 0 0 *
+* 6 = t 2/3 1/3 0 0 *
+* -6 = tbar -2/3 -1/3 0 0 *
+* *
+* Mquark = particle quark composition (Paprop numbering) *
+* Iqechr = electric charge ( in 1/3 unit ) *
+* Iqbchr = baryonic charge ( in 1/3 unit ) *
+* Iqichr = isospin ( in 1/2 unit ), z component *
+* Iqschr = strangeness *
+* Iqcchr = charm *
+* Iquchr = beauty *
+* Iqtchr = ...... *
+* *
+*----------------------------------------------------------------------*
+ DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
+ DATA IQBCHR / 6*-1, 0, 6*1 /
+ DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
+ DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
+ DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
+ DATA IQUCHR / 0, 1, 9*0, -1, 0 /
+ DATA IQTCHR / -1, 11*0, 1 /
+ DATA MQUARK /
+ & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
+ & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
+ & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
+ & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
+ & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
+
+* / DTHAIC /
+* (renamed) (HAdron InDex COnversion)
+* translation table version filled up by r.e. 25.01.94 *
+ DATA IAMCIN /
+ &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
+ &13,130,211,-211,321, -321,3122,-3122,310,3112,
+ &3222,3212,111,311,-311, 0,0,0,0,0,
+ &221,213,113,-213,223, 323,313,-323,-313,10323,
+ &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
+ &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
+ &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
+ &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
+ &5*99999, 5*99999,
+ &4*99999,331, 333,3322,3312,-3222,-3212,
+ &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
+ &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
+ &-431,441,423,413,-413, -423,433,-433,20443,443,
+ &-15,15,16,-16,14, -14,4122,4232,4132,4222,
+ &4212,4112,3*99999, 3*99999,-4122,-4232,
+ &-4132,-4222,-4212,-4112,99999, 5*99999,
+ &5*99999, 5*99999,
+ &10*99999,
+ &5*99999 , 20211,20111,-20211,99999,20321,
+ &-20321,20311,-20311,7*99999 ,
+ &7*99999,12212,12112,99999/
+
+* / DTHAIC /
+* (HAdron InDex COnversion)
+ DATA (IPDG2(1,K),K=1,7)
+ & / -11, -12, -13, -15, -16, -14, 0/
+ DATA (IBAM2(1,K),K=1,7)
+ & / 4, 6, 10, 131, 134, 136, 0/
+ DATA (IPDG2(2,K),K=1,7)
+ & / 11, 12, 22, 13, 15, 16, 14/
+ DATA (IBAM2(2,K),K=1,7)
+ & / 3, 5, 7, 11, 132, 133, 135/
+ DATA (IPDG3(1,K),K=1,22)
+ & / -211, -321, -311, -213, -323, -313, -411, -421,
+ & -431, -413, -423, -433, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0/
+ DATA (IBAM3(1,K),K=1,22)
+ & / 14, 16, 25, 34, 38, 39, 118, 119,
+ & 121, 125, 126, 128, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0/
+ DATA (IPDG3(2,K),K=1,22)
+ & / 130, 211, 321, 310, 111, 311, 221, 213,
+ & 113, 223, 323, 313, 331, 333, 421, 411,
+ & 431, 441, 423, 413, 433, 443/
+ DATA (IBAM3(2,K),K=1,22)
+ & / 12, 13, 15, 19, 23, 24, 31, 32,
+ & 33, 35, 36, 37, 95, 96, 116, 117,
+ & 120, 122, 123, 124, 127, 130/
+ DATA (IPDG4(1,K),K=1,29)
+ & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
+ & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
+ & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
+ & -4212, -4112, 0, 0, 0/
+ DATA (IBAM4(1,K),K=1,29)
+ & / 2, 9, 18, 67, 68, 69, 70, 75,
+ & 76, 99, 100, 101, 102, 103, 110, 111,
+ & 112, 113, 114, 115, 149, 150, 151, 152,
+ & 153, 154, 0, 0, 0/
+ DATA (IPDG4(2,K),K=1,29)
+ & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
+ & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
+ & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
+ & 4232, 4132, 4222, 4212, 4112/
+ DATA (IBAM4(2,K),K=1,29)
+ & / 1, 8, 17, 20, 21, 22, 48, 49,
+ & 50, 51, 52, 53, 54, 55, 56, 97,
+ & 98, 104, 105, 106, 107, 108, 109, 137,
+ & 138, 139, 140, 141, 142/
+ DATA (IPDG5(1,K),K=1,19)
+ & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
+ & -20211,-20321,-20311, 0, 0, 0, 0, 0,
+ & 0, 0, 0/
+ DATA (IBAM5(1,K),K=1,19)
+ & / 42, 43, 46, 47, 71, 72, 73, 74,
+ & 188, 191, 193, 0, 0, 0, 0, 0,
+ & 0, 0, 0/
+ DATA (IPDG5(2,K),K=1,19)
+ & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
+ & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
+ & 20311, 12212, 12112/
+ DATA (IBAM5(2,K),K=1,19)
+ & / 40, 41, 44, 45, 57, 58, 59, 60,
+ & 63, 64, 65, 66, 129, 186, 187, 190,
+ & 192, 208, 209/
+
+* / DTPAIN /
+* internal particle names
+ DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
+ &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
+ &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
+ &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
+ &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
+ &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
+ &'BLANK ' /
+
+ END
+*
+*===blkd46=============================================================*
+*
+CDECK ID>, DT_BLKD46
+ BLOCK DATA DT_BLKD46
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( AMMUON = 0.105658389 D+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)
+
+* / DTPART /
+* Particle masses Engel version JETSET compatible
+ DATA (AAM(K),K=1,85) /
+ & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
+ & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
+ & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
+ & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
+ & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
+ & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
+ & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
+ & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
+ & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
+ & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
+ & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
+ & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
+ & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
+ & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
+ & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
+ DATA (AAM(K),K=86,183) /
+ & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
+ & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
+ & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
+ & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
+ & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
+ & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
+ & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
+ & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
+ & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
+ & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
+ & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
+ & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
+ & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
+ & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
+ & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+ & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+ & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
+ & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
+ & .1250D+01, .1250D+01, .1250D+01 /
+ DATA (AAM ( I ), I = 184,210 ) /
+ & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
+ & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
+ & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
+ & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
+ & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+ & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
+ & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
+ & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
+ & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
+* Particle mean lives
+ DATA (TAU(K),K=1,183) /
+ & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
+ & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
+ & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
+ & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
+ & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
+ & 70*.0000D+00,
+ & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
+ & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
+ & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & 40*.0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00 /
+ DATA ( TAU ( I ), I = 184,210 ) /
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
+ & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
+* Resonance width Gamma in GeV
+ DATA (GA(K),K= 1,85) /
+ & 30*.0000D+00,
+ & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
+ & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
+ & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
+ & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
+ & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
+ & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
+ & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
+ & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
+ & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
+ & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
+ & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
+ DATA (GA(K),K= 86,183) /
+ & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
+ & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
+ & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
+ & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
+ & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
+ & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
+ & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
+ & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
+ & 50*.0000D+00,
+ & .3000D+00, .3000D+00, .3000D+00 /
+ DATA ( GA ( I ), I = 184,210 ) /
+ & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
+ & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
+ & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
+ & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
+ & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
+ & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
+ & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
+ & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
+ & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
+* Particle names
+* S+1385+Sigma+(1385) L02030+Lambda0(2030)
+* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
+* designation N*@@ means N*@1(@2)
+ DATA (ANAME(K),K=1,85) /
+ & 'P ','AP ','E- ','E+ ','NUE ',
+ & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
+ & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
+ & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
+ & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
+ & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
+ & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
+ & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
+ & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
+ & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
+ & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
+ & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
+ & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
+ & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
+ & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
+ & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
+ & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
+ DATA (ANAME(K),K=86,183) /
+ & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
+ & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
+ & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
+ & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
+ & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
+ & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
+ & 'D0 ','D+ ','D- ','AD0 ','F+ ',
+ & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
+ & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
+ & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
+ & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
+ & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
+ & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
+ & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
+ & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
+ & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
+ & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
+ & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
+ & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
+ & 'RO ','R+ ','R- ' /
+ DATA ( ANAME ( I ), I = 184,210 ) /
+ &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
+ &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
+ &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
+ &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
+ &'N*+14 ','N*014 ','BLANK '/
+* Charge of particles and resonances
+ DATA (IICH ( I ), I = 1,210 ) /
+ & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
+ & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
+ & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
+ & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
+ & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
+ & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
+ & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
+ & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
+ & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
+ & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
+ & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
+ & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
+ & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
+* Particle baryonic charges
+ DATA (IIBAR ( I ), I = 1,210 ) /
+ & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
+ & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
+ & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
+ & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
+ & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
+ & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
+ & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
+* First number of decay channels used for resonances
+* and decaying particles
+ DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
+ & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
+ & 2*330, 46, 51, 52, 54, 55, 58,
+* 50
+ & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
+ & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
+ & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
+* 85
+ & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
+ & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
+ & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
+ & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
+ & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
+ & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
+ & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
+ & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
+ & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
+ & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
+ & 590, 596, 602 /
+* Last number of decay channels used for resonances
+* and decaying particles
+ DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
+ & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
+ & 2* 330, 50, 51, 53, 54, 57,
+* 50
+ & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
+ & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
+ & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
+* 85
+ & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
+ & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
+ & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
+ & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
+ & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
+ & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
+ & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
+ & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
+ & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
+ & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
+ & 589, 595, 601, 602 /
+
+ END
+*
+*===blkd47=============================================================*
+*
+CDECK ID>, DT_BLKD47
+ BLOCK DATA DT_BLKD47
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+
+* Name of decay channel
+* Designation N*@ means N*@1(1236)
+* @1=# means ++, @1 = = means --
+* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
+ DATA (ZKNAME(K),K= 1, 85) /
+ & 'P ','AP ','E- ','E+ ','NUE ',
+ & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
+ & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
+ & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
+ & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
+ & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
+ & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
+ & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
+ & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
+ & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
+ & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
+ & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
+ & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
+ & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
+ & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
+ & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
+ & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
+ DATA (ZKNAME(K),K= 86,170) /
+ & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
+ & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
+ & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
+ & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
+ & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
+ & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
+ & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
+ & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
+ & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
+ & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
+ & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
+ & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
+ & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
+ & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
+ & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
+ & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
+ & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
+ DATA (ZKNAME(K),K=171,255) /
+ & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
+ & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
+ & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
+ & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
+ & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
+ & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
+ & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
+ & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
+ & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
+ & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
+ & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
+ & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
+ & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
+ & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
+ & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
+ & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
+ & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
+ DATA (ZKNAME(K),K=256,340) /
+ & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
+ & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
+ & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
+ & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
+ & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
+ & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
+ & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
+ & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
+ & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
+ & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
+ & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
+ & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
+ & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
+ DATA (ZKNAME(K),K=341,425) /
+ & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
+ & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
+ & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
+ & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
+ & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
+ & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
+ & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
+ & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
+ & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
+ & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
+ & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
+ & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
+ & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
+ & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
+ & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
+ & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
+ & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
+ DATA (ZKNAME(K),K=426,510) /
+ & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
+ & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
+ & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
+ & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
+ & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
+ & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
+ & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
+ & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
+ & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
+ & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
+ & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
+ & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
+ & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
+ & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
+ & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
+ & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
+ & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
+ DATA (ZKNAME(K),K=511,540) /
+ & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
+ & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
+ & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
+ & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
+ & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
+ & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
+ DATA (ZKNAME(I),I=541,602)/
+ & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
+ & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
+ & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
+ & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
+ & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
+ & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
+ & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
+ & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
+ & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
+* Weight of decay channel
+ DATA (WT(K),K= 1, 85) /
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
+ & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
+ & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
+ & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
+ & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
+ & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
+ & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
+ & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
+ & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
+ & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
+ & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
+ & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
+ & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
+ & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
+ & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
+ DATA (WT(K),K= 86,170) /
+ & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
+ & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
+ & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
+ & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
+ & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
+ & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
+ & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
+ & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
+ & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
+ & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
+ & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
+ & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
+ & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
+ & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
+ & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
+ & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
+ DATA (WT(K),K=171,255) /
+ & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
+ & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
+ & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
+ & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
+ & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
+ & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
+ & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
+ & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
+ & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
+ & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
+ & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
+ & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
+ & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
+ & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
+ & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
+ & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
+ & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
+ DATA (WT(K),K=256,340) /
+ & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
+ & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
+ & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
+ & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
+ & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
+ & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
+ & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
+ & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
+ & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
+ & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
+ & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
+ & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
+ DATA (WT(K),K=341,425) /
+ & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
+ & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
+ & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
+ & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
+ & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
+ & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
+ & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
+ & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
+ & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
+ & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
+ & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
+ & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
+ & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
+ & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
+ & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
+ & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
+ DATA (WT(K),K=426,510) /
+ & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
+ & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
+ & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
+ & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
+ & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
+ & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
+ & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
+ & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
+ & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
+ & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
+ & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
+ & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
+ & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
+ DATA (WT(K),K=511,540) /
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
+ & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
+ & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
+ & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
+C
+ DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
+ & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
+ & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
+ & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
+ & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
+ & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
+ & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
+* Particle numbers in decay channel
+ DATA (NZK(K,1),K= 1,170) /
+ & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
+ & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
+ & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
+ & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
+ & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
+ & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
+ & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
+ & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
+ & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
+ & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
+ & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
+ & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
+ & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
+ & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
+ & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
+ & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
+ & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
+ DATA (NZK(K,1),K=171,340) /
+ & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
+ & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
+ & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
+ & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
+ & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
+ & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
+ & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
+ & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
+ & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
+ & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
+ & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
+ & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
+ & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
+ & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
+ DATA (NZK(K,1),K=341,510) /
+ & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
+ & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
+ & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
+ & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
+ & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
+ & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
+ & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
+ & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
+ & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
+ & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
+ & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
+ & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
+ & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
+ & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
+ & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
+ & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
+ & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
+ DATA (NZK(K,1),K=511,540) /
+ & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
+ & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
+ & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
+ DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
+ & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
+ & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
+ & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
+ & 55, 8, 1, 8, 8, 54, 55, 210/
+ DATA (NZK(K,2),K= 1,170) /
+ & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
+ & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
+ & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
+ & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
+ & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
+ & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
+ & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
+ & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
+ & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
+ & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
+ & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
+ & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
+ & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
+ & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
+ & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
+ & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
+ & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
+ DATA (NZK(K,2),K=171,340) /
+ & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
+ & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
+ & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
+ & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
+ & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
+ & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
+ & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
+ & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
+ & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
+ & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
+ & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
+ & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
+ & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
+ & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
+ DATA (NZK(K,2),K=341,510) /
+ & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
+ & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
+ & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
+ & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
+ & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
+ & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
+ & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
+ & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
+ & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
+ & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
+ & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
+ & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
+ & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
+ & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
+ & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
+ & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
+ & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
+ DATA (NZK(K,2),K=511,540) /
+ & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
+ & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
+ DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
+ & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
+ & 14, 14, 23, 14, 16, 25,
+ & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
+ & 23, 13, 14, 23, 0 /
+ DATA (NZK(K,3),K= 1,170) /
+ & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
+ & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
+ & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
+ & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
+ & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
+ & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
+ & 110*0 /
+ DATA (NZK(K,3),K=171,340) /
+ & 80*0,
+ & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
+ & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
+ & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
+ & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
+ & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 30*0,
+ & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
+ DATA (NZK(K,3),K=341,510) /
+ & 30*0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
+ & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
+ & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
+ & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
+ & 80*0 /
+ DATA (NZK(K,3),K=511,540) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
+ & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
+ & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
+
+ END
+
+*
+*====phoini============================================================*
+*
+CDECK ID>, DT_XHOINI
+ SUBROUTINE DT_XHOINI
+C SUBROUTINE DT_PHOINI
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ RETURN
+ END
+*
+*====eventb============================================================*
+*
+CDECK ID>, DT_XVENTB
+ SUBROUTINE DT_XVENTB(NCSY,IREJ)
+C SUBROUTINE DT_EVENTB(NCSY,IREJ)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ WRITE(LOUT,1000)
+ 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
+ STOP
+
+ END
+*
+*===event==============================================================*
+*
+CDECK ID>, DT_XVENT
+ SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
+C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION PP(4),PT(4)
+
+ RETURN
+ END
+*
+*===pohisx=============================================================*
+*
+CDECK ID>, DT_XOHISX
+ SUBROUTINE DT_XOHISX(I,X)
+C SUBROUTINE POHISX(I,X)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ RETURN
+ END
+*
+*===poluhi=============================================================*
+*
+**PHOJET105a
+C SUBROUTINE XOLUHI(I,X)
+**PHOJET112
+
+CDECK ID>, PHO_LHIST
+ SUBROUTINE PHO_LHIST(I,X)
+
+**
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ RETURN
+ END
+*
+CDECK ID>, PDFSET
+C**********************************************************************
+C
+C dummy subroutines, remove to link PDFLIB
+C
+C**********************************************************************
+ SUBROUTINE PDFSET(PARAM,VALUE)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+ END
+CDECK ID>, STRUCTM
+ SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ END
+CDECK ID>, STRUCTP
+ SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ END
+*
+*===diqbrk=============================================================*
+*
+CDECK ID>, DT_DIQBRK
+ SUBROUTINE DT_XIQBRK
+C SUBROUTINE DT_DIQBRK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ STOP 'diquark-breaking not implemeted !'
+
+ RETURN
+ END
+*
+*===pho_rndm===========================================================*
+*
+CDECK ID>, PHO_RNDM
+ DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PHO_RNDM = DT_RNDM(DUMMY)
+
+ RETURN
+ END
+*
+*===pyr================================================================*
+*
+CDECK ID>, PYR
+ DOUBLE PRECISION FUNCTION PYR(IDUMMY)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DUMMY = DBLE(IDUMMY)
+ PYR = DT_RNDM(DUMMY)
+
+ RETURN
+ END
+*
+*===elhain=============================================================*
+*
+CDECK ID>, DT_ELHAIN
+ SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
+
+************************************************************************
+* Elastic hadron-hadron scattering. *
+* This is a revised version of the original. *
+* This version dated 03.04.98 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
+ & TINY10=1.0D-10)
+
+ PARAMETER (ENNTHR = 3.5D0)
+ PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
+ & BLOWB=0.05D0,BHIB=0.2D0,
+ & BLOWM=0.1D0, BHIM=2.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)
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+C DATA TSLOPE /10.0D0/
+
+ IREJ = 0
+
+ 1 CONTINUE
+
+ PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
+ EKIN = ELAB-AAM(IP)
+* kinematical quantities in cms of the hadrons
+ AMP2 = AAM(IP)**2
+ AMT2 = AAM(IT)**2
+ S = AMP2+AMT2+TWO*ELAB*AAM(IT)
+ ECM = SQRT(S)
+ ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
+ PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
+
+* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
+ IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
+ & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
+* TSAMCS treats pp and np only, therefore change pn into np and
+* nn into pp
+ IF (IT.EQ.1) THEN
+ KPROJ = IP
+ ELSE
+ KPROJ = 8
+ IF (IP.EQ.8) KPROJ = 1
+ ENDIF
+ CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
+ T = TWO*PCM**2*(CTCMS-ONE)
+
+* very crude treatment otherwise: sample t from exponential dist.
+ ELSE
+* momentum transfer t
+ TMAX = TWO*TWO*PCM**2
+ RR = (PLAB-PLOWH)/(PHIH-PLOWH)
+ IF (IIBAR(IP).NE.0) THEN
+ TSLOPE = BLOWB+RR*(BHIB-BLOWB)
+ ELSE
+ TSLOPE = BLOWM+RR*(BHIM-BLOWM)
+ ENDIF
+ FMAX = EXP(-TSLOPE*TMAX)-ONE
+ R = DT_RNDM(RR)
+ T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
+ IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
+ ENDIF
+
+* target hadron in Lab after scattering
+ ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
+ PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
+ IF (PLRH(2).LE.TINY10) THEN
+C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
+ GOTO 1
+ ENDIF
+* projectile hadron in Lab after scattering
+ ELRH(1) = ELAB+AAM(IT)-ELRH(2)
+ PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
+* scattering angle of projectile in Lab
+ CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
+ STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
+ CALL DT_DSFECF(SPLABP,CPLABP)
+* direction cosines of projectile in Lab
+ CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
+ & CXRH(1),CYRH(1),CZRH(1))
+* scattering angle of target in Lab
+ PLLABT = PLAB-CTLABP*PLRH(1)
+ CTLABT = PLLABT/PLRH(2)
+ STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
+* direction cosines of target in Lab
+ CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
+ & CXRH(2),CYRH(2),CZRH(2))
+* fill /HNFSPA/
+ IRH = 2
+ ITRH(1) = IP
+ ITRH(2) = IT
+
+ RETURN
+ END
+*
+*===tsamcs=============================================================*
+*
+CDECK ID>, DT_TSAMCS
+ SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
+
+************************************************************************
+* Sampling of cos(theta) for nucleon-proton scattering according to *
+* hetkfa2/bertini parametrization. *
+* This is a revised version of the original (HJM 24/10/88) *
+* This version dated 28.10.95 is written by S. Roesler *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
+ & TINY10=1.0D-10)
+
+ DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
+ DIMENSION PDCI(60),PDCH(55)
+
+ DATA (DCLIN(I),I=1,80) /
+ & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
+ & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
+ & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
+ & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
+ & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
+ & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
+ & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
+ & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
+ & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
+ & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
+ & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
+ & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
+ & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
+ & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
+ & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
+ & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
+ DATA (DCLIN(I),I=81,160) /
+ & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
+ & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
+ & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
+ & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
+ & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
+ & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
+ & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
+ & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
+ & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
+ & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
+ & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
+ & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
+ & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
+ & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
+ & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
+ & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
+ DATA (DCLIN(I),I=161,195) /
+ & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
+ & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
+ & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
+ & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
+ & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
+ & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
+ & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
+
+ DATA PDCI /
+ & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
+ & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
+ & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
+ & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
+ & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
+ & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
+ & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
+ & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
+ & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
+ & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
+ & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
+ & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
+
+ DATA PDCH /
+ & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
+ & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
+ & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
+ & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
+ & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
+ & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
+ & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
+ & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
+ & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
+ & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
+ & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
+
+ DATA (DCHN(I),I=1,90) /
+ & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
+ & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
+ & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
+ & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
+ & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
+ & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
+ & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
+ & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
+ & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
+ & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
+ & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
+ & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
+ & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
+ & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
+ & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
+ & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
+ & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
+ & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
+ DATA (DCHN(I),I=91,143) /
+ & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
+ & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
+ & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
+ & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
+ & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
+ & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
+ & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
+ & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
+ & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
+ & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
+ & 6.488D-02, 6.485D-02, 6.480D-02/
+
+ DATA DCHNA /
+ & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
+ & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
+ & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
+ & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
+ & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
+ & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
+ & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
+ & 1.000D+00/
+
+ DATA DCHNB /
+ & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
+ & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
+ & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
+ & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
+ & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
+ & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
+ & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
+ & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
+ & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
+ & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
+
+ CST = ONE
+ IF (EKIN.GT.3.5D0) RETURN
+C
+ IF(KPROJ.EQ.8) GOTO 101
+ IF(KPROJ.EQ.1) GOTO 102
+C* INVALID REACTION
+ WRITE(LOUT,'(A,I5/A)')
+ & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
+ & ' COS(THETA) = 1D0 RETURNED'
+ RETURN
+C-------------------------------- NP ELASTIC SCATTERING----------
+101 CONTINUE
+ IF (EKIN.GT.0.740D0)GOTO 1000
+ IF (EKIN.LT.0.300D0)THEN
+C EKIN .LT. 300 MEV
+ IDAT=1
+ ELSE
+C 300 MEV < EKIN < 740 MEV
+ IDAT=6
+ END IF
+C
+ ENER=EKIN
+ IE=INT(ABS(ENER/0.020D0))
+ UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
+C FORWARD/BACKWARD DECISION
+ K=IDAT+5*IE
+ BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
+ IF (DT_RNDM(CST).LT.BWFW)THEN
+ VALUE2=-1D0
+ K=K+1
+ ELSE
+ VALUE2=1D0
+ K=K+3
+ END IF
+C
+ COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
+ RND=DT_RNDM(COEF)
+C
+ IF(RND.LT.COEF)THEN
+ CST=DT_RNDM(RND)
+ CST=CST*VALUE2
+ ELSE
+ R1=DT_RNDM(CST)
+ R2=DT_RNDM(R1)
+ R3=DT_RNDM(R2)
+ R4=DT_RNDM(R3)
+C
+ IF(VALUE2.GT.0.0)THEN
+ CST=MAX(R1,R2,R3,R4)
+ GOTO 1500
+ ELSE
+ R5=DT_RNDM(R4)
+C
+ IF (IDAT.EQ.1)THEN
+ CST=-MAX(R1,R2,R3,R4,R5)
+ ELSE
+ R6=DT_RNDM(R5)
+ R7=DT_RNDM(R6)
+ CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
+ END IF
+C
+ END IF
+C
+ END IF
+C
+ GOTO 1500
+C
+C******** EKIN .GT. 0.74 GEV
+C
+1000 ENER=EKIN - 0.66D0
+C IE=ABS(ENER/0.02)
+ IE=INT(ENER/0.02D0)
+ EMEV=EKIN*1D3
+C
+ UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
+ K=IE
+ BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
+ RND=DT_RNDM(BWFW)
+C FORWARD NEUTRON
+ IF (RND.GE.BWFW)THEN
+ DO 1200 K=10,36,9
+ IF (DCHNA(K).GT.EMEV) THEN
+ UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
+ UNIV=DT_RNDM(UNIVE)
+ DO 1100 I=1,8
+ II=K+I
+ P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
+C
+ IF (P.GT.UNIV)THEN
+ UNIV=DT_RNDM(UNIVE)
+ FLTI=DBLE(I)-UNIV
+ GOTO(290,290,290,290,330,340,350,360) I
+ END IF
+ 1100 CONTINUE
+ END IF
+ 1200 CONTINUE
+C
+ ELSE
+C BACKWARD NEUTRON
+ DO 1400 K=13,60,12
+ IF (DCHNB(K).GT.EMEV) THEN
+ UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
+ UNIV=DT_RNDM(UNIVE)
+ DO 1300 I=1,11
+ II=K+I
+ P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
+C
+ IF (P.GT.UNIV)THEN
+ UNIV=DT_RNDM(P)
+ FLTI=DBLE(I)-UNIV
+ GOTO(120,120,140,150,160,160,180,190,200,210,220) I
+ END IF
+ 1300 CONTINUE
+ END IF
+ 1400 CONTINUE
+ END IF
+C
+120 CST=1.0D-2*FLTI-1.0D0
+ GOTO 1500
+140 CST=2.0D-2*UNIV-0.98D0
+ GOTO 1500
+150 CST=4.0D-2*UNIV-0.96D0
+ GOTO 1500
+160 CST=6.0D-2*FLTI-1.16D0
+ GOTO 1500
+180 CST=8.0D-2*UNIV-0.80D0
+ GOTO 1500
+190 CST=1.0D-1*UNIV-0.72D0
+ GOTO 1500
+200 CST=1.2D-1*UNIV-0.62D0
+ GOTO 1500
+210 CST=2.0D-1*UNIV-0.50D0
+ GOTO 1500
+220 CST=3.0D-1*(UNIV-1.0D0)
+ GOTO 1500
+C
+290 CST=1.0D0-2.5d-2*FLTI
+ GOTO 1500
+330 CST=0.85D0+0.5D-1*UNIV
+ GOTO 1500
+340 CST=0.70D0+1.5D-1*UNIV
+ GOTO 1500
+350 CST=0.50D0+2.0D-1*UNIV
+ GOTO 1500
+360 CST=0.50D0*UNIV
+C
+1500 RETURN
+C
+C----------------------------------- PP ELASTIC SCATTERING -------
+C
+ 102 CONTINUE
+ EMEV=EKIN*1D3
+C
+ IF (EKIN.LE.0.500D0) THEN
+ RND=DT_RNDM(EMEV)
+ CST=2.0D0*RND-1.0D0
+ RETURN
+C
+ ELSEIF (EKIN.LT.1.0D0) THEN
+ DO 2200 K=13,60,12
+ IF (PDCI(K).GT.EMEV) THEN
+ UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
+ UNIV=DT_RNDM(UNIVE)
+ SUM=0
+ DO 2100 I=1,11
+ II=K+I
+ SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
+C
+ IF (UNIV.LT.SUM)THEN
+ UNIV=DT_RNDM(SUM)
+ FLTI=DBLE(I)-UNIV
+ GOTO(55,55,55,60,60,65,65,65,65,70,70) I
+ END IF
+ 2100 CONTINUE
+ END IF
+ 2200 CONTINUE
+ ELSE
+ DO 2400 K=12,55,11
+ IF (PDCH(K).GT.EMEV) THEN
+ UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
+ UNIV=DT_RNDM(UNIVE)
+ SUM=0.0D0
+ DO 2300 I=1,10
+ II=K+I
+ SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
+C
+ IF (UNIV.LT.SUM)THEN
+ UNIV=DT_RNDM(SUM)
+ FLTI=UNIV+DBLE(I)
+ GOTO(50,55,60,60,65,65,65,65,70,70) I
+ END IF
+ 2300 CONTINUE
+ END IF
+ 2400 CONTINUE
+ END IF
+C
+50 CST=0.4D0*UNIV
+ GOTO 2500
+55 CST=0.2D0*FLTI
+ GOTO 2500
+60 CST=0.3D0+0.1D0*FLTI
+ GOTO 2500
+65 CST=0.6D0+0.04D0*FLTI
+ GOTO 2500
+70 CST=0.78D0+0.02D0*FLTI
+C
+2500 CONTINUE
+ IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
+C
+ RETURN
+ END
+*
+*===dhadri=============================================================*
+*
+CDECK ID>, DT_DHADRI
+ SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C
+C-----------------------------
+C*** INPUT VARIABLES LIST:
+C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
+C*** GEV/C LABORATORY MOMENTUM REGION
+C*** N - PROJECTILE HADRON INDEX
+C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
+C*** ELAB - LABORATORY ENERGY OF N (GEV)
+C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
+C*** ITTA - TARGET NUCLEON INDEX
+C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
+C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
+C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
+C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
+C*** RESPECT., UNITS (GEV/C AND GEV)
+C----------------------------
+
+ COMMON /HNGAMR/ REDU,AMO,AMM(15)
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+ COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
+ & ITS(149),IS
+ COMMON /HNDRUN/ RUNTES,EFTES
+* 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)
+* final state from HADRIN interaction
+ PARAMETER (MAXFIN=10)
+ COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
+ & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
+
+ DIMENSION ITPRF(110)
+ DATA NNN/0/
+ DATA UMODA/0./
+ DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
+ LOWP=0
+ IF (N.LE.0.OR.N.GE.111)N=1
+ IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
+ GOTO 280
+* WRITE (6,1000)
+* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
+* STOP
+*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
+* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
+ ENDIF
+ IATMPT=0
+ IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
+C IF(IPRI.GE.1) WRITE (6,1010) PLAB
+C STOP
+ 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
+ + ALLOWED REGION, PLAB=',1E15.5)
+
+ 20 CONTINUE
+ UMODAT=N*1.11111D0+ITTA*2.19291D0
+ IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
+ UMODA=UMODAT
+ 30 IATMPT=0
+ LOWP=LOWP+1
+ 40 CONTINUE
+ IMACH=0
+ REDU=2.0D0
+ IF (LOWP.GT.20) THEN
+C WRITE(LOUT,*) ' jump 1'
+ GO TO 280
+ ENDIF
+ NNN=N
+ IF (NNN.EQ.N) GO TO 50
+ RUNTES=0.0D0
+ EFTES=0.0D0
+ 50 CONTINUE
+ IS=1
+ IRH=0
+ IST=1
+ NSTAB=23
+ IRE=NURE(N,1)
+ IF(ITTA.GT.1) IRE=NURE(N,2)
+C
+C-----------------------------
+C*** IE,AMT,ECM,SI DETERMINATION
+C----------------------------
+ CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
+ IANTH=-1
+**sr
+C IF (AMH(1).NE.0.93828D0) IANTH=1
+ IF (AMH(1).NE.0.9383D0) IANTH=1
+**
+ IF (IANTH.GE.0) SI=1.0D0
+ ECMMH=ECM
+C
+C-----------------------------
+C ENERGY INDEX
+C IRE CHARACTERIZES THE REACTION
+C IE IS THE ENERGY INDEX
+C----------------------------
+ IF (SI.LT.1.D-6) THEN
+C WRITE(LOUT,*) ' jump 2'
+ GO TO 280
+ ENDIF
+ IF (N.LE.NSTAB) GO TO 60
+ RUNTES=RUNTES+1.0D0
+ IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
+ 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
+ IF(IBARH(N).EQ.1) N=8
+ IF(IBARH(N).EQ.-1) N=9
+ 60 CONTINUE
+ IMACH=IMACH+1
+**sr 19.2.97: loop for direct channel suppression
+C IF (IMACH.GT.10) THEN
+ IF (IMACH.GT.1000) THEN
+**
+C WRITE(LOUT,*) ' jump 3'
+ GO TO 280
+ ENDIF
+ ECM =ECMMH
+ AMN2=AMN**2
+ AMT2=AMT**2
+ ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
+ IF(ECMN.LE.AMN) ECMN=AMN
+ PCMN=SQRT(ECMN**2-AMN2)
+ GAM=(ELAB+AMT)/ECM
+ BGAM=PLAB/ECM
+ IF (IANTH.GE.0) ECM=2.1D0
+C
+C-----------------------------
+C*** RANDOM CHOICE OF REACTION CHANNEL
+C----------------------------
+ IST=0
+ VV=DT_RNDM(AMN2)
+ VV=VV-1.D-17
+C
+C-----------------------------
+C*** PLACE REDUCED VERSION
+C----------------------------
+ IIEI=IEII(IRE)
+ IDWK=IEII(IRE+1)-IIEI
+ IIWK=IRII(IRE)
+ IIKI=IKII(IRE)
+C
+C-----------------------------
+C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
+C----------------------------
+ HECM=ECM
+ HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
+ IF (HUMO.LT.ECM) ECM=HUMO
+C
+C-----------------------------
+C*** INTERPOLATION PREPARATION
+C----------------------------
+ ECMO=UMO(IE)
+ ECM1=UMO(IE-1)
+ DECM=ECMO-ECM1
+ DEC=ECMO-ECM
+C
+C-----------------------------
+C*** RANDOM LOOP
+C----------------------------
+ IK=0
+ WKK=0.0D0
+ WICOR=0.0D0
+ 70 IK=IK+1
+ IWK=IIWK+(IK-1)*IDWK+IE-IIEI
+ WOK=WK(IWK)
+ WDK=WOK-WK(IWK-1)
+C
+C-----------------------------
+C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
+C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
+C CONTRIBUTE
+C----------------------------
+ IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
+ WICO=WOK*1.23459876D0+WDK*1.735218469D0
+ IF (WICO.EQ.WICOR) GO TO 70
+ IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
+ WICOR=WICO
+C
+C-----------------------------
+C*** INTERPOLATION IN CHANNEL WEIGHTS
+C----------------------------
+ EKLIM=-THRESH(IIKI+IK)
+ IELIM=IDT_IEFUND(EKLIM,IRE)
+ DELIM=UMO(IELIM)+EKLIM
+ *+1.D-16
+ DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
+ IF (DELIM*DELIM-DETE*DETE) 90,90,80
+ 80 DECC=DELIM
+ GO TO 100
+ 90 DECC=DECM
+ 100 CONTINUE
+ WKK=WOK-WDK*DEC/(DECC+1.D-9)
+C
+C-----------------------------
+C*** RANDOM CHOICE
+C----------------------------
+C
+ IF (VV.GT.WKK) GO TO 70
+C
+C***IK IS THE REACTION CHANNEL
+C----------------------------
+ INRK=IKII(IRE)+IK
+ ECM=HECM
+ I1001 =0
+C
+ 110 CONTINUE
+ IT1=NRK(1,INRK)
+ AM1=DT_DAMG(IT1)
+ IT2=NRK(2,INRK)
+ AM2=DT_DAMG(IT2)
+ AMS=AM1+AM2
+ I1001=I1001+1
+ IF (I1001.GT.50) GO TO 60
+C
+ IF (IT2*AMS.GT.IT2*ECM) GO TO 110
+ IT11=IT1
+ IT22=IT2
+ IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
+ AM11=AM1
+ AM22=AM2
+ IF (IT2.GT.0) GO TO 120
+**sr 19.2.97: supress direct channel for pp-collisions
+ IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
+ RR = DT_RNDM(AM11)
+ IF (RR.LE.0.75D0) GOTO 60
+ ENDIF
+**
+C
+C-----------------------------
+C INCLUSION OF DIRECT RESONANCES
+C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
+C------------------------
+ KZ1=K1H(IT1)
+ IST=IST+1
+ IECO=0
+ ECO=ECM
+ GAM=(ELAB+AMT)/ECO
+ BGAM=PLAB/ECO
+ CXS(1)=CX
+ CYS(1)=CY
+ CZS(1)=CZ
+ GO TO 170
+ 120 CONTINUE
+ WW=DT_RNDM(ECO)
+ IF(WW.LT. 0.5D0) GO TO 130
+ IT1=IT22
+ IT2=IT11
+ AM1=AM22
+ AM2=AM11
+ 130 CONTINUE
+C
+C-----------------------------
+C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
+ IBN=IBARH(N)
+ IB1=IBARH(IT1)
+ IT11=IT1
+ IT22=IT2
+ AM11=AM1
+ AM22=AM2
+ IF(IB1.EQ.IBN) GO TO 140
+ IT1=IT22
+ IT2=IT11
+ AM1=AM22
+ AM2=AM11
+ 140 CONTINUE
+C-----------------------------
+C***IT1,IT2 ARE THE CREATED PARTICLES
+C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
+C------------------------
+ CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
+ *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
+ IST=IST+1
+ ITS(IST)=IT1
+ AMM(IST)=AM1
+C
+C-----------------------------
+C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
+C----------------------------
+ CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
+ &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IST=IST+1
+ ITS(IST)=IT2
+ AMM(IST)=AM2
+ CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
+ *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ 150 CONTINUE
+C
+C-----------------------------
+C***TEST STABLE OR UNSTABLE
+C----------------------------
+ IF(ITS(IST).GT.NSTAB) GO TO 160
+ IRH=IRH+1
+C
+C-----------------------------
+C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
+C----------------------------
+C* IF (REDU.LT.0.D0) GO TO 1009
+ ITRH(IRH)=ITS(IST)
+ PLRH(IRH)=PLS(IST)
+ CXRH(IRH)=CXS(IST)
+ CYRH(IRH)=CYS(IST)
+ CZRH(IRH)=CZS(IST)
+ ELRH(IRH)=ELS(IST)
+ IST=IST-1
+ IF(IST.GE.1) GO TO 150
+ GO TO 260
+ 160 CONTINUE
+C
+C RANDOM CHOICE OF DECAY CHANNELS
+C----------------------------
+C
+ IT=ITS(IST)
+ ECO=AMM(IST)
+ GAM=ELS(IST)/ECO
+ BGAM=PLS(IST)/ECO
+ IECO=0
+ KZ1=K1H(IT)
+ 170 CONTINUE
+ IECO=IECO+1
+ VV=DT_RNDM(GAM)
+ VV=VV-1.D-17
+ IIK=KZ1-1
+ 180 IIK=IIK+1
+ IF (VV.GT.WTI(IIK)) GO TO 180
+C
+C IIK IS THE DECAY CHANNEL
+C----------------------------
+ IT1=NZKI(IIK,1)
+ I310=0
+ 190 CONTINUE
+ I310=I310+1
+ AM1=DT_DAMG(IT1)
+ IT2=NZKI(IIK,2)
+ AM2=DT_DAMG(IT2)
+ IF (IT2-1.LT.0) GO TO 240
+ IT3=NZKI(IIK,3)
+ AM3=DT_DAMG(IT3)
+ AMS=AM1+AM2+AM3
+C
+C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
+C----------------------------
+ IF (IECO.LE.10) GO TO 200
+ IATMPT=IATMPT+1
+ IF(IATMPT.GT.3) THEN
+C WRITE(LOUT,*) ' jump 4'
+ GO TO 280
+ ENDIF
+ GO TO 40
+ 200 CONTINUE
+ IF (I310.GT.50) GO TO 170
+ IF (AMS.GT.ECO) GO TO 190
+C
+C FOR THE DECAY CHANNEL
+C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
+C----------------------------
+ IF (REDU.LT.0.D0) GO TO 30
+ ITWTHC=0
+ REDU=2.0D0
+ IF(IT3.EQ.0) GO TO 220
+ 210 CONTINUE
+ ITWTH=1
+ CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
+ *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
+ GO TO 230
+ 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
+ &COD2,COF2,SIF2,AM1,AM2)
+ ITWTH=-1
+ IT3=0
+ 230 CONTINUE
+ ITWTHC=ITWTHC+1
+ IF (REDU.GT.0.D0) GO TO 240
+ REDU=2.0D0
+ IF (ITWTHC.GT.100) GO TO 30
+ IF (ITWTH) 220,220,210
+ 240 CONTINUE
+ ITS(IST )=IT1
+ IF (IT2-1.LT.0) GO TO 250
+ ITS(IST+1) =IT2
+ ITS(IST+2)=IT3
+ RX=CXS(IST)
+ RY=CYS(IST)
+ RZ=CZS(IST)
+ AMM(IST)=AM1
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IST=IST+1
+ AMM(IST)=AM2
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ IF (IT3.LE.0) GO TO 250
+ IST=IST+1
+ AMM(IST)=AM3
+ CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
+ *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
+ 250 CONTINUE
+ GO TO 150
+ 260 CONTINUE
+ 270 CONTINUE
+ RETURN
+ 280 CONTINUE
+C
+C----------------------------
+C
+C ZERO CROSS SECTION CASE
+C----------------------------
+C
+ IRH=1
+ ITRH(1)=N
+ CXRH(1)=CX
+ CYRH(1)=CY
+ CZRH(1)=CZ
+ ELRH(1)=ELAB
+ PLRH(1)=PLAB
+ RETURN
+ END
+*
+*===runtt==============================================================*
+*
+CDECK ID>, DT_RUNTT
+ BLOCK DATA DT_RUNTT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /HNDRUN/ RUNTES,EFTES
+
+ DATA RUNTES,EFTES /100.D0,100.D0/
+
+ END
+*
+*===noname=============================================================*
+*
+CDECK ID>, DT_NONAME
+ BLOCK DATA DT_NONAME
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* slope parameters for HADRIN interactions
+ COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+
+C DATAS DATAS DATAS DATAS DATAS
+C****** *********
+ DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
+ & 207, 224, 241, 252, 268 /
+ DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
+ & 220, 241, 262, 279, 296 /
+ DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
+ & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
+
+C
+C MASSES FOR THE SLOPE B(M) IN GEV
+C SLOPE B(M) FOR AN MESONIC SYSTEM
+C SLOPE B(M) FOR A BARYONIC SYSTEM
+
+*
+ DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
+ & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
+ & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
+ & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
+ & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
+ & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
+ & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
+ & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
+ & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
+ & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
+ & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
+ & 14.2D0, 13.4D0, 12.6D0,
+ & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
+ & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
+*
+ END
+*
+*===damg===============================================================*
+*
+CDECK ID>, DT_DAMG
+ DOUBLE PRECISION FUNCTION DT_DAMG(IT)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ DIMENSION GASUNI(14)
+ DATA GASUNI/
+ *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
+ *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
+ DATA GAUNO/2.352D0/
+ DATA GAUNON/2.4D0/
+ DATA IO/14/
+ DATA NSTAB/23/
+
+ I=1
+ IF (IT.LE.0) GO TO 30
+ IF (IT.LE.NSTAB) GO TO 20
+ DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
+ VV=DT_RNDM(DGAUNI)
+ VV=VV*2.0D0-1.0D0+1.D-16
+ 10 CONTINUE
+ VO=GASUNI(I)
+ I=I+1
+ V1=GASUNI(I)
+ IF (VV.GT.V1) GO TO 10
+ UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
+ & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
+ DAM=GAH(IT)*UNIGA/GAUNO
+ AAM=AMH(IT)+DAM
+ DT_DAMG=AAM
+ RETURN
+ 20 CONTINUE
+ DT_DAMG=AMH(IT)
+ RETURN
+ 30 CONTINUE
+ DT_DAMG=0.0D0
+ RETURN
+ END
+*
+*===dcalum=============================================================*
+*
+CDECK ID>, DT_DCALUM
+ SUBROUTINE DT_DCALUM(N,ITTA)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IRE=NURE(N,ITTA/8+1)
+ IEO=IEII(IRE)+1
+ IEE=IEII(IRE +1)
+ AM1=AMH(N )
+ AM12=AM1**2
+ AM2=AMH(ITTA)
+ AM22=AM2**2
+ DO 10 IE=IEO,IEE
+ PLAB2=PLABF(IE)**2
+ ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
+ UMO(IE)=ELAB
+ 10 CONTINUE
+ IKO=IKII(IRE)+1
+ IKE=IKII(IRE +1)
+ UMOO=UMO(IEO)
+ DO 30 IK=IKO,IKE
+ IF(NRK(2,IK).GT.0) GO TO 30
+ IKI=NRK(1,IK)
+ AMSS=5.0D0
+ K11=K1H(IKI)
+ K22=K2H(IKI)
+ DO 20 IK1=K11,K22
+ IN=NZKI(IK1,1)
+ AMS=AMH(IN)
+ IN=NZKI(IK1,2)
+ IF(IN.GT.0)AMS=AMS+AMH(IN)
+ IN=NZKI(IK1,3)
+ IF(IN.GT.0) AMS=AMS+AMH(IN)
+ IF (AMS.LT.AMSS) AMSS=AMS
+ 20 CONTINUE
+ IF(UMOO.LT.AMSS) UMOO=AMSS
+ THRESH(IK)=UMOO
+ 30 CONTINUE
+ RETURN
+ END
+*
+*===dchanh=============================================================*
+*
+CDECK ID>, DT_DCHANH
+ SUBROUTINE DT_DCHANH
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ DIMENSION HWT(460),HWK(40),SI(5184)
+ EQUIVALENCE (WK(1),SI(1))
+C--------------------
+C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
+C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
+C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
+C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
+C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
+C--------------------------
+ IREG=16
+ DO 90 IRE=1,IREG
+ IWKO=IRII(IRE)
+ IEE=IEII(IRE+1)-IEII(IRE)
+ IKE=IKII(IRE+1)-IKII(IRE)
+ IEO=IEII(IRE)+1
+ IIKA=IKII(IRE)
+* modifications to suppress elestic scattering 24/07/91
+ DO 80 IE=1,IEE
+ SIS=1.D-14
+ SINORC=0.0D0
+ DO 10 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
+ SIS=SIS+SI(IWK)*SINORC
+ 10 CONTINUE
+ SIIN(IEO+IE-1)=SIS
+ SIO=0.D0
+ IF (SIS.GE.1.D-12) GO TO 20
+ SIS=1.D0
+ SIO=1.D0
+ 20 CONTINUE
+ SINORC=0.0D0
+ DO 30 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
+ SIO=SIO+SI(IWK)*SINORC/SIS
+ HWK(IK)=SIO
+ 30 CONTINUE
+ DO 40 IK=1,IKE
+ IWK=IWKO+IEE*(IK-1)+IE
+ 40 WK(IWK)=HWK(IK)
+ IIKI=IKII(IRE)
+ DO 70 IK=1,IKE
+ AM111=0.D0
+ INRK1=NRK(1,IIKI+IK)
+ IF (INRK1.GT.0) AM111=AMH(INRK1)
+ AM222=0.D0
+ INRK2=NRK(2,IIKI+IK)
+ IF (INRK2.GT.0) AM222=AMH(INRK2)
+ THRESH(IIKI+IK)=AM111 +AM222
+ IF (INRK2-1.GE.0) GO TO 60
+ INRKK=K1H(INRK1)
+ AMSS=5.D0
+ INRKO=K2H(INRK1)
+ DO 50 INRK1=INRKK,INRKO
+ INZK1=NZKI(INRK1,1)
+ INZK2=NZKI(INRK1,2)
+ INZK3=NZKI(INRK1,3)
+ IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
+ IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
+ IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
+C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
+ 1000 FORMAT (4I10)
+ AMS=AMH(INZK1)+AMH(INZK2)
+ IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
+ IF (AMSS.GT.AMS) AMSS=AMS
+ 50 CONTINUE
+ AMS=AMSS
+ IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
+ THRESH(IIKI+IK)=AMS
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ DO 100 J=1,460
+ 100 HWT(J)=0.D0
+ DO 120 I=1,110
+ IK1=K1H(I)
+ IK2=K2H(I)
+ HV=0.D0
+ IF (IK2.GT.460)IK2=460
+ IF (IK1.LE.0)IK1=1
+ DO 110 J=IK1,IK2
+ HV=HV+WTI(J)
+ HWT(J)=HV
+ JI=J
+ 110 CONTINUE
+ IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
+ 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
+ 120 CONTINUE
+ DO 130 J=1,460
+ 130 WTI(J)=HWT(J)
+ RETURN
+ END
+*
+*===dhadde=============================================================*
+*
+CDECK ID>, DT_DHADDE
+ SUBROUTINE DT_DHADDE
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* 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)
+* HADRIN: decay channel information
+ PARAMETER (IDMAX9=602)
+ CHARACTER*8 ZKNAME
+ COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+ COMMON /HNSPLI/ WTI(460),NZKI(460,3)
+* decay channel information for HADRIN
+ COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
+ & K1Z(16),K2Z(16),WTZ(153),II22,
+ & NZK1(153),NZK2(153),NZK3(153)
+
+ DATA IRETUR/0/
+
+ IRETUR=IRETUR+1
+ AMH(31)=0.48D0
+ IF (IRETUR.GT.1) RETURN
+ DO 10 I=1,94
+ AMH(I) = AAM(I)
+ GAH(I) = GA(I)
+ TAUH(I) = TAU(I)
+ ICHH(I) = IICH(I)
+ IBARH(I) = IIBAR(I)
+ K1H(I) = K1(I)
+ K2H(I) = K2(I)
+ 10 CONTINUE
+**sr
+C AMH(1)=0.93828D0
+ AMH(1)=0.9383D0
+**
+ AMH(2)=AMH(1)
+ DO 20 I=26,30
+ K1H(I)=452
+ K2H(I)=452
+ 20 CONTINUE
+ DO 30 I=1,307
+ WTI(I) = WT(I)
+ NZKI(I,1) = NZK(I,1)
+ NZKI(I,2) = NZK(I,2)
+ NZKI(I,3) = NZK(I,3)
+ 30 CONTINUE
+ DO 40 I=1,16
+ L=I+94
+ AMH(L)=AMZ(I)
+ GAH( L)=GAZ(I)
+ TAUH( L)=TAUZ(I)
+ ICHH( L)=ICHZ(I)
+ IBARH( L)=IBARZ(I)
+ K1H( L)=K1Z(I)
+ K2H( L)=K2Z(I)
+ 40 CONTINUE
+ DO 50 I=1,153
+ L=I+307
+ WTI(L) = WTZ(I)
+ NZKI(L,3) = NZK3(I)
+ NZKI(L,2) = NZK2(I)
+ NZKI(L,1) = NZK1(I)
+ 50 CONTINUE
+ RETURN
+ END
+*
+*===iefund=============================================================*
+*
+CDECK ID>, IDT_IEFUND
+ INTEGER FUNCTION IDT_IEFUND(PL,IRE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C*****IEFUN CALCULATES A MOMENTUM INDEX
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ COMMON /HNDRUN/ RUNTES,EFTES
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IPLA=IEII(IRE)+1
+ *+1
+ IPLE=IEII(IRE+1)
+ IF (PL.LT.0.) GO TO 30
+ DO 10 I=IPLA,IPLE
+ J=I-IPLA+1
+ IF (PL.LE.PLABF(I)) GO TO 60
+ 10 CONTINUE
+ I=IPLE
+ IF ( EFTES.GT.40.D0) GO TO 20
+ EFTES=EFTES+1.0D0
+ WRITE(LOUT,1000)PL,J
+ 20 CONTINUE
+ GO TO 70
+ 30 CONTINUE
+ DO 40 I=IPLA,IPLE
+ J=I-IPLA+1
+ IF (-PL.LE.UMO(I)) GO TO 60
+ 40 CONTINUE
+ I=IPLE
+ IF ( EFTES.GT.40.D0) GO TO 50
+ EFTES=EFTES+1.0D0
+ WRITE(LOUT,1000)PL,I
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ IDT_IEFUND=I
+ RETURN
+ 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
+ +7H IEFUN=,I5)
+ END
+*
+*===dsigin=============================================================*
+*
+CDECK ID>, DT_DSIGIN
+ SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+ COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ IE=IDT_IEFUND(PLAB,IRE)
+ IF (IE.LE.IEII(IRE)) IE=IE+1
+ AMT=AMH(ITAR)
+ AMN=AMH(N)
+ AMN2=AMN*AMN
+ AMT2=AMT*AMT
+ ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
+C*** INTERPOLATION PREPARATION
+ ECMO=UMO(IE)
+ ECM1=UMO(IE-1)
+ DECM=ECMO-ECM1
+ DEC=ECMO-ECM
+ IIKI=IKII(IRE)+1
+ EKLIM=-THRESH(IIKI)
+ WOK=SIIN(IE)
+ WDK=WOK-SIIN(IE-1)
+ IF (ECM.GT.ECMO) WDK=0.0D0
+C*** INTERPOLATION IN CHANNEL WEIGHTS
+ IELIM=IDT_IEFUND(EKLIM,IRE)
+ DELIM=UMO(IELIM)+EKLIM
+ *+1.D-16
+ DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
+ IF (DELIM*DELIM-DETE*DETE) 20,20,10
+ 10 DECC=DELIM
+ GO TO 30
+ 20 DECC=DECM
+ 30 CONTINUE
+ WKK=WOK-WDK*DEC/(DECC+1.D-9)
+ IF (WKK.LT.0.0D0) WKK=0.0D0
+ SI=WKK+1.D-12
+ IF (-EKLIM.GT.ECM) SI=1.D-14
+ RETURN
+ END
+*
+*===dtchoi=============================================================*
+*
+CDECK ID>, DT_DTCHOI
+ SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C ****************************
+C TCHOIC CALCULATES A RANDOM VALUE
+C FOR THE FOUR-MOMENTUM-TRANSFER T
+C ****************************
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+* slope parameters for HADRIN interactions
+ COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
+
+ AMA=AM1
+ AMB=AM2
+ IF (I.GT.30.AND.II.GT.30) GO TO 20
+ III=II
+ AM3=AM2
+ IF (I.LE.30) GO TO 10
+ III=I
+ AM3=AM1
+ 10 CONTINUE
+ GO TO 30
+ 20 CONTINUE
+ III=II
+ AM3=AM2
+ IF (AMA.LE.AMB) GO TO 30
+ III=I
+ AM3=AM1
+ 30 CONTINUE
+ IB=IBARH(III)
+ AMA=AM3
+ K=INT((AMA-0.75D0)/0.05D0)
+ IF (K-2.LT.0) K=1
+ IF (K-26.GE.0) K=25
+ IF (IB)50,40,50
+ 40 BM=BBM(K)
+ GO TO 60
+ 50 BM=BBB(K)
+ 60 CONTINUE
+C NORMALIZATION
+ TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
+ TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
+ VB=DT_RNDM(TMIN)
+**sr test
+C IF (VB.LT.0.2D0) BM=BM*0.1
+C **0.5
+ BM = BM*5.05D0
+**
+ TMI=BM*TMIN
+ TMA=BM*TMAX
+ ETMA=0.D0
+ IF (ABS(TMA).GT.120.D0) GO TO 70
+ ETMA=EXP(TMA)
+ 70 CONTINUE
+ AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
+C*** RANDOM CHOICE OF THE T - VALUE
+ R=DT_RNDM(TMI)
+ T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
+ RETURN
+ END
+*
+*===dtwopa=============================================================*
+*
+CDECK ID>, DT_DTWOPA
+ SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
+ &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C ******************************************************
+C QUASI TWO PARTICLE PRODUCTION
+C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
+C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
+C IN THE CM - SYSTEM
+C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
+C SPHERICAL COORDINATES
+C ******************************************************
+
+* particle properties (BAMJET index convention),
+* (dublicate of DTPART for HADRIN)
+ COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
+ & K1H(110),K2H(110)
+
+ AMA=AM1
+ AMB=AM2
+ AMA2=AMA*AMA
+ E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
+ E2=UMOO - E1
+ IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
+ AMTE=(E1-AMA)*(E1+AMA)
+ AMTE=AMTE+1.D-18
+ P1=SQRT(AMTE)
+ P2=P1
+C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
+C DETERMINATION OF THE ANGLES
+C COS(THETA1)=COD1 COS(THETA2)=COD2
+C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
+C COS(PHI1)=COF1 COS(PHI2)=COF2
+C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
+ CALL DT_DSFECF(COF1,SIF1)
+ COF2=-COF1
+ SIF2=-SIF1
+C CALCULATION OF THETA1
+ CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
+ COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
+ IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
+ COD2=-COD1
+ RETURN
+ END
+*
+*===zk=================================================================*
+*
+CDECK ID>, DT_ZK
+ BLOCK DATA DT_ZK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* decay channel information for HADRIN
+ COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
+ & K1Z(16),K2Z(16),WTZ(153),II22,
+ & NZK1(153),NZK2(153),NZK3(153)
+* decay channel information for HADRIN
+ CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
+ COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
+
+* Particle masses in GeV *
+ DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
+ & 2*1.7D0, 3*0.D0/
+* Resonance width Gamma in GeV *
+ DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
+* Mean life time in seconds *
+ DATA TAUZ / 16*0.D0 /
+* Charge of particles and resonances *
+ DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
+* Baryonic charge *
+ DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
+* First number of decay channels used for resonances *
+* and decaying particles *
+ DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
+ & 3*460/
+* Last number of decay channels used for resonances *
+* and decaying particles *
+ DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
+ & 3*460/
+* Weight of decay channel *
+ DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
+ & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
+ & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
+ & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
+ & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
+ & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
+ & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
+ & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
+ & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
+ & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
+ & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
+ & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
+ & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
+ & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
+ & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
+ & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
+ & .05D0, .65D0, 9*1.D0 /
+* Particle numbers in decay channel *
+ DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
+ & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
+ & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
+ & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
+ & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
+ & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
+ & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
+ & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
+ DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
+ & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
+ & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
+ & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
+ & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
+ & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
+ & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
+ & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
+ & 1, 8, 1, 8, 1, 9*0 /
+ DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
+ & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
+ & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
+ & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
+ & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
+ & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
+* Particle names *
+ DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
+ & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
+ & 3*'BLANK' /
+* Name of decay channel *
+ DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
+ & 'ANNPI0','APPPI0','ANPPI-'/
+ DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
+ & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
+ & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
+ & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
+ & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
+ & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
+ & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
+ & 'OMOMOM',
+ & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
+ & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
+ & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
+ & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
+ & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
+ & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
+ DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
+ & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
+ & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
+ & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
+ & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
+ & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
+ & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
+ & 9*'BLANK'/
+*= end*block.zk *
+ END
+*
+*===blkd43=============================================================*
+*
+CDECK ID>, DT_BLKD43
+ BLOCK DATA DT_BLKD43
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+*$ CREATE REAC.ADD
+*COPY REAC
+*
+*=== reac =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-dec-91 by Alfredo Ferrari *
+* *
+* This is the original common reac of Hadrin *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
+ & NRK(2,268),NURE(30,2)
+
+ DIMENSION
+ & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
+ & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
+ & SPIKP1(315), SPIKPU(278), SPIKPV(372),
+ & SPIKPW(278), SPIKPX(372), SPIKP4(315),
+ & SPIKP5(187), SPIKP6(289),
+ & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
+ & SPIKP9(143), SPIKP0(169), SPKPV(143),
+ & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
+ & SANPEL(84) , SPIKPF(273),
+ & SPKP15(187), SPKP16(272),
+ & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
+ & NURELN(60)
+*
+ DIMENSION NRKLIN(532)
+ EQUIVALENCE (NRK(1,1), NRKLIN(1))
+ EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
+ EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
+ EQUIVALENCE ( UMO(263), UMOK0(1))
+ EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
+ EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
+ EQUIVALENCE ( PLABF(263), PLAK0(1))
+ EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
+ EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
+ EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
+ EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
+ EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
+ EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
+ EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
+ EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
+ EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
+ EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
+ EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
+ EQUIVALENCE ( WK(4913), SPKP16(1))
+ EQUIVALENCE (NRK(1,1), NRKLIN(1))
+ EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
+ EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
+ EQUIVALENCE (NRKLIN( 483), NRKK0(1))
+ EQUIVALENCE (NURE(1,1), NURELN(1))
+*
+**** pi- p data *
+**** pi+ n data *
+ DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
+ & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
+ & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
+ & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
+ & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
+ & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
+ & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
+ & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
+ & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
+ & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
+ DATA PLAKC /
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
+ DATA PLAK0 /
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
+ & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
+ & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
+ & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
+* pp pn np nn *
+ DATA PLAP /
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
+* app apn anp ann *
+ DATA PLAN /
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
+ & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
+ & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
+ & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
+ DATA SIIN / 296*0.D0 /
+ DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
+ & 1.557D0,1.615D0,1.6435D0,
+ & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
+ & 2.286D0,2.366D0,2.482D0,2.56D0,
+ & 2.735D0,2.90D0,
+ & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
+ & 1.496D0,1.527D0,1.557D0,
+ & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
+ & 2.071D0,2.159D0,2.286D0,2.366D0,
+ & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
+ & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
+ & 1.496D0,1.527D0,1.557D0,
+ & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
+ & 2.071D0,2.159D0,2.286D0,2.366D0,
+ & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
+ & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
+ & 1.557D0,1.615D0,1.6435D0,
+ & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
+ & 2.286D0,2.366D0,2.482D0,2.56D0,
+ & 2.735D0, 2.90D0/
+ DATA UMOKC/ 1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0/
+ DATA UMOK0/ 1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0,1.44D0,
+ & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
+ & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
+ & 3.1D0/
+* pp pn np nn *
+ DATA UMOP/
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0/
+* app apn anp ann *
+ DATA UMON /
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0,
+ & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
+ & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
+ & 3.D0,3.1D0,3.2D0/
+**** reaction channel state particles *
+ DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
+ & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
+ & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
+ & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
+ & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
+ & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
+ & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
+ & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
+ & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
+ & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
+ DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
+ & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
+ & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
+ & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
+ & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
+ & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
+ & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
+ & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
+* *
+* k0 p k0 n ak0 p ak/ n *
+* *
+ DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
+ & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
+ & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
+ & 53, 47, 1, 103, 0, 93, 0/
+* pp pn np nn *
+ DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
+ & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
+ & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
+ & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
+* app apn anp ann *
+ DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
+ & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
+ & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
+ & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
+ & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
+ & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
+ & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
+**** channel cross section *
+ DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
+ & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
+ & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
+ & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
+ & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
+ &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
+ & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
+ & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
+ &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
+ & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
+ & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
+ & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
+ & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
+ & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
+ & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
+ & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
+ & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
+ & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
+ & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
+ & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
+**** pi+ n data *
+ DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
+ & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
+ & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
+ & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
+ & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
+ & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
+ & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
+ & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
+ & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
+ & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
+ & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
+ & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
+ & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
+ & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
+ & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
+ & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
+ & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
+ & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
+ & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
+ & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
+*
+ DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
+ & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
+ & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
+ & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
+ & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
+ & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
+ & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
+ & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
+ & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
+ & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
+ & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
+ & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
+ & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
+ & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
+ & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
+ & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
+ & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
+ & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
+ & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
+**** pi- p data *
+ DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
+ & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
+ & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
+ & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
+ & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
+ & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
+ & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
+ & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
+ & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
+ & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
+ & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
+ & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
+ & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
+ & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
+ & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
+ & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
+ & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
+ & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
+ & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
+*
+ DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
+ & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
+ & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
+ & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
+ & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
+ & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
+ & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
+ & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
+ & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
+ & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
+ & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
+ & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
+ & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
+ & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
+ & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
+ & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
+ & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
+ & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
+ & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
+ & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
+**** pi- n data *
+ DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
+ & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
+ & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
+ & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
+ & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
+ & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
+ & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
+ & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
+ & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
+ & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
+ & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
+ & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
+ & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
+ & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
+ & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
+ & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
+ & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
+ & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
+ & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
+ & 3.3D0, 5.4D0, 7.D0 /
+**** k+ p data *
+ DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
+ & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
+ & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
+ & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
+ & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
+ & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
+ & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
+ & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
+ & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
+ & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
+ & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
+ & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
+**** k+ n data *
+ DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
+ & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
+ & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
+ & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
+ & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
+ & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
+ & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
+ & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
+ & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
+ & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
+ & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
+ & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
+ & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
+ & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
+ & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
+ & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
+ & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
+ & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
+ & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
+**** k- p data *
+ DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
+ & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
+ & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
+ & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
+ & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
+ & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
+ & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
+ & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
+ & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
+ & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
+ & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
+ & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
+ DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
+ & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
+ & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
+ & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
+ & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
+ & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
+ & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
+ & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
+ & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
+ & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
+ & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
+ & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
+ & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
+ & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
+ & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
+ & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
+ & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
+ & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
+ & 10*0.D0/
+***** k- n data *
+ DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
+ & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
+ & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
+ & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
+ & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
+ & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
+ & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
+ & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
+ DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
+ & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
+ & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
+ & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
+ & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
+ & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
+ & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
+ & .39D0, .22D0, .07D0, 0.D0,
+ & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
+ & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
+ & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
+ & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
+ & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
+ & 5.10D0, 5.44D0, 5.3D0,
+ & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
+***** p p data *
+ DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
+ & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
+ & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
+ & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
+ & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
+ & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
+ & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
+ & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
+ & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
+ & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
+ & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
+***** p n data *
+ DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 1.8D0, .2D0, 12*0.D0,
+ & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
+ & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
+ & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
+ & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
+ & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
+ & 10*0.D0, .7D0, 5.1D0, 8.D0,
+ & 10*0.D0, .7D0, 5.1D0, 8.D0,
+ & 10*.0D0, .3D0, 2.8D0, 4.7D0,
+ & 10*.0D0, .3D0, 2.8D0, 4.7D0,
+ & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
+ & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
+ & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
+* nn - data *
+* *
+ DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
+ & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
+ & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
+ & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
+ & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
+ & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
+ & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
+ & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
+ & 11.D0, 5.5D0, 3.5D0,
+ & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
+ & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
+ & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
+ & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
+ & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
+ & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
+**************** ap - p - data *
+ DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
+ & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
+ & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
+ & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
+ & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
+ & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
+ & 1.55D0, 1.3D0, .95D0, .75D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
+ & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0/
+ DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
+ & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
+ & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
+ & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
+ & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
+ & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
+ & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
+ & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
+ & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
+ & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
+ & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
+ & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
+ & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
+ & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
+ & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
+**************** ap - n - data *
+ DATA SAPNEL/
+ & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
+ & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
+ & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
+ & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
+ & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
+ & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0 /
+ DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
+ & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
+ & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
+ & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
+ & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
+ & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
+ & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
+* *
+* *
+**************** an - p - data *
+* *
+ DATA SANPEL/
+ & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
+ & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
+ & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
+ & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
+ & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
+ & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
+ & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
+ & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
+ & .01D0, .008D0, .006D0, .005D0 /
+ DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
+ & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
+ & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
+ & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
+ & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
+ & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
+ & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
+ & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
+ & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
+ & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
+ & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
+ & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
+**** ko - n - data *
+ DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
+ & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
+ & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
+ & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
+ & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
+ & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
+ & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
+ & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
+ & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
+ & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
+ & 4.85D0, 4.9D0,
+ & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
+ & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
+ & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
+ & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
+ & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
+**** ako - p - data *
+ DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
+ & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
+ & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
+ & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
+ & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
+ & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
+ & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
+ & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
+ & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
+ & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
+ & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
+ & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
+ & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
+ & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
+ & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
+ & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
+ & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
+ & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
+ & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
+ & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
+ & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
+ DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
+ & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
+*= end*block.blkdt3 *
+ END
+*
+*===qel_pol============================================================*
+*
+CDECK ID>, DT_QEL_POL
+ SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CALL DT_MASS_INI
+ CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+ RETURN
+ END
+
+C==================================================================
+C Generation of a Quasi-Elastic neutrino scattering
+C==================================================================
+*
+*===gen_qel============================================================*
+*
+CDECK ID>, DT_GEN_QEL
+ SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
+
+C...Generate a quasi-elastic neutrino/antineutrino
+C. Interaction on a nuclear target
+C. INPUT : LTYP = neutrino type (1,...,6)
+C. ENU (GeV) = neutrino energy
+C----------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+* 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
+**sr - removed (not needed)
+C COMMON /CBAD/ LBAD, NBAD
+C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
+**
+
+ DIMENSION PI(3),PO(3)
+CJR+
+ DATA ININU/0/
+CJR-
+C REAL*8 DBETA(3)
+C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
+ DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
+ DATA AMN /0.93827231D0, 0.93956563D0/
+ DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
+ DATA INIPRI/0/
+
+C DATA PFERMI/0.22D0/
+CGB+...Binding Energy
+ DATA EBIND/0.008D0/
+CGB-...
+
+ ININU=ININU+1
+ IF(ININU.EQ.1)NDSIG=0
+ LBAD = 0
+ enu0=enu
+c write(*,*) enu0
+C...Lepton mass
+ AML = AML0(LTYP) ! massa leptoni
+ AML2 = AML**2 ! massa leptoni **2
+C...Particle labels (LUND)
+ N = 5
+ K(1,1) = 21
+ K(2,1) = 21
+ K(3,1) = 21
+ K(3,3) = 1
+ K(4,1) = 1
+ K(4,3) = 1
+ K(5,1) = 1
+ K(5,3) = 2
+ K0 = (LTYP-1)/2 ! 2
+ K1 = LTYP/2 ! 2
+ KA = 12 + 2*K0 ! 16
+ IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
+ K(1,2) = IS*KA
+ K(4,2) = IS*(KA-1)
+ K(3,2) = IS*24
+ LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
+ IF (LNU .EQ. 2) THEN
+ K(2,2) = 2212
+ K(5,2) = 2112
+ AMI = AMN(1)
+ AMF = AMN(2)
+CJR+
+ PFERMI=PFERMN(2)
+CJR-
+ ELSE
+ K(2,2) = 2112
+ K(5,2) = 2212
+ AMI = AMN(2)
+ AMF = AMN(1)
+CJR+
+ PFERMI=PFERMP(2)
+CJR-
+ ENDIF
+ AMI2 = AMI**2
+ AMF2 = AMF**2
+
+ DO IGB=1,5
+ P(3,IGB) = 0.
+ P(4,IGB) = 0.
+ P(5,IGB) = 0.
+ END DO
+
+ NTRY = 0
+CGB+...
+ EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
+ ENWELL = EFMAX + EBIND ! depth of nuclear potential well
+CGB-...
+
+ 100 CONTINUE
+
+C...4-momentum initial lepton
+ P(1,5) = 0. ! massa
+ P(1,4) = ENU0 ! energia
+ P(1,1) = 0. ! px
+ P(1,2) = 0. ! py
+ P(1,3) = ENU0 ! pz
+
+C PF = PFERMI*PYR(0)**(1./3.)
+c write(23,*) PYR(0)
+c write(*,*) 'Pfermi=',PF
+c PF = 0.
+ NTRY=NTRY+1
+C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
+ IF (NTRY .GT. 500) THEN
+ LBAD = 1
+ WRITE (LOUT,1001) NBAD, ENU
+ RETURN
+ ENDIF
+C CT = -1. + 2.*PYR(0)
+c CT = -1.
+C ST = SQRT(1.-CT*CT)
+C F = 2.*3.1415926*PYR(0)
+c F = 0.
+
+C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
+C P(2,1) = PF*ST*COS(F) ! px
+C P(2,2) = PF*ST*SIN(F) ! py
+C P(2,3) = PF*CT ! pz
+C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
+ P(2,1) = P21
+ P(2,2) = P22
+ P(2,3) = P23
+ P(2,4) = P24
+ P(2,5) = P25
+ beta1=-p(2,1)/p(2,4)
+ beta2=-p(2,2)/p(2,4)
+ beta3=-p(2,3)/p(2,4)
+ N=2
+C WRITE(6,*)' before transforming into target rest frame'
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
+
+C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
+ N=5
+
+ phi11=atan(p(1,2)/p(1,3))
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+
+ CALL DT_TESTROT(PI,Po,PHI11,1)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+c WRITE(*,*) po
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+ phi12=atan(p(1,1)/p(1,3))
+
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,2)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+c WRITE(*,*) po
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+
+ enu=p(1,4)
+
+C...Kinematical limits in Q**2
+c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
+ S = P(2,5)**2 + 2.*ENU*P(2,5)
+ SQS = SQRT(S) ! E centro massa
+ IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
+ ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
+ PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
+ PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
+ Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
+ Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
+ IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
+
+C...Generate Q**2
+ DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
+ 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
+ DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
+ IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
+ CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
+ NDSIG=NDSIG+1
+C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
+C &Q2,Q2min,Q2MAX,DSIGEV
+
+C...c.m. frame. Neutrino along z axis
+ DETOT = (P(1,4)) + (P(2,4)) ! e totale
+ DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
+ DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
+ DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
+c WRITE(*,*)
+c WRITE(*,*)
+C WRITE(*,*) 'Input values laboratory frame'
+ N=2
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
+
+ N=5
+c STHETA = ULANGL(P(1,3),P(1,1))
+c write(*,*) 'stheta' ,stheta
+c stheta=0.
+c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
+c WRITE(*,*)
+c WRITE(*,*)
+C WRITE(*,*) 'Output values cm frame'
+C...Kinematic in c.m. frame
+ CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
+ STSTAR = SQRT(1.-CTSTAR**2)
+ PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
+ P(4,5) = AML ! massa leptone
+ P(4,4) = ELF ! e leptone
+ P(4,3) = PLF*CTSTAR ! px
+ P(4,1) = PLF*STSTAR*COS(PHI) ! py
+ P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
+
+ P(5,5) = AMF ! barione
+ P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
+ P(5,3) = -P(4,3) ! px
+ P(5,1) = -P(4,1) ! py
+ P(5,2) = -P(4,2) ! pz
+
+ P(3,5) = -Q2
+ P(3,1) = P(1,1)-P(4,1)
+ P(3,2) = P(1,2)-P(4,2)
+ P(3,3) = P(1,3)-P(4,3)
+ P(3,4) = P(1,4)-P(4,4)
+
+C...Transform back to laboratory frame
+C WRITE(*,*) 'before going back to nucl rest frame'
+c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
+ N=5
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
+
+C WRITE(*,*) 'Now back in nucl rest frame'
+ IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
+
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,3)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI11,4)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+
+c********************************************
+
+C WRITE(*,*) 'Now back in lab frame'
+
+ CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
+
+CGB+...
+C...test (on final momentum of nucleon) if Fermi-blocking
+C...is operating
+ ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
+ & - P(5,5)
+ IF (ENUCL.LT. EFMAX) THEN
+ IF(INIPRI.LT.10)THEN
+ INIPRI=INIPRI+1
+C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
+C...the interaction is not possible due to Pauli-Blocking and
+C...it must be resampled
+ ENDIF
+ GOTO 100
+ ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
+ IF(INIPRI.LT.10)THEN
+ INIPRI=INIPRI+1
+C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
+ ENDIF
+C Reject (J:R) here all these events
+C are otherwise rejected in dpmjet
+ GOTO 100
+C...the interaction is possible, but the nucleon remains inside
+C...the nucleus. The nucleus is therefore left excited.
+C...We treat this case as a nucleon with 0 kinetic energy.
+C P(5,5) = AMF
+C P(5,4) = AMF
+C P(5,1) = 0.
+C P(5,2) = 0.
+C P(5,3) = 0.
+ ELSE IF (ENUCL.GE.ENWELL) THEN
+C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
+C...the interaction is possible, the nucleon can exit the nucleus
+C...but the nuclear well depth must be subtracted. The nucleus could be
+C...left in an excited state.
+ Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
+C P(5,4) = ENUCL-ENWELL + AMF
+ Pnucl = SQRT(P(5,4)**2-AMF**2)
+C...The 3-momentum is scaled assuming that the direction remains
+C...unaffected
+ P(5,1) = P(5,1) * Pnucl/Pstart
+ P(5,2) = P(5,2) * Pnucl/Pstart
+ P(5,3) = P(5,3) * Pnucl/Pstart
+C WRITE(6,*)' qel new P(5,4) ',P(5,4)
+ ENDIF
+CGB-...
+ DSIGSU=DSIGSU+DSIGEV
+
+ GA=P(4,4)/P(4,5)
+ BGX=P(4,1)/P(4,5)
+ BGY=P(4,2)/P(4,5)
+ BGZ=P(4,3)/P(4,5)
+*
+ DBETB(1)=BGX/GA
+ DBETB(2)=BGY/GA
+ DBETB(3)=BGZ/GA
+ IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
+
+ CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
+
+ ENDIF
+c
+C PRINT*,' FINE EVENTO '
+ enu=enu0
+ RETURN
+
+ 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
+ END
+
+C====================================================================
+C. Masses
+C====================================================================
+
+*
+*===mass_ini===========================================================*
+*
+CDECK ID>, DT_MASS_INI
+ SUBROUTINE DT_MASS_INI
+C...Initialize the kinematics for the quasi-elastic cross section
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+
+ EML(1) = 0.51100D-03 ! e-
+ EML(2) = EML(1) ! e+
+ EML(3) = 0.105659D0 ! mu-
+ EML(4) = EML(3) ! mu+
+ EML(5) = 1.7777D0 ! tau-
+ EML(6) = EML(5) ! tau+
+ EMPROT = 0.93827231D0 ! p
+ EMNEUT = 0.93956563D0 ! n
+ EMPROTSQ = EMPROT**2
+ EMNEUTSQ = EMNEUT**2
+ EMN = (EMPROT + EMNEUT)/2.
+ EMNSQ = EMN**2
+ DO J=1,3
+ J0 = 2*(J-1)
+ EMN1(J0+1) = EMNEUT
+ EMN1(J0+2) = EMPROT
+ EMN2(J0+1) = EMPROT
+ EMN2(J0+2) = EMNEUT
+ ENDDO
+ DO J=1,6
+ EMLSQ(J) = EML(J)**2
+ ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
+ ENDDO
+ RETURN
+ END
+*
+*===dsqel_q2===========================================================*
+*
+CDECK ID>, DT_DSQEL_Q2
+ DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
+
+C...differential cross section for Quasi-Elastic scattering
+C. nu + N -> l + N'
+C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
+C.
+C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
+C. ENU (GeV) = Neutrino energy
+C. Q2 (GeV**2) = (Transfer momentum)**2
+C.
+C. OUTPUT : DSQEL_Q2 = differential cross section :
+C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
+C------------------------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+**sr - removed (not needed)
+C COMMON /CAXIAL/ FA0, AXIAL2
+**
+
+ DIMENSION SS(6)
+ DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
+ DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
+ DATA AXIAL2 /1.03D0/ ! to be checked
+
+ FA0=-1.253D0
+ CSI = 3.71D0 ! ???
+ GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
+ GVM = (1.D0+CSI)*GVE ! G_m (q**2)
+ X = Q2/(EMN*EMN) ! emn=massa barione
+ XA = X/4.D0
+ FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
+ FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
+ FA = FA0/(1.D0 + Q2/AXIAL2)**2
+ FFA = FA*FA
+ FFV1 = FV1*FV1
+ FFV2 = FV2*FV2
+ RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
+ A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
+ A2 = -RM * ((FV1 + FV2)**2 + FFA)
+ AA = (XA+0.25D0*RM)*(A1 + A2)
+ BB = -X*FA*(FV1 + FV2)
+ CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
+ SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
+ DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
+ IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
+
+ RETURN
+ END
+*
+*===prepola============================================================*
+*
+CDECK ID>, DT_PREPOLA
+ SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+c
+c By G. Battistoni and E. Scapparone (sept. 1997)
+c According to:
+c Albright & Jarlskog, Nucl Phys B84 (1975) 467
+c
+c
+
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+ COMMON /QNPOL/ POLARX(4),PMODUL
+* particle masses used in qel neutrino scattering modules
+ COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
+ & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
+ & EMPROTSQ,EMNEUTSQ,EMNSQ
+* steering flags for qel neutrino scattering modules
+ COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+**sr - removed (not needed)
+C COMMON /CAXIAL/ FA0, AXIAL2
+C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
+C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
+**
+ REAL*8 POL(4,4),BB2(3)
+ DIMENSION SS(6)
+C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
+ DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
+**sr uncommented since common block CAXIAL is now commented
+ DATA AXIAL2 /1.03D0/ ! to be checked
+**
+
+ RML=P(4,5)
+ RMM=0.93960D+00
+ FM2 = RMM**2
+ MPI = 0.135D+00
+ OLDQ2=Q2
+ FA0=-1.253D+00
+ CSI = 3.71D+00 !
+ GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
+ GVM = (1.D0+CSI)*GVE ! G_m (q**2)
+ X = Q2/(EMN*EMN) ! emn=massa barione
+ XA = X/4.D0
+ FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
+ FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
+ FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
+ FFA = FA*FA
+ FFV1 = FV1*FV1
+ FFV2 = FV2*FV2
+ FP=2.D0*FA*RMM/(MPI**2 + Q2)
+ RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
+ A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
+ A2 = -RM * ((FV1 + FV2)**2 + FFA)
+ AA = (XA+0.25D+00*RM)*(A1 + A2)
+ BB = -X*FA*(FV1 + FV2)
+ CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
+ SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
+
+ OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
+ OMEGA2=4.D+00*CC
+ OMEGA3=2.D+00*FA*(FV1+FV2)
+ OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
+ 1 (Q2/FM2))*FP**2)
+ OMEGA5=OMEGA2
+ OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
+ WW1=2.D+00*OMEGA1*EMN**2
+ WW2=2.D+00*OMEGA2*EMN**2
+ WW3=2.D+00*OMEGA3*EMN**2
+ WW4=2.D+00*OMEGA4*EMN**2
+ WW5=2.D+00*OMEGA5*EMN**2
+
+ DO I=1,3
+ BB2(I)=-P(4,I)/P(4,4)
+ END DO
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
+ N=5
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
+
+* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'Prepola: now in lepton rest frame'
+ EE=ENU
+ QM2=Q2+RML**2
+ U=Q2/(2.*RMM)
+ FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
+ + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
+ + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
+
+ FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
+ + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
+
+ FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
+
+ DO I=1,3
+ POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
+ POLARX(I)=POL(4,I)
+ END DO
+
+ PMODUL=0.D0
+ DO I=1,3
+ PMODUL=PMODUL+POL(4,I)**2
+ END DO
+
+ IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
+ IF(NEUDEC.EQ.1) THEN
+ CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
+ + ETL,PXL,PYL,PZL,
+ + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+c
+c Tau has decayed in muon
+c
+ ENDIF
+ IF(NEUDEC.EQ.2) THEN
+ CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
+ + ETL,PXL,PYL,PZL,
+ + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+c
+c Tau has decayed in electron
+c
+ ENDIF
+ K(4,1)=15
+ K(4,4) = 6
+ K(4,5) = 8
+ N=N+3
+c
+c fill common for muon(electron)
+c
+ P(6,1)=PXL
+ P(6,2)=PYL
+ P(6,3)=PZL
+ P(6,4)=ETL
+ K(6,1)=1
+ IF(JTYP.EQ.5) THEN
+ IF(NEUDEC.EQ.1) THEN
+ P(6,5)=EML(JTYP-2)
+ K(6,2)=13
+ ELSEIF(NEUDEC.EQ.2) THEN
+ P(6,5)=EML(JTYP-4)
+ K(6,2)=11
+ ENDIF
+ ELSEIF(JTYP.EQ.6) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(6,2)=-13
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(6,2)=-11
+ ENDIF
+ END IF
+ K(6,3)=4
+ K(6,4)=0
+ K(6,5)=0
+c
+c fill common for tau_(anti)neutrino
+c
+ P(7,1)=PXB
+ P(7,2)=PYB
+ P(7,3)=PZB
+ P(7,4)=ETB
+ P(7,5)=0.
+ K(7,1)=1
+ IF(JTYP.EQ.5) THEN
+ K(7,2)=16
+ ELSEIF(JTYP.EQ.6) THEN
+ K(7,2)=-16
+ END IF
+ K(7,3)=4
+ K(7,4)=0
+ K(7,5)=0
+c
+c Fill common for muon(electron)_(anti)neutrino
+c
+ P(8,1)=PXN
+ P(8,2)=PYN
+ P(8,3)=PZN
+ P(8,4)=ETN
+ P(8,5)=0.
+ K(8,1)=1
+ IF(JTYP.EQ.5) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(8,2)=-14
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(8,2)=-12
+ ENDIF
+ ELSEIF(JTYP.EQ.6) THEN
+ IF(NEUDEC.EQ.1) THEN
+ K(8,2)=14
+ ELSEIF(NEUDEC.EQ.2) THEN
+ K(8,2)=12
+ ENDIF
+ END IF
+ K(8,3)=4
+ K(8,4)=0
+ K(8,5)=0
+ ENDIF
+c WRITE(*,*)
+c WRITE(*,*)
+
+c IF(PMODUL.GE.1.D+00) THEN
+c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
+c write(*,*) pmodul
+c DO I=1,3
+c POL(4,I)=POL(4,I)/PMODUL
+c POLARX(I)=POL(4,I)
+c END DO
+c PMODUL=0.
+c DO I=1,3
+c PMODUL=PMODUL+POL(4,I)**2
+c END DO
+c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
+c
+c ENDIF
+
+c WRITE(*,*) 'PMODUL = ',PMODUL
+
+c WRITE(*,*)
+c WRITE(*,*)
+c WRITE(*,*) 'prepola: Now back to nucl rest frame'
+
+ CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
+
+ XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
+ YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
+ ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
+ DO NDC =6,8
+ V(NDC,1) = XDC
+ V(NDC,2) = YDC
+ V(NDC,3) = ZDC
+ END DO
+
+ RETURN
+ END
+*
+*===testrot============================================================*
+*
+CDECK ID>, DT_TESTROT
+ SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION ROT(3,3),PI(3),PO(3)
+
+ IF (MODE.EQ.1) THEN
+ ROT(1,1) = 1.D0
+ ROT(1,2) = 0.D0
+ ROT(1,3) = 0.D0
+ ROT(2,1) = 0.D0
+ ROT(2,2) = COS(PHI)
+ ROT(2,3) = -SIN(PHI)
+ ROT(3,1) = 0.D0
+ ROT(3,2) = SIN(PHI)
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.2) THEN
+ ROT(1,1) = 0.D0
+ ROT(1,2) = 1.D0
+ ROT(1,3) = 0.D0
+ ROT(2,1) = COS(PHI)
+ ROT(2,2) = 0.D0
+ ROT(2,3) = -SIN(PHI)
+ ROT(3,1) = SIN(PHI)
+ ROT(3,2) = 0.D0
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.3) THEN
+ ROT(1,1) = 0.D0
+ ROT(2,1) = 1.D0
+ ROT(3,1) = 0.D0
+ ROT(1,2) = COS(PHI)
+ ROT(2,2) = 0.D0
+ ROT(3,2) = -SIN(PHI)
+ ROT(1,3) = SIN(PHI)
+ ROT(2,3) = 0.D0
+ ROT(3,3) = COS(PHI)
+ ELSEIF (MODE.EQ.4) THEN
+ ROT(1,1) = 1.D0
+ ROT(2,1) = 0.D0
+ ROT(3,1) = 0.D0
+ ROT(1,2) = 0.D0
+ ROT(2,2) = COS(PHI)
+ ROT(3,2) = -SIN(PHI)
+ ROT(1,3) = 0.D0
+ ROT(2,3) = SIN(PHI)
+ ROT(3,3) = COS(PHI)
+ ELSE
+ STOP ' TESTROT: mode not supported!'
+ ENDIF
+ DO 1 J=1,3
+ PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
+ 1 CONTINUE
+
+ RETURN
+ END
+*
+*===lepdcyp============================================================*
+*
+CDECK ID>, DT_LEPDCYP
+ SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
+ & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
+C
+C-----------------------------------------------------------------
+C
+C Author :- G. Battistoni 10-NOV-1995
+C
+C=================================================================
+C
+C Purpose : performs decay of polarized lepton in
+C its rest frame: a => b + l + anti-nu
+C (Example: mu- => nu-mu + e- + anti-nu-e)
+C Polarization is assumed along Z-axis
+C WARNING:
+C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
+C OF NEGLIGIBLE MASS
+C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
+C IN THIS VERSION
+C
+C Method : modifies phase space distribution obtained
+C by routine EXPLOD using a rejection against the
+C matrix element for unpolarized lepton decay
+C
+C Inputs : Mass of a : AMA
+C Mass of l : AML
+C Polar. of a: POL
+C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
+C POL = -1)
+C
+C Outputs : kinematic variables in the rest frame of decaying lepton
+C ETL,PXL,PYL,PZL 4-moment of l
+C ETB,PXB,PYB,PZB 4-moment of b
+C ETN,PXN,PYN,PZN 4-moment of anti-nu
+C
+C============================================================
+C +
+C Declarations.
+C -
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+ PARAMETER ( KALGNM = 2 )
+ PARAMETER ( ANGLGB = 5.0D-16 )
+ PARAMETER ( ANGLSQ = 2.5D-31 )
+ PARAMETER ( AXCSSV = 0.2D+16 )
+ PARAMETER ( ANDRFL = 1.0D-38 )
+ PARAMETER ( AVRFLW = 1.0D+38 )
+ PARAMETER ( AINFNT = 1.0D+30 )
+ PARAMETER ( AZRZRZ = 1.0D-30 )
+ PARAMETER ( EINFNT = +69.07755278982137 D+00 )
+ PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
+ PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( CSNNRM = 2.0D-15 )
+ PARAMETER ( DMXTRN = 1.0D+08 )
+ PARAMETER ( ZERZER = 0.D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( THRTHR = 3.D+00 )
+ PARAMETER ( FOUFOU = 4.D+00 )
+ PARAMETER ( FIVFIV = 5.D+00 )
+ PARAMETER ( SIXSIX = 6.D+00 )
+ PARAMETER ( SEVSEV = 7.D+00 )
+ PARAMETER ( EIGEIG = 8.D+00 )
+ PARAMETER ( ANINEN = 9.D+00 )
+ PARAMETER ( TENTEN = 10.D+00 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( ONETHI = ONEONE / THRTHR )
+ PARAMETER ( TWOTHI = TWOTWO / THRTHR )
+ PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
+ PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
+ PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
+ PARAMETER ( CLIGHT = 2.99792458 D+10 )
+ PARAMETER ( AVOGAD = 6.0221367 D+23 )
+ PARAMETER ( AMELGR = 9.1093897 D-28 )
+ PARAMETER ( PLCKBR = 1.05457266 D-27 )
+ PARAMETER ( ELCCGS = 4.8032068 D-10 )
+ PARAMETER ( ELCMKS = 1.60217733 D-19 )
+ PARAMETER ( AMUGRM = 1.6605402 D-24 )
+ PARAMETER ( AMMUMU = 0.113428913 D+00 )
+ PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
+ PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
+ PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
+ PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
+ PARAMETER ( PLABRC = 0.197327053 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMMUON = 0.105658389 D+00 )
+ PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
+ PARAMETER ( GEVMEV = 1.0 D+03 )
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
+ PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
+ PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
+C +
+C variables for EXPLOD
+C -
+ PARAMETER ( KPMX = 10 )
+ DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
+ & PZEXPL (KPMX), ETEXPL (KPMX)
+C +
+C test variables
+C -
+**sr - removed (not needed)
+C COMMON /GBATNU/ ELERAT,NTRY
+**
+C +
+C Initializes test variables
+C -
+ NTRY = 0
+ ELERAT = 0.D+00
+C +
+C Maximum value for matrix element
+C -
+ ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
+ & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
+C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+C Inputs for EXPLOD
+C part. no. 1 is l (e- in mu- decay)
+C part. no. 2 is b (nu-mu in mu- decay)
+C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ NPEXPL = 3
+ ETOTEX = AMA
+ AMEXPL(1) = AML
+ AMEXPL(2) = 0.D+00
+ AMEXPL(3) = 0.D+00
+C +
+C phase space distribution
+C -
+ 100 CONTINUE
+ NTRY = NTRY + 1
+
+ CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
+ & PYEXPL, PZEXPL )
+
+C +
+C Calculates matrix element:
+C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
+C Here CTH is the cosine of the angle between anti-nu and Z axis
+C -
+ CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
+ & PZEXPL(3)**2 )
+ PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
+ PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
+ & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
+ ELEMAT = 16.D+00 * PROD1 * PROD2
+ IF(ELEMAT.GT.ELEMAX) THEN
+ WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
+ STOP
+ ENDIF
+C +
+C Here performs the rejection
+C -
+ TEST = DT_RNDM(ETOTEX) * ELEMAX
+ IF ( TEST .GT. ELEMAT ) GO TO 100
+C +
+C final assignment of variables
+C -
+ ELERAT = ELEMAT/ELEMAX
+ ETL = ETEXPL(1)
+ PXL = PXEXPL(1)
+ PYL = PYEXPL(1)
+ PZL = PZEXPL(1)
+ ETB = ETEXPL(2)
+ PXB = PXEXPL(2)
+ PYB = PYEXPL(2)
+ PZB = PZEXPL(2)
+ ETN = ETEXPL(3)
+ PXN = PXEXPL(3)
+ PYN = PYEXPL(3)
+ PZN = PZEXPL(3)
+ 999 RETURN
+ END
+
+C==================================================================
+C. Generation of Delta resonance events
+C==================================================================
+*
+*===gen_delta==========================================================*
+*
+CDECK ID>, DT_GEN_DELTA
+ SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+C...Generate a Delta-production neutrino/antineutrino
+C. CC-interaction on a nucleon
+C
+C. INPUT ENU (GeV) = Neutrino Energy
+C. LLEP = neutrino type
+C. LTARG = nucleon target type 1=p, 2=n.
+C. JINT = 1:CC, 2::NC
+C.
+C. OUTPUT PPL(4) 4-monentum of final lepton
+C----------------------------------------------------
+
+ PARAMETER (MAXLND=4000)
+ COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+
+**sr - removed (not needed)
+C COMMON /CBAD/ LBAD, NBAD
+**
+
+ DIMENSION PI(3),PO(3)
+C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
+ DIMENSION AML0(6),AMN(2)
+ DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
+ DATA AMN /0.93827231, 0.93956563/
+ DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
+
+c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
+ LBAD = 0
+C...Final lepton mass
+ IF (JINT.EQ.1) THEN
+ AML = AML0(LLEP)
+ ELSE
+ AML = 0.
+ ENDIF
+ AML2 = AML**2
+
+C...Particle labels (LUND)
+ N = 5
+ K(1,1) = 21
+ K(2,1) = 21
+ K(3,1) = 21
+ K(4,1) = 1
+ K(3,3) = 1
+ K(4,3) = 1
+ IF (LTARG .EQ. 1) THEN
+ K(2,2) = 2212
+ ELSE
+ K(2,2) = 2112
+ ENDIF
+ K0 = (LLEP-1)/2
+ K1 = LLEP/2
+ KA = 12 + 2*K0
+ IS = -1 + 2*LLEP - 4*K1
+ LNU = 2 - LLEP + 2*K1
+ K(1,2) = IS*KA
+ K(5,1) = 1
+ K(5,3) = 2
+ IF (JINT .EQ. 1) THEN ! CC interactions
+ K(3,2) = IS*24
+ K(4,2) = IS*(KA-1)
+ IF(LNU.EQ.1) THEN
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2224
+ ELSE
+ K(5,2) = 2214
+ ENDIF
+ ELSE
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2114
+ ELSE
+ K(5,2) = 1114
+ ENDIF
+ ENDIF
+ ELSE
+ K(3,2) = 23 ! NC (Z0) interactions
+ K(4,2) = K(1,2)
+**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
+* Delta0 for neutron (LTARG=2)
+C IF (LTARG .EQ. 1) THEN
+C K(5,2) = 2114
+C ELSE
+C K(5,2) = 2214
+C ENDIF
+ IF (LTARG .EQ. 1) THEN
+ K(5,2) = 2214
+ ELSE
+ K(5,2) = 2114
+ ENDIF
+**
+ ENDIF
+
+C...4-momentum initial lepton
+ P(1,5) = 0.
+ P(1,4) = ENU
+ P(1,1) = 0.
+ P(1,2) = 0.
+ P(1,3) = ENU
+C...4-momentum initial nucleon
+ P(2,5) = AMN(LTARG)
+C P(2,4) = P(2,5)
+C P(2,1) = 0.
+C P(2,2) = 0.
+C P(2,3) = 0.
+ P(2,1) = P21
+ P(2,2) = P22
+ P(2,3) = P23
+ P(2,4) = P24
+ P(2,5) = P25
+ N=2
+ beta1=-p(2,1)/p(2,4)
+ beta2=-p(2,2)/p(2,4)
+ beta3=-p(2,3)/p(2,4)
+ N=2
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
+
+C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
+
+ phi11=atan(p(1,2)/p(1,3))
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+
+ CALL DT_TESTROT(PI,Po,PHI11,1)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+ phi12=atan(p(1,1)/p(1,3))
+
+ pi(1)=p(1,1)
+ pi(2)=p(1,2)
+ pi(3)=p(1,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,2)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(1,1)=po(1)
+ p(1,2)=po(2)
+ p(1,3)=po(3)
+
+ ENUU=P(1,4)
+
+C...Generate the Mass of the Delta
+ NTRY = 0
+100 R = PYR(0)
+ AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
+ NTRY = NTRY + 1
+ IF (NTRY .GT. 1000) THEN
+ LBAD = 1
+ WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
+ RETURN
+ ENDIF
+ IF (AMD .LT. AMDMIN) GOTO 100
+ ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
+ IF (ENUU .LT. ET) GOTO 100
+
+C...Kinematical limits in Q**2
+ S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
+ SQS = SQRT(S)
+ PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
+ ELF = (S - AMD**2 + AML2)/(2.*SQS)
+ PLF = SQRT(ELF**2 - AML2)
+ Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
+ Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
+ IF (Q2MIN .LT. 0.) Q2MIN = 0.
+
+ DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
+200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
+ DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
+ IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
+
+C...Generate the kinematics of the final particles
+ EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
+ GAM = EISTAR/AMN(LTARG)
+ BET = PSTAR/EISTAR
+ CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
+ EL = GAM*(ELF + BET*PLF*CTSTAR)
+ PLZ = GAM*(PLF*CTSTAR + BET*ELF)
+ PL = SQRT(EL**2 - AML2)
+ PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
+ PHI = 6.28319*PYR(0)
+ P(4,1) = PLT*COS(PHI)
+ P(4,2) = PLT*SIN(PHI)
+ P(4,3) = PLZ
+ P(4,4) = EL
+ P(4,5) = AML
+
+C...4-momentum of Delta
+ P(5,1) = -P(4,1)
+ P(5,2) = -P(4,2)
+ P(5,3) = ENUU-P(4,3)
+ P(5,4) = ENUU+AMN(LTARG)-P(4,4)
+ P(5,5) = AMD
+
+C...4-momentum of intermediate boson
+ P(3,5) = -Q2
+ P(3,4) = P(1,4)-P(4,4)
+ P(3,1) = P(1,1)-P(4,1)
+ P(3,2) = P(1,2)-P(4,2)
+ P(3,3) = P(1,3)-P(4,3)
+ N=5
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI12,3)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+
+c********************************************
+
+ DO kw=1,5
+ pi(1)=p(kw,1)
+ pi(2)=p(kw,2)
+ pi(3)=p(kw,3)
+ CALL DT_TESTROT(Pi,Po,PHI11,4)
+ DO ll=1,3
+ IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
+ END DO
+ p(kw,1)=po(1)
+ p(kw,2)=po(2)
+ p(kw,3)=po(3)
+ END DO
+c********************************************
+C transform back into Lab.
+
+ CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
+
+C WRITE(6,*)' Lab fram ( fermi incl.) '
+ N=5
+ CALL PYEXEC
+
+ RETURN
+1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
+ END
+*
+*===dsigma_delta=======================================================*
+*
+CDECK ID>, DT_DSIGMA_DELTA
+ DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C...Reaction nu + N -> lepton + Delta
+C. returns the cross section
+C. dsigma/dt
+C. INPUT LNU = 1, 2 (neutrino-antineutrino)
+C. QQ = t (always negative) GeV**2
+C. S = (c.m energy)**2 GeV**2
+C. OUTPUT = 10**-38 cm+2/GeV**2
+C-----------------------------------------------------
+ REAL*8 MN, MN2, MN4, MD,MD2, MD4
+ DATA MN /0.938/
+ DATA PI /3.1415926/
+
+ GF = (1.1664 * 1.97)
+ GF2 = GF*GF
+ MN2 = MN*MN
+ MN4 = MN2*MN2
+ MD2 = MD*MD
+ MD4 = MD2*MD2
+ AML2 = AML*AML
+ AML4 = AML2*AML2
+ VQ = (MN2 - MD2 - QQ)/2.
+ VPI = (MN2 + MD2 - QQ)/2.
+ VK = (S + QQ - MN2 - AML2)/2.
+ PIK = (S - MN2)/2.
+ QK = (AML2 - QQ)/2.
+ PIQ = (QQ + MN2 - MD2)/2.
+ Q = SQRT(-QQ)
+ C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
+ C3 = SQRT(3.)*C3V/MN
+ C4 = -C3/MD ! attenzione al segno
+ C5A = 1.18/(1.-QQ/0.4225)**2
+ C32 = C3**2
+ C42 = C4**2
+ C5A2 = C5A**2
+
+ IF (LNU .EQ. 1) THEN
+ ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
+ . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
+ . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
+ . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
+ ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
+ . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
+ . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
+ . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
+ . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
+ . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
+ . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
+ . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
+ . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
+ . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
+ . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
+ . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
+ . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
+ . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
+ . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
+ . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
+ . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
+ . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
+ . *C42-2.*MD2*VPI*QK**2*C32+ANS3
+ ELSE
+ ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
+ . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
+ . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
+ . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
+ ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
+ . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
+ . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
+ . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
+ . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
+ . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
+ . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
+ . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
+ . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
+ . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
+ . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
+ . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
+ . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
+ . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
+ . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
+ . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
+ . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
+ . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
+ . *C42-2.*MD2*VPI*QK**2*C32+ANS3
+ ENDIF
+ ANS1=32.*ANS2
+ ANS=ANS1/(3.*MD2)
+ P1CM = (S-MN2)/(2.*SQRT(S))
+ DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
+
+ RETURN
+ END
+*
+*===qgaus==============================================================*
+*
+CDECK ID>, DT_QGAUS
+ SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION X(5),W(5)
+ DATA X/.1488743389D0,.4333953941D0,
+ & .6794095682D0,.8650633666D0,.9739065285D0
+ */
+ DATA W/.2955242247D0,.2692667193D0,
+ & .2190863625D0,.1494513491D0,.0666713443D0
+ */
+ XM=0.5D0*(B+A)
+ XR=0.5D0*(B-A)
+ SS=0
+ DO 11 J=1,5
+ DX=XR*X(J)
+ SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
+ * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
+11 CONTINUE
+ SS=XR*SS
+
+ RETURN
+ END
+*
+*===diqbrk=============================================================*
+*
+CDECK ID>, DT_DIQBRK
+ SUBROUTINE DT_DIQBRK
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* 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)
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+C IF(DT_RNDM(VV).LE.0.5D0)THEN
+C CALL GSQBS1(NHKK)
+C CALL GSQBS2(NHKK)
+C CALL USQBS1(NHKK)
+C CALL USQBS2(NHKK)
+C CALL GSABS1(NHKK)
+C CALL GSABS2(NHKK)
+C CALL USABS1(NHKK)
+C CALL USABS2(NHKK)
+C ELSE
+C CALL GSQBS2(NHKK)
+C CALL GSQBS1(NHKK)
+C CALL USQBS2(NHKK)
+C CALL USQBS1(NHKK)
+C CALL GSABS2(NHKK)
+C CALL GSABS1(NHKK)
+C CALL USABS2(NHKK)
+C CALL USABS1(NHKK)
+C ENDIF
+
+ IF(DT_RNDM(VV).LE.0.5D0) THEN
+ CALL DT_DBREAK(1)
+ CALL DT_DBREAK(2)
+ CALL DT_DBREAK(3)
+ CALL DT_DBREAK(4)
+ CALL DT_DBREAK(5)
+ CALL DT_DBREAK(6)
+ CALL DT_DBREAK(7)
+ CALL DT_DBREAK(8)
+ ELSE
+ CALL DT_DBREAK(2)
+ CALL DT_DBREAK(1)
+ CALL DT_DBREAK(4)
+ CALL DT_DBREAK(3)
+ CALL DT_DBREAK(6)
+ CALL DT_DBREAK(5)
+ CALL DT_DBREAK(8)
+ CALL DT_DBREAK(7)
+ ENDIF
+
+ RETURN
+ END
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
+C
+C USQBS-2 diagram (split target diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+ COMMON /EVFLAG/ NUMEV
+C
+C USQBS-2 diagram (split target diquark)
+C
+C
+C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
+C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
+C
+C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ IREJ=0
+ IF(IPIP.EQ.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
+C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1T diquark
+ XDIQT=PHKK(4,NC1T)*2.D0/UMO
+ XVQP=PHKK(4,NC1P)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
+ * UMO, XDIQT,XVQP
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQT/2.0D0
+ XAQMAX = 2.D0*XVQP/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQP/3.0D0
+ XAQMAX = XDIQT/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
+ * XDIQT,XVQP,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1T diquark and NC1P quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQT=XDIQT-XSQ
+ XVQP =XVQP -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQT=XDIQT-XSAQ
+ XVQP =XVQP -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
+C
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQT)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQII=XDIQT-XVTQI
+ ELSE
+ XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQI=XDIQT-XVTQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP1,IPP2)
+C
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ IDHKT(1) =IPP1
+ ISTHKT(1) =951
+ JMOHKT(1,1)=NC2P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
+ PHKT(1,1) =PHKK(1,NC2P)
+ PHKT(2,1) =PHKK(2,NC2P)
+ PHKT(3,1) =PHKK(3,NC2P)
+ PHKT(4,1) =PHKK(4,NC2P)
+C PHKT(5,1) =PHKK(5,NC2P)
+ XMIST =(PHKT(4,1)**2-
+ * PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC2P)
+ VHKT(2,1) =VHKK(2,NC2P)
+ VHKT(3,1) =VHKK(3,NC2P)
+ VHKT(4,1) =VHKK(4,NC2P)
+ WHKT(1,1) =WHKK(1,NC2P)
+ WHKT(2,1) =WHKK(2,NC2P)
+ WHKT(3,1) =WHKK(3,NC2P)
+ WHKT(4,1) =WHKK(4,NC2P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+ IDHKT(2+IIGLU1) =IP21
+ ISTHKT(2+IIGLU1) =952
+ JMOHKT(1,2+IIGLU1)=NC1T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
+C PHKT(5,2) =PHKK(5,NC1T)
+ XMIST =(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =95
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ XMIST
+ * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+C * JDAHKT(1,1),
+C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+C & JMOHKT(1,IIG),JMOHKT(2,IIG),
+C * JDAHKT(1,IIG),
+C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(4+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(4+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(4+IIGLU1) =951
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ ELSE
+C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
+ PHKT(5,4+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IDHKT(5+IIGLU1) =IP22
+ ISTHKT(5+IIGLU1) =952
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XMIST =(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =95
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ XMIST
+ * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+C IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+C ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 6',
+C * CHAMAL,PHKT(5,6+IIGLU1)
+ GO TO 3466
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(7) =1000*IPP1+100*ISQ+1
+ IDHKT(7+IIGLU1) =IP1
+ ISTHKT(7+IIGLU1) =951
+ JMOHKT(1,7+IIGLU1)=NC1P
+ JMOHKT(2,7+IIGLU1)=0
+**NEW
+C JDAHKT(1,7+IIGLU1)=9+IIGLU1
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+**
+ JDAHKT(2,7+IIGLU1)=0
+ PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
+C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
+ PHKT(5,7+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
+ ENDIF
+ ISTHKT(8+IIGLU1+IIGLU2) =952
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
+ * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
+ * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
+ * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
+ * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
+C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
+ IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
+C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,8) =PHKK(5,NC2T)
+ XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =95
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+**NEW
+C PHKT(1,9+IIGLU1+IIGLU2)
+C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+C PHKT(2,9+IIGLU1+IIGLU2)
+C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+C PHKT(3,9+IIGLU1+IIGLU2)
+C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+C PHKT(4,9+IIGLU1+IIGLU2)
+C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+**
+ XMIST
+ * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ IF(IPIP.GE.2)THEN
+C IF(NUMEV.EQ.-324)THEN
+C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
+C * JDAHKT(1,IIG),
+C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+C 91 CONTINUE
+C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
+C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
+C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 9',
+C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
+C
+C GSQBS-2 diagram (split target diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+C
+C GSQBS-2 diagram (split target diquark)
+C
+C
+C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
+C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
+C
+C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ IREJ=0
+C IF(IPIP.EQ.2)THEN
+C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
+C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
+C ENDIF
+C
+C
+C
+C determine x-values of NC1T diquark
+ XDIQT=PHKK(4,NC1T)*2.D0/UMO
+ XVQP=PHKK(4,NC1P)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
+ * UMO, XDIQT,XVQP
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQT/2.0D0
+ XAQMAX = 2.D0*XVQP/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQP/3.0D0
+ XAQMAX = XDIQT/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
+ * XDIQT,XVQP,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1T diquark and NC1P quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQT=XDIQT-XSQ
+ XVQP =XVQP -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQT=XDIQT-XSAQ
+ XVQP =XVQP -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
+C
+C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQT)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQII=XDIQT-XVTQI
+ ELSE
+ XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
+ XVTQI=XDIQT-XVTQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
+C
+C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
+C
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ KK11=IP21
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ KK21=IPP11
+ KK22=IPP12
+ XGIVE=0.D0
+ IF(IPIP.EQ.1)THEN
+ IDHKT(4+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(4+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(4+IIGLU1) =961
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IDHKT(5+IIGLU1) =IP22
+ ISTHKT(5+IIGLU1) =962
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XXMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,5+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =96
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+C---------------------------------------------------
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+ IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
+C we drop chain 6 and give the energy to chain 3
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1'
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK11 to IDHKT(5)
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
+ KK11=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK21 to IDHKT(5+IIGLU1)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
+ KK21=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK22 to IDHKT(5)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IDHKT(6+IIGLU1)=22888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
+ KK22=IDHKT(5+IIGLU1)
+ GO TO 7788
+ ENDIF
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ 7788 CONTINUE
+C---------------------------------------------------
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(1) =1000*IPP11+100*IPP12+1
+ IF(IPIP.EQ.1)THEN
+ IDHKT(1) =1000*KK21+100*KK22+3
+ IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
+ IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
+ IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(1) =1000*KK21+100*KK22-3
+ IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
+ IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
+ IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
+ ENDIF
+ ISTHKT(1) =961
+ JMOHKT(1,1)=NC2P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
+ PHKT(1,1) =PHKK(1,NC2P)
+ *+XGIVE*PHKT(1,4+IIGLU1)
+ PHKT(2,1) =PHKK(2,NC2P)
+ *+XGIVE*PHKT(2,4+IIGLU1)
+ PHKT(3,1) =PHKK(3,NC2P)
+ *+XGIVE*PHKT(3,4+IIGLU1)
+ PHKT(4,1) =PHKK(4,NC2P)
+ *+XGIVE*PHKT(4,4+IIGLU1)
+C PHKT(5,1) =PHKK(5,NC2P)
+ XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC2P)
+ VHKT(2,1) =VHKK(2,NC2P)
+ VHKT(3,1) =VHKK(3,NC2P)
+ VHKT(4,1) =VHKK(4,NC2P)
+ WHKT(1,1) =WHKK(1,NC2P)
+ WHKT(2,1) =WHKK(2,NC2P)
+ WHKT(3,1) =WHKK(3,NC2P)
+ WHKT(4,1) =WHKK(4,NC2P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+C IDHKT(2) =IP21
+ IDHKT(2+IIGLU1) =KK11
+ ISTHKT(2+IIGLU1) =962
+ JMOHKT(1,2+IIGLU1)=NC1T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
+C * +0.5D0*PHKK(1,NC2T)
+ *+XGIVE*PHKT(1,5+IIGLU1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(2,NC2T)
+ *+XGIVE*PHKT(2,5+IIGLU1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(3,NC2T)
+ *+XGIVE*PHKT(3,5+IIGLU1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
+C *+0.5D0*PHKK(4,NC2T)
+ *+XGIVE*PHKT(4,5+IIGLU1)
+C PHKT(5,2) =PHKK(5,NC1T)
+ XXMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,2+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =96
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(IPIP.EQ.3)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+ * JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+ * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
+ IDHKT(7+IIGLU1) =IP1
+ ISTHKT(7+IIGLU1) =961
+ JMOHKT(1,7+IIGLU1)=NC1P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+ PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
+C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,7+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,7+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C IDHKT(7) =1000*IPP1+100*ISQ+1
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+**NEW
+C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
+ IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
+**
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
+ IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
+ ENDIF
+ ISTHKT(8+IIGLU1+IIGLU2) =962
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
+C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
+ PHKT(1,8+IIGLU1+IIGLU2) =
+ * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(2,8+IIGLU1+IIGLU2) =
+ * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(3,8+IIGLU1+IIGLU2) =
+ * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
+ PHKT(4,8+IIGLU1+IIGLU2) =
+ * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
+C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
+ IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,8) =PHKK(5,NC2T)
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =96
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
+ * PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+ * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
+ *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+ *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+C
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
+C
+C USQBS-1 diagram (split projectile diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+ COMMON /EVFLAG/ NUMEV
+C
+C USQBS-1 diagram (split projectile diquark)
+C
+C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
+C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
+C
+C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
+ CVQ=1.D0
+ IREJ=0
+ IF(IPIP.EQ.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+ * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
+ *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1P diquark
+ XDIQP=PHKK(4,NC1P)*2.D0/UMO
+ XVQT=PHKK(4,NC1T)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
+ * UMO, XDIQP,XVQT
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQP/2.0D0
+ XAQMAX = 2.D0*XVQT/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQT/3.0D0
+ XAQMAX = XDIQP/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
+**
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
+ * XDIQP,XVQT,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1P diquark and NC1T quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQP=XDIQP-XSQ
+ XVQT =XVQT -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQP=XDIQP-XSAQ
+ XVQT =XVQT -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
+C
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQP)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQII=XDIQP-XVPQI
+ ELSE
+ XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQI=XDIQP-XVPQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ IDHKT(1) =IP11
+ ISTHKT(1) =931
+ JMOHKT(1,1)=NC1P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
+ PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
+ PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
+C PHKT(5,1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC1P)
+ VHKT(2,1) =VHKK(2,NC1P)
+ VHKT(3,1) =VHKK(3,NC1P)
+ VHKT(4,1) =VHKK(4,NC1P)
+ WHKT(1,1) =WHKK(1,NC1P)
+ WHKT(2,1) =WHKK(2,NC1P)
+ WHKT(3,1) =WHKK(3,NC1P)
+ WHKT(4,1) =WHKK(4,NC1P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+ IDHKT(2+IIGLU1) =IPP2
+ ISTHKT(2+IIGLU1) =932
+ JMOHKT(1,2+IIGLU1)=NC2T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
+C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
+ XMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,2+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
+ IDHKT(3+IIGLU1) =88888
+ ISTHKT(3+IIGLU1) =94
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ XMIST
+ * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
+ * JMOHKT(2,1),JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
+ * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MUSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IDHKT(4+IIGLU1) =IP12
+ ISTHKT(4+IIGLU1) =931
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ *PHKT(1,4+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,4+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(5+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(5+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(5+IIGLU1) =932
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
+C IF( PHKT(4,5).EQ.0.D0)THEN
+C IREJ=1
+CIPCO=0
+CRETURN
+C ENDIF
+C PHKT(5,5) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+ ISTHKT(6+IIGLU1) =94
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ XMIST
+ * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+C IF(IPIP.EQ.3)THEN
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 6',
+C * CHAMAL,PHKT(5,6+IIGLU1)
+ GO TO 3466
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
+ IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
+ IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
+ IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
+ IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
+ IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
+ IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
+C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
+ ENDIF
+ ISTHKT(7+IIGLU1) =931
+ JMOHKT(1,7+IIGLU1)=NC2P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
+C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
+ IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,7) =PHKK(5,NC2P)
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IDHKT(8+IIGLU1+IIGLU2) =IP2
+ ISTHKT(8+IIGLU1+IIGLU2) =932
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
+C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,8+IIGLU1+IIGLU2)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+ ISTHKT(9+IIGLU1+IIGLU2) =94
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2)
+ * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2)
+ * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2)
+ * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2)
+ * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ XMIST
+ *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,9+IIGLU1+IIGLU2)
+ *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
+ * -PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ IF(IPIP.GE.3)THEN
+C IF(NUMEV.EQ.-324)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,
+ * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
+ * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
+ *JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
+ *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 9',
+C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IPCO=0
+ IGCOUN=9+IIGLU1+IIGLU2
+ RETURN
+ END
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
+C
+C GSQBS-1 diagram (split projectile diquark)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+
+C
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+*KEEP,XSEADI.
+ COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+ +SSMIMQ,VVMTHR
+*KEEP,DPRIN.
+ COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
+C
+C GSQBS-1 diagram (split projectile diquark)
+C
+C
+C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
+C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
+C
+C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+C
+C Put new chains into COMMON /HKKTMP/
+C
+ IIGLU1=NC1T-NC1P-1
+ IIGLU2=NC2T-NC2P-1
+ IGCOUN=0
+C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
+ CVQ=1.D0
+ NNNC1=IDHKK(NC1)/1000
+ MMMC1=IDHKK(NC1)-NNNC1*1000
+ KKKC1=ISTHKK(NC1)
+ NNNC2=IDHKK(NC2)/1000
+ MMMC2=IDHKK(NC2)-NNNC2*1000
+ KKKC2=ISTHKK(NC2)
+ IREJ=0
+ IF(IPIP.EQ.3)THEN
+ WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
+ * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
+ *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
+ * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
+ ENDIF
+C
+C
+C
+C determine x-values of NC1P diquark
+ XDIQP=PHKK(4,NC1P)*2.D0/UMO
+ XVQT=PHKK(4,NC1T)*2.D0/UMO
+C
+C determine x-values of sea quark pair
+C
+ IPCO=1
+ ICOU=0
+ 2234 CONTINUE
+ ICOU=ICOU+1
+ IF(ICOU.GE.500)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
+ * UMO, XDIQP,XVQT
+ XSQ=0.D0
+ XSAQ=0.D0
+**NEW
+C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
+ IF (IPIP.EQ.1) THEN
+ XQMAX = XDIQP/2.0D0
+ XAQMAX = 2.D0*XVQT/3.0D0
+ ELSE
+ XQMAX = 2.D0*XVQT/3.0D0
+ XAQMAX = XDIQP/2.0D0
+ ENDIF
+ CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
+ ISAQ = 6+ISQ
+C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
+**
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IF(IREJ.GE.1)THEN
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
+ * XDIQP,XVQT,XSQ,XSAQ
+ ENDIF
+C
+C subtract xsq,xsaq from NC1P diquark and NC1T quark
+C
+C XSQ=0.D0
+ IF(IPIP.EQ.1)THEN
+ XDIQP=XDIQP-XSQ
+**NEW
+C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
+**
+ XVQT =XVQT -XSAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XDIQP=XDIQP-XSAQ
+ XVQT =XVQT -XSQ
+ ENDIF
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
+C
+C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
+C
+ XVTHRO=CVQ/UMO
+ IVTHR=0
+ 3466 CONTINUE
+ IF(IVTHR.EQ.10)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
+ IPCO=0
+ RETURN
+ ENDIF
+ IVTHR=IVTHR+1
+ XVTHR=XVTHRO/(201-IVTHR)
+ UNOPRV=UNON
+ 380 CONTINUE
+ IF(XVTHR.GT.0.66D0*XDIQP)THEN
+ IREJ=1
+ IF(ISQ.EQ.3)IREJ=3
+ IF(IPCO.GE.3)
+ & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
+ * XVTHR
+ IPCO=0
+ RETURN
+ ENDIF
+ IF(DT_RNDM(V).LT.0.5D0)THEN
+ XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQII=XDIQP-XVPQI
+ ELSE
+ XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
+ XVPQI=XDIQP-XVPQII
+ ENDIF
+ IF(IPCO.GE.3)THEN
+ WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
+ * XVTHR,XDIQP,XVPQI,XVPQII
+ ENDIF
+C
+C Prepare 4 momenta of new chains and chain ends
+C
+C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+C +(4,NTMHKK)
+C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
+C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
+C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
+ IF(IPIP.EQ.1)THEN
+ XSQ1=XSQ
+ XSAQ1=XSAQ
+ ISQ1=ISQ
+ ISAQ1=ISAQ
+ ELSEIF(IPIP.EQ.2)THEN
+ XSQ1=XSAQ
+ XSAQ1=XSQ
+ ISQ1=ISAQ
+ ISAQ1=ISQ
+ ENDIF
+ KK11=IP11
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ KK21= IPP21
+ KK22= IPP22
+ XGIVE=0.D0
+ IDHKT(4+IIGLU1) =IP12
+ ISTHKT(4+IIGLU1) =921
+ JMOHKT(1,4+IIGLU1)=NC1P
+ JMOHKT(2,4+IIGLU1)=0
+ JDAHKT(1,4+IIGLU1)=6+IIGLU1
+ JDAHKT(2,4+IIGLU1)=0
+**NEW
+ IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
+ & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
+**
+ PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
+ PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
+C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
+ XXMIST=(PHKT(4,4+IIGLU1)**2-
+ * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
+ * PHKT(1,4+IIGLU1)**2)
+ IF(XXMIST.GT.0.D0)THEN
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ELSE
+ WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
+ XXMIST=ABS(XXMIST)
+ PHKT(5,4+IIGLU1) =SQRT(XXMIST)
+ ENDIF
+ VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
+ VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
+ VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
+ VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
+ WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
+ WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
+ WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
+ WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(5+IIGLU1) =-(ISAQ1-6)
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(5+IIGLU1) =ISAQ1
+ ENDIF
+ ISTHKT(5+IIGLU1) =922
+ JMOHKT(1,5+IIGLU1)=NC1T
+ JMOHKT(2,5+IIGLU1)=0
+ JDAHKT(1,5+IIGLU1)=6+IIGLU1
+ JDAHKT(2,5+IIGLU1)=0
+**NEW
+ IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
+**
+ PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
+ PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
+C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
+ * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
+ *PHKT(1,5+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
+ PHKT(5,5+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
+ VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
+ VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
+ VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
+ WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
+ WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
+ WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
+ WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
+ IDHKT(6+IIGLU1) =88888
+C IDHKT(6) =1000*NNNC1+MMMC1
+ ISTHKT(6+IIGLU1) =93
+C ISTHKT(6) =KKKC1
+ JMOHKT(1,6+IIGLU1)=4+IIGLU1
+ JMOHKT(2,6+IIGLU1)=5+IIGLU1
+ JDAHKT(1,6+IIGLU1)=0
+ JDAHKT(2,6+IIGLU1)=0
+ PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
+ PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
+ PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
+ PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
+ PHKT(5,6+IIGLU1)
+ * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
+ * -PHKT(3,6+IIGLU1)**2)
+ CHAMAL=CHAM1
+ IF(IPIP.EQ.1)THEN
+ IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
+ ENDIF
+ IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
+ IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
+C we drop chain 6 and give the energy to chain 3
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1'
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK11 to IDHKT(4)
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
+ KK11=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK21 to IDHKT(4)
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
+ KK21=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
+C we drop chain 6 and give the energy to chain 3
+C and change KK22 to IDHKT(4)
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IDHKT(6+IIGLU1)=33888
+ XGIVE=1.D0
+C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
+ KK22=IDHKT(4+IIGLU1)
+ GO TO 7788
+ ENDIF
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 6'
+ GO TO 3466
+ ENDIF
+ 7788 CONTINUE
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
+ * JMOHKT(1,4+IIGLU1),
+ * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
+ *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
+ WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
+ * JMOHKT(1,5+IIGLU1),
+ * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
+ *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
+ WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
+ * JMOHKT(1,6+IIGLU1),
+ * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
+ *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
+ ENDIF
+ VHKT(1,6+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,6+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,6+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,6+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,6+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,6+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,6+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,6+IIGLU1) =WHKK(4,NC1)
+C IDHKT(1) =IP11
+ IDHKT(1) =KK11
+ ISTHKT(1) =921
+ JMOHKT(1,1)=NC1P
+ JMOHKT(2,1)=0
+ JDAHKT(1,1)=3+IIGLU1
+ JDAHKT(2,1)=0
+ PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(1,NC2P)
+ *+XGIVE*PHKT(1,4+IIGLU1)
+ PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(2,NC2P)
+ *+XGIVE*PHKT(2,4+IIGLU1)
+ PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(3,NC2P)
+ *+XGIVE*PHKT(3,4+IIGLU1)
+ PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
+C * +0.5D0*PHKK(4,NC2P)
+ *+XGIVE*PHKT(4,4+IIGLU1)
+C PHKT(5,1) =PHKK(5,NC1P)
+ XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ IF(XMIST.GE.0.D0)THEN
+ PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
+ *PHKT(1,1)**2)
+ ELSE
+C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,1)=0.D0
+ ENDIF
+ VHKT(1,1) =VHKK(1,NC1P)
+ VHKT(2,1) =VHKK(2,NC1P)
+ VHKT(3,1) =VHKK(3,NC1P)
+ VHKT(4,1) =VHKK(4,NC1P)
+ WHKT(1,1) =WHKK(1,NC1P)
+ WHKT(2,1) =WHKK(2,NC1P)
+ WHKT(3,1) =WHKK(3,NC1P)
+ WHKT(4,1) =WHKK(4,NC1P)
+C Add here IIGLU1 gluons to this chaina
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU1.GE.1)THEN
+ JJG=NC1P
+ DO 61 IIG=2,2+IIGLU1-1
+ KKG=JJG+IIG-1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=3+IIGLU1
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 61 CONTINUE
+ ENDIF
+C IDHKT(2) =1000*IPP21+100*IPP22+1
+ IF(IPIP.EQ.1)THEN
+ IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
+ IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
+ IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
+ IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
+ IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
+ IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
+ IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
+ ENDIF
+ ISTHKT(2+IIGLU1) =922
+ JMOHKT(1,2+IIGLU1)=NC2T
+ JMOHKT(2,2+IIGLU1)=0
+ JDAHKT(1,2+IIGLU1)=3+IIGLU1
+ JDAHKT(2,2+IIGLU1)=0
+ PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
+ *+XGIVE*PHKT(1,5+IIGLU1)
+ PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
+ *+XGIVE*PHKT(2,5+IIGLU1)
+ PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
+ *+XGIVE*PHKT(3,5+IIGLU1)
+ PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
+ *+XGIVE*PHKT(4,5+IIGLU1)
+C PHKT(5,2) =PHKK(5,NC2T)
+ XMIST=(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
+ * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
+ *PHKT(1,2+IIGLU1)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,2+IIGLU1)=0.D0
+ ENDIF
+ VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
+ VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
+ VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
+ VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
+ WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
+ WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
+ WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
+ WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
+ IDHKT(3+IIGLU1) =88888
+C IDHKT(3) =1000*NNNC1+MMMC1+10
+ ISTHKT(3+IIGLU1) =93
+C ISTHKT(3) =KKKC1
+ JMOHKT(1,3+IIGLU1)=1
+ JMOHKT(2,3+IIGLU1)=2+IIGLU1
+ JDAHKT(1,3+IIGLU1)=0
+ JDAHKT(2,3+IIGLU1)=0
+ PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
+ PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
+ PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
+ PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
+ PHKT(5,3+IIGLU1)
+ * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
+ * -PHKT(3,3+IIGLU1)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
+ * JDAHKT(1,1),
+ *JDAHKT(2,1),(PHKT(III,1),III=1,5)
+ DO 71 IIG=2,2+IIGLU1-1
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 71 CONTINUE
+ WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
+ & IDHKT(2),JMOHKT(1,2+IIGLU1),
+ * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
+ *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
+ WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
+ * JMOHKT(1,3+IIGLU1),
+ * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
+ *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+**NEW
+C IF(IPIP.EQ.1)THEN
+C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
+C ELSEIF(IPIP.EQ.2)THEN
+C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
+C ENDIF
+ IF(IPIP.EQ.1)THEN
+ IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
+ ENDIF
+**
+ IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 3'
+ GO TO 3466
+ ENDIF
+ VHKT(1,3+IIGLU1) =VHKK(1,NC1)
+ VHKT(2,3+IIGLU1) =VHKK(2,NC1)
+ VHKT(3,3+IIGLU1) =VHKK(3,NC1)
+ VHKT(4,3+IIGLU1) =VHKK(4,NC1)
+ WHKT(1,3+IIGLU1) =WHKK(1,NC1)
+ WHKT(2,3+IIGLU1) =WHKK(2,NC1)
+ WHKT(3,3+IIGLU1) =WHKK(3,NC1)
+ WHKT(4,3+IIGLU1) =WHKK(4,NC1)
+ IF(IPIP.EQ.1)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
+ IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
+ IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
+ IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
+ ELSEIF(IPIP.EQ.2)THEN
+ IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
+ IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
+ IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
+ IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
+C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
+ ENDIF
+ ISTHKT(7+IIGLU1) =921
+ JMOHKT(1,7+IIGLU1)=NC2P
+ JMOHKT(2,7+IIGLU1)=0
+ JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
+ JDAHKT(2,7+IIGLU1)=0
+C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
+C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
+**NEW
+ IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
+**
+ PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
+ PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
+C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
+C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
+ IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
+C IREJ=1
+C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
+ IPCO=0
+C RETURN
+ GO TO 3466
+ ENDIF
+C PHKT(5,7) =PHKK(5,NC2P)
+ PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
+ * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
+ *PHKT(1,7+IIGLU1)**2)
+ VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
+ VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
+ VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
+ VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
+ WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
+ WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
+ WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
+ WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
+C Insert here the IIGLU2 gluons
+ PG1=0.D0
+ PG2=0.D0
+ PG3=0.D0
+ PG4=0.D0
+ IF(IIGLU2.GE.1)THEN
+ JJG=NC2P
+ DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ KKG=JJG+IIG-7-IIGLU1
+ IDHKT(IIG) =IDHKK(KKG)
+ ISTHKT(IIG) =921
+ JMOHKT(1,IIG)=KKG
+ JMOHKT(2,IIG)=0
+ JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
+ JDAHKT(2,IIG)=0
+ PHKT(1,IIG)=PHKK(1,KKG)
+ PG1=PG1+ PHKT(1,IIG)
+ PHKT(2,IIG)=PHKK(2,KKG)
+ PG2=PG2+ PHKT(2,IIG)
+ PHKT(3,IIG)=PHKK(3,KKG)
+ PG3=PG3+ PHKT(3,IIG)
+ PHKT(4,IIG)=PHKK(4,KKG)
+ PG4=PG4+ PHKT(4,IIG)
+ PHKT(5,IIG)=PHKK(5,KKG)
+ VHKT(1,IIG) =VHKK(1,KKG)
+ VHKT(2,IIG) =VHKK(2,KKG)
+ VHKT(3,IIG) =VHKK(3,KKG)
+ VHKT(4,IIG) =VHKK(4,KKG)
+ WHKT(1,IIG) =WHKK(1,KKG)
+ WHKT(2,IIG) =WHKK(2,KKG)
+ WHKT(3,IIG) =WHKK(3,KKG)
+ WHKT(4,IIG) =WHKK(4,KKG)
+ 81 CONTINUE
+ ENDIF
+ IDHKT(8+IIGLU1+IIGLU2) =IP2
+ ISTHKT(8+IIGLU1+IIGLU2) =922
+ JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
+ JMOHKT(2,8+IIGLU1+IIGLU2)=0
+ JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
+ JDAHKT(2,8+IIGLU1+IIGLU2)=0
+**NEW
+ IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
+ & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
+**
+ PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
+ PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
+C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
+ XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ IF(XMIST.GT.0.D0)THEN
+ PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
+ * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
+ *PHKT(1,8+IIGLU1+IIGLU2)**2)
+ ELSE
+C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
+ PHKT(5,8+IIGLU1+IIGLU2)=0.D0
+ ENDIF
+ VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
+ VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
+ VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
+ VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
+ WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
+ WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
+ WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
+ WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
+ IDHKT(9+IIGLU1+IIGLU2) =88888
+C IDHKT(9) =1000*NNNC2+MMMC2+10
+ ISTHKT(9+IIGLU1+IIGLU2) =93
+C ISTHKT(9) =KKKC2
+ JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
+ JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
+ JDAHKT(1,9+IIGLU1+IIGLU2)=0
+ JDAHKT(2,9+IIGLU1+IIGLU2)=0
+ PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
+ * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
+ PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
+ * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
+ PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
+ * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
+ PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
+ * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
+ PHKT(5,9+IIGLU1+IIGLU2)
+ * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
+ * PHKT(2,9+IIGLU1+IIGLU2)**2
+ * -PHKT(3,9+IIGLU1+IIGLU2)**2)
+ IF(IPIP.GE.3)THEN
+ WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
+ * JMOHKT(1,7+IIGLU1),
+ * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
+ *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
+ DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
+ WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
+ & JMOHKT(1,IIG),JMOHKT(2,IIG),
+ * JDAHKT(1,IIG),
+ *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
+ 91 CONTINUE
+ WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
+ * IDHKT(8+IIGLU1+IIGLU2),
+ * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
+ * JDAHKT(1,8+IIGLU1+IIGLU2),
+ *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
+ WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
+ * IDHKT(9+IIGLU1+IIGLU2),
+ * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
+ * JDAHKT(1,9+IIGLU1+IIGLU2),
+ *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
+ ENDIF
+ CHAMAL=CHAB1
+ IF(IPIP.EQ.1)THEN
+ IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
+ ELSEIF(IPIP.EQ.2)THEN
+ IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
+ ENDIF
+ IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
+C IREJ=1
+ IPCO=0
+C RETURN
+C WRITE(6,*)' MGSQBS1 jump back from chain 9',
+C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
+ GO TO 3466
+ ENDIF
+ VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
+ VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
+ VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
+ VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
+ WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
+ WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
+ WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
+ WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
+C
+ IGCOUN=9+IIGLU1+IIGLU2
+ IPCO=0
+ RETURN
+ END
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+ SUBROUTINE HKKHKT(I,J)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+* 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)
+
+ PARAMETER (NTMHKK= 300)
+ COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
+ +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
+ +(4,NTMHKK)
+C
+ ISTHKK(I) =ISTHKT(J)
+ IDHKK(I) =IDHKT(J)
+C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
+ IF(IDHKK(I).EQ.88888)THEN
+C JMOHKK(1,I)=I-2
+C JMOHKK(2,I)=I-1
+ JMOHKK(1,I)=I-(J-JMOHKT(1,J))
+ JMOHKK(2,I)=I-(J-JMOHKT(2,J))
+ ELSE
+ JMOHKK(1,I)=JMOHKT(1,J)
+ JMOHKK(2,I)=JMOHKT(2,J)
+ ENDIF
+ JDAHKK(1,I)=JDAHKT(1,J)
+ JDAHKK(2,I)=JDAHKT(2,J)
+C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
+C JDAHKK(1,I)=I+2
+C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
+C JDAHKK(1,I)=I+1
+C ENDIF
+ IF(JDAHKT(1,J).GT.0)THEN
+ JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
+ ENDIF
+ PHKK(1,I) =PHKT(1,J)
+ PHKK(2,I) =PHKT(2,J)
+ PHKK(3,I) =PHKT(3,J)
+ PHKK(4,I) =PHKT(4,J)
+ PHKK(5,I) =PHKT(5,J)
+ VHKK(1,I) =VHKT(1,J)
+ VHKK(2,I) =VHKT(2,J)
+ VHKK(3,I) =VHKT(3,J)
+ VHKK(4,I) =VHKT(4,J)
+ WHKK(1,I) =WHKT(1,J)
+ WHKK(2,I) =WHKT(2,J)
+ WHKK(3,I) =WHKT(3,J)
+ WHKK(4,I) =WHKT(4,J)
+ RETURN
+ END
+*
+*===dbreak=============================================================*
+*
+CDECK ID>, DT_DBREAK
+ SUBROUTINE DT_DBREAK(MODE)
+
+************************************************************************
+* This is the steering subroutine for the different diquark breaking *
+* mechanisms. *
+* *
+* MODE = 1 breaking of projectile diquark in qq-q chain using *
+* a sea quark (q-qq chain) of the same projectile *
+* = 2 breaking of target diquark in q-qq chain using *
+* a sea quark (qq-q chain) of the same target *
+* = 3 breaking of projectile diquark in qq-q chain using *
+* a sea quark (q-aq chain) of the same projectile *
+* = 4 breaking of target diquark in q-qq chain using *
+* a sea quark (aq-q chain) of the same target *
+* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
+* a sea anti-quark (aq-aqaq chain) of the same projectile *
+* = 6 breaking of target anti-diquark in aq-aqaq chain using *
+* a sea anti-quark (aqaq-aq chain) of the same target *
+* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
+* a sea anti-quark (aq-q chain) of the same projectile *
+* = 8 breaking of target anti-diquark in aq-aqaq chain using *
+* a sea anti-quark (q-aq chain) of the same target *
+* *
+* Original version by J. Ranft. *
+* This version dated 17.5.00 is written by S. Roesler. *
+************************************************************************
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( LINP = 5 ,
+ & LOUT = 6 ,
+ & LDAT = 9 )
+
+* 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
+* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
+ PARAMETER (MAXCHN=10000)
+ COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
+* diquark-breaking mechanism
+ COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+* 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
+
+*
+* chain identifiers
+* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
+* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
+ DIMENSION IDCHN1(8),IDCHN2(8)
+ DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
+ DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
+*
+* parton identifiers
+* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
+* +-51/52 = unitarity-sea, +-61/62 = gluons )
+ DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
+ DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
+ & 31, 31, 31, 31, 31, 31, 31, 31,
+ & 41, 41, 41, 41, 51, 51, 51, 51/
+ DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
+ & 32, 32, 32, 32, 32, 32, 32, 32,
+ & 42, 42, 42, 42, 52, 52, 52, 52/
+ DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
+ & 51, 31, 41, 41, 31, 31, 31, 31,
+ & 0, 41, 51, 51, 51, 51, 51, 51/
+ DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
+ & 32, 52, 42, 42, 32, 32, 32, 32,
+ & 42, 0, 52, 52, 52, 52, 52, 52/
+
+ IF (NCHAIN.LE.0) RETURN
+ DO 1 I=1,NCHAIN
+ IDX1 = IDXCHN(1,I)
+ IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
+ IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
+ IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
+ & .AND.
+ & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
+ & (IS1P.EQ.ISP1P(MODE,3)))
+ & .AND.
+ & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
+ & (IS1T.EQ.ISP1T(MODE,3)))
+ & ) THEN
+ DO 2 J=1,NCHAIN
+ IDX2 = IDXCHN(1,J)
+ IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
+ IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
+ IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
+ & .AND.
+ & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
+ & .OR.(IS2P.EQ.ISP2P(MODE,3)))
+ & .AND.
+ & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
+ & .OR.(IS2T.EQ.ISP2T(MODE,3)))
+ & ) THEN
+* find mother nucleons of the diquark to be splitted and of the
+* sea-quark and reject this combination if it is not the same
+ IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
+ & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
+ IANCES = 1
+ ELSE
+ IANCES = 2
+ ENDIF
+ IDXMO1 = JMOHKK(IANCES,IDX1)
+ 4 CONTINUE
+ IF ((JMOHKK(1,IDXMO1).NE.0).AND.
+ & (JMOHKK(2,IDXMO1).NE.0)) THEN
+ IANC = IANCES
+ ELSE
+ IANC = 1
+ ENDIF
+ IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
+ IDXMO1 = JMOHKK(IANC,IDXMO1)
+ GOTO 4
+ ENDIF
+ IDXMO2 = JMOHKK(IANCES,IDX2)
+ 5 CONTINUE
+ IF ((JMOHKK(1,IDXMO2).NE.0).AND.
+ & (JMOHKK(2,IDXMO2).NE.0)) THEN
+ IANC = IANCES
+ ELSE
+ IANC = 1
+ ENDIF
+ IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
+ IDXMO2 = JMOHKK(IANC,IDXMO2)
+ GOTO 5
+ ENDIF
+ IF (IDXMO1.NE.IDXMO2) GOTO 2
+* quark content of projectile parton
+ IP1 = IDHKK(JMOHKK(1,IDX1))
+ IP11 = IP1/1000
+ IP12 = (IP1-1000*IP11)/100
+ IP2 = IDHKK(JMOHKK(2,IDX1))
+ IP21 = IP2/1000
+ IP22 = (IP2-1000*IP21)/100
+* quark content of target parton
+ IT1 = IDHKK(JMOHKK(1,IDX2))
+ IT11 = IT1/1000
+ IT12 = (IT1-1000*IT11)/100
+ IT2 = IDHKK(JMOHKK(2,IDX2))
+ IT21 = IT2/1000
+ IT22 = (IT2-1000*IT21)/100
+* split diquark and form new chains
+ IF (MODE.EQ.1) THEN
+ IF (IT1.EQ.4) GOTO 2
+ CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.2) THEN
+ IF (IT2.EQ.4) GOTO 2
+ CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.3) THEN
+ IF (IT1.EQ.4) GOTO 2
+ CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.4) THEN
+ IF (IT2.EQ.4) GOTO 2
+ CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.5) THEN
+ CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.6) THEN
+ CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.7) THEN
+ CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
+ ELSEIF (MODE.EQ.8) THEN
+ CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
+ & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
+ & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
+ ENDIF
+ IF (IREJ.GE.1) THEN
+ if ((ipq.lt.0).or.(ipq.ge.4))
+ & write(LOUT,*) 'ipq !!!',ipq,mode
+ DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
+* accept or reject new chains corresponding to PDBSEA
+ ELSE
+ IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
+ ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
+ REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
+ ELSEIF (IPQ.EQ.3) THEN
+ ACC = DBRKA(3,MODE)
+ REJ = DBRKR(3,MODE)
+ ELSE
+ WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
+ STOP
+ ENDIF
+ IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
+ DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
+ IACC = 1
+ ELSE
+ DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
+ IACC = 0
+ ENDIF
+* new chains have been accepted and are now copied into HKKEVT
+ IF (IACC.EQ.1) THEN
+ IF (LEMCCK) THEN
+ CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
+ & PHKK(3,IDX1),PHKK(4,IDX1),
+ & 1,IDUM1,IDUM2)
+ CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
+ & PHKK(3,IDX2),PHKK(4,IDX2),
+ & 2,IDUM1,IDUM2)
+ ENDIF
+ IDHKK(IDX1) = 99888
+ IDHKK(IDX2) = 99888
+ IDXCHN(2,I) = -1
+ IDXCHN(2,J) = -1
+ DO 3 K=1,IGCOUN
+ NHKK = NHKK+1
+ CALL HKKHKT(NHKK,K)
+ IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
+ PX = -PHKK(1,NHKK)
+ PY = -PHKK(2,NHKK)
+ PZ = -PHKK(3,NHKK)
+ PE = -PHKK(4,NHKK)
+ CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+ ENDIF
+ 3 CONTINUE
+ IF (LEMCCK) THEN
+ CHKLEV = 0.1D0
+ CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
+ & IREJ)
+ IF (IREJ.NE.0) CALL DT_EVTOUT(4)
+ ENDIF
+ GOTO 1
+ ENDIF
+ ENDIF
+ ENDIF
+ 2 CONTINUE
+ ENDIF
+ 1 CONTINUE
+ RETURN
+ END
+*
+*===cqpair=============================================================*
+*
+CDECK ID>, DT_CQPAIR
+ SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
+
+************************************************************************
+* This subroutine Creates a Quark-antiquark PAIR from the sea. *
+* *
+* XQMAX maxium energy fraction of quark (input) *
+* XAQMAX maxium energy fraction of antiquark (input) *
+* XQ energy fraction of quark (output) *
+* XAQ energy fraction of antiquark (output) *
+* IFLV quark flavour (- antiquark flavor) (output) *
+* *
+* This version dated 14.5.00 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
+
+*
+ IREJ = 0
+ XQ = 0.0D0
+ XAQ = 0.0D0
+*
+* sample quark flavour
+*
+* set seasq here (the one from DTCHAI should be used in the future)
+ SEASQ = 0.5D0
+ IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
+*
+* sample energy fractions of sea pair
+* we first sample the energy fraction of a gluon and then split the gluon
+*
+* maximum energy fraction of the gluon forced via input
+ XGMAXI = XQMAX+XAQMAX
+* minimum energy fraction of the gluon
+ XTHR1 = 4.0D0 /UMO**2
+ XTHR2 = 0.54D0/UMO**1.5D0
+ XGMIN = MAX(XTHR1,XTHR2)
+* maximum energy fraction of the gluon
+ XGMAX = 0.3D0
+ XGMAX = MIN(XGMAXI,XGMAX)
+ IF (XGMIN.GE.XGMAX) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+*
+* sample energy fraction of the gluon
+ NLOOP = 0
+ 1 CONTINUE
+ NLOOP = NLOOP+1
+ IF (NLOOP.GE.50) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+ XGLUON = DT_SAMSQX(XGMIN,XGMAX)
+ EGLUON = XGLUON*UMO/2.0D0
+*
+* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
+ ZMIN = MIN(0.1D0,0.5D0/EGLUON)
+ ZMAX = 1.0D0-ZMIN
+ RZ = DT_RNDM(ZMAX)
+ XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
+ RQ = DT_RNDM(ZMAX)
+ IF (RQ.LT.0.5D0) THEN
+ XQ = XGLUON*XHLP
+ XAQ = XGLUON-XQ
+ ELSE
+ XAQ = XGLUON*XHLP
+ XQ = XGLUON-XAQ
+ ENDIF
+ IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
+
+ RETURN
+ END
--- /dev/null
+***********************************************************
+*
+* parameter set for running cut option IPAMDL(7) = 1
+*
+* new fits
+*
+***********************************************************
+NEXTDATA
+ -2212 GRV94 LO 5 6 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ 2212 GRV94 LO 5 6 0
+ -2212 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ 2212 GRV94 LO 5 6 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.576 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ -211 GRV-P LO 5 2 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 3.658 6.926 0.359 1.208
+ 0.490 1.000 8.384 7.945 0.072 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.600
+ 0.300 1.100 3.000
+NEXTDATA
+ 211 GRV-P LO 5 2 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 3.706 6.926 0.362 1.208
+ 0.490 1.000 5.090 7.945 2.289 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.600
+ 0.300 1.100 3.000
+NEXTDATA
+ 111 GRV-P LO 5 2 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 3.706 6.926 0.362 1.208
+ 0.490 1.000 5.090 7.945 2.289 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.600
+ 0.300 1.100 3.000
+NEXTDATA
+ -321 GRV-P LO 5 2 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 3.658 6.926 0.359 1.208
+ 0.490 1.000 8.384 7.945 0.072 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.600
+ 0.300 1.100 3.000
+NEXTDATA
+ 321 GRV-P LO 5 2 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 3.706 6.926 0.362 1.208
+ 0.490 1.000 5.090 7.945 2.289 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.600
+ 0.300 1.100 3.000
+NEXTDATA
+ 22 GRV-G LO 5 3 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 2.863 6.926 1.030 1.208
+ 0.473 1.000 8.526 5.908 0.000 0.374
+ 0.149 0.500 0.176 0.300
+ 0.00446 0.00008 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.750 0.600
+ 1.000 1.100 3.000
+NEXTDATA
+ 2212 GRV94 LO 5 6 0
+ 22 GRV-G LO 5 3 0
+ 1.080 0.250 6.926 2.863 1.208 1.030
+ 0.473 1.000 5.908 8.526 0.374 0.000
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 0.00446 0.00008
+ 2.500
+ 1.000
+ 0.600 0.750
+ 1.100 1.000 3.000
+NEXTDATA
+ 22 GRV-G LO 5 3 0
+ 22 GRV-G LO 5 3 0
+ 1.080 0.250 2.863 2.863 1.030 1.030
+ 0.473 1.000 5.526 5.526 0.124 0.124
+ 0.149 0.500 0.176 0.300
+ 0.00446 0.00008 0.00446 0.00008
+ 2.500
+ 1.000
+ 0.750 0.750
+ 1.000 1.000 3.000
+NEXTDATA
+ 211 GRV-P LO 5 2 0
+ 211 GRV-P LO 5 2 0
+ 1.080 0.250 3.706 3.706 0.362 0.362
+ 0.490 1.000 7.945 7.945 1.174 1.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.700 0.700
+ 0.300 0.300 3.000
+NEXTDATA
+ 2212 GRV94 LO 5 6 0
+ 2112 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.576 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ 2112 GRV94 LO 5 6 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.576 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ 2112 GRV94 LO 5 6 0
+ 2112 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.576 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ -2112 GRV94 LO 5 6 0
+ 2212 GRV94 LO 5 6 0
+ 1.080 0.250 6.926 6.926 1.208 1.208
+ 0.490 1.000 5.908 5.908 2.174 2.174
+ 0.149 0.500 0.176 0.300
+ 1.00000 0.00000 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.600 0.600
+ 1.100 1.100 3.000
+NEXTDATA
+ 22 GRV-G LO 5 3 0
+ -2212 GRV94 LO 5 6 0
+ 1.080 0.250 2.863 6.926 1.030 1.208
+ 0.473 1.000 8.526 5.908 0.000 0.374
+ 0.149 0.500 0.176 0.300
+ 0.00446 0.00008 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.750 0.600
+ 1.000 1.100 3.000
+NEXTDATA
+ 22 GRV-G LO 5 3 0
+ 2112 GRV94 LO 5 6 0
+ 1.080 0.250 2.863 6.926 1.030 1.208
+ 0.473 1.000 8.526 5.908 0.000 0.374
+ 0.149 0.500 0.176 0.300
+ 0.00446 0.00008 1.00000 0.00000
+ 2.500
+ 1.000
+ 0.750 0.600
+ 1.000 1.100 3.000
+STOP
--- /dev/null
+*$ CREATE AACOLL.ADD
+*COPY AACOLL
+*
+*=== Aacoll ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* A-A COLLision common: *
+* *
+* Ion-Ion collision common for Fluka 9x....: *
+* *
+* Last change on 15-apr-99 by Alfredo Ferrari, INFN-Milan *
+* *
+* Description of the variable(s): *
+* *
+* Ekpern = kinetic energy per nucleon GeV/amu *
+* Enpern = total energy per nucleon GeV/amu *
+* Plpern = momentum per nucleon GeV/c/amu *
+* Eexion = excitation energy of the projectile ion *
+* Matprj(i) = list of materials used as projectiles *
+* Nmatpr = number of materials defined inside Matprj *
+* Iproa = the projectile mass number *
+* Iproz = the projectile proton number *
+* Mattar = material number of the target *
+* Itara = the target mass number *
+* Itarz = the target proton number *
+* Matpro = material number of the (current) projectile *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! Note that the units are GeV/amu --> per unit mass !!!! *
+* !!!! with mass measured in amu (1 amu = Amuc12 GeV) !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / AACOLL / EKPERN, ENPERN, PLPERN, EEXION, MATPRJ (MXXMDF),
+ & NMATPR, MATPRO, IPROA , IPROZ , MATTAR, ITARA ,
+ & ITARZ
+
--- /dev/null
+*$ CREATE AADAT.ADD
+*COPY AADAT
+* *
+*=== aadat ============================================================*
+* *
+ PARAMETER (IPROM = 100)
+ PARAMETER (ITARM = 100)
+ COMMON/AADAT/ENPERN,PLPERN,SIGAA(IPROM,ITARM),SIGNN,TMASS,AAEVNO,
+ + SELAA(IPROM,ITARM),RLASTP(IPROM,ITARM),
+ + MATPRO,MATTAR,LASTM,IPROA,IPROZ,ITARA,ITARZ
+
--- /dev/null
+*$ CREATE ABLTIS.ADD
+*COPY ABLTIS
+*
+*=== abltis ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* This is the old ABLTIS common of Hadrin, extracted and put *
+* into an include file *
+* *
+* Created on 17 may 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 07-feb-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* AMGA *
+* CALUMO *
+* CALUMV *
+* DATESH *
+* FERHAV *
+* HADDEN *
+* HADRIN *
+* HADRIV *
+* HYPERO *
+* NUCRIV *
+* RCHANV *
+* SIGINT *
+* TCHOIC *
+* TWOPAR *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / ABLTIS / AM (-6:MXPABL), GA (-6:MXPABL),
+ & TAU (-6:MXPABL), ICH (-6:MXPABL),
+ & IBAR (-6:MXPABL), K1 (-6:MXPABL),
+ & K2 (-6:MXPABL)
+
--- /dev/null
+*$ CREATE ADDHP.ADD
+*COPY ADDHP
+*
+*=== addhp ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file Addhp: (it is a very old one, recently put into an *
+* include file) *
+* *
+* Created on 17 may 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 03-aug-99 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BLKDT5 *
+* HADDEN *
+* *
+*----------------------------------------------------------------------*
+*
+* Till 3-aug-99:
+* PARAMETER ( MXPADD = 16 )
+* PARAMETER ( MXADZK = 153 )
+ PARAMETER ( MXPADD = 26 )
+ PARAMETER ( MXADZK = 183 )
+ CHARACTER*8 ANAMZ,ZKNAMZ
+ COMMON / ADDHP / AMZ (MXPADD), GAZ (MXPADD), TAUZ (MXPADD),
+ & WTZ (MXADZK), ICHZ (MXPADD), IBARZ (MXPADD),
+ & K1Z (MXPADD), K2Z (MXPADD), NZKZ (MXADZK,3),
+ & II22
+ COMMON / ADDHN / ANAMZ (MXPADD), ZKNAMZ (MXADZK)
+
--- /dev/null
+*$ CREATE ATFFAC.ADD
+*COPY ATFFAC
+*
+*=== ATFFAC ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file atffac: ATomic Form FACtors *
+* *
+* Created on 18 march 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-may-93 by Alfredo Ferrari *
+* *
+* Gmoliz(iz) = Z^1/3 / 121 *
+* Algmlz(iz) = Log (Gmoliz(iz)) *
+* Xsielz(iz) = asymptotic contribution of atomic electrons to pair *
+* and bremsstrahlung *
+* Fclmbz(iz) = Coulomb correction *
+* Aagelz(iz) = a for the Tsai fit to the atomic elastic form factor*
+* [1-F^2(q)]=(aq)^4/[1+(aq)^2]^2, [a] = [MeV/c]^-1 *
+* For Z>=5 is given by a = 111.7 / (Z^1/3 me) *
+* Apginz(iz) = a' for the Tsai fit to the atomic inelastic form *
+* factor S(q)=(a'q)^4/[1+(a'q)^2]^2, [a'] = [MeV/c]^-1*
+* For Z>=5 is given by a' = 724.2 / (Z^2/3 me) *
+* *
+* Actually a and a' are stored already squared !! *
+* *
+* Asqzft(iz) = a parameter for the fit to S(q,Z) computed with the *
+* Hartree-Fock method *
+* Bsqzft(iz) = b parameter for the fit to S(q,Z) computed with the *
+* Hartree-Fock method *
+* Csqzft(iz) = c parameter for the fit to S(q,Z) computed with the *
+* Hartree-Fock method *
+* Dsqzft(iz) = d parameter for the fit to S(q,Z) computed with the *
+* Hartree-Fock method *
+* Esqzft(iz) = e parameter for the fit to S(q,Z) computed with the *
+* Hartree-Fock method *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( A121 = 121. D+00 )
+ PARAMETER ( A111P7 = 111.7 D+00 )
+ PARAMETER ( A724P2 = 724.2 D+00 )
+ PARAMETER ( A184 = 184.15 D+00 )
+ PARAMETER ( A1194 = 1194. D+00 )
+*
+ COMMON / ATFFAC / GMOLIZ (100), ALGMLZ (100), XSIELZ (100),
+ & FCLMBZ (100), AAGELZ (100), APGINZ (100),
+ & ASQZFT (100), BSQZFT (100), CSQZFT (100),
+ & DSQZFT (100), ESQZFT (100)
+
--- /dev/null
+*$ CREATE ATNUBF.ADD
+*COPY ATNUBF
+*
+*=== atnubf ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* ATmospheric NeUtrino BuFfer: *
+* *
+* Created on 29 may 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 15-dec-99 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Idatnu = neutrino id (Paprop numbering) *
+* Lgatnu = neutrino generation *
+* Enatnu = neutrino energy (GeV) *
+* Diatnu = neutrino production height or distance (cm) *
+* Thatnu = neutrino direction polar (theta) angle (rad) *
+* Phatnu = neutrino direction azimuthal (phi) angle (rad) *
+* Wtatnu = neutrino weight (such to be automatically norm- *
+* alized to fluence per unit time and area) *
+* Ipatnu = parent cosmic ray id (Z + 100 x A) *
+* Ifatnu = "father" hadron/muon Fluka id *
+* Igatnu = "grandfather" hadron Fluka id *
+* Ictfnu = i1 + j1 x 3 + i2 x 9 + j2 x 27 + i3 x 81 + j3 x 243*
+* + i4 x 729 + j4 x 2187 + i5 x 6561 + j5 x 19683 *
+* ik = cutoff flag for the k_th location, direct nu *
+* jk = cutoff flag for the k_th location, mirror nu *
+* = 0 <-> not yet checked *
+* = 1 <-> neutrino not cutoffed *
+* = 2 <-> neutrino cutoffed *
+* Pmatnu = parent cosmic ray momentum (GeV/c/amu) *
+* Pfatnu = "father" hadron/muon momentum (GeV/c) *
+* Pgatnu = "grandfather" hadron momentum (GeV/c) *
+* Xpatnu = parent cosmic ray 1st interaction x coord. (cm) *
+* Ypatnu = parent cosmic ray 1st interaction y coord. (cm) *
+* Zpatnu = parent cosmic ray 1st interaction z coord. (cm) *
+* Tpatnu = parent cosmic ray direction polar angle (rad) *
+* Ppatnu = parent cosmic ray direction azimuthal angle (rad) *
+* Wpatnu = accumulated primary weight at the previous buffer *
+* flush *
+* Npatnu = accumulated primary number at the previous buffer *
+* flush *
+* Ncatnu = current pointer in the buffer *
+* Lbatnu = logical flag for atmospheric neutrino buffering *
+* Lunatn = logical unit for the atmospheric neutrino file *
+* *
+* ALL VARIABLES ARE MEANT IN THE FRAME WHERE THE NEUTRINO POSITION *
+* IS ALONG (0,0,1), THAT IS Z IS THE LOCAL ZENITH AXIS, X IS POIN- *
+* TING NORTH, AND Y IS POINTING WEST *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXATNU = 2000 )
+ LOGICAL LBATNU
+*
+ COMMON / ATNUBF / ENATNU (MXATNU), DIATNU (MXATNU),
+ & THATNU (MXATNU), PHATNU (MXATNU),
+ & WTATNU (MXATNU), PMATNU (MXATNU),
+ & PFATNU (MXATNU), PGATNU (MXATNU),
+ & XPATNU (MXATNU), YPATNU (MXATNU),
+ & ZPATNU (MXATNU), TPATNU (MXATNU),
+ & PPATNU (MXATNU), WPATNU,
+ & IDATNU (MXATNU), LGATNU (MXATNU),
+ & IPATNU (MXATNU), IFATNU (MXATNU),
+ & IGATNU (MXATNU), ICTFNU (MXATNU),
+ & NPATNU, NCATNU, LBATNU, LUNATN
--- /dev/null
+*$ CREATE ATNUBM.ADD
+*COPY ATNUBM
+*
+*=== atnubm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* ATmospheric NeUtrino Buffer for Mirrors neutrinos: *
+* *
+* Created on 29 may 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 15-dec-99 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Idatnm = neutrino id (Paprop numbering) *
+* Lgatnm = neutrino generation *
+* Enatnm = neutrino energy (GeV) *
+* Diatnm = neutrino production height or distance (cm) *
+* Thatnm = neutrino direction polar (theta) angle (rad) *
+* Phatnm = neutrino direction azimuthal (phi) angle (rad) *
+* Wtatnm = neutrino weight (such to be automatically norm- *
+* alized to fluence per unit time and area) *
+* Ipatnm = parent cosmic ray id (Z + 100 x A) *
+* Ictfnm = i1 + j1 x 3 + i2 x 9 + j2 x 27 + i3 x 81 + j3 x 243*
+* + i4 x 729 + j4 x 2187 + i5 x 6561 + j5 x 19683 *
+* ik = cutoff flag for the k_th location, direct nu *
+* jk = cutoff flag for the k_th location, mirror nu *
+* = 0 <-> not yet checked *
+* = 1 <-> neutrino not cutoffed *
+* = 2 <-> neutrino cutoffed *
+* Ifatnm = "father" hadron/muon Fluka id *
+* Igatnm = "grandfather" hadron Fluka id *
+* Pmatnm = parent cosmic ray momentum (GeV/c/amu) *
+* Pfatnm = "father" hadron/muon momentum (GeV/c) *
+* Pgatnm = "grandfather" hadron momentum (GeV/c) *
+* Xpatnm = parent cosmic ray 1st interaction x coord. (cm) *
+* Ypatnm = parent cosmic ray 1st interaction y coord. (cm) *
+* Zpatnm = parent cosmic ray 1st interaction z coord. (cm) *
+* Tpatnm = parent cosmic ray direction polar angle (rad) *
+* Ppatnm = parent cosmic ray direction azimuthal angle (rad) *
+* Ncatnm = current pointer in the buffer *
+* *
+* ALL VARIABLES ARE MEANT IN THE FRAME WHERE THE NEUTRINO POSITION *
+* IS ALONG (0,0,1), THAT IS Z IS THE LOCAL ZENITH AXIS, X IS POIN- *
+* TING NORTH, AND Y IS POINTING WEST *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXATNM = MXATNU )
+ COMMON / ATNUBM / ENATNM (MXATNM), DIATNM (MXATNM),
+ & THATNM (MXATNM), PHATNM (MXATNM),
+ & WTATNM (MXATNM), PMATNM (MXATNM),
+ & PFATNM (MXATNM), PGATNM (MXATNM),
+ & XPATNM (MXATNM), YPATNM (MXATNM),
+ & ZPATNM (MXATNM), TPATNM (MXATNM),
+ & PPATNM (MXATNM),
+ & IDATNM (MXATNM), LGATNM (MXATNM),
+ & IPATNM (MXATNM), IFATNM (MXATNM),
+ & IGATNM (MXATNM), ICTFNM (MXATNM),
+ & NCATNM
+
--- /dev/null
+*$ CREATE ATNUCM.ADD
+*COPY ATNUCM
+*
+*=== atnucm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* ATmospheric NeUtrino CoMmon: *
+* *
+* Created on 29 may 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 24-feb-00 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+* Earth magnetic field (Tesla) at surface at (earth) magnetic equator
+ PARAMETER ( BEQUA0 = 3.12 D-05 )
+*
+ COMMON / ATNUCM / BEQUAT, EARDIP, UDIPOL, VDIPOL, WDIPOL, BLATTD,
+ & XDIPOL, YDIPOL, ZDIPOL, ALATDT (5), ALONDT (5),
+ & NNUDTC, INUDTC, IMGFLG, IFLG3D, IFLOSC, IFLAMS,
+ & NATMSH, LCFLOC (5)
+ COMMON / ATNUCH / FLDATE
+ CHARACTER FLDATE*7
+ LOGICAL LCFLOC
+
+
--- /dev/null
+*$ CREATE AUXPAR.ADD
+*COPY AUXPAR
+*
+*=== Auxpar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of Auxpar: *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-oct-96 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Pxa(i) = X-component of the momentum of the i_th produced *
+* particle *
+* Pya(i) = Y-component of the momentum of the i_th produced *
+* particle *
+* Pza(i) = Z-component of the momentum of the i_th produced *
+* particle *
+* Hepa(i) = Total energy of the i_th produced particle *
+* Ama(i) = Mass of the i_th produced particle *
+* Icha(i) = Charge of the i_th produced particle *
+* Ibara(i) = Baryon number of the i_th produced particle *
+* Nrea(i) = Identity (part scheme) of the i_th produced particle *
+* Ichnfa(3,i) = Array containing additional information about pro- *
+* duction verteces, ranking etc *
+* Ana(i) = Literal name of the i_th produced particle *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANA
+ COMMON / AUXPAR / PXA (MXPDPM), PYA (MXPDPM), PZA (MXPDPM),
+ & HEPA (MXPDPM), AMA (MXPDPM), ICHA (MXPDPM),
+ & IBARA (MXPDPM), NREA (MXPDPM),
+ & ICHNFA(3,MXPDPM)
+ COMMON / CHAXPR / ANA (MXPDPM)
+
--- /dev/null
+*$ CREATE BALANC.ADD
+*COPY BALANC
+* *
+*=== balanc ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Include file Balanc *
+* *
+* Created on 20 april 1990 by Alfredo Ferrari *
+* INFN Milan *
+* *
+* Last change on 09-nov-99 by Alfredo Ferrari, INFN - Milan *
+* *
+* Actual common name changed from BALANC to CMBLNC on 22-jan-01 *
+* to get around a bug in the Linux compiler/linker *
+* *
+* Included in the following routines: not updated *
+* *
+* Kpprct = Id (Part) of the projectile of the current interac. *
+* Ptprct = Momentum of the projectile of the current interac. *
+* Px,y,zprct = Mom.comp. of the projectile of the current interac. *
+* Ax,y,zprct = Orb.Ang.Mom.comp. of the projectile of the current *
+* interac. *
+* Ekprct = Kin.ener. of the projectile of the current interac. *
+* Umoini = (initial and ... possibly final) invariant mass *
+* Uthinl = invariant mass threshold for inelastic scattering *
+* (h,h'X) *
+* Uthinl = invariant mass threshold for inelastic scattering *
+* (h,h'X) *
+* Uthcxp = threshold for charge exchange (h0,h-X)/(h-,h0X) *
+* Uthcxm = threshold for charge exchange (h-,h0X)/(h0,h+X) *
+* Jsprct = projectile spin (in hbar/2 units) *
+* Ipprct = projectile parity *
+* Llprct = Proj-target orbital angular momentum (hbar units) *
+* Jstrgt = target spin (in hbar/2 units) *
+* Iptrgt = target parity *
+* Lresmp = logical flag for resampling the whole event *
+* Lnupau = logical flag for resampling the target nucleus *
+* after a Pauli rejected neutrino interaction *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LRESMP, LNUPAU, LEVDIF, LPRDIF, LSCHAI
+ COMMON /CMBLNC/ EKPRCT, PTPRCT, PXPRCT, PYPRCT, PZPRCT, AXPRCT,
+ & AYPRCT, AZPRCT, ETTOT, PTTOT, PXTTOT, PYTTOT,
+ & PZTTOT, ENUCR, PXNUCR, PYNUCR, PZNUCR, AXNUCR,
+ & AYNUCR, AZNUCR, EINTR, PXINTR, PYINTR, PZINTR,
+ & AXINTR, AYINTR, AZINTR, EINCP, EINCN, TVGREY,
+ & TVGRE0, TVEUZ, EUZ, PUX, PUY, PUZ,
+ & EFRM, PXFRM, PYFRM, PZFRM, PSEA, UMOINI,
+ & UTHINL, UTHCXP, UTHCXM,
+ & NGREYP, NGREYN, ICU, IBU, ICNUCR, IBNUCR,
+ & ICINTR, IBINTR, KPPRCT, JSPRCT, IPPRCT, LLPRCT,
+ & LRESMP, LNUPAU, LEVDIF, LPRDIF, LSCHAI
+
--- /dev/null
+*$ CREATE BAMJCM.ADD
+*COPY BAMJCM
+*
+*=== bamjcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* BAMJev CoMmon: *
+* *
+* Created on 01 november 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-dec-97 by Alfredo Ferrari *
+* *
+* included in: *
+* bamjet *
+* *
+* When changing kmxjcm dimension look also at verein!!!!! *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LOQ1, LOQ2
+ PARAMETER ( KMXJCM = 100 )
+*
+ COMMON / BAMJCM / RPX (0:KMXJCM,0:1), RPY (0:KMXJCM,0:1),
+ & RPZ (0:KMXJCM,0:1), RE (0:KMXJCM,0:1),
+ & RPX1 (0:KMXJCM,0:1), RPX2 (0:KMXJCM,0:1),
+ & RPY1 (0:KMXJCM,0:1), RPY2 (0:KMXJCM,0:1),
+ & ISK12(0:KMXJCM,0:1), KFR1 (0:KMXJCM,0:1),
+ & KFR2 (0:KMXJCM,0:1), IV (0:KMXJCM,0:1),
+ & LOQ1 (0:KMXJCM,0:1), LOQ2 (0:KMXJCM,0:1)
+
--- /dev/null
+*$ CREATE BEAM.ADD
+*COPY BEAM
+*
+*=== Beam =============================================================*
+*
+*----------------------------------------------------------------------*
+* include file: beam copy created 26/11/86 by pa*
+* *
+* changes: on 22-oct-1993 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* /beam/ contains properties of the beam of primary particles *
+* pbeam = average momentum of the beam particles in gev/c *
+* dpbeam = momentum spread of the beam in gev/c *
+* divbm = angular divergense of the beam in mrad *
+* xspot = beam width in x-direction in cm *
+* yspot = beam width in y-direction in cm *
+* xina = x-coordinate of the centre of the beam spot *
+* yina = y-coordinate of the centre of the beam spot *
+* zina = z-coordinate of the centre of the beam spot *
+* tinx = direction cosine of the beam with respect to *
+* x-axis *
+* tiny = direction cosine of the beam with respect to *
+* y-axis *
+* tinz = direction cosine of the beam with respect to *
+* z-axis *
+* tinpx = direction cosine of the beam polariz. with respect to*
+* x-axis *
+* tinpy = direction cosine of the beam polariz. with respect to*
+* y-axis *
+* tinpz = direction cosine of the beam polariz. with respect to*
+* z-axis *
+* polfra = polarization fraction *
+* nforce = number of the region of forced interaction *
+* xfor = x-coord. of the starting point of the region nforce *
+* yfor = y-coord. of the starting point of the region nforce *
+* zfor = z-coord. of the starting point of the region nforce *
+* disfor = thickness of the region nforce in cm *
+* wfor = relative weight of the particle due to forcing *
+* ijbeam = beam particle type (see btype in /paprop/) *
+* ijhion = heavy ion type if ijbeam = -2 *
+* ipbite = flag describing the shape of the momentum *
+* distribution of the beam *
+* 0=rectangular, 1=gaussian *
+* idiv = flag describing the shape of the angular *
+* divergence distribution of the beam *
+* 0=rectangular, 1=gaussian *
+* ixspot = flag describing the shape of the spatial *
+* distribution of the beam spot in x-direction *
+* 0=rectangular, 1=gaussian *
+* iyspot = flag describing the shape of the spatial *
+* distribution of the beam spot in y-direction *
+* 0=rectangular, 1=gaussian *
+* beawei = weight of the beam particles *
+* lbeamc = flag for an annular beam *
+* lpperp = flag for polar. perp. to the beam direction *
+* lpfrac = flag for interpreting the polar. fraction *
+* *
+*----------------------------------------------------------------------*
+ LOGICAL LBEAMC, LPPERP, LPFRAC
+ COMMON / BEAM / PBEAM , DPBEAM, DIVBM , XSPOT , YSPOT , XINA ,
+ 1 YINA , ZINA , TINX , TINY , TINZ , TINPX ,
+ 2 TINPY , TINPZ , POLFRA, BEAWEI, XFOR , YFOR ,
+ 3 ZFOR , DISFOR, WFOR , IJBEAM, IJHION, IPBITE,
+ 4 IDIV , IXSPOT, IYSPOT, NFORCE, LBEAMC, LPPERP,
+ 5 LPFRAC
+
--- /dev/null
+*$ CREATE BEMIT.ADD
+*COPY BEMIT
+*----------------------------------------------------------------------*
+* include file: bemit copy created 26/11/86 by p*
+* changes: none *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /bemit/ contains beam properties when emittances specified *
+* verts = s-parameter for the vertical focus, is distance of *
+* v-focus from xina,yina,zina along the beam, *
+* +ve if focus upstream of xina,yina,zina. *
+* vertl = vertical l-parameter of the beam *
+* verte = vertical emittance *
+* hors = s-parameter for horizontal focus, is distance of *
+* h-focus from xina,yina,zina along the beam, *
+* +ve if focus upstream of xina,yina,zina. *
+* horl = horizontal l-parameter of the beam *
+* hore = horizontal emittance *
+* vsig = sigma of spatial v-distribution *
+* vpsig = sigma of angular vprime-distribution *
+* hsig = sigma of spatial h-distribution *
+* hpsig = sigma of angular hprime-distribution *
+* txv = x-direction cosine of v-axis *
+* tyv = y-direction cosine of v-axis *
+* tzv = z-direction cosine of v-axis *
+* txh = x-direction cosine of h-axis *
+* tyh = y direction cosine of h-axis *
+* tzh = z-direction cosine of h-axis *
+* ibemit = 1 if emittance option chosen, if not = 0 *
+*----------------------------------------------------------------------*
+ COMMON/BEMIT/VERTS,VERTL,VERTE,HORS,HORL,HORE,VSIG,VPSIG,
+ 1 HSIG,HPSIG,TXV,TYV,TZV,TXH,TYH,TZH,IBEMIT
+
--- /dev/null
+*$ CREATE BLNKCM.ADD
+*COPY BLNKCM
+*
+*=== blnkcm ===========================================================*
+*
+*======================================================================*
+* *
+* Include file Blnkcm : *
+* *
+* Created on 3 september 1989 by Alfredo Ferrari *
+* INFN, Milan *
+* *
+* Last change on 19-aug-00 by Alfredo Ferrari *
+* *
+* Blnkcm: this is the blank common for the Vax version of Fluka *
+* *
+* W A R N I N G !!!! check also blnkdm module for any change!!! *
+* *
+* Nblnmx: blank common dimension in real*8 units! *
+* *
+* Addrcm: this common contains all useful addresses for the blank *
+* common (in real*4 or i*4 numeration!!!!!!!!!!!!!!!!) *
+* *
+* Mblnmx = blank common dimension in i*4/real*4 units *
+* *
+* Kblnkl = Last memory location used in the blank common *
+* *
+* Kgmbgn = Beginning of geometry data *
+* *
+* Kgmlst = Last memory location for the geometry data *
+* *
+* Kcmbgn = Beginning of the region dependent Comsco energy *
+* and stars accumulation arrays *
+* (note this address if for zero index!!) *
+* *
+* Kcmlst = Last memory location of the region dependent *
+* Comsco energy and stars accumulation arrays *
+* *
+* Kisbgn = Beginning of isotope data tabulations *
+* *
+* Kislst = Last memory location of isotope data tabulations*
+* *
+* Kdtbgn = Beginning of detector data *
+* *
+* Kdtlst = Last memory location for the detector data *
+* *
+* Kubbgn = Beginning of user defined binning storage *
+* *
+* Kublst = Last memory location for user defined binnings *
+* *
+* Kuxbgn = Beginning of user defined bdrx storage *
+* *
+* Kuxlst = Last memory location for user defined bdrx *
+* *
+* Ktcbgn = Beginning of user defined track-length and/or *
+* collision estimators *
+* *
+* Ktclst = Last memory location for user defined track- *
+* length and/or collision density estimators *
+* *
+* Krnbgn = Beginning of user defined residual nuclei sco- *
+* ring *
+* (note this address is for zero index!!) *
+* *
+* Krnlst = Last memory location for user defined residual *
+* nuclei scoring *
+* *
+* Kylbgn = Beginning of user defined yield estimator *
+* (note this address is for zero index!!) *
+* *
+* Kyllst = Last memory location for user defined yield *
+* estimators *
+* *
+* Kxsbgn = Beginning of cross section storage *
+* *
+* Kxslst = Last memory location for cross section storage *
+* *
+* Kihbgn = Beginning of region importance storage *
+* for high energy particles *
+* (note this address is for zero index!!) *
+* *
+* Kihlst = Last memory location for region importances *
+* for high energy particles *
+* *
+* Kinbgn = Beginning of region importance storage *
+* for low energy neutrons *
+* (note this address is for zero index!!) *
+* *
+* Kinlst = Last memory location for region importances *
+* for low energy neutrons *
+* *
+* Kiebgn = Beginning of region importance storage *
+* for em cascade particles *
+* (note this address is for zero index!!) *
+* *
+* Kielst = Last memory location for region importances *
+* for em cascade particles *
+* *
+* Ketbgn = Beginning of exp. transf. parameters *
+* (note this address is for zero index!!) *
+* *
+* Ketlst = Last memory location for exp. transf. parameters*
+* *
+* Krrbgn = Beginning of region RR storage *
+* (note this address is for zero index!!) *
+* *
+* Krrlst = Last memory location for region RR storage *
+* *
+* Kglbgn = Beginning of the region dependent non-analog *
+* absorption group limit storage *
+* (note this address is for zero index!!) *
+* *
+* Kgllst = Last memory location of the region dependent *
+* non-analog absorption group limits *
+* *
+* Knabgn = Beginning of the region dependent non-analog *
+* absorption factor storage *
+* (note this address is for zero index!!) *
+* *
+* Knalst = Last memory location of the region dependent *
+* non-analog absorption factors *
+* *
+* Kgdbgn = Beginning of the region dependent biased down- *
+* scattering group limit storage *
+* (note this address is for zero index!!) *
+* *
+* Kgdlst = Last memory location of the region dependent *
+* biased downscattering group limits *
+* *
+* Kdwbgn = Beginning of the region dependent biased down- *
+* scattering factor storage *
+* (note this address is for zero index!!) *
+* *
+* Kdwlst = Last memory location of the region dependent *
+* biased downscattering factors *
+* *
+* Kgcbgn = Beginning of the region dependent group cut-off *
+* storage *
+* (note this address is for zero index!!) *
+* *
+* Kgclst = Last memory location of the region dependent *
+* group cut-off's *
+* *
+* Kwlbgn = Beginning of the region dependent weight window *
+* lower bound *
+* (note this address is for zero index!!) *
+* *
+* Kwllst = Last memory location of the region dependent *
+* weight window lower bound *
+* *
+* Kwhbgn = Beginning of the region dependent weight window *
+* higher bound *
+* (note this address is for zero index!!) *
+* *
+* Kwhlst = Last memory location of the region dependent *
+* weight window higher bound *
+* *
+* Kwmbgn = Beginning of the region dependent weight window *
+* threshold multiplication factor *
+* (note this address is for zero index!!) *
+* *
+* Kwmlst = Last memory location of the region dependent *
+* weight window threshold multiplication factor *
+* *
+* Kwsbgn = Beginning of the region dependent weight window *
+* shape profile index for low energy neutrons *
+* (note this address is for zero index!!) *
+* *
+* Kwslst = Last memory location of the region dependent *
+* shape profile index for low energy neutrons *
+* *
+* Kndbgn = Beginning of nuclear data tabulations required *
+* by the preequilibrium model *
+* *
+* Kndlst = Last memory location of nuclear data storage *
+* *
+* Kdpbgn = Beginning of the dp/dx tabulation storage *
+* (note this address is for zero index!!) *
+* *
+* Kdplst = Last memory location of dp/dx tabulations *
+* *
+* Krgbgn = Beginning of the range tabulation storage *
+* (note this address is for zero index!!) *
+* *
+* Krglst = Last memory location of range tabulations *
+* *
+* Ksgbgn = Beginning of the cross section storage *
+* (note this address is for zero index!!) *
+* *
+* Ksglst = Last memory location of cross section *
+* tabulations *
+* *
+* Kbrbgn = Beginning of the brem. (e+,e-) storage *
+* (note this address is for zero index!!) *
+* *
+* Kbrlst = Last memory location of the brem. (e+,e-) *
+* storage *
+* *
+* Kfybgn = Beginning of the fission yield storage *
+* (note this address is for zero index!!) *
+* *
+* Kfylst = Last memory location of the fission yield *
+* storage *
+* *
+* Kpwbgn = Beginning of the neutron pointwise cross section*
+* storage (note this address is for zero index!!) *
+* *
+* Kpwlst = Last memory location of the neutron pointwise *
+* cross section storage *
+* *
+* Kgrbgn = Beginning of the GDR cross section storage *
+* (note this address is for zero index!!) *
+* *
+* Kgrlst = Last memory location of the GDR cross section *
+* storage *
+* *
+* Ktmbgn = Beginning of the temporary storage *
+* (note this address is for zero index!!) *
+* *
+* W A R N I N G the blank common is initialized to 0 as a I*4 *
+* array!!!!!!!!!!!!! *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NBLNMX = 6000000 )
+ DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
+ & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
+ & SIGGDR ( KALGNM*NBLNMX ), COMSCO ( NBLNMX ),
+ & LBSTOR ( KALGNM*NBLNMX )
+ REAL SIGGTT, SIGGDR
+ LOGICAL LBSTOR
+ COMMON NSTOR ( KALGNM*NBLNMX )
+ COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
+ & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
+ & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
+ & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
+ & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
+ & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
+ & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
+ & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
+ & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
+ & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
+ & KFYBGN, KFYLST, KPWBGN, KPWLST, KGRBGN, KGRLST,
+ & KTMBGN
+
+ EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
+ EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
+ EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
+ EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
+ EQUIVALENCE ( NSTOR (1), COMSCO (1) )
+ EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
+ EQUIVALENCE ( NSTOR (1), SIGGDR (1) )
+ EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
+
--- /dev/null
+*$ CREATE BLNKDM.ADD
+*COPY BLNKDM
+*
+*=== blnkdm ===========================================================*
+*
+*======================================================================*
+* *
+* Include file Blnkdm : *
+* *
+* Created on 3 september 1989 by Alfredo Ferrari *
+* INFN, Milan *
+* *
+* Last change on 19-aug-00 by Alfredo Ferrari *
+* *
+* Blnkdm: this is dummy version of the blank common for the Vax *
+* version of Fluka. It is included in most routines to *
+* avoid to compile them again if the common dimension have *
+* been changed!! *
+* *
+* W A R N I N G !!!! check also blnkcm module for any change!!! *
+* *
+* *
+* Addrcm: this common contains all useful addresses for the blank *
+* common (in real*4 or i*4 numeration!!!!!!!!!!!!!!!!) *
+* *
+* Mblnmx = blank common dimension in i*4/real*4 units *
+* *
+* Kblnkl = Last memory location used in the blank common *
+* *
+* Kgmbgn = Beginning of geometry data *
+* *
+* Kgmlst = Last memory location for the geometry data *
+* *
+* Kcmbgn = Beginning of the region dependent Comsco energy *
+* and stars accumulation arrays *
+* (note this address if for zero index!!) *
+* *
+* Kcmlst = Last memory location of the region dependent *
+* Comsco energy and stars accumulation arrays *
+* *
+* Kisbgn = Beginning of isotope data tabulations *
+* *
+* Kislst = Last memory location of isotope data tabulations*
+* *
+* Kdtbgn = Beginning of detector data *
+* *
+* Kdtlst = Last memory location for the detector data *
+* *
+* Kubbgn = Beginning of user defined binning storage *
+* *
+* Kublst = Last memory location for user defined binnings *
+* *
+* Kuxbgn = Beginning of user defined bdrx storage *
+* *
+* Kuxlst = Last memory location for user defined bdrx *
+* *
+* Ktcbgn = Beginning of user defined track-length and/or *
+* collision estimators *
+* *
+* Ktclst = Last memory location for user defined track- *
+* length and/or collision density estimators *
+* *
+* Krnbgn = Beginning of user defined residual nuclei sco- *
+* ring *
+* (note this address is for zero index!!) *
+* *
+* Krnlst = Last memory location for user defined residual *
+* nuclei scoring *
+* *
+* Kylbgn = Beginning of user defined yield estimator *
+* (note this address is for zero index!!) *
+* *
+* Kyllst = Last memory location for user defined yield *
+* estimators *
+* *
+* Kxsbgn = Beginning of cross section storage *
+* *
+* Kxslst = Last memory location for cross section storage *
+* *
+* Kihbgn = Beginning of region importance storage *
+* for high energy particles *
+* (note this address is for zero index!!) *
+* *
+* Kihlst = Last memory location for region importances *
+* for high energy particles *
+* *
+* Kinbgn = Beginning of region importance storage *
+* for low energy neutrons *
+* (note this address is for zero index!!) *
+* *
+* Kinlst = Last memory location for region importances *
+* for low energy neutrons *
+* *
+* Kiebgn = Beginning of region importance storage *
+* for em cascade particles *
+* (note this address is for zero index!!) *
+* *
+* Kielst = Last memory location for region importances *
+* for em cascade particles *
+* *
+* Ketbgn = Beginning of exp. transf. parameters *
+* (note this address is for zero index!!) *
+* *
+* Ketlst = Last memory location for exp. transf. parameters*
+* *
+* Krrbgn = Beginning of region RR storage *
+* (note this address is for zero index!!) *
+* *
+* Krrlst = Last memory location for region RR storage *
+* *
+* Kglbgn = Beginning of the region dependent non-analog *
+* absorption group limit storage *
+* (note this address is for zero index!!) *
+* *
+* Kgllst = Last memory location of the region dependent *
+* non-analog absorption group limits *
+* *
+* Knabgn = Beginning of the region dependent non-analog *
+* absorption factor storage *
+* (note this address is for zero index!!) *
+* *
+* Knalst = Last memory location of the region dependent *
+* non-analog absorption factors *
+* *
+* Kgdbgn = Beginning of the region dependent biased down- *
+* scattering group limit storage *
+* (note this address is for zero index!!) *
+* *
+* Kgdlst = Last memory location of the region dependent *
+* biased downscattering group limits *
+* *
+* Kdwbgn = Beginning of the region dependent biased down- *
+* scattering factor storage *
+* (note this address is for zero index!!) *
+* *
+* Kdwlst = Last memory location of the region dependent *
+* biased downscattering factors *
+* *
+* Kgcbgn = Beginning of the region dependent group cut-off *
+* storage *
+* (note this address is for zero index!!) *
+* *
+* Kgclst = Last memory location of the region dependent *
+* group cut-off's *
+* *
+* Kwlbgn = Beginning of the region dependent weight window *
+* lower bound *
+* (note this address is for zero index!!) *
+* *
+* Kwllst = Last memory location of the region dependent *
+* weight window lower bound *
+* *
+* Kwhbgn = Beginning of the region dependent weight window *
+* higher bound *
+* (note this address is for zero index!!) *
+* *
+* Kwhlst = Last memory location of the region dependent *
+* weight window higher bound *
+* *
+* Kwmbgn = Beginning of the region dependent weight window *
+* threshold multiplication factor *
+* (note this address is for zero index!!) *
+* *
+* Kwmlst = Last memory location of the region dependent *
+* weight window threshold multiplication factor *
+* *
+* Kwsbgn = Beginning of the region dependent weight window *
+* shape profile index for low energy neutrons *
+* (note this address is for zero index!!) *
+* *
+* Kwslst = Last memory location of the region dependent *
+* shape profile index for low energy neutrons *
+* *
+* Kndbgn = Beginning of nuclear data tabulations required *
+* by the preequilibrium model *
+* *
+* Kndlst = Last memory location of nuclear data storage *
+* *
+* Kdpbgn = Beginning of the dp/dx tabulation storage *
+* (note this address is for zero index!!) *
+* *
+* Kdplst = Last memory location of dp/dx tabulations *
+* *
+* Krgbgn = Beginning of the range tabulation storage *
+* (note this address is for zero index!!) *
+* *
+* Krglst = Last memory location of range tabulations *
+* *
+* Ksgbgn = Beginning of the cross section storage *
+* (note this address is for zero index!!) *
+* *
+* Ksglst = Last memory location of cross section *
+* tabulations *
+* *
+* Kbrbgn = Beginning of the brem. (e+,e-) storage *
+* (note this address is for zero index!!) *
+* *
+* Kbrlst = Last memory location of the brem. (e+,e-) *
+* storage *
+* *
+* Kfybgn = Beginning of the fission yield storage *
+* (note this address is for zero index!!) *
+* *
+* Kfylst = Last memory location of the fission yield *
+* storage *
+* *
+* Kpwbgn = Beginning of the neutron pointwise cross section*
+* storage (note this address is for zero index!!) *
+* *
+* Kpwlst = Last memory location of the neutron pointwise *
+* cross section storage *
+* *
+* Kgrbgn = Beginning of the GDR cross section storage *
+* (note this address is for zero index!!) *
+* *
+* Kgrlst = Last memory location of the GDR cross section *
+* storage *
+* *
+* Ktmbgn = Beginning of the temporary storage *
+* (note this address is for zero index!!) *
+* *
+* W A R N I N G the blank common is initialized to 0 as a I*4 *
+* array!!!!!!!!!!!!! *
+* *
+*----------------------------------------------------------------------*
+*
+ DIMENSION GMSTOR ( 2 ), BRMBRR ( 2 ), BRMEXP ( 2 ), BRMSIG ( 2 ),
+ & SIGGTT ( 2 ), SIGGDR ( 2 ), COMSCO ( 2 ), LBSTOR ( 2 )
+ REAL SIGGTT, SIGGDR
+ LOGICAL LBSTOR
+ COMMON NSTOR ( 2 )
+ COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
+ & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
+ & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
+ & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
+ & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
+ & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
+ & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
+ & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
+ & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
+ & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
+ & KFYBGN, KFYLST, KPWBGN, KPWLST, KGRBGN, KGRLST,
+ & KTMBGN
+
+ EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
+ EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
+ EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
+ EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
+ EQUIVALENCE ( NSTOR (1), COMSCO (1) )
+ EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
+ EQUIVALENCE ( NSTOR (1), SIGGDR (1) )
+ EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
+
--- /dev/null
+*$ CREATE BLNTMP.ADD
+*COPY BLNTMP
+* *
+*=== blntmp ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Blntmp: created on 9 july 1990 by Alfredo Ferrari *
+* *
+* included in : *
+* Blnset *
+* Fluka *
+* *
+* The following are all temporary locations in I*4 addresses !! *
+* *
+* Kihbtm = Beginning of region importance storage *
+* for high energy particles *
+* (note this address if for zero index!!) *
+* *
+* Kinbtm = Beginning of region importance storage *
+* for low energy neutrons *
+* (note this address if for zero index!!) *
+* *
+* Kiebtm = Beginning of region importance storage *
+* for em cascade particles *
+* (note this address if for zero index!!) *
+* *
+* Krrbtm = Beginning of region dependent inelastic inte- *
+* raction RR/Splitting fator storage *
+* (note this address if for zero index!!) *
+* *
+* Kglbtm = Beginning of the region dependent non-analog *
+* absorption group limit storage *
+* (note this address if for zero index!!) *
+* *
+* Knabtm = Beginning of the region dependent non-analog *
+* absorption factor storage *
+* (note this address if for zero index!!) *
+* *
+* Kgcbtm = Beginning of the region dependent group cut-off *
+* storage *
+* (note this address if for zero index!!) *
+* *
+* Kgdwtm = Beginning of the region dependent biased *
+* downscattering group limit storage *
+* (note this address if for zero index!!) *
+* *
+* Kbdwtm = Beginning of the region dependent biased *
+* downscattering factor storage *
+* (note this address if for zero index!!) *
+* *
+* Kwlotm = Beginning of the region dependent weight window *
+* lower bound storage *
+* (note this address if for zero index!!) *
+* *
+* Kwhitm = Beginning of the region dependent weight window *
+* higher bound storage *
+* (note this address if for zero index!!) *
+* *
+* Kwmutm = Beginning of the region dependent WW threshold *
+* multiplicative factor storage *
+* (note this address if for zero index!!) *
+* *
+* Kwshtm = Beginning of the region dependent WW shape *
+* profile index storage *
+* (note this address if for zero index!!) *
+* *
+* Kexttm = Beginning of the region dependent exponential *
+* transformation parameter temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Kstxtm = Beginning of the region dependent maximum step *
+* size temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Kstntm = Beginning of the region dependent minimum step *
+* size temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Kecttm = Beginning of the region dependent electron cut *
+* off energy temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Kpcttm = Beginning of the region dependent photon cut *
+* off energy temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Klpbtm = Beginning of the region dependent leading par- *
+* ticle flag temporary storage *
+* (note this address if for zero index!!) *
+* *
+* Nxxrgn = Number of regions for which the temporary sto- *
+* rage must be set up *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
+ & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
+ & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
+ & KLPBTM, NXXRGN
+
--- /dev/null
+*$ CREATE BOUNDS.ADD
+*COPY BOUNDS
+*----------------------------------------------------------------------*
+* *
+* Common Bounds for EGS4 *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /BOUNDS/ ECUT(MXXRGN), PCUT(MXXRGN), VACDST
+
--- /dev/null
+*$ CREATE BPTECM.ADD
+*COPY BPTECM
+*
+*=== Bptecm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 25 february 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 27-feb-98 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXPRCN = 100 )
+ PARAMETER ( MXALPH = 25 )
+ PARAMETER ( MXBETA = 25 )
+* If Mxprcn is 100, then the prob of the last-1 percentiles
+* is 1 - 1/100, Mxdcds is giving Eps up to 1 - 1/10^(2+Mxdcds)
+* or more generally, up to 1 - 1/(Mxprcn x 10^Mxdcds)
+ PARAMETER ( MXDCDS = 6 )
+* Epsepi must be smaller than the minimum probability left
+* by Mxdcds:
+ PARAMETER ( EPSEPI = 1.D-09 )
+*
+ COMMON / BPTECM / ALNAL0, ALNAL1, DLNALP, ALNBE0, ALNBE1, DLNBET,
+ & EPSPER (0:MXPRCN,0:MXALPH,0:MXBETA),
+ & EPSDCD (0:MXDCDS,0:MXALPH,0:MXBETA),
+ & EPSOMN (0:MXALPH,0:MXBETA),
+ & PRCOOF (0:MXALPH,0:MXBETA),
+ & PRCOTN (0:MXALPH,0:MXBETA),
+ & PRCHLF (0:MXALPH,0:MXBETA),
+ & PRCHPI (0:MXALPH,0:MXBETA)
+
+
--- /dev/null
+*$ CREATE BREANG.ADD
+*COPY BREANG
+*
+*=== breang ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 22 march 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 22-mar-91 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BDANDI *
+* BREMNW *
+* BREMS *
+* *
+* Mxphtb = number of intervals on which phi(y) is tabulated *
+* Yphimn = minimum value of y for which phi is taublated *
+* Yphirt = ratio of y between two tabulated points *
+* Yphimx = maximum value of y for which phi is taublated *
+* (=Yphimn*Yphirt**(Mxphtb-1)) *
+* Phiytb = tabulated values of phi *
+* Alymin = natural logarithm of Yphimn *
+* Alyrat = natural logarithm of Yphirt *
+* Alytra = natural logarithm of the max. y allowed for Xsitra *
+* Phia00 = used for asymptotic behaviour *
+* Phib00 = used for asymptotic behaviour *
+* Phic0 = used for asymptotic behaviour *
+* Phid0 = used for asymptotic behaviour *
+* ( for y > yphimx, Phi = Phia00 + Phib00 / y^2 *
+* for y < yphimn, Phi = log(y) + Phic0 + Phid0 x y^2 ) *
+* Accrit = parameter used for the Migdal polarization effect, *
+* given by Nel x Lambda_compt^2 x r0 / pi *
+* Zbrem = approximate "effective" Z for bremsstrahlung *
+* Fcoul = Coulomb factor fc(Z) *
+* Gmolie = factor entering Moliere's expansion of Thomas-Fermi *
+* form factor ( = Z^1/3/121 ) *
+* Algmol = natural logarithm of Gmolie *
+* *
+*----------------------------------------------------------------------*
+*
+* Tpifsc = 2 x pi x fine structure constant
+ PARAMETER ( TPIFSC = 4.5850621648360624 D-02 )
+ PARAMETER ( MXPHTB = 100 )
+ PARAMETER ( YPHIMN = 1.0 D-01 )
+ PARAMETER ( YPHIRT = 1.07 D+00 )
+*
+ COMMON / BREANG / PHIYTB (MXPHTB), YPHIMX, ALYMIN, ALYRAT,
+ & ALYTRA, PHIA00, PHIB00, PHIC0, PHID0,
+ & ACCRIT (MXXMDE), ZBREM (MXXMDE),
+ & FCOUL (MXXMDE), GMOLIE (MXXMDE),
+ & ALGMOL (MXXMDE)
+
--- /dev/null
+*$ CREATE BREMPR.ADD
+*COPY BREMPR
+*----------------------------------------------------------------------*
+* *
+* Common Brempr for EMF *
+* Mxxmde = maximum number of media in Emf *
+* *
+* Variables for the new bremsstrahlung: *
+* *
+* Thbrem = total electron/positron threshold energy for *
+* bremsstrahlung production (or minimum energy *
+* of emitted photons), MeV *
+* Althbr = natural logarithm of Thbrem - me *
+* Ebrm0 = minimum energy for which bremsstrahlung data *
+* are tabulated *
+* Albrm0 = natural logarithm of Ebrm0 *
+* Ebrmrt = ratio between subsequent tabulated energies *
+* after the initial 0:nktl-3 values *
+* Abrmrt = natural logarithm of Ebrmrt *
+* Aktild = k/T values corresponding at the tabulated en- *
+* ergies ( jth energy = (Thbrem-me) / Aktild (j) )*
+* Alktld = natural logarithm of Aktild *
+* Indsum = array used for addressing data *
+* Jndsum = array used for addressing data *
+* Ind0br = zero index address of brm. branching ratios *
+* and of brm. power fit exponents *
+* Ind1br = last index address of brm. branching ratios *
+* and of brm. power fit exponents *
+* Jnd0br = zero index address of brm. tabulated ds/dk *
+* Jnd1br = last index address of brm. tabulated ds/dk *
+* Lnwbrm = Logical flag for the new bremss. *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NKTL = 17 )
+ PARAMETER ( NBRBIN = 75 )
+ COMMON /BREMPR/ DL1(6,MXXMDE), DL2(6,MXXMDE), DL3(6,MXXMDE),
+ & DL4(6,MXXMDE), DL5(6,MXXMDE), DL6(6,MXXMDE),
+ & DELCM(MXXMDE), ALPHI(2,MXXMDE), BPAR(2,MXXMDE),
+ & DELPOS(2,MXXMDE), PWR2I(50),
+ & THBREM (MXXMDE), ALTHBR (MXXMDE),
+ & EBRM0 (MXXMDE), ALBRM0 (MXXMDE),
+ & EBRMRT (MXXMDE), ABRMRT (MXXMDE),
+ & AKTILD (0:NBRBIN), ALKTLD (0:NBRBIN),
+ & INDSUM (0:NBRBIN+1), IND0BR (2,MXXMDE),
+ & IND1BR (2,MXXMDE), LND0BR (2,MXXMDE),
+ & LND1BR (2,MXXMDE), JND0BR (2,MXXMDE),
+ & JND1BR (2,MXXMDE), LNWBRM (MXXMDE)
+ LOGICAL LNWBRM
+ DIMENSION JNDSUM (0:NBRBIN)
+ EQUIVALENCE ( INDSUM (1), JNDSUM (0) )
+
--- /dev/null
+*$ CREATE BRPRHV.ADD
+*COPY BRPRHV
+*
+*=== brprhv ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: BRPRHV *
+* *
+* BRemsstrahlung and PaiR production by HeaVy particles *
+* *
+* Created on 10 march 1992 by Alfredo Ferrari *
+* INFN - Milan *
+* *
+* Last change on 11-may-94 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* FLUKA *
+* DPDX *
+* HEABRE *
+* HVPAIR *
+* HVBREM *
+* KASKAD *
+* SIGTAB *
+* ZEROIN *
+* *
+*----------------------------------------------------------------------*
+*
+* minimum eta^2 for pair production ( gamma = sqrt (1+eta^2) = 44.7,
+* E_prot = 42 GeV, E_mu = 4.7 GeV )
+ PARAMETER ( ESQTHP = 2000.D+00 )
+* minimum eta^2 for bremsstrahlung ( gamma = sqrt (1+eta^2) = 44.7,
+* E_prot = 42 GeV, E_mu = 4.7 GeV )
+ PARAMETER ( ESQTHB = 2000.D+00 )
+ LOGICAL LHPAIR, LHBREM
+ COMMON / BRPRHV / T0PAIR (MXXMDF), T0BREM (MXXMDF),
+ & CSTBRE (MXXMDF), AABREM (MXXMDF),
+ & APBREM (MXXMDF), VCR0BR (MXXMDF),
+ & ALRDCS (MPDPDX,MXXMDF), FNBREM (MPDPDX,MXXMDF),
+ & PCBREM (MPDPDX,MXXMDF),
+ & LHPAIR (MXXMDF), LHBREM (MXXMDF), IOFNBR,
+ & IOFCBR
+
--- /dev/null
+*$ CREATE CASLIM.ADD
+*COPY CASLIM
+*
+*=== caslim ===========================================================*
+*
+*----------------------------------------------------------------------*
+* include file: caslim copy created 26/11/86 by p*
+* changes: 20-sep-89 by A. Ferrari *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* *
+* /caslim/ is needed to decide when to stop the run *
+* tlim = if cpu-time-left<tlim the run will be ended *
+* tmean = is the average time needed for the following *
+* of one beam particle *
+* tmax = is the maximum time needed for the following *
+* of one beam particle *
+* ttot = the cumulative time needed to follow the beam *
+* particles *
+* ncases = the maximum number of beam particles to be followed *
+* nstars = the maximum number of stars to be generated *
+* ncase = the number of beam particles followed *
+* mbatch = batch sizes *
+* nbatch = number of batches *
+* ibatch = current batch number *
+* ncoinc = flag used by the detect option to know if the ncase *
+* particle has or has not to be considered in coinci- *
+* dence with the previous one (if they have the same *
+* ncoinc they belong to the same event) *
+* lpseed = if .true. seeds will be printed for any history *
+* levtdt = if .true. a few data will be printed at each history *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LPSEED, LEVTDT
+ COMMON / CASLIM / TLIM, TMEAN, TMAX, TTOT, NCASES, NSTARS, NCASE,
+ & MBATCH(500), NBATCH, IBATCH, NCOINC, LPSEED,
+ & LEVTDT
+
--- /dev/null
+*$ CREATE CHNCMM.ADD
+*COPY CHNCMM
+*
+*=== chncmm ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* CHaiN formation CoMMon: *
+* *
+* Created on 22 march 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 21-dec-97 by Alfredo Ferrari *
+* *
+* Gammes,Unomes = gamma and eta parameters for unflavoured mesons *
+* (P(x) = C x^(gamma-1) x (1-x)**(eta-1)) *
+* Gammes,Unomes = gamma and eta parameters for baryons *
+* Gamstr,Unostr = gamma and eta parameters for strange mesons *
+* Gamsea,Unosea = gamma and eta parameters for sea (anti)quarks *
+* Seamtr = minimal transverse mass for sea (anti)quarks *
+* Fslmtr = minimal transverse mass for X fraction selection *
+* Ecutrf = reference energy in p-p collisions for setting *
+* x-fraction minimal values *
+* Ucutrf = Sqrt(s) corresponding to Ecutrf *
+* Acutrf = coefficient used for x-fraction minimal values *
+* Bcutrf = coefficient used for x-fraction minimal values *
+* For E < Ecutrf: *
+* Xcutff = ( Acutrf + Bcutrf * Etrial / Ecutrf ) *
+* * Ethsea / Ekxlab *
+* for E > Ecutrf: *
+* Xcutff = ( Acutrf + Bcutrf ) * Ethsea * Umo *
+* / ( Ucutrf * Ekxlab ) *
+* Dfscml = diffractive single chain multiplicative factor *
+* with respect to the standard single chain prob. *
+* (Ldfscv=.false.), or triple pomeron cut-off mass *
+* multiplicative factor (Ldfscv=.true.) *
+* Dfscrs = number of gamma's after which diffractive resonant *
+* production is going into single chain production *
+* Ldfscv = Old single chain (low mass) probability for *
+* diffraction (=.false.), or new one (=.true.) *
+* Lxflip = If .true. random choiche of the Xp/Xt fraction to *
+* be changed of a parjet chain is performed *
+* Lmnxch = Meaningful only for Lxflip = .false. . If .true. *
+* minimal variation of both Xp/Xt for a parjet is *
+* performed *
+* Lmcons = Meaningful only for Lxflip, Lmnxch = .false., in *
+* this case invariant mass invariance is forced when *
+* computing Xp/Xt for a parjet. *
+* Lpcons = Meaningful only for Lxflip, Lmnxch, Lmcons =.false.,*
+* in this case momentum invariance is forced when *
+* computing Xp/Xt for a parjet. Never set to .false. *
+* Lsuxkn = Flag used to decide whether update immediately X *
+* fractions after one chain has been forced to a *
+* defined mass value, or do it for both at the end *
+* Imnxfr = Flag if requesting or not minimum fractions for *
+* q/qq, and their interpretation *
+* 0 = no threshold used (rejection if unphysical), *
+* 1 = minimum thresholds used, *
+* 2 = X interpreted as fractions of the available *
+* energy (minimum masses out) *
+* Lrealx = Flag for applying X fractions to real momenta/ *
+* energies of projectile/target: it should not be *
+* activated for Imnxfr > 0 since it will be inconsi- *
+* stent *
+* L2ndmp = Flag for using (whenever available) the 2nd baryon *
+* octet and the 2nd pseudoscalar meson nonet *
+* Lchspn = Flag for selecting a precise spin configuration *
+* (and hence "fixed" mass states according to) during *
+* chain creation *
+* Lsqgsm = flag for adopting the QGSM prescription for sea *
+* quarks X fractions, and in particular the "running" *
+* eta according to the number of sea qqbar to be *
+* produced *
+* *
+*----------------------------------------------------------------------*
+*
+* Minimum lab momentum requested for valence chain formation:
+* PARAMETER ( PLBCMN = 4.0D+00 )
+ PARAMETER ( PLBCMN = 3.5D+00 )
+*
+ LOGICAL LDFSCV, LXFLIP, LMNXCH, LMCONS, LPCONS, LSUXKN, LREALX,
+ & L2NDMP, LCHSPN, LSQGSM
+ COMMON / CHNCMM / GAMMES, UNOMES, GAMBAR, UNOBAR, GAMSTR, UNOSTR,
+ & GAMSEA, UNOSEA, SEAMTR, FSLMTR, ECUTRF, UCUTRF,
+ & ACUTRF, BCUTRF, DFSCML, DFSCRS,
+ & IMNXFR, LDFSCV, LXFLIP, LPCONS, LMNXCH, LSUXKN,
+ & LREALX, L2NDMP, LCHSPN, LMCONS, LSQGSM
+
--- /dev/null
+*$ CREATE CHNGLB.ADD
+*COPY CHNGLB
+* *
+*=== chnglb ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* CHaiN and GLauBer common: *
+* *
+* Created on 10 october 1996 by Alfredo Ferrari *
+* Infn - Milan *
+* *
+* Last change on 01-jul-00 by Alfredo Ferrari *
+* *
+* Nhtprj = number of hit nucleons of the projectile *
+* Nhttrg = number of hit nucleons of the target *
+* Nseprj(i) = number of sea aq-q (or aqaq-qq) components of the *
+* i_th projectile nucleon *
+* Nsetrg(j) = number of sea aq-q (or aqaq-qq) components of the *
+* j_th target nucleon *
+* Khttrg(i) = number of target nucleons hit by the i_th projec- *
+* tile nucleon *
+* Khtprj(j) = number of projectile nucleons hit by the j_th tar- *
+* get nucleon *
+* Ihtprj(i) = id. (part scheme) of the i_th hit nucleon of the *
+* projectile (every id is possible, not only p or n *
+* in case the projectile is a single particle) *
+* Ihttrg(j) = id. (part scheme) of the j_th hit nucleon of the *
+* target (1=proton, 8=neutron) *
+* Mhtrpr(j,i) = number of collisions for the elementary j_th target*
+* nucleon - i_th projectile nucleon interaction *
+* ( 0 = no collision ) *
+* Ehtprj(i) = total energy of the i_th hit projectile nucleon *
+* in the given frame *
+* Phprjx(i) = momentum X component of the i_th hit projectile *
+* nucleon in the given frame *
+* Phprjy(i) = momentum Y component of the i_th hit projectile *
+* nucleon in the given frame *
+* Phprjz(i) = momentum Z component of the i_th hit projectile *
+* nucleon in the given frame *
+* Rhprjp(i) = local proton density (fm^-3) for the i_th hit *
+* projectile nucleon *
+* Rhprjn(i) = local neutron density (fm^-3) for the i_th hit *
+* projectile nucleon *
+* Ehttrg(j) = total energy of the j_th hit target nucleon *
+* in the given frame *
+* Phtrgx(j) = momentum X component of the j_th hit target *
+* nucleon in the given frame *
+* Phtrgy(j) = momentum Y component of the j_th hit target *
+* nucleon in the given frame *
+* Phtrgz(j) = momentum Z component of the j_th hit target *
+* nucleon in the given frame *
+* Rhtrgp(j) = local proton density (fm^-3) for the j_th hit *
+* target nucleon *
+* Rhtrgn(j) = local neutron density (fm^-3) for the j_th hit *
+* target nucleon *
+* Xqkprj(i) = (anti)quark X fraction for mesons and (anti)baryons*
+* for the i_th projectile component *
+* Xdqprj(i) = qbar/(anti)diquark X fraction for mesons/(anti)ba- *
+* ryons for the i_th projectile component *
+* Xseprj(k,i) = X fraction of the (di)quark of the k_th sea *
+* q(q)-aq(aq) couple for the i_th projectile nucleon *
+* Xasprj(k,i) = X fraction of the anti(di)quark of the k_th sea *
+* q(q)-aq(aq) couple for the i_th projectile nucleon *
+* Xqktrg(j) = quark X fraction for the j_th target nucleon *
+* Xdqtrg(j) = diquark X fraction for the j_th target nucleon *
+* Xsetrg(k,j) = X fraction of the (di)quark of the k_th sea *
+* q(q)-aq(aq) couple for the j_th target nucleon *
+* Xastrg(k,j) = X fraction of the anti(di)quark of the k_th sea *
+* q(q)-aq(aq) couple for the j_th target nucleon *
+* Iqsprj(k,i) = quark id of the k_th sea q(q)-aq(aq) couple of the *
+* i_th projectile nucleon (diquark are recognized by *
+* the double index, i.e. uu=11, us=13 etc) *
+* Iqstrg(k,j) = quark id of the k_th sea q(q)-aq(aq) couple of the *
+* i_th target nucleon *
+* Kchain(m) = type of the m_th chain: *
+* Kchain = i0 + 100 * iqprj + 10000 * iqtrg *
+* Proj Target *
+* i0 = 0 <--> sea-q sea-q *
+* = 1 <--> sea-q sea-qq *
+* = 2 <--> sea-qq sea-q *
+* = 3 <--> sea-qq sea-qq *
+* = 10 <--> sea-q valence-q *
+* = 11 <--> sea-q valence-qq *
+* = 12 <--> sea-qq valence-q *
+* = 13 <--> sea-qq valence-qq *
+* = 20 <--> valence-q sea-q *
+* = 21 <--> valence-q sea-qq *
+* = 22 <--> valence-qq sea-q *
+* = 23 <--> valence-qq sea-qq *
+* = 30 <--> valence-q valence-q *
+* = 31 <--> valence-q valence-qq *
+* = 32 <--> valence-qq valence-q *
+* = 33 <--> valence-qq valence-qq *
+* iqprj = q(q) of the (di)quarks coming from the proje- *
+* ctile *
+* iqtrg = q(q) of the (di)quarks coming from the target *
+* Mchain(m) = type of the m_th chain: *
+* Mchain = ihtprj + 1000 * ihttrg *
+* ihtprj = index of hit projectile nucleon used to build *
+* this chain *
+* ihttrg = index of hit target nucleon used to build *
+* this chain *
+* Nchai0 = original number of chains *
+* Nchain = actual number of chains *
+* Nvvchn = actual number of valence-valence chains *
+* Nsvchn = actual number of sea(prj)-valence(trg) chains *
+* Nvschn = actual number of valence(prj)-sea(trg) chains *
+* Nsschn = actual number of sea-sea chains *
+* Lglaub = logical flag for activation of Glauber calculus *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXHTRG = MXHTTR + 1 )
+ PARAMETER ( MXHPRJ = 5 )
+* Mxseax: maximum number of sea component of a projectile/target
+* nucleon, it must be >= Max (MXHTRG-1,MXHPRJ-1)
+ PARAMETER ( MXSEAX = 20 )
+* Mxchan: maximum number of chains
+ PARAMETER ( MXCHAI = 200 )
+*
+ LOGICAL LGLAUB
+*
+ COMMON / CHNGLB / EHTPRJ (MXHPRJ), PHPRJX (MXHPRJ),
+ & PHPRJY (MXHPRJ), PHPRJZ (MXHPRJ),
+ & RHPRJP (MXHPRJ), RHPRJN (MXHPRJ),
+ & EHTTRG (MXHTRG), PHTRGX (MXHTRG),
+ & PHTRGY (MXHTRG), PHTRGZ (MXHTRG),
+ & RHTRGP (MXHTRG), RHTRGN (MXHTRG),
+ & XQKPRJ (MXHPRJ), XDQPRJ (MXHPRJ),
+ & XSEPRJ (MXSEAX,MXHPRJ), XASPRJ (MXSEAX,MXHPRJ),
+ & XQKTRG (MXHTRG), XDQTRG (MXHTRG),
+ & XSETRG (MXSEAX,MXHTRG), XASTRG (MXSEAX,MXHTRG),
+ & IHTPRJ (MXHPRJ), IHTTRG (MXHTRG),
+ & KHTTRG (MXHPRJ), KHTPRJ (MXHTRG),
+ & NSEPRJ (MXHPRJ), NSETRG (MXHTRG),
+ & IQSPRJ (MXSEAX,MXHPRJ), IQSTRG (MXSEAX,MXHTRG),
+ & MHTRPR (MXHTRG,MXHTRG), KCHAIN (MXCHAI),
+ & MCHAIN (MXCHAI), NCHAI0, NCHAIN, NVVCHN, NSVCHN,
+ & NVSCHN, NSSCHN, NHTPRJ, NHTTRG, LGLAUB
+
--- /dev/null
+*$ CREATE CLSCCM.ADD
+*COPY CLSCCM
+*
+*=== clsccm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoaLeSCence CoMmon: *
+* *
+* Created on 5 april 1996 by Alfredo Ferrari, INFN Milan *
+* *
+* Last change on 23-jun-99 by Alfredo Ferrari, INFN Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* pclscn(i,j) = momentum sigma for coalescing a particle of mass *
+* i (i=1,2,3) into the jth heavy particle *
+* (j=-3 <-> deuteron) *
+* (j=-4 <-> triton ) *
+* (j=-5 <-> 3-He ) *
+* (j=-6 <-> alpha ) *
+* rclscn(i,j) = position sigma for coalescing a particle of mass *
+* i (i=1,2,3) into the jth heavy particle *
+* bnclmx(j) = number of maximum times the binding energy over *
+* the sum of proton/neutron masses to check for *
+* coalescence into the jth heavy particle *
+* dclwpk = sigma (fm) of the gaussian wave packet of each *
+* individual nucleon *
+* dsclcy = time (ct unit) between different preequilibrium *
+* cycles, see below *
+* ddscly = time/amu^1/3 (ct unit) between different pree- *
+* quilibrium cycles *
+* Total time = dsclcy + ddscly * A^1/3 *
+* dbscly = (relative) importance of the barrier when compu- *
+* ting the time between different preequilibrium *
+* cycles *
+* Final time = [ dsclcy + ddscly * A^1/3 ] *
+* x [ ( 1 - dbscly ) / beta_bar *
+* + dvscly / beta_part ] *
+* ftscly = multiplication factor for the above total time *
+* for cascade-preequilibrium transitions *
+* icycls = starting preequilibrium cycle to be used for *
+* coalescence checks *
+* n0clsc = number of stack particles to be skipped for *
+* coalescence purposes *
+* npclsc = (final) stack number of particles to be conside- *
+* red for coalescence purposes *
+* nsclsc = starting stack number of particles to be conside-*
+* red for coalescence purposes *
+* ndclsc = diff. stack number of particles to call the *
+* coalescence model *
+* laclsc = flag for making coalescence checks on angular *
+* momentum rather than on p and x separately *
+* lclscn = flag for activating the coalescence model *
+* iclexc = flag for coalescence excitation energy treatment *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXCLSC = 100 )
+ LOGICAL LACLSC, LCLSCN
+*
+ COMMON / CLSCCM / PCLSCN (3,-6:-3), RCLSCN (3,-6:-3), DCLWPK,
+ & BNCLMX (-6:-3), DSCLCY, DDSCLY, DBSCLY, FTSCLY,
+ & PXCLSC (MXCLSC), PYCLSC (MXCLSC),
+ & PZCLSC (MXCLSC), ECLSCN (MXCLSC),
+ & XCLSCN (MXCLSC), YCLSCN (MXCLSC),
+ & ZCLSCN (MXCLSC), ACLSCN (MXCLSC),
+ & ICYCLS, N0CLSC, NPCLSC, NSCLSC, NDCLSC,
+ & ICLEXC, LACLSC, LCLSCN
+
--- /dev/null
+*$ CREATE CMABRS.ADD
+*COPY CMABRS
+*
+*=== cmabrs ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoMmon for ABsorption at ReSt: *
+* *
+* Created on 08 july 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-jul-95 by Alfredo Ferrari *
+* *
+* Hufffc (i) = Huff factor for mu- decay rate after atomic *
+* capture for Z=i *
+* Zeffmu (i) = Z_eff for mu- after atomic capture for Z=i *
+* *
+*----------------------------------------------------------------------*
+*
+* Parameters entering the Goulard-Primakoff formula for muon- nuclear
+* capture rates:
+ PARAMETER ( G1PRMK = 261. D+00 )
+ PARAMETER ( G2PRMK =-0.040D+00 )
+ PARAMETER ( G3PRMK =-0.26 D+00 )
+ PARAMETER ( G4PRMK = 3.24 D+00 )
+ COMMON / CMABRS / ZEFFMU (100), HUFFFC (100)
+
--- /dev/null
+*$ CREATE CMCSCM.ADD
+*COPY CMCSCM
+C------------------------------------------------------------------ COMMON /NEWGEOM/ -----------------------------------------------
+ PARAMETER (MAXNOGELE=2000) ! max no geometrical elements
+ PARAMETER (MAXNOGPAR=300) ! max no of parameters & pointers
+ PARAMETER (MAXNGTYPE=20) ! max no of element types
+
+ COMMON/NEWGEOM/HTITLE,NOGELE,IGEOTYPE(MAXNOGELE),
+ + GEONAME(MAXNOGELE),MATVAL(MAXNOGELE), ! generalities
+ + NGPARAM(MAXNOGELE),PARGEO(MAXNOGELE,MAXNOGPAR), ! parameters
+ + NGPOINT(MAXNOGELE),IIPOINT(MAXNOGELE,MAXNOGPAR), ! pointers
+ + IIMASTER,GEOTYPE(MAXNGTYPE),NONUMPAR(MAXNGTYPE) ! type & miscell
+ CHARACTER*20,GEONAME
+ CHARACTER*120 HTITLE
+ CHARACTER*4 GEOTYPE
+ DOUBLE PRECISION PARGEO
+C
+C HTITLE title(name) of geometry
+C NOGELE number of elements
+C IGEOTYPE(IGELE) type of element, address to GEOTYPE,NONUMPAR
+C GEONAME(IGELE) name of element (A20)
+C MATVAL(IGELE) material no (only for simple geometries)
+C NGPARAM(IGELE) no of associated parameters
+C PARGEO(IGELE,IPAR) associated parameters (floating DP)
+C NGPOINT(IGELE) no of associated pointers
+C IIPOINT(IGELE,IPNT) associated pointers (integers)=> IGELE of associated elements
+C IIMASTER IGELE of initiator element in the chain
+C GEOTYPE(k) key name for operator
+C NONUMPAR(k) no of elem in numeric list
+C
+C---------------------------------------------------------------END COMMON /NEWGEOM/ -----------------------------------------------
+C
+
+
+
--- /dev/null
+*$ CREATE CMKBSG.ADD
+*COPY CMKBSG
+*
+*=== cmkbsg ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoMmon for Kaon-Bar-nucleon SiGmas: *
+* *
+* Created on 07 december 1996 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* Last change on 30-sep-98 by Alfredo Ferrari, INFN-Milan *
+* *
+* List of variables: *
+* *
+* Knbout(io,ir,ip,it) = reaction products indeces, (io=1,2 for the two *
+* two products, ir=1,6 for the various reactions,*
+* ip=1,2 for K- or K0bar projectiles, it=1,2 for *
+* proton or neutron targets) *
+* Ipkbar(ir,ip,it) = internal reaction identifier for the ir_th *
+* reaction with ip (1,2 for K- or K0bar) projec- *
+* tile and it (1,2 for proton or neutron) target *
+* Lcxkbr(ir,ip,it) = charge exchange flag *
+* *
+* Ir = 1 => elastic (K- N -> K- N or K0bar N -> K0bar N) *
+* (variable Selas in Sgkbar) *
+* Ir = 2 => ch.exc. (K- p -> K0bar n or K0bar n -> K- p) *
+* (variable Scx in Sgkbar) *
+* Ir = 3 => st.exc. (K- p -> pi- Sigma+ or K0bar n -> pi+ Sigma- *
+* or K- n -> pi- Sigma0 or K0bar p -> pi0 Sigma+)*
+* (variable Ssigm in Sgkbar) *
+* Ir = 4 => st.exc. (K- p -> pi+ Sigma- or K0bar n -> pi- Sigma+ *
+* or K- n -> pi0 Sigma- or K0bar p -> pi+ Sigma0)*
+* (variable Ssigmc in Sgkbar) *
+* Ir = 5 => st.exc. (K- p -> pi0 Lambda or K0bar n -> pi0 Lambda *
+* or K- n -> pi- Lambda or K0bar p -> pi+ Lambda)*
+* Ir = 6 => st.exc. (K- p -> pi0 Sigma0 or K0bar n -> pi0 Sigma0)*
+* *
+*----------------------------------------------------------------------*
+*
+* Thresholds for pion production
+* ( Kinetic energy threshold for producing particle x in a collision
+* between p and t giving rise to p,t,x:
+* Ekth_ptx = m_x ( 2 m_p + 2 m_t + m_x ) / ( 2 m_t ) )
+* ( Kinetic energy threshold for producing particle x in a collision
+* between p and t giving rise to a,b,x:
+* Ekth_pt_abx = ( ( m_a + m_a + m_x )^2 - ( m_p + m_t )^2 )
+* / ( 2 m_t ) )
+* K-+p-->Lamda+pi0+pi0
+ PARAMETER ( TKMP00 = 0.0 D+00 )
+*
+ PARAMETER ( MKBREA = 6 )
+ PARAMETER ( MKBETB = 200 )
+ PARAMETER ( MKBWAV = 11 )
+*
+ LOGICAL LCXKBR
+ COMMON / CMKBSG /
+ & RE0KBA (MKBETB,MKBWAV,3), RE1KBA (MKBETB,MKBWAV,3),
+ & AIM0KB (MKBETB,MKBWAV,3), AIM1KB (MKBETB,MKBWAV,3),
+ & EKBTAB (MKBETB), NEKBTB, KBNOUT (2,MKBREA,2,2),
+ & IPKBAR (MKBREA,2,2), LCXKBR (MKBREA,2,2)
+
--- /dev/null
+*$ CREATE CMMDNR.ADD
+*COPY CMMDNR
+*
+*=== cmmdnr ==========================================================*
+*
+*---------------------------------------------------------------------*
+* Module CMMDNR: *
+* *
+* Last change A. Ferrari 26-may-1990 *
+* Created on 26-05-1990 by A. Ferrari, Infn-Milan *
+* *
+* *
+*---------------------------------------------------------------------*
+*
+ LOGICAL LFLDNR
+ COMMON / CMMDNR / DDNEAR, LFLDNR
+
--- /dev/null
+*$ CREATE CMPAIR.ADD
+*COPY CMPAIR
+*
+*=== cmpair ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoMmon for e+/e- PAIR production by heavy charged particles *
+* *
+* Created on 03 march 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 17-jun-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* HEAPAI *
+* CMPAIR *
+* DSDVVV *
+* DSDVVT *
+* DSDVRR *
+* DSDVDR *
+* PHEPAI *
+* PHPPAI *
+* ALPHE *
+* ALPHP *
+* YPAIRE *
+* YPAIRP *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( FELPAI = 1.0 D+00 )
+ PARAMETER ( RADLOG = 184.15 D+00 )
+ PARAMETER ( COSPAI = FSCTO4 * 2.D+00 / PIPIPI / 3.D+00 *
+ & PLABRC * PLABRC / AMELCT / AMELCT *
+ & AVOGAD * 1.D-26 )
+ COMMON / CMPAIR / AMPROJ, EPROJ, VTHRES, Z, Z2, Z13, DENS, ATOMW,
+ & COST , VV, RR, RRSQ, BBETA, XXSI, AMSQRT,
+ & ICHRG2, IPPROJ, MATBRE
+
--- /dev/null
+*$ CREATE CMPHLP.ADD
+*COPY CMPHLP
+*
+*=== Cmphlp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 01 august 1999 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 01-aug-99 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / CMPHLP / CNTNT (ICOMAX), MTNM (ICOMAX), ICNMAX, NMENUM
+ COMMON / CMPHCH / COMNAM (MXXMDF)
+ CHARACTER*8 COMNAM
+
--- /dev/null
+*$ CREATE CMPHNU.ADD
+*COPY CMPHNU
+* *
+*=== cmphnu ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Created on 05 october 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 22-oct-92 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* FLUKA *
+* DEFLTS *
+* EVXTES *
+* PHNCEV *
+* PHNCVR *
+* PHNVEV *
+* SIGTAB *
+* ZEROIN *
+* DSPHDV *
+* DSPHIV *
+* DSPHJV *
+* DSPVL1 *
+* DSPVL2 *
+* DSPVT1 *
+* DSPVT2 *
+* DVSPHV *
+* SGAPN *
+* *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER ( ANGEPP = 1.2D-04 )
+*
+ LOGICAL LPHNCL
+ COMMON / CMPHNU / AMPPHN, AMTPHN, EPRPHN, PPRPHN, QPH2MN, QPH2MX,
+ & VVPHMN, VVPHMX, RHOPHN, CSTPHN, GXSHDW, AMNPHN,
+ & A13PHN, AMPHN1, AMPHN2, ASQPH1, ASQPH2, EPSPH1,
+ & EPSPH2, FR1PHN, FR2PHN, SGPHUB, XLNPHN, AOCPHN,
+ & ZPHNMN, ZPHNMX, WPHNMN, WPHNMX, EOUPHN, POUPHN,
+ & AMPHSQ, ENHPHN, QU2PHN, CSTPHV, ARSQP1, ARSQP2,
+ & AMRPHE, T1MVOV, PHNORD, PHNEXO, PHNSTR, PHNEXS,
+ & AMRP1N, VSQ44V, VVSQRD, EPSSQ1, EPSSQ2, RRPHN1,
+ & RRSQR1, RRPHN2, RRSQR2, YESS1T, YESS2T, YESS1L,
+ & YESS2L, AFACTZ, ALOGA1, DIFZPH, PHOZP1, ALOGB1,
+ & DPHNSQ, DENPHN, ZMTPHN, MATPHN, IPPHNU,
+ & JFLPHN (MXXMDF), LPHNCL
+
--- /dev/null
+*$ CREATE CMPISG.ADD
+*COPY CMPISG
+*
+*=== cmpisg ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoMmon for PIon-nucleon SiGmas: *
+* *
+* Created on 07 december 1992 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* Last change on 06-sep-96 by Alfredo Ferrari, INFN-Milan *
+* *
+* List of variables: *
+* *
+* pmnpis = minimum momentum of tabulations *
+* pmmpis = median momentum of tabulations (switch from *
+* lin to log tabulations) *
+* pispis = maximum momentum for which an isotropic/- *
+* resonant term is computed for the angular *
+* distribution, it must be > pmmpis and *
+* =< pexpis / rtpisg. It is given by: *
+* pispis = pmmpis x rtpisg^(npisis-npirln) *
+* pexpis = momentum a exp(bt) term is computed from *
+* it is given by: *
+* pexpis = pmmpis x rtpisg^(npisex-npirln) *
+* pmxpis = maximum momentum of tabulations *
+* dppisg = Delta_p of the lin tabulation *
+* (dppisg = (pmmpis-pmnpis) / (npirln-1) ) *
+* rtpisg = ratio between subsequent tabulated momenta *
+* in the log part *
+* amnpis = log (pmnpis) *
+* ammpis = log (pmmpis) *
+* aispis = log (pispis) *
+* aexpis = log (pexpis) *
+* amxpis = log (pmxpis) *
+* arpisg = log (rtpisg) *
+* sgpicu(i,j,l) = cumulative cross section for cos theta = 1 *
+* - 0.1 * i at jth energy for lth reaction, ani-*
+* sotropic component (npirvr=1)/non resonant *
+* component (npirvr=2) *
+* sgpiis(j,l) = isotropic cross section (npirvr=1) /resonant*
+* cross section (npirvr=2), at jth energy for *
+* lth reaction, total cross section is given *
+* by sgpiis (j,l) + sgpicu (20,j,l) *
+* sgpidf(i,j,l) = differential cross section at cos theta = 1 *
+* - 0.1 * i at jth energy for lth reaction *
+* sgpiin(j,l) = inelastic (pion production, NO cx) cross *
+* section at jth energy for lth reaction *
+* ( l=1: pi+ p / pi- n, l=2: pi- p / pi+ n, *
+* l=3: pi0 p / pi0 n ) *
+* bpislo(j,l) = b slope parameter at jth energy for lth rea-*
+* ction (p>pexpis>pispis>pmmpis) *
+* cpislo(j,l) = bcurvature parameter at jth energy for lth *
+* reaction (p>pexpis>pispis>pmmpis) *
+* spislo(j,l) = cross section at jth energy for lth reaction*
+* for the exp(bt) part, the total cross *
+* section is given by: spislo (j,l) + *
+* sgpicu (20,j,l) *
+* sgrtrs(l) = ratio of the lth reaction at resonance with *
+* respect to the resonant "standard" form as *
+* given by Fpires *
+* brrein(l) = branching ratio in the entrance channel of *
+* the lth reaction, resonant part *
+* brreou(l) = branching ratio in the exit channel of *
+* the lth reaction, resonant part *
+* brdeou(i,j) = branching ratio in the (i=1->proton,i=2-> *
+* neutron) exit channel for 2-body resonant *
+* pion absorption of a Delta of charge j *
+* brd3ou(i,k,j) = branching ratio in the (i=1->proton,i=2-> *
+* neutron,k=1->proton,k=2->neutron) exit chan-*
+* nel for 3-body resonant pion absorption of *
+* a Delta of charge j *
+* brdeou(l) = branching ratio in the exit channel of *
+* the lth reaction, resonant part *
+* Prrsdl = random number representing the probability *
+* to select the anisotropic component *
+* ppithr(l) = threshold momentum for the pion in the lab *
+* system for the lth reaction channel *
+* rhpicr(l) = density correction factors for absorption of*
+* l type pions with respect to average rho *
+* ipirea(i,j,l) = reaction channel indexes (two at most) for *
+* l type incident particle (3=pi+,4=pi-,5=pi0)*
+* j type target nucleon (1=p,2=n) *
+* ipiine(j,l) = inelastic (pion production NO cx) reaction *
+* channel indexes for l type incident particle*
+* (3=pi+,4=pi-,5=pi0) j type target nucleon *
+* (1=p,2=n) *
+* kpiire(j,i) = incoming particles indexes (j=1,2, first the*
+* projectile pion, second the target nucleon, *
+* PAPROP numbering) for the ith reaction chan-*
+* nel *
+* kpiore(j,i) = outgoing particles indexes (j=1,2, first the*
+* pion, second the nucleon, PAPROP numbering) *
+* for the ith reaction channel *
+* ittrrs(l) = nucleon index of the resonant cross section *
+* for l type pions *
+* ldlres = flag for reaction going via an intermediate *
+* resonance Delta state *
+* *
+*----------------------------------------------------------------------*
+*
+* Thresholds for pion production
+* ( Kinetic energy threshold for producing particle x in a collision
+* between p and t giving rise to p,t,x:
+* Ekth_ptx = m_x ( 2 m_p + 2 m_t + m_x ) / ( 2 m_t ) )
+* ( Kinetic energy threshold for producing particle x in a collision
+* between p and t giving rise to a,b,x:
+* Ekth_pt_abx = ( ( m_a + m_a + m_x )^2 - ( m_p + m_t )^2 )
+* / ( 2 m_t ) )
+* p+p-->p+p+pi0
+ PARAMETER ( TPPPI0 = 0.279661403974980D+00 )
+* n+n-->n+n+pi0
+ PARAMETER ( TNNPI0 = 0.279648039999871D+00 )
+* p+p-->p+n+pi+
+ PARAMETER ( TPPPIP = 0.292300474999261D+00 )
+* p+p-->d+pi+
+ PARAMETER ( TPPDEP = 0.287520039338373D+00 )
+* n+n-->n+p+pi-
+ PARAMETER ( TNNPIM = 0.286728401466252D+00 )
+* n+n-->d+pi-
+ PARAMETER ( TNNDEM = 0.281954546115298D+00 )
+* p+n-->p+n+pi0
+ PARAMETER ( TPNPI0 = 0.279462243848891D+00 )
+* p+n-->d+pi0
+ PARAMETER ( TPNDE0 = 0.274699264355169D+00 )
+* p+n-->n+n+pi+
+ PARAMETER ( TPNPIP = 0.292092020411614D+00 )
+* n+p-->n+p+pi0
+ PARAMETER ( TNPPI0 = 0.279847456228455D+00 )
+* n+p-->d+pi0
+ PARAMETER ( TNPDE0 = 0.275077911416144D+00 )
+* n+p-->n+n+pi+
+ PARAMETER ( TNPPIP = 0.292494641748525D+00 )
+* This is the maximum momentum for which it makes sense to use
+* the "standard" resonant cross section given by Fpires to get
+* a resonant part: it can well be different from Pispis
+ PARAMETER ( PIRSMX = 1.2D+00 )
+*
+ PARAMETER ( NPIREA = 10 )
+ PARAMETER ( NPIRTA = 68 )
+ PARAMETER ( NPIRLN = 21 )
+ PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
+ PARAMETER ( NPISIS = NPIRLN + 20 )
+ PARAMETER ( NPISEX = NPIRLN + 21 )
+ PARAMETER ( NPIIMN = 14 )
+ PARAMETER ( NPIIRC = 6 )
+* Delta nuclear well: 35 MeV (at center)
+ PARAMETER ( DELWLL = 0.035D+00 )
+ CHARACTER CHPIRE*8
+ LOGICAL LDLRES
+ COMMON / CMPISG / PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
+ & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
+ & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
+ & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
+ & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
+ & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
+ & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
+ & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
+ & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
+ & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
+ & SGABSR (2,2,4) , PRRSDL,
+ & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
+ & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
+ & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
+ COMMON / CHPISG / CHPIRE (NPIREA)
+ DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
+ EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
+ EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
+ EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
+
--- /dev/null
+*$ CREATE CMSRES.ADD
+*COPY CMSRES
+*
+*=== cmsres ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of CMSRES: *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* *
+* Last change on 06-dec-97 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Pxr(i) = X-component of the momentum of the i_th produced *
+* resonance *
+* Pyr(i) = Y-component of the momentum of the i_th produced *
+* resonance *
+* Pzr(i) = Z-component of the momentum of the i_th produced *
+* resonance *
+* Her(i) = Total energy of the i_th produced resonance *
+* Amr(i) = Mass of the i_th produced resonance *
+* Ichr(i) = Charge of the i_th produced resonance *
+* Ibarr(i) = Baryon number of the i_th produced resonance *
+* Nrer(i) = Identity (part scheme) of the i_th produced resonance*
+* Ichnr(3,i) = Array containing additional informations about pro- *
+* duction verteces, ranking etc. *
+* Nres = Number of produced resonances *
+* Nres1 = Number of produced resonances from the first chain *
+* Nres2 = Number of produced resonances from the second chain *
+* Anr(i) = Literal name of the i_th produced resonance *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANR
+ COMMON / CMSRES / PXR (MXPDPM), PYR (MXPDPM), PZR (MXPDPM),
+ & HER (MXPDPM), AMR (MXPDPM), ICHR (MXPDPM),
+ & IBARR (MXPDPM), NRER (MXPDPM), ICHNR(3,MXPDPM),
+ & NRES, NRES1, NRES2
+ COMMON / CHCMSR / ANR (MXPDPM)
+
--- /dev/null
+*$ CREATE CMTIME.ADD
+*COPY CMTIME
+*
+*=== cmtime ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file cmtime *
+* *
+* Created on 03 august 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-jul-92 by Alfredo Ferrari *
+* *
+* Included in: *
+* Electr *
+* Feeder *
+* Fluka *
+* Kaskad *
+* Kasneu *
+* Photon *
+* Zeroin *
+* Variables: *
+* Tctffp(i) = cut off time for ith-particle type *
+* in seconds *
+* Tdelap(i) = delay time before applying the ti- *
+* me cutoff for ith-particle type in *
+* seconds *
+* Tcutof = total time cutoff for the present *
+* particle in seconds *
+* Tstart = start time in seconds *
+* Mtstrp(i) = material number for the start si- *
+* gnal *
+* *
+* W A R N I N G !!! S T A R T S I G N A L N O T Y E T *
+* I M P L E M E N T E D !!! *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / CMTIME / TCTFFP (-6:NALLWP), TDELAP (-6:NALLWP), TCUTOF,
+ & TSTART, MTSTRP (-6:NALLWP)
+
--- /dev/null
+*$ CREATE COMCON.ADD
+*COPY COMCON
+*
+*=== comcon ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file COMpound CONstants: new version for FLUKA92 on *
+* *
+* Created on 30 october 1992 by Alfredo Ferrari *
+* INFN, Milan *
+* *
+* Last change on 28-apr-97 by Alfredo Ferrari, INFN - Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /comcon/ contains information about compounds *
+* icompl(imat) = number of materials in a compound *
+* matnum(i) = material numbers (compounds consist of the *
+* materials) *
+* aocmbc(i) = atomic densities in barn**-1 cm**-1 *
+* (Atoms Over Cm times Barn for Compounds) *
+* cona13(i) = A^1/3 of the constituents *
+* sumzmf(i) = cumulative z^2 for multiple scattering *
+* contnt(i) = partial densities *
+* sumacn(i) = cumulative atom contents of the compounds *
+* cabinx(i) = cumulative at.cont.*inelastic cross section *
+* cabelx(i) = cumulative at.cont.* elastic cross section *
+* anxnor = total inelastic cross section *
+* elxnor = total elastic cross section *
+* pliflu(imat) = plasma energy of the Fluka medium Imat *
+* jchflu(imat) = number of harmonic oscillator levels in a *
+* compound *
+* jc0flu(imat) = starting position for 0 index for Imat medium *
+* in the following arrays *
+* ehoflu(j) = jth - jc0flu(imat) harmonic oscillator levels *
+* of Fluka medium Imat *
+* elnhfl(j) = natural logarithm of ehoflu (j) *
+* fosflu(j) = oscillator strength for the jth - jc0flu(Imat)*
+* harmonic oscillator levels of Fluka medium *
+* Imat *
+* zhoflu(j) = atomic number of the element for the jth - *
+* jc0flu(imat) harmonic oscillator level of *
+* Fluka medium Imat *
+* ahoflu(j) = atomic weights of the element for the jth - *
+* jc0flu(imat) harmonic oscillator level of *
+* Fluka medium Imat *
+* eliflu(j) = l_i of the Sternheimer theory for the jth - *
+* jc0flu(Imat) harmonic oscillator level of *
+* Fluka medium Imat *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /COMCON/ AOCMBC (ICOMAX), CONA13 (ICOMAX), SUMZMF (ICOMAX),
+ & CONTNT (ICOMAX), SUMACN (ICOMAX), CABINX (ICOMAX),
+ & CABELX (ICOMAX), ANXNOR, ELXNOR, EHOFLU (ICHMAX),
+ & ELNHFL (ICHMAX), FOSFLU (ICHMAX), ZHOFLU (ICHMAX),
+ & AHOFLU (ICHMAX), ELIFLU (ICHMAX), PLIFLU (MXXMDF),
+ & ICOMPL (MXXMDF), JC0FLU (MXXMDF), JCHFLU (MXXMDF),
+ & MATNUM (ICOMAX)
+
--- /dev/null
+*$ CREATE COMPUT.ADD
+*COPY COMPUT
+*
+*=== comput ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: comput copy created 23/08/94 by afa *
+* *
+* Last change on 09-nov-98 by Alfredo Ferrari, CERN *
+* included in the following subroutines or functions: *
+* *
+* berttp *
+* blkdt1 *
+* cmsppr *
+* dtimst *
+* elsgrd *
+* epilog *
+* feeder *
+* flukam *
+* fluoin *
+* geogeo *
+* mgdraw *
+* nuscti *
+* pisgrd *
+* plotgm *
+* rsncli *
+* source *
+* usrbdx *
+* usrbin *
+* usrtrk *
+* usryld *
+* which *
+* xnbnls *
+* xnloan *
+* xsread *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* /comput/ contains information about the computer used *
+* and about the input file *
+* komput = system (1=OpenVms, 2=ibm-vm, 3=ibm-mvs, *
+* 4=cray, 5=unix-aix, 6=unix-hp, *
+* 7=unix-sun, 8=DEC-unix, 9=Linux...) *
+* Cpuspe = computer speed with respect to IBM 370/168-3 *
+* or to VAX 780/11 or to IBM RISC/6000 7012/370 *
+* Cpujob = cpu limit (s) for the current job *
+* Kpwdir = last non blank character of Pwddir *
+* Kfldir = last non blank character of Hfldir *
+* Khmdir = last non blank character of Homdir *
+* Mxftnu = maximum fortran unit number allowed *
+* Comptr = model *
+* Inpfil = input file *
+* Pwddir = current work directory *
+* Hfldir = home FLUKA directory *
+* Homdir = user home directory *
+* Hostnm = host name *
+* Usrflk = user name *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER COMPTR*50, INPFIL*80, PWDDIR*80, HFLDIR*80, HOMDIR*80,
+ & HOSTNM*80, USRFLK*80
+ COMMON / COMPUT / CPUSPE, CPUJOB, KOMPUT, KPWDIR, KFLDIR, KHMDIR,
+ & MXFTNU
+ COMMON / CHCMPT / COMPTR, INPFIL, PWDDIR, HFLDIR, HOMDIR, HOSTNM,
+ & USRFLK
+
--- /dev/null
+*$ CREATE COOKCM.ADD
+*COPY COOKCM
+*
+*----------------------------------------------------------------------*
+* *
+* Include file CookCm *
+* *
+* This is the Fluka version of LAHET common COOK *
+* *
+* This common together with the routines GETA,GETG and the relevant*
+* initialization in common BDEVAP has been obtained by the corre- *
+* sponding LAHET routines, thanks to the kindness of R.E.Prael *
+* *
+* Created on 18 january 1993 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 22-jul-00 by Alfredo Ferrari *
+* *
+* Note that the AMEAN array has been eliminated since its function *
+* is already provided by the Aprime array of EVAP-V from HETC-KFA *
+* Moreover the following variable names have been changed to avoid *
+* clashes: *
+* PZ --> PZCOOK *
+* PN --> PNCOOK *
+* SZ --> SZCOOK *
+* SN --> SNCOOK *
+* ISZ --> LDEFOZ *
+* ISN --> LDEFON *
+* and the array CON has been directly coded into GETA/GETG *
+* *
+* Data tables of Cook et. al. from AAEC/TM392, supplemented by G+C.*
+* *
+* The variables Pzgica, Pngica, Szgica, Sngica are the original *
+* values from A.Gilbert, A.G.W.Cameron, Can.J.Phys. 43 (1965) 1447 *
+* *
+* The ...IGN variables relate to the Ignyatuk-like fit for the *
+* excitation energy dependence of the level density. *
+* In particular, the asymptotic level density parameter is given *
+* by: *
+* a(oo) = alpign + betign * Ahelp *
+* where: *
+* Ahelp = A, for powign = 0 *
+* Ahelp = A^powign, for powign >< 0 *
+* and for any given Ueff (Ueff=U-delta): *
+* a(Ueff) = a(0) * G(gamma*Ueff) + a(oo) * [1 - G(gamma*Ueff)] *
+* where: *
+* G(x) = [1 - exp(-x)]/x *
+* and: *
+* gamma = gamign, for gamign > 0 *
+* gamma = -a(oo) / gamign / A^1/3, for gamign < 0 *
+* *
+*----------------------------------------------------------------------*
+*
+* Conversion factor from a to g:
+ PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
+*
+ LOGICAL LDEFOZ, LDEFON
+ PARAMETER ( INCOOK = 150, IZCOOK = 98 )
+ PARAMETER ( INGICA = 150, IZGICA = 98 )
+ COMMON / COOKCM / ALPIGN, BETIGN, GAMIGN, POWIGN,
+ & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
+ & PNCOOK (INCOOK), SZGICA (IZGICA), SNGICA (INGICA),
+ & PZGICA (IZGICA), PNGICA (INGICA), SZGINW (IZGICA),
+ & SNGINW (INGICA), PZGINW (IZGICA), PNGINW (INGICA),
+ & SZGIEX (IZGICA), SNGIEX (INGICA), PZGIEX (IZGICA),
+ & PNGIEX (INGICA), LDEFOZ (IZCOOK), LDEFON (INCOOK)
+
--- /dev/null
+*$ CREATE CORINC.ADD
+*COPY CORINC
+* *
+*=== corinc ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Created on 02 february 1990 by Alfredo Ferrari *
+* Infn - Milan *
+* *
+* Last change on 19-may-95 by Alfredo Ferrari *
+* *
+* Be sure that the parameter Inmax is >= than the same parameter *
+* in the function Nudisv *
+* *
+* Xquark = projectile (anti)quark X fraction for mesons and *
+* (anti)baryons *
+* Xqbdiq = projectile qbar/(anti)diquark X fraction for *
+* mesons/(anti)baryons *
+* Xequar = lab energy associated with Xquark *
+* Xpquar = lab momentum associated with Xquark *
+* Xeqbdq = lab energy associated with Xqbdiq *
+* Xpqbdq = lab momentum associated with Xqbdiq *
+* Xsea(i) = X fraction of the quark of the i_th sea qqbar *
+* couple *
+* Xasea(i) = X fraction of the qbar of the i_th sea qqbar *
+* couple *
+* Xesea(1,i) = lab energy associated with Xsea(i) *
+* Xesea(2,i) = lab energy associated with Xasea(i) *
+* Xpsea(1,i) = lab momentum associated with Xsea(i) *
+* Xpsea(2,i) = lab momentum associated with Xasea(i) *
+* Frainc = reduction factor for intranuclear cascade energy, *
+* including correlations *
+* Anuav = expected asymptotic (E_cms>>m_pro) average number *
+* of primary collisions, before threshold effects *
+* Sgivmd = Vector meson - A inelastic sigma *
+* Sivmdp = Vector meson - p inelastic sigma *
+* Sivmdn = Vector meson - n inelastic sigma *
+* Sgtvmd = Vector meson - A total sigma *
+* Stvmdp = Vector meson - p total sigma *
+* Stvmdn = Vector meson - n total sigma *
+* Iqsea(i) = quark id of the i_th sea qqbar couple *
+* Ijtarg(i+1) = target nucleon id of the i_th sea-valence intera- *
+* ction (i=0 --> valence-valence) *
+* Nsea = number of sea-valence interactions *
+* Nsebdf = number of sea-valence interactions before possible *
+* reductions due to diffraction exclusion *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( INMAX = 30 )
+ COMMON / CORINC / XQUARK, XQBDIQ, XEQUAR, XPQUAR, XEQBDQ, XPQBDQ,
+ & XSEA (INMAX), XASEA (INMAX), XESEA (2,INMAX),
+ & XPSEA (2,INMAX), FRAINC, ANUAV, SGIVMD, SIVMDP,
+ & SIVMDN, SGTVMD, STVMDP, STVMDN,
+ & IQSEA (INMAX), IJTARG (INMAX+1), NSEA , NSEBDF
+
--- /dev/null
+*$ CREATE COUNTQ.ADD
+*COPY COUNTQ
+*
+*=== countq ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: countq copy *
+* *
+* New version of the original Countq from P.Aarnio: *
+* *
+* Now Sopp's have no meaning, it is used only to steer the new *
+* Fred James double precision random number generator *
+* *
+* Created on 19 july 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-jan-97 by Alfredo Ferrari *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MHLPAL = 2 * KALGNM )
+ LOGICAL LFJR48
+ COMMON / COUNTQ / SOPP (2), LFJR48
+ DIMENSION KSOPP (MHLPAL)
+ EQUIVALENCE ( KSOPP (1), SOPP (1) )
+
--- /dev/null
+*$ CREATE CRQRKS.ADD
+*COPY CRQRKS
+*
+*=== Crqrks ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CuRrent QuaRKS: *
+* *
+* Created on 21 october 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 16-oct-00 by Alfredo Ferrari *
+* *
+* i=1,2 Iqrkx(i) = x_th (anti)quark of the i_th particle selected *
+* by qrstvx (1 selected normally, two selected for*
+* chain joining) *
+* i=-1,0 Iqrkx(i) = x_th (anti)quark of the last particle produced *
+* out of the -i jet (-i=LL in bamjev terminology) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXQRKJ = 2 )
+*
+ COMMON / CRQRKS / IQURK1 (-1:MXQRKJ), IQURK2 (-1:MXQRKJ),
+ & IQURK3 (-1:MXQRKJ), NPRTST
--- /dev/null
+*$ CREATE CSMCRY.ADD
+*COPY CSMCRY
+*
+*=== csmcry ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CoSMiC RaY common: *
+* *
+* Created on 29 may 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-mar-01 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXATSH = 201 )
+ PARAMETER ( MXPNSK = 64 )
+ LOGICAL LGMGCO, LMBCKT, LCFCRC
+ COMMON / CSMCRY / ALMGMG, PHMGMG, DOSCRN, ALPSCR, DPHSCR, BESMPL,
+ & DOSMPL, TMNSMP, TMXSMP, PMNSMP, PMXSMP, PEARTH,
+ & RPLANT, RPLNTS, RMNCTF, RMXCTF, CRBNNR,
+ & SRSCRN (MXATSH),GAMMAE, SPNORM, CSTHPR,
+ & AFLUX (79), XFLUX (79), FFLUX (79), RFLUX (79),
+ & FLPINS(MXPNSK,28), FPINST(28), XCRCRR, YCRCRR,
+ & ZCRCRR, TXCRCR, TYCRCR, TZCRCR, PCRCRR, IACRCR,
+ & IZCRCR, IZPINS, NEPINS, IFLXFL, LGMGCO, LMBCKT,
+ & LCFCRC
+
--- /dev/null
+*$ CREATE CTITLE.ADD
+*COPY CTITLE
+*
+*=== ctitle ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common Ctitle: it allows the identification of the run *
+* created by A. Ferrari on 10-feb-1990 *
+* *
+* included in: *
+* fluka (main) *
+* bdnopt *
+* detect *
+* jomin *
+* usrbin *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10, RUNGEO*60
+ COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY, RUNGEO
+ COMMON / CEXPCK / ITEXPI, ITEXMX, IOPOUT, IOUTUN (MXOUTU)
+
--- /dev/null
+*$ CREATE CURPRO.ADD
+*COPY CURPRO
+*
+*=== curpro ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* CURrent PROjectile parameters *
+* *
+* Created on 28 january 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-jan-92 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BIMSEL *
+* NWISEL *
+* FORNUC *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / CURPRO / XCRRNT, YCRRNT, ZCRRNT, CXCRRN, CYCRRN, CZCRRN,
+ & RCRRNT, VCRRNT, PCRRNT, ECRNNT
+
--- /dev/null
+*$ CREATE DBLPRC.ADD
+*COPY DBLPRC
+* *
+*=== dblprc ==========================================================*
+* *
+*---------------------------------------------------------------------*
+* *
+* Dblprc: included in any routine, machine, mathematical and *
+* physical constants plus global declarations *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
+* !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
+* !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
+* !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
+* !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
+* !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Kalgnm = real address alignment, 2 for double precision, *
+* 1 for single precision *
+* Anglgb = this parameter should be set equal to the machine *
+* "zero" with respect to unit *
+* Anglsq = this parameter should be set equal to the square *
+* of Anglgb *
+* Axcssv = this parameter should be set equal to the number *
+* for which unity is negligible for the machine *
+* accuracy *
+* Andrfl = "underflow" of the machine for floating point *
+* operation *
+* Avrflw = "overflow" of the machine for floating point *
+* operation *
+* Ainfnt = code "infinite" *
+* Azrzrz = code "zero" *
+* Einfnt = natural logarithm of the code "infinite" *
+* Ezrzrz = natural logarithm of the code "zero" *
+* Excssv = natural logarithm of the code number for which *
+* unit is negligible *
+* Englgb = natural logarithm of the code "zero" with respect *
+* to unit *
+* Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
+* Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
+* Csnnrm = maximum tolerable error on cosine normalization, *
+* u**2+v**2+w**2: assuming a typical anglgb relative *
+* error on each component we would get 2xanglgb: use *
+* 4xanglgb to avoid too many normalizations *
+* Dmxtrn = "infinite" distance for transport (cm) *
+* Rhflmn = minimal density for Fluka (g/cm^3) *
+* *
+* "Global" declarations: *
+* Lfluka = set to true for a real (full) Fluka run *
+* Lgbias = set to true for a fully biased run *
+* Lgbana = set to true for a fully analogue run *
+* Lflgeo = set to true when using the standard Fluka geometry *
+* Loflts = set to true for special off-line testing of speci- *
+* fic routines *
+* Lusrin = set to true if the user dependent initialization *
+* routine Usrini has been called at least onec *
+* *
+*---------------------------------------------------------------------*
+* *
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ PARAMETER ( KALGNM = 2 )
+ PARAMETER ( ANGLGB = 5.0D-16 )
+ PARAMETER ( ANGLSQ = 2.5D-31 )
+ PARAMETER ( AXCSSV = 0.2D+16 )
+ PARAMETER ( ANDRFL = 1.0D-38 )
+ PARAMETER ( AVRFLW = 1.0D+38 )
+ PARAMETER ( AINFNT = 1.0D+30 )
+ PARAMETER ( AZRZRZ = 1.0D-30 )
+ PARAMETER ( EINFNT = +69.07755278982137 D+00 )
+ PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
+ PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
+ PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
+ PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
+ PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
+ PARAMETER ( CSNNRM = 2.0D-15 )
+ PARAMETER ( DMXTRN = 1.0D+08 )
+ PARAMETER ( RHFLMN = 1.0D-06 )
+*
+*======================================================================*
+*======================================================================*
+*========= ==========*
+*========= M A T H E M A T I C A L C O N S T A N T S ==========*
+*========= ==========*
+*======================================================================*
+*======================================================================*
+* *
+* Numerical constants (single precision): *
+* *
+* Zersng = 0 *
+* *
+* Numerical constants (double precision): *
+* *
+* Zerzer = 0 *
+* Oneone = 1 *
+* Twotwo = 2 *
+* Thrthr = 3 *
+* Foufou = 4 *
+* Fivfiv = 5 *
+* Sixsix = 6 *
+* Sevsev = 7 *
+* Eigeig = 8 *
+* Aninen = 9 *
+* Tenten = 10 *
+* Eleven = 11 *
+* Twelve = 12 *
+* Fiften = 15 *
+* Sixten = 16 *
+* Hlfhlf = 1/2 *
+* Onethi = 1/3 *
+* Onefou = 1/4 *
+* Onefiv = 1/5 *
+* Onesix = 1/6 *
+* Onesev = 1/7 *
+* Oneeig = 1/8 *
+* Twothi = 2/3 *
+* Thrfou = 3/4 *
+* Thrtwo = 3/2 *
+* Pipipi = Circumference / diameter *
+* Twopip = 2 x Pipipi *
+* Pip5o2 = 5/2 x Pipipi *
+* Pipisq = Pipipi x Pipipi *
+* Pihalf = 1/2 x Pipipi *
+* Erfa00 = Erf (oo) = 1/2 x square root of pi *
+* Sqtwpi = square root of 2xpi *
+* Eulero = Eulero's constant *
+* Eulexp = exp ( Eulero ) *
+* E1m2eu = exp ( 1 - 2 eulero ) *
+* Eneper = "e", base of natural logarithm *
+* Sqrent = square root of "e" *
+* Sqrtwo = square root of 2 *
+* Sqrthr = square root of 3 *
+* Sqrfiv = square root of 5 *
+* Sqrsix = square root of 6 *
+* Sqrsev = square root of 7 *
+* Sqrt12 = square root of 12 *
+* *
+*----------------------------------------------------------------------*
+*
+ REAL ZERSNG
+ PARAMETER ( ZERSNG = 0.E+00 )
+ PARAMETER ( ZERZER = 0.D+00 )
+ PARAMETER ( ONEONE = 1.D+00 )
+ PARAMETER ( TWOTWO = 2.D+00 )
+ PARAMETER ( THRTHR = 3.D+00 )
+ PARAMETER ( FOUFOU = 4.D+00 )
+ PARAMETER ( FIVFIV = 5.D+00 )
+ PARAMETER ( SIXSIX = 6.D+00 )
+ PARAMETER ( SEVSEV = 7.D+00 )
+ PARAMETER ( EIGEIG = 8.D+00 )
+ PARAMETER ( ANINEN = 9.D+00 )
+ PARAMETER ( TENTEN = 10.D+00 )
+ PARAMETER ( ELEVEN = 11.D+00 )
+ PARAMETER ( TWELVE = 12.D+00 )
+ PARAMETER ( FIFTEN = 15.D+00 )
+ PARAMETER ( SIXTEN = 16.D+00 )
+ PARAMETER ( HLFHLF = 0.5D+00 )
+ PARAMETER ( ONETHI = ONEONE / THRTHR )
+ PARAMETER ( ONEFOU = ONEONE / FOUFOU )
+ PARAMETER ( ONEFIV = ONEONE / FIVFIV )
+ PARAMETER ( ONESIX = ONEONE / SIXSIX )
+ PARAMETER ( ONESEV = ONEONE / SEVSEV )
+ PARAMETER ( ONEEIG = ONEONE / EIGEIG )
+ PARAMETER ( TWOTHI = TWOTWO / THRTHR )
+ PARAMETER ( THRFOU = THRTHR / FOUFOU )
+ PARAMETER ( THRTWO = THRTHR / TWOTWO )
+ PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
+ PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
+ PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
+ PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
+ PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
+ PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
+ PARAMETER ( SQRTPI = 1.772453850905516027298167483341D+00 )
+ PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
+ PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
+ PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
+ PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
+ PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
+ PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
+ PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
+ PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
+ PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
+ PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
+ PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
+ PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
+ PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
+*
+*======================================================================*
+*======================================================================*
+*========= ==========*
+*========= P H Y S I C A L C O N S T A N T S ==========*
+*========= ==========*
+*======================================================================*
+*======================================================================*
+* *
+* Primary constants: *
+* *
+* Clight = speed of light in cm s-1 *
+* Avogad = Avogadro number *
+* Boltzm = k Boltzmann constant (J K-1) *
+* Amelgr = electron mass (g) *
+* Plckbr = reduced Planck constant (erg s) *
+* Elccgs = elementary charge (CGS unit) *
+* Elcmks = elementary charge (MKS unit) *
+* Amugrm = Atomic mass unit (g) *
+* Ammumu = Muon mass (amu) *
+* Amprmu = Proton mass (amu) *
+* Amnemu = Neutron mass (amu) *
+* *
+* Derived constants: *
+* *
+* Alpfsc = Fine structure constant = e^2/(hbar c) (CGS units) *
+* Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
+* Amugev = Atomic mass unit (GeV) = 10^-16Amugrm Clight^2 *
+* / Elcmks *
+* Ammuon = Muon mass (GeV) = Ammumu * Amugev *
+* Amprtn = Proton mass (GeV) = Amprmu * Amugev *
+* Amntrn = Neutron mass (GeV) = Amnemu * Amugev *
+* Amdeut = Deuteron mass (GeV) *
+* Amalph = Alpha mass (GeV) (derived from the excess mass *
+* and an (approximate) atomic binding not a really *
+* measured constant) *
+* Cougfm = e^2 (GeV fm) = Elccgs^2 / Elcmks * 10^-7 * 10^-9 *
+* * 10^13 (10^..=erg cm->joule cm->GeV cm->GeV fm *
+* it is equal to 0.00144 GeV fm *
+* Fscto2 = (Fine structure constant)^2 *
+* Fscto3 = (Fine structure constant)^3 *
+* Fscto4 = (Fine structure constant)^4 *
+* Plabrc = Reduced Planck constant times the light velocity *
+* expressed in GeV fm *
+* Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
+* Bltzmn = k Boltzmann constant in GeV K-1 *
+* A0bohr = Bohr radius, hbar^2 / ( m_e e^2) (fm) = Plabrc**2 *
+* / Amelct / Cougfm, or equivalently, *
+* Plabrc / Alpfsc / Amelct *
+* Gfohb3 = Fermi constant, G_f/(hbar c)^3, in GeV^-2 *
+* Gfermi = Fermi constant in GeV fm^3 *
+* Sin2tw = sin^2 theta_Weinberg *
+* Prmgnm = proton magnetic moment (magneton) *
+* Anmgnm = neutron magnetic moment (magneton) *
+* *
+* Astronomical constants: *
+* *
+* Rearth = Earth equatorial radius (cm) *
+* Auastu = Astronomical Unit (cm) *
+* *
+* Conversion constants: *
+* *
+* GeVMeV = from GeV to MeV *
+* eMVGeV = from MeV to GeV *
+* alGVMV = from GeV to MeV, log *
+* Raddeg = from radians to degrees *
+* Degrad = from degrees to radians *
+* GeVOmg = from (photon) energy [GeV] in 2pi x frequency [s^-1]*
+* *
+* Useful constants: *
+* *
+* Fertho = constant to be used in the Fermi-Thomas approxima- *
+* ted expression for atomic binding energies *
+* Expebn = exponent to be used in the Fermi-Thomas approxima- *
+* ted expression for atomic binding energies *
+* B_atomic (Z) = Fertho x Z^Expebn (GeV) *
+* Bexc12 = Fermi-Thomas approximated expression for 12-C ato- *
+* mic binding energies (GeV) *
+* Amunmu = difference between the atomic and nuclear mass units*
+* Amuc12 = "Nuclear" mass unit = 1/12 M_nucl (12-C), *
+* M_nucl (12-C) = M_atom (12-C) - 6 m_e + B_atom(12-C)*
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( CLIGHT = 2.99792458 D+10 )
+ PARAMETER ( AVOGAD = 6.0221367 D+23 )
+ PARAMETER ( BOLTZM = 1.380658 D-23 )
+ PARAMETER ( AMELGR = 9.1093897 D-28 )
+ PARAMETER ( PLCKBR = 1.05457266 D-27 )
+ PARAMETER ( ELCCGS = 4.8032068 D-10 )
+ PARAMETER ( ELCMKS = 1.60217733 D-19 )
+ PARAMETER ( AMUGRM = 1.6605402 D-24 )
+ PARAMETER ( AMMUMU = 0.113428913 D+00 )
+ PARAMETER ( AMPRMU = 1.007276470 D+00 )
+ PARAMETER ( AMNEMU = 1.008664904 D+00 )
+* PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
+* PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
+* PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
+* PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
+* It is important to set the electron mass exactly with the same
+* rounding as in the mass tables, so use the explicit expression
+* PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
+* It is important to set the amu mass exactly with the same
+* rounding as in the mass tables, so use the explicit expression
+* PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
+* It is important to set the muon,proton,neutron masses exactly with
+* the same rounding as in the mass tables, so use the explicit
+* expression
+* PARAMETER ( AMMUON = AMMUMU * AMUGEV )
+* PARAMETER ( AMPRTN = AMPRMU * AMUGEV )
+* PARAMETER ( AMNTRN = AMNEMU * AMUGEV )
+* PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
+* PARAMETER ( BLTZMN = BOLTZM / ELCMKS * 1.D-09 )
+ PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
+ PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
+ PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
+ PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
+ PARAMETER ( PLABRC = 0.197327053 D+00 )
+ PARAMETER ( AMELCT = 0.51099906 D-03 )
+ PARAMETER ( AMUGEV = 0.93149432 D+00 )
+ PARAMETER ( AMMUON = 0.105658389 D+00 )
+ PARAMETER ( AMPRTN = 0.93827231 D+00 )
+ PARAMETER ( AMNTRN = 0.93956563 D+00 )
+ PARAMETER ( AMDEUT = 1.87561339 D+00 )
+ PARAMETER ( AMALPH = 3.72738025692891 D+00 )
+ PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
+ & * 1.D-09 )
+ PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
+ PARAMETER ( BLTZMN = 8.617385 D-14 )
+ PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
+ PARAMETER ( GFOHB3 = 1.16639 D-05 )
+ PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
+ PARAMETER ( SIN2TW = 0.2319 D+00 )
+ PARAMETER ( PRMGNM = 2.792847386 D+00 )
+ PARAMETER ( ANMGNM =-1.91304275 D+00 )
+ PARAMETER ( REARTH = 6.378140 D+08 )
+ PARAMETER ( AUASTU = 1.4959787066 D+13 )
+ PARAMETER ( GEVMEV = 1.0 D+03 )
+ PARAMETER ( EMVGEV = 1.0 D-03 )
+ PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
+ PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
+ PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
+ PARAMETER ( GEVOMG = CLIGHT * 1.D+13 / PLABRC )
+* Old Fermi-Thomas parametrization of atomic binding energies:
+* PARAMETER ( FERTHO = 15.73 D-09 )
+* PARAMETER ( EXPEBN = 7.D+00 / 3.D+00 )
+* PARAMETER ( BEXC12 = FERTHO * 65.41634134195703D+00 )
+* New Fermi-Thomas parametrization of atomic binding energies:
+ PARAMETER ( FERTHO = 14.33 D-09 )
+ PARAMETER ( EXPEBN = 2.39 D+00 )
+ PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
+ PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
+ PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
+*
+ LOGICAL LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS, LUSRIN
+ COMMON / GLOBAL / LFLUKA, LGBIAS, LGBANA, LFLGEO, LOFLTS,
+ & LUSRIN, KFLGEO, KFLDNR
+
--- /dev/null
+*$ CREATE DCDRBS.ADD
+*COPY DCDRBS
+*
+*=== Dcdrbs ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* DeCay DiRection BiaSing: *
+* *
+* Created on 30 march 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-apr-98 by Alfredo Ferrari *
+* *
+* Aldcdr = Lamda for eps=1-cos(theta). The polar direction *
+* around the direction corresponding to the one *
+* wished by the user is sample from *
+* P(eps) = exp (-eps/Aldcdr) *
+* U,V,Wdcdrb = Lab direction the neutrino should go along *
+* Sdcdrb = Sin(acos(Wdcdrb)) *
+* Spdcdr = Vdcdrb / Sdcdrb *
+* Cpdcdr = Udcdrb / Sdcdrb *
+* Aldcdc = current Lamda for eps=1-cos(theta) *
+* Sth0dc = Sin(Theta_0), where (Theta_0,Phi_0) is the direc- *
+* tion corresponding to U,V,Wdcdrb in the decaying *
+* particle CMS *
+* Cth0dc = Cos(Theta_0) *
+* Sph0dc = Sin(Phi_0) *
+* Cph0dc = Cos(Phi_0) *
+* Kpdcdr = number (1,2,3...) of the decay product whose *
+* direction is biased *
+* Ldcdrb(i) = flag for decay direction biasing for i_th particle *
+* type (Paprop numbering scheme) *
+* Ldcdbc = current flag for decay direction biasing *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LDCDRB, LDCDBC
+*
+ COMMON / DCDRBS / ALDCDR, UDCDRB, VDCDRB, WDCDRB, SDCDRB, SPDCDR,
+ & CPDCDR, ALDCDC, STH0DC, CTH0DC, SPH0DC, CPH0DC,
+ & KPDCDR, LDCDRB (-6:NALLWP), LDCDBC
+
--- /dev/null
+*$ CREATE DECAYC.ADD
+*COPY DECAYC
+*
+*=== Decayc ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: Decayc (new version of old Decayc) *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! S E E A L S O I N C L U D E F I L E !!!! *
+* !!!! D E C A Y C 2 !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Created on 07 february 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 07-feb-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* AMPART *
+* BLKDT7 *
+* CHANWT *
+* DATEST *
+* DECAY *
+* DIFEVV *
+* HADDEN *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ZKNAME
+ COMMON / DECAYC / WT (-6:IDMXDC), NZK (-6:IDMXDC,3)
+ COMMON / DCYCCH / ZKNAME (-6:IDMXDC)
+
--- /dev/null
+*$ CREATE DECAYC2.ADD
+*COPY DECAYC2
+*
+*=== Decayc2 ==========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: Decayc2 (new version of old Decayc2) *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! S E E A L S O I N C L U D E F I L E !!!! *
+* !!!! D E C A Y C !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Created on 07 february 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 07-feb-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* AMPART *
+* BLKDT7 *
+* CHANWT *
+* DATEST *
+* DECAY *
+* DIFEVV *
+* HADDEN *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ZKNAMC
+ COMMON / DECAYC / WTC (-6:IDMXDC), NZKC (-6:IDMXDC,3)
+ COMMON / DCYCCH / ZKNAMC (-6:IDMXDC)
+
--- /dev/null
+*$ CREATE DEPNUC.ADD
+*COPY DEPNUC
+* *
+*=== depnuc ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* DEPleted NUCleus: *
+* *
+* Created on 05 may 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 02-may-95 by Alfredo Ferrari *
+* *
+* Llastn = flag for the situation where just two residual *
+* target nucleons are left *
+* Llast1 = flag for the situation where just one residual *
+* target nucleon is left *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LLASTN, LLAST1
+ COMMON /DEPNUC/ EKLAST, AMLAST, PXLAST, PYLAST, PZLAST,
+ & EKINC , AMINC , PXXINC, PYYINC, PZZINC,
+ & KTLAST, KTINC , LLASTN, LLAST1
+
--- /dev/null
+*$ CREATE DETECT.ADD
+*COPY DETECT
+* *
+*=== detect ===========================================================*
+* *
+
+*----------------------------------------------------------------------*
+* *
+* detect created 20-sep-1989 by A. Ferrari *
+* *
+* included in: *
+* geoden *
+* detect *
+* bdnopt *
+* *
+* W A R N I N G any change of the Ndtcmx parameter must be *
+* done also on the Ndtcm2 parameter of the Detloc module! *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER (NRGNMX = 10)
+ PARAMETER (NDTCMX = 10)
+ PARAMETER (NSCRMX = 10)
+ PARAMETER (NDTBIN = 1024)
+ CHARACTER*10 TITDET,TITSCO
+ LOGICAL LDTCTR
+ COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
+ & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
+ & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
+ & KDTSCD(NSCRMX)
+ COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
+
--- /dev/null
+*$ CREATE DETLOC.ADD
+*COPY DETLOC
+* *
+*=== detloc ===========================================================*
+* *
+
+*----------------------------------------------------------------------*
+* *
+* detloc created 20-sep-1989 by A. Ferrari *
+* *
+* included in: *
+* detect *
+* bdnopt *
+* *
+* W A R N I N G any change of the Ndtcm2 parameter must be *
+* done also on the Ndtcmx parameter of the Detect module! *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER (NDTCM2 = 10)
+ COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
+ & ICOINC(NDTCM2), NCLAS
+
--- /dev/null
+*$ CREATE DFXSTB.ADD
+*COPY DFXSTB
+*
+*=== dfxstb ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* h-h DiFfractive X-section TaBulations: *
+* *
+* Created on 11-september-1996 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 11-sep-96 by Alfredo Ferrari, INFN-Milan *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXDFTB = 80 )
+ PARAMETER ( RTDFTB = 1.2D+00 )
+* This is the logarithm of the previous one:
+ PARAMETER ( ARDFTB = 0.182321556793955D+00 )
+ COMMON / DFXSTB / SGDFTB (MXDFTB,4,-6:NALLWP), ALS0DF (-6:NALLWP),
+ & UMSQDF, UMODFF, PCM0DF, ECMHA0, AMDFHA, ECMHX0,
+ & AMDFHX, TTMNDF, TTMXDF
+
--- /dev/null
+*$ CREATE DIFSCT.ADD
+*COPY DIFSCT
+*
+*=== difsct ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* h-h DIFfractive SCaTtering informations: *
+* *
+* Created on 15-september-1993 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 05-mar-98 by Alfredo Ferrari, INFN-Milan *
+* *
+* Sdftot = total single diffractive cross section (both target *
+* and projectile) *
+* *
+* Sdfprt(i) = single diffractive cross section for projectile (i=1) *
+* or target (i=2) *
+* Sdflwm(k) = single diffractive cross section for the k_th quantum *
+* number combination *
+* Sdfres(k,i) = single diffractive cross section for projectile (i=1) *
+* or target (i=2), resonant part, for the k_th quantum *
+* number combination *
+* *
+* Sdfrsc(k,j,i)= single diffractive cross section for projectile (i=1) *
+* target (i=2), resonant part components (before and *
+* after z_bmax), for the k_th quantum number combination*
+* *
+* Sdfnrs(k,i) = single diffractive cross section for projectile (i=1) *
+* or target (i=2), non resonant part, for the k_th *
+* quantum number combination *
+* *
+* Zbmxdf(k,i) = Zbmax for the transition from the increasing slope *
+* resonant part to the constant slope resonant part, *
+* for the k_th quantum number combination *
+* Zbdiff(k,i) = Zbar for the transition from the resonant part to the *
+* non resonant part, for the k_th quantum number *
+* combination *
+* *
+* Zbrhlp(k,i) = Z_r_hlp bar for the transition from the resonant part *
+* to the non resonant part, for the k_th quantum number *
+* combination* *
+* *
+* Atzmnd(k,i) = Atan (z_min_diff) *
+* *
+* Atzmxd(k,i) = Atan (zbmxdf(k,i)) *
+* *
+* Atzbdf(k,i) = Atan (zbdiff(k,i)) *
+* *
+* Adfhlp(k,i) = Mass of the hadron going to be diffracted or zero, *
+* depending on option *
+* *
+* Amdfrs(k,i) = Mass of the resonant system, for the k_th quantum *
+* number combination *
+* *
+* Gadfrs(k,i) = Width of the resonant system, for the k_th quantum *
+* number combination *
+* *
+* Amdfms(k,i) = Squared Mass of the diffracted system - m_hlp^2 at the*
+* linking point (z=zbdiff), for the k_th quantum number *
+* combination *
+* *
+* Almxdf(k,i) = Ratio of the maximum squared Mass of the diffracted *
+* system - m_hlp^2 to the squared invariant mass, for *
+* the k_th quantum number combination *
+* *
+* Aldmdf(k,i) = Ratio of the maximum dumping function squared Mass of *
+* the diffracted system - m_hlp^2 to the squared inva- *
+* riant mass, for the k_th quantum number combination *
+* *
+* Exdmdf(k,i) = exp (-(aldmdf(k,i)-almxdf(k,i))/almxdf(k,i)) or K *
+* factor depending on option, for the k_th quantum *
+* number combination *
+* *
+* Prdmdf(k,i) = Probability to sample from the dumping function with *
+* respect to sampling from 1/M_x^2, for the k_th quantum*
+* number combination *
+* *
+* B0sldf(k,i) = asymptotic B_slope to be used, for the k_th quantum *
+* number combination *
+* *
+* Bmaxdf(k,i) = maximum B_slope to be used (at Z=Zbmax), for the k_th *
+* quantum number combination *
+* *
+* Sg0hdf(k,i) = Sigma_0 for (high mass) diffractive cross section *
+* computation, for the k_th quantum number combination *
+* *
+* Sg0hrf(k,i) = Sigma_0 for (resonant) diffractive cross section *
+* computation, for the k_th quantum number combination *
+* *
+* Brlwmd(k,ip) = ip Paprop numbering, Brlwmd is the branching of the *
+* k_th quantum number combination for diffraction of *
+* particle ip *
+* *
+* Amdfxs = Sampled diffracted system mass squared *
+* *
+* Amdifx = Sampled diffracted system mass *
+* *
+* Bsldif = actual B_slope to be used for the current diffracting *
+* scattering *
+* *
+* Acsgdf = A coefficient for the diffractive cross section *
+* d2 s_diff/dtdM2 = A (1+B/s) f(t,M2) *
+* *
+* Bcsgdf = B coefficient for the diffractive cross section *
+* *
+* Ccsgdf = C coefficient for the diffractive cross section *
+* (same as p but for mesons) *
+* *
+* B0podf = asymptotic B_slope for triple pomeron diffracting *
+* scattering, *
+* B_slope = B0podf + 2 aprdff ln [ s / M_x^2 ] *
+* *
+* Aprdff = alpha' of Pomeron trajectory *
+* a(t) = 1 + eps + a't *
+* *
+* Epsdff = epsilon of Pomeron trajectory (0 for a critical *
+* pomeron, >0 for a supercritical one) *
+* *
+* Crvesc = curvature (GeV/c)^-4 for elastic scattering *
+* *
+* *
+* Zbdff0 = Zbdiff for options where it is not computed from *
+* continuity constraints *
+* *
+* Dfcoml = Multiplication factor for the coherence condition *
+* for determining the maximum diffr. mass *
+* *
+* Iflgdf = flag for main diffraction option *
+* *
+* Mlwmdf(i) = number of quantum number combinations available for *
+* the excited system (1:projectile,2:target) *
+* *
+* Idifpt = id of the excited system (1:projectile,2:target) *
+* *
+* Ilwmdf = id of the quantum number of the excited system *
+* *
+* Nlwmdf = maximum number of allowed quantum number combinations *
+* for the present run *
+* *
+* Ijlwmd(k,ip) = ip Paprop numbering, is the index of the low mass *
+* diffraction resonant state (if any) for particle ip *
+* and for quantum number combination k. It comes out *
+* in Part numbering of course! *
+* *
+* Ijchco(ip) = ip Paprop numbering, Ijchco is the index (Paprop num- *
+* bering) of the charge conjugated of particle ip *
+* *
+* Lrsdif = Run-time flag for performing direct resonance produc- *
+* tion of the (low mass) diffracted system *
+* *
+* Lscdif = Run-time flag for performing single chain production *
+* of the (low mass) diffracted system *
+* *
+* Lmcldf = Flag for performing or not diffractive scattering for *
+* valence collisions for h-A interactions were sea coll. *
+* also take place (.true. --> not performed) *
+* *
+* Lmndfs = Flag for accounting or not diffractive scattering cross *
+* sections in computing the number of collisions for h-A *
+* interactions when sea coll. also take place (.true. --> *
+* not accounted) *
+* *
+* Lmndft = Flag for accounting or not diffractive scattering cross *
+* sections for the (excited) target nucleon in computing *
+* the number of collisions for h-A interactions when sea *
+* coll. also take place (.true. --> not accounted) *
+* Meaningful for Lmndfs = .true. only *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXLWMD = 2 )
+ PARAMETER ( ALMXXD = 0.4 D+00 )
+* How many times hbar/q_min to define the coherence condition:
+ PARAMETER ( DFLMTM = 1.0 D+00 )
+* s0 to be used in Regge expressions like [s/s0]^alpha etc:
+ PARAMETER ( UM0SQR = 1.0 D+00 )
+ PARAMETER ( ZMNDIF = 1.5 D+00 )
+* Triple pomeron (--> high mass --> two chain) mass cut-off for
+* diffraction
+ PARAMETER ( AMDXTP = 3.0 D+00 )
+ LOGICAL LRSDIF, LSCDIF, LMCLDF, LMNDFS, LMNDFT
+ COMMON / DIFSCT / SDFTOT , SDFPRT (2), SDFLWM (MXLWMD),
+ & SDFRSC (2,MXLWMD,2), SDFRES (MXLWMD,2), SDFNRS (MXLWMD,2),
+ & ZBDIFF (MXLWMD,2), ZBMXDF (MXLWMD,2), ZBRHLP (MXLWMD,2),
+ & ADFHLP (MXLWMD,2), AMDFRS (MXLWMD,2), GADFRS (MXLWMD,2),
+ & ATZMND (MXLWMD,2), ATZMXD (MXLWMD,2), ATZBDF (MXLWMD,2),
+ & AMDFMS (MXLWMD,2), ALMXDF (MXLWMD,2), ALDMDF (MXLWMD,2),
+ & EXDMDF (MXLWMD,2), PRDMDF (MXLWMD,2), B0SLDF (MXLWMD,2),
+ & BMAXDF (MXLWMD,2), SG0HDF (MXLWMD,2), SG0RDF (MXLWMD,2),
+ & BRLWMD (MXLWMD,NALLWP), AMDIFX, AMDFXS, BSLDIF, ACSGDF,
+ & BCSGDF, CCSGDF, B0PODF, APRDFF, EPSDFF, CRVESC, ZBDFF0,
+ & DFCOML, IJLWMD (MXLWMD,NALLWP), IJCHCO (NALLWP),
+ & IJDFPT (MXLWMD,2), MLWMDF (2), IFLGDF, IDIFPT, ILWMDF,
+ & NLWMDF, LRSDIF, LSCDIF, LMCLDF, LMNDFS, LMNDFT
+
--- /dev/null
+*$ CREATE DIMPAR.ADD
+*COPY DIMPAR
+* *
+*=== dimpar ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* DIMPAR: included in any routine *
+* *
+* Mxxrgn = maximum number of regions *
+* Mxxmdf = maximum number of media in Fluka *
+* Mxxmde = maximum number of media in Emf *
+* Mfstck = stack dimension in Fluka *
+* Mestck = stack dimension in Emf *
+* Mostck = stack dimension for optical photons *
+* Mxprsn = secondary stack dimension for resonance generator *
+* Mxpdpm = secondary stack dimension for DPM generators *
+* Mxoutu = maximum number of output units *
+* Nallwp = number of allowed particles *
+* Nelemx = number of maximum allowed elements of a compound *
+* Mpdpdx = number of particle types for which EM dE/dx pro- *
+* cesses (ion,pair,bremss) have to be computed *
+* Mxhttr = maximum number of (hit) target nucleons for a *
+* given collision generation *
+* Icomax = maximum number of materials for compounds (equal *
+* to the sum of the number of materials for every *
+* compound ) *
+* Ichmax = maximum number of harmonic oscillator levels for *
+* compounds (equal to the sum of the number of har- *
+* monic oscillator levels for every compound ) *
+* Nstbis = number of stable isotopes recorded in common iso- *
+* top *
+* Mxpabl = number of resonances inside Hadrin common blocks *
+* Idmaxp = number of particles/resonances defined in common *
+* part *
+* Idmxdc = number of particles/resonances decay channels *
+* defined in common decayc *
+* Ihypmx = maximum number of hyperons in a hypernucleus *
+* Mkbmx1 = dimension for KWB real spare array in Fluka Stack *
+* Mkbmx2 = dimension for KWB int. spare array in Fluka Stack *
+* *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER ( MXXRGN =10000 )
+ PARAMETER ( MXXMDF = 210 )
+ PARAMETER ( MXXMDE = 202 )
+ PARAMETER ( MFSTCK = 2500 )
+ PARAMETER ( MESTCK = 100 )
+ PARAMETER ( MOSTCK = 2000 )
+ PARAMETER ( MXPRSN = 100 )
+ PARAMETER ( MXPDPM = 800 )
+ PARAMETER ( MXOUTU = 50 )
+ PARAMETER ( NALLWP = 64 )
+ PARAMETER ( NELEMX = 80 )
+ PARAMETER ( MPDPDX = 18 )
+ PARAMETER ( MXHTTR = 20 )
+ PARAMETER ( ICOMAX = 700 )
+ PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
+ PARAMETER ( NSTBIS = 304 )
+* Till 3-aug-99:
+* PARAMETER ( MXPABL = 110 )
+ PARAMETER ( MXPABL = 120 )
+ PARAMETER ( IDMAXP = 450 )
+ PARAMETER ( IDMXDC = 2000 )
+ PARAMETER ( MXMCIN = 410 )
+ PARAMETER ( IHYPMX = 4 )
+* Till 19-jul-2000:
+* PARAMETER ( MKBMX1 = 9 )
+* PARAMETER ( MKBMX2 = 3 )
+ PARAMETER ( MKBMX1 = 9 )
+ PARAMETER ( MKBMX2 = 9 )
+
--- /dev/null
+*$ CREATE DORTSF.ADD
+*COPY DORTSF
+*
+*=== Dortsf ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* DO RoTation Statement Functions: *
+* *
+* Created on 31 january 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 31-mar-98 by Alfredo Ferrari *
+* *
+* Rotate ux,y,z from the original frame to a frame where the z *
+* axis has components (csph0 x snth0, snph0 x snth0, csth0) *
+* *
+*----------------------------------------------------------------------*
+*
+ DOXROT ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & UX * CSPH0 * CSTH0 + UY * SNPH0 * CSTH0 - UZ * SNTH0
+ DOYROT ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & - UX * SNPH0 + UY * CSPH0
+ DOZROT ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & UX * CSPH0 * SNTH0 + UY * SNPH0 * SNTH0 + UZ * CSTH0
+
--- /dev/null
+*$ CREATE DPDXCM.ADD
+*COPY DPDXCM
+*
+*=== dpdxcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: dpdxcm (DP/DX CoMmon) *
+* *
+* Created on 10 february 1991 by Alfredo Ferrari *
+* INFN - Milan *
+* *
+* Last change on 17-jun-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* FLUKA *
+* BLKDT1 *
+* DEDX *
+* DPDXIO *
+* DPDX *
+* HVBREM *
+* ZEROIN *
+* *
+* Avionp (m) = average ionization potential (eV) of medium m *
+* Ccster (m) = Sternheimer cbar parameter for medium m *
+* X0ster (m) = Sternheimer x0 parameter for medium m *
+* Xester (m) = Sternheimer x1 parameter for medium m *
+* Amster (m) = Sternheimer m parameter for medium m *
+* Aaster (m) = Sternheimer a parameter for medium m *
+* D0ster (m) = Sternheimer delta0 parameter for medium m *
+* Aviont (m) = auxiliary ionization potential of medium m *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MNDPDX = 50 )
+ PARAMETER ( RMDPDX = 1.15D+00 )
+ PARAMETER ( DPDXR1 = 0.15D+00 )
+ PARAMETER ( DPDXR2 = 0.70D+00 )
+ PARAMETER ( ERDEDX = 0.15D+00 * 0.15D+00 )
+ PARAMETER ( MDPDXH = 4 )
+* Toln10 = 2 x log (10)
+ PARAMETER ( TOLN10 = 4.605170185988091 D+00 )
+*
+ LOGICAL LDELTA, LPDETB, LETFUN
+ COMMON / DPDXCM / P0DPDX (MPDPDX,MXXMDF), P1DPDX (MPDPDX,MXXMDF),
+ & TMDPDX (MXXMDF), T0DPDX (MXXMDF),
+ & D0DPDX (MXXMDF), AVIONP (MXXMDF),
+ & RHORFL (MXXMDF), GASPFL (MXXMDF),
+ & CCSTER (MXXMDF), AMSTER (MXXMDF),
+ & XOSTER (MXXMDF), XESTER (MXXMDF),
+ & AASTER (MXXMDF), D0STER (MXXMDF),
+ & AVIONT (MXXMDF), ETDPDX (MXXMDF),
+ & ALMASS (MPDPDX),
+ & NBDPDX (MXXMDF), KDPDXT (MPDPDX,MXXMDF),
+ & LDELTA (MXXMDF), LPDETB (MXXMDF),
+ & IJDPDX (-6:NALLWP), LETFUN
+
--- /dev/null
+*$ CREATE ELEINP.ADD
+*COPY ELEINP
+*
+*=== Eleinp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common Eleinp for EMF (It supersedes the old Elecin from EGS4) *
+* *
+* Created on 19 april 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-apr-97 by Alfredo Ferrari *
+* *
+* IESIG0, IESIG1 etc are the starting locations for 0 address *
+* in blank common of the ESIG0 etc arrays *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum (fractional) difference for computing de/dx without using
+* the accurate integration loop (used for setting Nldedx)
+ PARAMETER ( FDDXMX = 0.15D+00 )
+* Maximum (fractional) difference for computing de/dx without using
+* the accurate integration loop (used for direct checking)
+ PARAMETER ( FDRXMX = 0.1 D+00 )
+ COMMON /ELEINP/ EKE0 (MXXMDE), EKE1 (MXXMDE),
+ & CMFP0 (MXXMDE), CMFP1 (MXXMDE),
+ & RANGE0 (MXXMDE), RANGE1 (MXXMDE),
+ & XR0 (MXXMDE), TEFF0 (MXXMDE),
+ & BLCC (MXXMDE), XCC (MXXMDE),
+ & BLCCRA (MXXMDE), EKRAT (MXXMDE),
+ & NLDEDX (2,MXXMDE),
+ & IESIG0 (MXXMDE), IESIG1 (MXXMDE),
+ & IPSIG0 (MXXMDE), IPSIG1 (MXXMDE),
+ & IEDDX0 (MXXMDE), IEDDX1 (MXXMDE),
+ & IPDDX0 (MXXMDE), IPDDX1 (MXXMDE),
+ & IEBR10 (MXXMDE), IEBR11 (MXXMDE),
+ & IPBR10 (MXXMDE), IPBR11 (MXXMDE),
+ & IPBR20 (MXXMDE), IPBR21 (MXXMDE),
+ & ITXSE0 (MXXMDE), ITXSE1 (MXXMDE),
+ & ITXSP0 (MXXMDE), ITXSP1 (MXXMDE)
+
--- /dev/null
+*$ CREATE ELFLCM.ADD
+*COPY ELFLCM
+*
+*=== elflcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Energy Loss FLuctuation CoMmon: *
+* *
+* Created on 23 november 1993 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 25-oct-95 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* DLFINI *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NMXEPX = 20 )
+ PARAMETER ( NMNEPX = -8 )
+ PARAMETER ( ELSFTY = ONEONE )
+ PARAMETER ( EPMXRT = HLFHLF )
+*
+ COMMON / ELFLCM / USMCUM (6,NMNEPX:NMXEPX), ELLEIX (6), ELLEIE(6),
+ & AVEPSF (NMNEPX:NMXEPX), SGEPSF (NMNEPX:NMXEPX),
+ & AEPSDL, SGEPDL, EPSFMX, EPSFCT, EPSFTP,
+ & ENDLDF, SNDLDF, NDLDFL, IEPFMX
+
--- /dev/null
+*$ CREATE ELFLST.ADD
+*COPY ELFLST
+*
+*=== elflst ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Energy Loss
+* Created on 26 january 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 26-jan-96 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+* SAFETY (ALN,EPS,ILVL) = ONEONE + TWOTWO / ( ALN + TWOTHI )
+* SSAFET (ALN,EPS,ILVL) = 1.5D+00 + THRTHR / ( ALN + TWOTHI )
+* SAFETY (ALN,EPS,ILVL) = 0.7D+00 + ( 13.0 D+00 - ILVL - ALN ) / EPS
+* SSAFET (ALN,EPS,ILVL) = 0.8D+00 + ( 13.43D+00 - ILVL - ALN ) / EPS
+ SAFETY (ALN,EPS,ILVL) = 0.5D+00 + ( 10.0 D+00 - ILVL - ALN ) / EPS
+ SSAFET (ALN,EPS,ILVL) = 0.6D+00 + ( 10.5 D+00 - ILVL - ALN ) / EPS
+
--- /dev/null
+*$ CREATE ELSCRT.ADD
+*COPY ELSCRT
+*
+*=== Elscrt ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* p/n ELaStic SCattering Run Time informations: *
+* *
+* Created on 15-september-1993 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 08-jul-97 by Alfredo Ferrari, INFN-Milan *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LRJJ0, LRJJ1, LCOUJ0, LCOUJ1, L2TNT4
+ COMMON / ELSCRT / R0ACT (0:1), R0ESCO (0:1), VESCOU (0:1), PROJ0,
+ & ALMJ0 , ALMJ1 , LRJJ0 , LRJJ1 , LCOUJ0, LCOUJ1,
+ & L2TNT4
+
--- /dev/null
+*$ CREATE ELSSCT.ADD
+*COPY ELSSCT
+*
+*=== elssct ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* p/n ELaStic SCaTtering informations: *
+* *
+* Created on 15-september-1993 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 16-sep-93 by Alfredo Ferrari, INFN-Milan *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( R0ELNE = 1.4 D+00 )
+ PARAMETER ( R0ELPI = 1.3 D+00 )
+ PARAMETER ( N0ELSC = 152 )
+ PARAMETER ( D0ELSC = 0.005D+00 )
+ PARAMETER ( ELSI0M = ZERZER )
+ PARAMETER ( ELSI0X = ( N0ELSC - 2 ) * D0ELSC )
+ PARAMETER ( N1ELSC = 153 )
+ PARAMETER ( D1ELSC = 0.0015D+00 )
+ PARAMETER ( ELSI1M = ELSI0X - D1ELSC )
+ PARAMETER ( ELSI1X = ( N1ELSC - 2 ) * D1ELSC + ELSI1M )
+ PARAMETER ( N2ELSC = 152 )
+ PARAMETER ( D2ELSC = 0.000166D+00 )
+ PARAMETER ( ELSI2M = ELSI1X - D2ELSC )
+ PARAMETER ( ELSI2X = ( N2ELSC - 1 ) * D2ELSC + ELSI2M )
+ PARAMETER ( ELSIMX = ONEONE - 0.01D+00 * ELSI2X )
+ COMMON / ELSSCT / R0ELSC (NALLWP), XELJ00 (N0ELSC),
+ & XELJ01 (N1ELSC), XELJ02 (N2ELSC),
+ & XELJ10 (N0ELSC), XELJ11 (N1ELSC),
+ & XELJ12 (N2ELSC), ANRMJ0, AJ0DMP,
+ & XJ0MAX
+
--- /dev/null
+*$ CREATE EMFBCM.ADD
+*COPY EMFBCM
+*
+*=== emfbcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* EMF Biasing CoMmon: *
+* *
+* Created on 27 august 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 28-aug-94 by Alfredo Ferrari *
+* *
+* *
+* Pthlpb = threshold for playing leading particle biasing for *
+* photons (E must be below the threshold for applying *
+* lpb) *
+* Ethlpb = threshold for playing leading particle biasing for *
+* electrons/positrons (E_k / E_tot + m_e must be below *
+* the threshold to apply lpb) *
+* Lpbemf = flag for leading particle biasing for EMF particles *
+* Let be Lpbemf represented as: *
+* 2^0xb0 + 2^1xb1 + 2^2xb2 + 2^3xb3 + 2^4xb4 + *
+* 2^5Xb5 + 2^6xb6 + 2^7xb7 + 2^8xb8 + 2^9xb9 *
+* then the meaning of the nine bits is the following: *
+* b0 = 1 --> lpb for brems and pair activated *
+* (old default) *
+* b1 = 1 --> lpb for bremsstrahlung activated *
+* b2 = 1 --> lpb for pair production activated *
+* b3 = 1 --> lpb for rest annihilation activated *
+* b4 = 1 --> lpb for Compton activated *
+* b5 = 1 --> lpb for Bhabha & Moller activated *
+* b6 = 1 --> lpb for Photoelectric activated *
+* b7 = 1 --> lpb for in flight annih. activated *
+* b8 = 1 --> not used *
+* b9 = 1 --> not used *
+* Please note that flag=1022 activates everything (values larger*
+* than 1022 are converted into 1022) *
+* *
+* Rlbemf (j,i) = reduction factor for interaction mean free *
+* paths for jth medium (i=1->e+/e-,i=2->phot) *
+* Ilbemf (j,i) = flag for interaction mean free path biasing *
+* for jth medium (i=1->e+/e-,i=2->phot) *
+* 0 : no biasing *
+* 1 : only Compt/bremss no RR of survived primary *
+* 2 : all interactions no RR of survived primary *
+* 11 : only Compt/bremss RR for survived primary *
+* 12 : all interactions RR for survived primary *
+* Nlbemf (j,i) = maximum generation number for which interaction*
+* mean free path biasing is performed for jth *
+* medium (i=1->e+/e-,i=2->phot) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NLPBBT = 9 )
+* *** The following must equal 2**(nlpbbt+1) - 2
+ PARAMETER ( MAXLPB = 1022 )
+ COMMON / EMFBCM / PTHLPB (MXXRGN) , ETHLPB (MXXRGN),
+ & RLBEMF (MXXMDF,2), LPBEMF (MXXRGN),
+ & ILBEMF (MXXMDF,2), NLBEMF (MXXMDF,2)
+
--- /dev/null
+*$ CREATE EMFCMP.ADD
+*COPY EMFCMP
+*
+*=== emfcmp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: emfcmp created on 31-10-90 by A. Ferrari *
+* & P. Sala *
+* Infn - Milan *
+* Last change on 28-apr-97 by Alfredo Ferrari, INFN-Milan *
+* *
+* included in the following routines: *
+* *
+* Ededxf *
+* Electr(new version) *
+* Emfin (new version) *
+* Emfret(new version) *
+* Formfe *
+* Pdedxf *
+* Photfl *
+* Photon(new version) *
+* Thnzse *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /EMFCMP/ contains information about composition of Emf media *
+* iclemf(med) = number of materials in a compound *
+* ic0emf(med) = starting position for 0 index for med medium *
+* in the following arrays *
+* zetemf(i) = atomic numbers of the constituents *
+* rhozef(i) = partial densities (sum = rho ) *
+* pzemf (i) = proportion by number (sum = 1) *
+* atwemf(i) = atomic weights *
+* aocmbe(i) = atomic densities in barn**-1 cm**-1 *
+* (Atoms Over Cm times Barn for Emf compounds) *
+* cnea13(i) = atomic weight^1/3 *
+* sumzme(i) = cumulative proportion of z(z+fudgem) (sum=1) *
+* metofl(i) = fluka medium corresponding to ith Emf medium *
+* jchemf(med) = number of harmonic oscillator levels in a *
+* compound *
+* jc0emf(med) = starting position for 0 index for med medium *
+* in the following arrays *
+* pliemf(med) = plasma energy for Emf med medium *
+* ehoemf(j) = jth - jc0emf(med) harmonic oscillator levels *
+* of Emf medium Med *
+* elnhem(j) = natural logarithm of ehoemf (j) *
+* fosemf(j) = oscillator strength for the jth - jc0emf(med) *
+* harmonic oscillator levels of Emf medium Med *
+* zhoemf(j) = atomic number of the element for the jth - *
+* jc0emf(med) harmonic oscillator level of Emf *
+* medium Med *
+* ahoemf(j) = atomic weights of the element for the jth - *
+* jc0emf(med) harmonic oscillator level of Emf *
+* medium Med *
+* eliemf(j) = l_i of the Sternheimer theory for the jth - *
+* jc0emf(med) harmonic oscillator level of Emf *
+* medium Med *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / EMFCMP / AOCMBE (ICOMAX), ZETEMF (ICOMAX),
+ & RHOZEF (ICOMAX), PZEMF (ICOMAX),
+ & ATWEMF (ICOMAX), CNEA13 (ICOMAX),
+ & SUMZME (ICOMAX), EHOEMF (ICHMAX),
+ & ELNHEM (ICHMAX), FOSEMF (ICHMAX),
+ & ZHOEMF (ICHMAX), AHOEMF (ICHMAX),
+ & ELIEMF (ICHMAX), PLIEMF (MXXMDE),
+ & IC0EMF (MXXMDE), ICLEMF (MXXMDE),
+ & JC0EMF (MXXMDE), JCHEMF (MXXMDE),
+ & METOFL (0:MXXMDE)
+
--- /dev/null
+*$ CREATE EMFSTK.ADD
+*COPY EMFSTK
+*
+*=== Emfstk ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common emfstk (EMF STacK) for EMF *
+* *
+* Last change on 08-oct-97 by Alfredo Ferrari *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( IDMEMF = MESTCK )
+ COMMON /EMFSTK/ E (IDMEMF), X (IDMEMF), Y (IDMEMF),
+ & Z (IDMEMF), U (IDMEMF), V (IDMEMF),
+ & W (IDMEMF), DNEAR (IDMEMF), UPOL (IDMEMF),
+ & VPOL (IDMEMF), WPOL (IDMEMF), USNRML (IDMEMF),
+ & VSNRML (IDMEMF), WSNRML (IDMEMF), WT (IDMEMF),
+ & AGEMF (IDMEMF), ESPARK (MKBMX1,IDMEMF),
+ & IESPAK (MKBMX2,IDMEMF), IQ (IDMEMF),
+ & IR (IDMEMF), IRLATT (IDMEMF), NHPEMF (IDMEMF),
+ & LLOEMF (IDMEMF), LOUEMF (IDMEMF), NP , NPSTRT
+
--- /dev/null
+*$ CREATE EMGTRN.ADD
+*COPY EMGTRN
+*
+*=== emgtrn ==========================================================*
+*
+*---------------------------------------------------------------------*
+* *
+* Module Emgtrn: *
+* *
+* Last change A. Ferrari 02-nov-1993 *
+* Created on 26-05-1991 by A. Ferrari, Infn-Milan *
+* *
+* Included in: *
+* BDNOPT *
+* ELECTR *
+* KASKAD *
+* MAGNEW *
+* MAGEAS *
+* MAGMOV *
+* MULEMF *
+* MULHAD *
+* *
+*---------------------------------------------------------------------*
+*
+ LOGICAL LMCSMG
+ COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
+
--- /dev/null
+*$ CREATE EMSHO.ADD
+*COPY EMSHO
+* *
+*=== emsho ============================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* !!!! N E W V E R S I O N !!!! *
+* *
+* Created on 20 june 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 20-jan-95 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* emflo = .true. emf is used for em cascades *
+* emfhlo = .true. photohadrons are produced *
+* emfelo = .true. electrohadrons are produced *
+* limpre = .true. importance biassing at boundaries selected for *
+* the EM cascade (meaningful only if emflo = .true. ) *
+* lexpte = .true. exponential transformation selected for *
+* the EM cascade (meaningful only if emflo = .true. ) *
+* emfeth = cut-off transport energy of emf electrons *
+* emfbia = biasing factor for electro/photohadron production: *
+* the interaction are sampled using a mean free path *
+* equal to the actual one divided by emfbia *
+* emfpth = cut-off transport energy of emf photons *
+* emfhet = cut-off energy for electrohadron production *
+* emfhpt = cut-off energy for photohadron production *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
+ COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
+ & EMFHLO, EMFELO, LIMPRE, LEXPTE
+
--- /dev/null
+*$ CREATE EPCONT.ADD
+*COPY EPCONT
+*----------------------------------------------------------------------*
+* *
+* Common Epcont for EGS4 *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / EPCONT / EDEP , TSTEP , TUSTEP, USTEP , TVSTEP, VSTEP ,
+ & RHOF , EOLD , ENEW , EKE , ELKE , BETA2 ,
+ & GLE , TSCAT , IDISC , IROLD , IRNEW ,
+ & IAUSFL (0:26)
+
--- /dev/null
+*$ CREATE EPISOR.ADD
+*COPY EPISOR
+*
+*=== episor ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: episor *
+* *
+* version march 1996 by Alfredo Ferrari, INFN - Milan *
+* *
+* Included in the following subroutines or functions: *
+* *
+* EPILOG *
+* FLUKA *
+* SOURCE *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Whasou(1-12) = user variables *
+* Tkesum = total kinetic energy of the primaries of the *
+* user written source *
+* Lussrc = flag to inform that the user written source was *
+* used *
+* Sdusou = user character variable *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LUSSRC
+ CHARACTER SDUSOU*8
+ COMMON / EPISOR / WHASOU (12), TKESUM, LUSSRC
+ COMMON / CHEPSR / SDUSOU
+
--- /dev/null
+*$ CREATE ERRGE2.ADD
+*COPY ERRGE2
+*----------------------------------------------------------------------*
+* include file: errge2 copy created 5/7/86 by A.Ferrari*
+* Any change must be done also in module errgeo which differs only *
+* for ekin ---> encur ( this is included in Kaskad ) *
+* (A.Ferrari 5/7/89) *
+* changes: none *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /errgeo/ variables to handle geometry errors (only implemented *
+* in combinatorial geometry at present) *
+* ljomes = if .false. switches off geometry error messages, *
+* giving only a global summary (default: .true.) *
+* lmgnmv = if .true. the last step was performed using the *
+* tracking inside the magnetic field *
+* lephad = index to distinguish hadrons (value = 1) and *
+* leptons/photons (value = 2) *
+* ekin = current particle kinetic energy for transmission to *
+* geometry subroutines *
+* jomerr = counters of geometry errors *
+* endisc = accumulators of energy discarded because of geometry *
+* errors *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LJOMES, LMGNMV
+ COMMON / ERRGEO / EKIN, ENDISC(2), LJOMES, LMGNMV, LEPHAD,
+ & JOMERR(2)
+
--- /dev/null
+*$ CREATE ERRGEO.ADD
+*COPY ERRGEO
+*----------------------------------------------------------------------*
+* include file: errgeo copy created 27/11/86 by p*
+* Any change must be done also in module errge2 which differs only *
+* for encur ---> ekin and which is included in Kaskad *
+* (A.Ferrari 5/7/89) *
+* changes: none *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /errgeo/ variables to handle geometry errors (only implemented *
+* in combinatorial geometry at present) *
+* ljomes = if .false. switches off geometry error messages, *
+* giving only a global summary (default: .true.) *
+* lmgnmv = if .true. the last step was performed using the *
+* tracking inside the magnetic field *
+* lephad = index to distinguish hadrons (value = 1) and *
+* leptons/photons (value = 2) *
+* encur = current particle kinetic energy for transmission to *
+* geometry subroutines *
+* jomerr = counters of geometry errors *
+* endisc = accumulators of energy discarded because of geometry *
+* errors *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LJOMES, LMGNMV
+ COMMON / ERRGEO / ENCUR, ENDISC(2), LJOMES, LMGNMV, LEPHAD,
+ & JOMERR(2)
+
--- /dev/null
+*$ CREATE EVA0.ADD
+*COPY EVA0
+* *
+*=== eva0 =============================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Created on 05 july 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-nov-96 by Alfredo Ferrari *
+* *
+* Originally based on common EVA0 of Hetc, has been now deeply *
+* changed and progressively emptied *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / EVA0 / P0 (1001), P1 (1001), P2 (1001)
+
--- /dev/null
+*$ CREATE EVAPAR.ADD
+*COPY EVAPAR
+* *
+*=== evapar ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Created on 05 july 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 21-jul-00 by Alfredo Ferrari *
+* *
+* Originally based on common EVA0 of Hetc, has been now deeply *
+* changed and progressively emptied *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / EVAPAR / CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
+ & TDSTR (4,7), RMASS (297), ALPH (297), BET (297),
+ & APRIME(250), Y0EVAP, B0EVAP, IFISS , IB0EVP,
+ & JSIPFL, IMSSFR
+
--- /dev/null
+*$ CREATE EVAPRD.ADD
+*COPY EVAPRD
+* *
+*=== evaprd ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* New version of evaporation product common: *
+* *
+* Created on 04 november 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 24-mar-97 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BDEVAP *
+* BERTTP *
+* DRES *
+* ERUP *
+* EVEVAP *
+* EVPRTN *
+* FPROB *
+* FRMBRK *
+* *
+* Evaporation products: *
+* *
+* 0 = photon *
+* 1 = neutron *
+* 2 = proton *
+* 3 = deuteron *
+* 4 = triton *
+* 5 = 3-He *
+* 6 = alpha *
+* *
+* Variables: *
+* *
+* Flaevp(k) = mass number of the k_th type particle *
+* Flzevp(k) = atomic number of the k_th type particle *
+* Iaevpr(k) = mass number of the k_th type particle *
+* Izevpr(k) = atomic number of the k_th type particle *
+* Exmsev(k) = excess mass (MeV) (atomic or nuclear, depend- *
+* ing on Lncmss flag in common Frbkcm) of the *
+* k_th type particle *
+* Rhoevp(k) = Coulomb barrier radius factors of the k_th *
+* type particle *
+* Eprtev(i,k) = (kinetic) energy (MeV) of the i_th evaporated *
+* particle of the k_th type *
+* Pprtev(i,k) = Momentum (MeV/c) of the i_th evaporated *
+* particle of the k_th type *
+* Cosevp(j,i,k) = j_th (j=1,2,3) cosine of the i_th evaporated *
+* particle of the k_th type *
+* Hevsum = Total (kinetic) energy of evaporated heavies *
+* (heavies=Z>1) *
+* Nprtev(k) = number of evaporated particles of k_th type *
+* Ioprev(l) = id of the l_th evaporated particle of the *
+* present event (including fission etc) *
+* Npevap = Total number of evaporated particles for the *
+* present event (including fission etc) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NEVPRD = 6 )
+ COMMON / EVAPRD / FLAEVP (0:NEVPRD), FLZEVP (0:NEVPRD),
+ & EXMSEV (0:NEVPRD), RHOEVP (0:NEVPRD),
+ & EPRTEV (100,0:NEVPRD), PPRTEV (100,0:NEVPRD),
+ & COSEVP (3,100,0:NEVPRD), HEVSUM,
+ & IAEVPR (0:NEVPRD), IZEVPR (0:NEVPRD),
+ & NPRTEV (0:NEVPRD), IOPREV (250), NPEVAP
+
--- /dev/null
+*$ CREATE EVESEL.ADD
+*COPY EVESEL
+* *
+*=== evesel ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* include file: evesel copy created 26/11/86 by p*
+* changes: none *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* /evesel/ used to remember the event-creation method *
+* evecod = literal descriptions of the event-generation *
+* ieve = number of the event subroutines used *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 EVECOD
+ COMMON /EVESEL/ EVECOD(12), IEVE
+
--- /dev/null
+*$ CREATE EVTFLG.ADD
+*COPY EVTFLG
+*
+*=== Evtflg ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* EVenT FLaGs: *
+* *
+* Created on 19 may 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-aug-99 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LELEVT, LINEVT, LDECAY, LDLTRY, LPAIRP, LBRMSP, LANNRS,
+ & LANNFL, LPHOEL, LCMPTN, LCOHSC, LLENSC, LOPPSC
+*
+ COMMON / EVTFLG / LELEVT, LINEVT, LDECAY, LDLTRY, LPAIRP, LBRMSP,
+ & LANNRS, LANNFL, LPHOEL, LCMPTN, LCOHSC, LLENSC,
+ & LOPPSC, NTRCKS
+
--- /dev/null
+*$ CREATE FHEAVY.ADD
+*COPY FHEAVY
+*
+*=== fheavy ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: fheavy *
+* *
+* Created on 5 april 1990 by Alfredo Ferrari, INFN Milan *
+* *
+* Last change on 26-jul-97 by Alfredo Ferrari, INFN Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /fheavy/ is the storage for heavy secondaries created in the *
+* nuclear evaporation *
+* npheav = number of secondaries *
+* kheavy(ip) = type of the secondary ip *
+* ( 3 = deuteron, 4 = 3-H, 5 = 3-He, 6 = 4-He, *
+* 7-12 = "Heavy" fragment specified by Ibheav and *
+* Icheav ) *
+* cxheav(ip) = direction cosine of the secondary ip *
+* with respect to x-axis *
+* cyheav(ip) = direction cosine of the secondary ip *
+* with respect to y-axis *
+* czheav(ip) = direction cosine of the secondary ip *
+* with respect to z-axis *
+* tkheav(ip) = kinetic energy of secondary ip *
+* pheavy(ip) = momentum of the secondary ip *
+* wheavy(ip) = weight of the secondary ip *
+* agheav(ip) = "age" of the secondary ip with respect to the *
+* interaction time *
+* amheav(kp) = atomic masses of the twelve types of evaporated *
+* or fragmented or fissioned particles *
+* amnhea(kp) = nuclear masses of the twelve types of evaporated *
+* or fragmented or fissioned particles *
+* bhheav(jp,kp) = (nuclear) binding energy of the jp_th hyperon of *
+* the kp-type heavy particle *
+* anheav(kp) = name of the kp-type heavy particle *
+* icheav(kp) = charge of the kp-type heavy particle *
+* ibheav(kp) = mass number of the kp-type heavy particle *
+* imheav(kp) = isomeric state of the kp-type heavy particle *
+* ihheav(kp) = number of hyperons of the kp-type heavy particle *
+* khheav(jp,kp) = id of the jp_th hyperon of the kp-type heavy *
+* particle *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!! There is now the possibility to produce up to 6 "heavy" !!!! *
+* !!! fragments besides the residual nucleus recorded in !!!! *
+* !!! Resnuc: they are identified by indeces 7-12, of course !!!! *
+* !!! the corresponding physical properties (Z,A,m..) must be !!!! *
+* !!! updated every time they are produced !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXHEAV = 100 )
+ PARAMETER ( KXHEAV = 12 )
+ CHARACTER*8 ANHEAV
+ COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
+ & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
+ & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
+ & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
+ & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
+ & KHEAVY (MXHEAV), ICHEAV (KXHEAV),
+ & IBHEAV (KXHEAV), IMHEAV (KXHEAV),
+ & IHHEAV (KXHEAV), KHHEAV (IHYPMX,KXHEAV), NPHEAV
+ COMMON / FHEAVC / ANHEAV (KXHEAV)
+
--- /dev/null
+*$ CREATE FINLSP.ADD
+*COPY FINLSP
+*
+*=== Finlsp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of FINLSP: *
+* *
+* W A R N I N G !!!! check also Finlsp2/3 modules for any change!!!*
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-oct-96 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Cxr(i) = X-cosine of the i_th produced particle *
+* Cyr(i) = Y-cosine of the i_th produced particle *
+* Czr(i) = Z-cosine of the i_th produced particle *
+* Elr(i) = Total energy of the i_th produced particle *
+* Plr(i) = Momentum of the i_th produced particle *
+* Itr(i) = Identity (part scheme) of the i_th produced particle *
+* Ir = Number of produced particles *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / FINLSP / CXR (MXPRSN), CYR (MXPRSN), CZR (MXPRSN),
+ & ELR (MXPRSN), PLR (MXPRSN), ITR (MXPRSN),
+ & IR
+
--- /dev/null
+*$ CREATE FINLSP2.ADD
+*COPY FINLSP2
+*
+*=== Finlsp2 ==========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of FINLSP2: *
+* *
+* W A R N I N G !!!! check also Finlsp/3 modules for any change!!! *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-oct-96 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Cxr(i) = X-cosine of the i_th produced particle *
+* Cyr(i) = Y-cosine of the i_th produced particle *
+* Czr(i) = Z-cosine of the i_th produced particle *
+* El(i) = Total energy of the i_th produced particle *
+* Pl(i) = Momentum of the i_th produced particle *
+* Itr(i) = Identity (part scheme) of the i_th produced particle *
+* Ir = Number of produced particles *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / FINLSP / CXR (MXPRSN), CYR (MXPRSN), CZR (MXPRSN),
+ & EL (MXPRSN), PL (MXPRSN), ITR (MXPRSN),
+ & IR
+
--- /dev/null
+*$ CREATE FINLSP3.ADD
+*COPY FINLSP3
+*
+*=== Finlsp3 ==========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of FINLSP3: *
+* *
+* W A R N I N G !!!! check also Finlsp/2 modules for any change!!! *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-oct-96 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Cxh(i) = X-cosine of the i_th produced particle *
+* Cyh(i) = Y-cosine of the i_th produced particle *
+* Czh(i) = Z-cosine of the i_th produced particle *
+* Elh(i) = Total energy of the i_th produced particle *
+* Plh(i) = Momentum of the i_th produced particle *
+* Ith(i) = Identity (part scheme) of the i_th produced particle *
+* Ih = Number of produced particles *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / FINLSP / CXH (MXPRSN), CYH (MXPRSN), CZH (MXPRSN),
+ & ELH (MXPRSN), PLH (MXPRSN), ITH (MXPRSN),
+ & IH
+
--- /dev/null
+*$ CREATE FINPAR.ADD
+*COPY FINPAR
+*
+*=== Finpar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of Finpar: *
+* *
+* W A R N I N G !!!! HEP --> HEF on 28-nov-97 and Finpar2 module *
+* eliminated *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 06-dec-97 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Pxf(i) = X-component of the momentum of the i_th produced *
+* particle *
+* Pyf(i) = Y-component of the momentum of the i_th produced *
+* particle *
+* Pzf(i) = Z-component of the momentum of the i_th produced *
+* particle *
+* Hef(i) = Total energy of the i_th produced particle *
+* Amf(i) = Mass of the i_th produced particle *
+* Ichf(i) = Charge of the i_th produced particle *
+* Ibarf(i) = Baryon number of the i_th produced particle *
+* Nref(i) = Identity (part scheme) of the i_th produced particle *
+* Ipzf(i) = Auxiliary array *
+* Noqrk(i) = Array counting the number of (anti)quark of the ori- *
+* ginal chain ends making up this hadron *
+* Ichnf(3,i) = Array containing additional informations about prod- *
+* uction verteces, ranking etc *
+* Ichnf(1,i) = Ivx + 100 * Irank *
+* Ivx = Bamjet production vertex id, or *
+* -10 for a parjet, *
+* 10+Ivx for the last normally cre- *
+* ated hadron used together with*
+* the residual quark hadron of *
+* a q-qbar, qbar-qbarqbar or *
+* q-qq final jet joining *
+* +30 for the last antibaryon of a *
+* final qbar-qbarqbar jet join- *
+* ing *
+* +40 for the last meson of a final *
+* q-qbar jet joining *
+* +50 for the last baryon of a final*
+* q-qq jet joining *
+* +60 for both mesons of a final *
+* qq-qbarqbar jet joining *
+* Irank = rank order of production in the *
+* corresponding jet *
+* Ichnf(2,i) = Noqrk + 10 x Idcyg + 1000 x Idori *
+* Noqrk = Number of chain end quarks in *
+* the mother resonance *
+* Idcyg = decay generation (1,2,...), if *
+* any *
+* Idori = id of the mother resonance, if *
+* any *
+* Ichnf(3,i) = Nresn *
+* Nresn = number of the mother resonance *
+* recorded in Cmsres *
+* Anf(i) = Literal name of the i_th produced particle *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANF
+ COMMON / FINPAR / PXF (MXPDPM), PYF (MXPDPM), PZF (MXPDPM),
+ & HEF (MXPDPM), AMF (MXPDPM), ICHF (MXPDPM),
+ & IBARF (MXPDPM), NREF (MXPDPM), IPZF (MXPDPM),
+ & NOQRK (MXPDPM), ICHNF (3,MXPDPM)
+ COMMON / CHFNPR / ANF (MXPDPM)
+
--- /dev/null
+*$ CREATE FINUC.ADD
+*COPY FINUC
+*
+*=== finuc ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: Finuc (new version of old Finuc of FLUKA86) *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! S E E A L S O I N C L U D E F I L E !!!! *
+* !!!! F I N U C 2 !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Created on 20 january 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 26-jul-97 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /finuc/ is the storage for secondaries created in event *
+* np = number of secondaries *
+* kpart (ip) = type of the secondary ip *
+* cxr (ip) = direction cosine of the secondary ip *
+* with respect to x-axis *
+* cyr (ip) = direction cosine of the secondary ip *
+* with respect to y-axis *
+* czr (ip) = direction cosine of the secondary ip *
+* with respect to z-axis *
+* cxrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to x-axis *
+* cyrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to y-axis *
+* czrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to z-axis *
+* tki (ip) = kinetic energy of secondary ip *
+* plr (ip) = momentum of the secondary ip *
+* wei (ip) = weight of the secondary ip *
+* agesec (ip) = "age" of the secondary ip with respect to the *
+* interaction time *
+* tv = excitation energy *
+* tvcms = actual excitation energy of the residual nucleus *
+* tvrecl = recoil kinetic energy of the residual nucleus *
+* tvheav = recoil kinetic energies of heavy (2-H, 3-H, 3-He, *
+* 4-He) fragments after evaporation *
+* tvbind = approximate energy wasted in nuclear binding *
+* effects (not yet operational) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER (MXP=999)
+*
+ COMMON / FINUC / CXR (MXP), CYR (MXP), CZR (MXP),
+ & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
+ & TKI (MXP), PLR (MXP), WEI (MXP),
+ & AGESEC (MXP), TV, TVCMS, TVRECL, TVHEAV, TVBIND,
+ & NP0, NP, KPART (MXP)
+
--- /dev/null
+*$ CREATE FINUC2.ADD
+*COPY FINUC2
+*
+*=== finuc2 ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: Finuc2 (new version of old Finuc2 of FLUKA86) *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! S E E A L S O I N C L U D E F I L E !!!! *
+* !!!! F I N U C !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Created on 20 january 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 26-jul-97 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /finuc/ is the storage for secondaries created in event *
+* irn = number of secondaries *
+* itrn (ip) = type of the secondary ip *
+* cxrn (ip) = direction cosine of the secondary ip *
+* with respect to x-axis *
+* cyrn (ip) = direction cosine of the secondary ip *
+* with respect to y-axis *
+* czrn (ip) = direction cosine of the secondary ip *
+* with respect to z-axis *
+* cxrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to x-axis *
+* cyrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to y-axis *
+* czrpol (ip) = direction cosine of the secondary ip polarization *
+* with respect to z-axis *
+* elr (ip) = kinetic energy of secondary ip *
+* plr (ip) = momentum of the secondary ip *
+* wei (ip) = weight of the secondary ip *
+* agesec (ip) = "age" of the secondary ip with respect to the *
+* interaction time *
+* tv = excitation energy *
+* tvcms = actual excitation energy of the residual nucleus *
+* tvrecl = recoil kinetic energy of the residual nucleus *
+* tvheav = recoil kinetic energies of heavy (2-H, 3-H, 3-He, *
+* 4-He) fragments after evaporation *
+* tvbind = approximate energy wasted in nuclear binding *
+* effects (not yet operational) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER (MXP=999)
+*
+ COMMON / FINUC / CXRN (MXP), CYRN (MXP), CZRN (MXP),
+ & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
+ & ELR (MXP), PLR (MXP), WEI (MXP),
+ & AGESEC (MXP), TV, TVCMS, TVRECL, TVHEAV, TVBIND,
+ & NP0, IRN, ITRN (MXP)
+
--- /dev/null
+*$ CREATE FLUOXR.ADD
+*COPY FLUOXR
+*
+*=== fluoxr ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file Fluoxr: created on 4-october-1990 by A. Ferrari *
+* INFN - Milan *
+* Description of the variables (not complete): *
+* *
+* Brrlxl(ix,il,iz) = Relative branching ratios of the *
+* ix-th Lil line (il=1-3, LI,LII,LIII) *
+* Brrkxl(ix,iz) = Relative branching ratios of the *
+* ix-th K line *
+* Flyldk(iz) = Fluorescence yield for the K-shell *
+* of the iz-th element *
+* Flyldl(il,iz) = Fluorescence yield for the il sub- *
+* shell of the L-shell (LI,LII,LII) *
+* of the iz-th element *
+* Ishell(id) = Main shell (K,L,M,N,O) of the id-th *
+* level *
+* id=1 --> K *
+* id=2 - 4 --> L *
+* id=5 - 9 --> M *
+* id=10-16 --> N *
+* id=17-20 --> O *
+* Ktoxtr(ix) = end level index for the ix-th X *
+* transitions from the K shell *
+* Ltoxtr(ix,il) = end level index for the ix-th X *
+* transitions from Lil subshell *
+* Nshell(is) = Number of sub-shell for the is-th *
+* shell (is=1-5 --> K,L,M,N,O) *
+* Nflndx(3,iz) = Starting level number for the iz ele-*
+* ment in the global numbering (for the*
+* 0th level,Nlfndx(3,iz)-Nflndx(3,iz-1)*
+* is the total number of tabulated *
+* levels of the iz element) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( EHYDRO = 1.3605697953179906 D-05 )
+ PARAMETER ( AMELEC = GEVMEV * AMELCT )
+ PARAMETER ( SIGTHO = 6.6524615280813428 D-01 )
+* PARAMETER ( TWOPIP = TWOTWO * PIPIPI )
+* This is 4 sqrt(2)
+ PARAMETER ( TWO3O2 = 5.656854249492380 D+00 )
+* PARAMETER ( PHCONS = TWO3O2 * SIGTHO * FSCTO4 )
+ PARAMETER ( PHCONS = 1.0671336148164197D-08 )
+ PARAMETER ( PHCON2 = 64.D+00 * SIGTHO / FSCTO3 )
+* PARAMETER ( PHCON2 = XXXXXXXXXXXXXXX )
+* This is 2 x pi x exp (-4)
+ PARAMETER ( PHEDG0 = 0.1150805531573017 D+00 )
+* This is 3 / ( 8 x sqrt (2) )
+ PARAMETER ( SAUCST = 0.2651650429449553 D+00 )
+*
+ COMMON / FLUOXR / ZPHOTO (920) , AZPHOT (306) , BZPHOT (306),
+ & ZIEDGE (1329) , EIEDGE (306) , HALLCR (100),
+ & BRRLXL (4,3,100), BRRKXL (8,100), FLYLDK (100),
+ & FLYLDL (3,100) , SGPHPA (920) ,
+ & KTOXTR (8) , LTOXTR (4,3) ,
+ & NFLNDX (3,0:100), ISHELL (0:20) , NSHELL (0:5),
+ & IDMIN (100)
+ COMMON / CHFLUO / CHKXLN (8), CHLXLN (4,3)
+ CHARACTER*8 CHKXLN, CHLXLN
+
--- /dev/null
+*$ CREATE FLUXES.ADD
+*COPY FLUXES
+*
+*=== Fluxes ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Fluxes version for FLUKA9x: it is now almost useless since all *
+* fluxesm... scoring does not work inside FLUKA9x and has been *
+* removed *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* Lfluw3 = if Lfluw3.eq.true fluxes are multiplied by the Fluscw *
+* function when scored *
+* Lfluwd = if Lfluwd.eq.true a call is generated to the user sub- *
+* routine fldscp when scoring distributed along the track *
+* fluxes for possible position changes. This is done befo-*
+* re any user requested rotation *
+* Lbnflx = if Lbnflx.eq.true fluxes at boundaries have to be *
+* scored or by Iflux.gt.2 or by boundary crossing *
+* estimators both usual or user defined *
+* (A. Ferrari 1-July-89) *
+* Lbxflx = if Lbxflx.eq.true fluxes at boundaries have to be *
+* scored by boundary crossing *
+* estimators both usual or user defined *
+* (A. Ferrari 1-July-89) *
+* Ltrflx = if Ltrflx.eq.true track length has to be *
+* scored or by user defined tracklength or by usual *
+* estimators (A. Ferrari 17-May-90) *
+* Lclflx = if Lclflx.eq.true collision density has to be *
+* scored or by user defined or by usual *
+* estimators (A. Ferrari 17-May-90) *
+* Lfluxs = if Lfluxs.eq.true fluxes at boundaries or tracklength *
+* or collision density have to be scored *
+* (A. Ferrari 17-May-90) *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LFLUW3, LFLUWD, LBNFLX, LBXFLX, LTRFLX, LCLFLX, LFLUXS
+ COMMON / FLUXES / LFLUW3, LFLUWD, LBNFLX, LBXFLX, LTRFLX, LCLFLX,
+ & LFLUXS
+
--- /dev/null
+*$ CREATE FRBKCM.ADD
+*COPY FRBKCM
+*
+*=== frbkcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* FeRmi BreaKup CoMmon: *
+* *
+* Created on 10 february 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 17-aug-00 by Alfredo Ferrari *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!! !!!! *
+* !!!! Energy, momentum and mass units of the Fermi !!!! *
+* !!!! break-up algorithm are MeV, MeV/c, and MeV/c^2 !!!! *
+* !!!! respectively !!!! *
+* !!!! !!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* Lfrmbk = Logical flag for activating the Fermi Break-Up *
+* algorithm *
+* Amufbk = Atomic/Nuclear mass unit for the Fermi breakup *
+* algorithm (it must be consistent with Lncmss *
+* and the recorded mas excesses) *
+* Lncmss = Logical flag for nuclear (.true.) or atomic *
+* masses *
+* Eexfbk (j) = excitation energy (MeV) of the jth particle *
+* stable state *
+* Gamfbk (j) = width (MeV) of the jth particle stable state *
+* (Gamma tau = hbar) *
+* Amfrbk (j) = total atomic/nuclear mass of the jth particle *
+* stable state *
+* Exmxfb = Maximum excess mass to be used to build the *
+* break up channels *
+* Nbufbk = The above restriction is used only if the total*
+* estimated number of break up channels is larger*
+* than Nbufbk *
+* R0frbk = R0 for the interaction volume *
+* R0cfbk = R0 for the Coulomb potential among fragments *
+* C1cfbk = C1 for the Coulomb potential among fragments *
+* C2cfbk = C2 for the Coulomb potential among fragments *
+* Ifrbkn (j) = neutron number of the jth particle stable state*
+* Ifrbkz (j) = atomic number of the jth particle stable state*
+* Ifbksp (j) = spin (in hbar/2 unit) of the jth particle *
+* stable state *
+* Ifbkpr (j) = parity of the jth particle stable state *
+* Ifbkst (j) = stability index of the jth particle stable *
+* state *
+* Ipsind (in,iz,1) = starting index of the particle stable states *
+* with N=in and Z=iz *
+* Ipsind (in,iz,2) = last index of the particle stable states with *
+* N=in and Z=iz *
+* Jpsind (ia) = last index of the particle stable states with *
+* A=ia *
+* Exfrbk (i) = total mass excess of the ith break-up *
+* Sdmfbk (i) = (global) spin, degeneracy and mass factor *
+* of the ith break-up *
+* Coufbk (i) = (global) Coulomb energy of the ith break-up *
+* Cenfbk (i) = (global) centrifugal barrier of the ith break *
+* -up (to be multiplied by l(l+1) ) *
+* Ifbcha (1,i) = N of the ith break up combination *
+* Ifbcha (2,i) = Z of the ith break up combination *
+* Ifbcha (3,i) = first particle to be emitted *
+* Ifbcha (4,i) = second particle to be emitted (if negative it *
+* is a combination of particles of index=| |) *
+* Ifbcha (5,i) = (global) multiplicity of the ith break-up *
+* Ifbcha (6,i) = Minimum, (2)Jmin, and Maximum, (2)Jmax, angu- *
+* lar momentum (2)J (in hbar/2 units) (for L=0 *
+* orbital momentum) of the ith break-up, encoded *
+* as: (2)Jmin + 1000 x (2)Jmax *
+* Ifbcha (7,i) = Multiplicity of angular momentum J encoded as: *
+* m(Jmin) IB^0 + m(Jmin+1) IB^1 + .... *
+* .... + m(Jmax-1) IB^(Jmax-Jmin-1) *
+* + m(Jmax) IB^(Jmax-Jmin) *
+* J total multiplicity = (2J+1) x m(J) *
+* where the base IB is given by the parameter *
+* IBFRBK, if Jmax-Jmin > Jpwfbx an underflow *
+* would result, therefore the remaining part is *
+* endcoded into: *
+* Ifbcha (8,i) = Multiplicity of angular momentum J, 2nd part *
+* .... + m(Jmax-1) IB^(Jmax-Jmin-Jpwfbx-2) *
+* + m(Jmax) IB^(Jmax-Jmin-Jpwfbx-1) *
+* The allowed maximum number of different J *
+* values (Jmax-Jmin+1) is so 2*(Jpwfbx+1) *
+* Ifbcha (9,i) = Parity/(-1)^L (L orbital momentum) of the ith *
+* break-up *
+* Ifbind (in,iz,1) = starting index of the break up combinations *
+* with N=in and Z=iz *
+* Ifbind (in,iz,2) = last index of the break up combinations with *
+* N=in and Z=iz *
+* Jfbind (ia) = last index of the break up combinations with *
+* A=ia *
+* Iposst = total number of possible particle stable states*
+* Iposfb = total number of possible break up combinations *
+* Ifbstf = flag for level of inclusion of stable levels *
+* Ifbstf = i0 + i1 x 100 *
+* Ifbpsf = flag for parity-spin effects: *
+* -1 : no account *
+* 0 : L=0 fully accounted for, channels with L>=1 *
+* suppressed by FRBKLS^L (in practice they are *
+* retained only if no L=0 channel is available)*
+* 0 < L': reasonable centrifugal barrier account up *
+* to orbital momentum L=L', as above for L>L' *
+* Frbkls = suppression factor for L>Lmax to be cosidered *
+* for orbital momentum barriers *
+* Ifbfrb = (possible) forbidden "particle stable" state *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum number of fragments to be emitted:
+ PARAMETER ( MXFFBK = 6 )
+ PARAMETER ( MXZFBK = 10 )
+ PARAMETER ( MXNFBK = 12 )
+ PARAMETER ( MXAFBK = 16 )
+ PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
+ PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
+ PARAMETER ( NXAFBK = MXAFBK + 1 )
+ PARAMETER ( MXPSST = 400 )
+ PARAMETER ( MXPSFB = 41000 )
+* Base for J multiplicity encoding:
+ PARAMETER ( IBFRBK = 73 )
+* Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
+* it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
+* ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
+* --> Ibfrbk^(Jpwfbx+1) < 2100000000
+ PARAMETER ( JPWFBX = 4 )
+ LOGICAL LFRMBK, LNCMSS
+ COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
+ & GAMFBK (MXPSST), EXFRBK (MXPSFB), SDMFBK (MXPSFB),
+ & COUFBK (MXPSFB), CENFBK (MXPSFB), EXMXFB, R0FRBK,
+ & R0CFBK, C1CFBK, C2CFBK, FRBKLS,
+ & IFRBKN (MXPSST), IFRBKZ (MXPSST),
+ & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
+ & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:NXAFBK),
+ & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
+ & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
+ & IFBFRB, NBUFBK, LFRMBK, LNCMSS
+
--- /dev/null
+*$ CREATE FRTLCM.ADD
+*COPY FRTLCM
+*
+*=== Frtlcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* FeRmi motion high momentum TaiL CoMmon: *
+* *
+* Created on 18 january 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 18-jan-97 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+* k_fermi (fm^-1) for infinite symmetric nuclear matter
+* with rho0=0.1678 fm^-3 ( k_f=(3/2 pi^2 rho0)^1/3 )
+ PARAMETER ( AKFRM0 = 1.35487770196973D+00 )
+ PARAMETER ( A100LW = 0.859 D+00 * AKFRM0 * AKFRM0 * AKFRM0 )
+ PARAMETER ( A100LG = 0.432 D+00 * AKFRM0 * AKFRM0 * AKFRM0 )
+ PARAMETER ( B100LW = 0.043 D+00 * AKFRM0 * AKFRM0 )
+* Sqrt (b100lw):
+ PARAMETER ( SQB1LW = 0.207364413533277D+00 * AKFRM0 )
+ PARAMETER ( B100LG = 0.97 D+00 * AKFRM0 * AKFRM0 )
+* Sqrt (b100lg):
+ PARAMETER ( SQB1LG = 0.984885780179610D+00 * AKFRM0 )
+ PARAMETER ( C100LW =-0.839 D+00 * AKFRM0 * AKFRM0 * AKFRM0 )
+ PARAMETER ( C100LG = 0.0313 D+00 * AKFRM0 * AKFRM0 * AKFRM0 )
+ PARAMETER ( D100LW = 0.12 D+00 * AKFRM0 * AKFRM0 )
+* Sqrt (d100lw):
+ PARAMETER ( SQD1LW = 0.346410161513775D+00 * AKFRM0 )
+ PARAMETER ( D100LG = 0.22 D+00 * AKFRM0 * AKFRM0 )
+* Sqrt (d100lg):
+ PARAMETER ( SQD1LG = 0.469041575982343D+00 * AKFRM0 )
+
--- /dev/null
+*$ CREATE FXTMX.ADD
+*COPY FXTMX
+*----------------------------------------------------------------------*
+* *
+* Common Fxtmx *
+* Common Fxtmx is used for the fractional fixed step option *
+* Any change in common Fxtmx must be done also in the module Media *
+* of Egsadd!!!!!!!!!!!!!!!! *
+* Mxxmde = maximum number of media in Emf *
+* Estepe = maximum fractional energy loss allowed for the gi- *
+* ven medium *
+* Lpemdt = flag for printing dE/dx and Tmxs tabulations *
+* Ltmin = logical array to flag whether or not has the step *
+* to be larger or the equal than the minimum allowed *
+* by Moliere's theory, regardless of the energy loss: *
+* default is .true. *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LTMIN, LFXTMX, LPEMDT
+ COMMON /FXTMX/ ESTEPE (MXXMDE), ISTPE (MXXMDE), LTMIN (MXXMDE),
+ & LPEMDT (MXXMDE), LFXTMX
+
--- /dev/null
+*$ CREATE GAMRED.ADD
+*COPY GAMRED
+*
+*=== gamred ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* This is the old GAMRED common of Hadrin, extracted and put *
+* into an include file *
+* *
+* Created on 17 may 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 17-may-95 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* AMGA *
+* DECAY *
+* HADRIN *
+* HADRIV *
+* TCHOIC *
+* THREPD *
+* TWOPAD *
+* TWOPAR *
+* XLAMB *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / GAMRED / REDU, AMO, AMM (15)
+
--- /dev/null
+*$ CREATE GDRDCM.ADD
+*COPY GDRDCM
+*
+*=== gdrdcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* *
+* Created on 16 august 2000 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 23-sep-00 by Alfredo Ferrari *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* Egdrbn = energy bin width in data table *
+* Egdrth(is) = threshold energy for isotope is *
+* Ngdrpn(is) = number of table points for isotope is *
+* Igdrpn(is) = pointer to the first table point for isotope is *
+* Lgdrld = logical flag for using the old GDR routine *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LGDRLD
+ PARAMETER ( EGDRBN = 0.2D+00 )
+ COMMON / GDRDCM / EGDRTH (NSTBIS), NGDRPN (NSTBIS),
+ & IGDRPN (NSTBIS), LGDRLD
+
--- /dev/null
+*$ CREATE GENTHR.ADD
+*COPY GENTHR
+*
+*=== genthr ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* hadronic interaction GENerator THResholds *
+* *
+* Created on 20 april 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 21-sep-00 by Alfredo Ferrari *
+* *
+* dpjhdt = DPmJet HaDron interaction Threshold (kin. en.) *
+* dpjiot = DPmJet IOn interaction Threshold (kin. en./n) *
+* peanct = PEAnut NuCleon interaction Threshold (kin. en.) *
+* peapit = PEAnut PIon interaction Threshold (kin. en.) *
+* peakat = PEAnut KAon interaction Threshold (kin. en.) *
+* peakbt = PEAnut KaonBar interaction Threshold (kin. en.) *
+* peaant = PEAnut Anti-Nucleon inter. Threshold (kin. en.) *
+* peahyt = PEAnut HYperon interaction Threshold (kin. en.) *
+* peaaht = PEAnut Anti-Hyperon inter. Threshold (kin. en.) *
+* pldnct = Peanut (oLD version) NuCleon interaction Thresh. *
+* phaswt = switching momentum from h-A resonance model *
+* to the h-A DPM model for those particles supported*
+* by the resonance model *
+* phasmr = smearing +/-DeltaP for switching from the h-A *
+* resonance model to the h-A DPM model for those *
+* particles supported by the resonance model *
+* phnsmr = smearing +/-DeltaP for switching from the h-N *
+* resonance model to the h-N DPM model for those *
+* particles supported by the resonance model *
+* pthrsh = momentum threshold for switching from the reso- *
+* nance to the DPM model for h-h interactions *
+* pthdff = momentum threshold for diffractive events *
+* ijnucr = flags for particles supported by the resonance *
+* model *
+* lhasmr = flag for smearing the transition between the *
+* h-A resonance model and the h-A DPM model *
+* lhnsmr = flag for smearing the transition between the *
+* h-N resonance model and the h-N DPM model *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / GENTHR / PEANCT, PEAPIT, PEAKAT, PEAKBT, PEAANT, PEAHYT,
+ & PEAAHT, PLDNCT, PHASWT, PHASMR, PHNSMR, DPJHDT,
+ & DPJIOT, PTHRSH (NALLWP), PTHDFF (NALLWP),
+ & IJNUCR (NALLWP), LHASMR, LHNSMR
+ LOGICAL LHASMR, LHNSMR
+
--- /dev/null
+*$ CREATE GEOSEL.ADD
+*COPY GEOSEL
+*
+*=== geosel ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version from Alfredo Ferrari: *
+* *
+* Created on 27 april 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 27-apr-98 by Alfredo Ferrari *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /geosel/, /geslch/ used to remember the geometry *
+* geocod = literal descriptions of the geometries *
+* igeo = number of the geometry type used (useless now) *
+* ipri = >=1 print out the calls to geofar, skipping the first*
+* ipri lines *
+* linegm = number of lines already printed *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER * 8 GEOCOD
+*
+ COMMON / GEOSEL / IGEO, IPRI, LINEGM
+ COMMON / GESLCH / GEOCOD (10)
+
--- /dev/null
+*$ CREATE H1PWXS.ADD
+*COPY H1PWXS
+*
+*=== H1pwxs ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* H-1 Point-Wise XSec common: *
+* *
+* Created on 27 may 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 02-jun-97 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Ekei1h (i) = initial kinetic energy (GeV) of the i_th *
+* tabulation range *
+* Elni1h (i) = natural logarithm of the initial kinetic *
+* energy (GeV) of the i_th tabulation range *
+* Dlni1h (i) = constant difference in the natural logarithm *
+* of the initial kinetic energy (GeV) of the *
+* i_th tabulation range *
+* Seln1h (j) = natural logarithm of the n 1-H elastic cross *
+* section at the j_th energy point *
+* Sabn1h (j) = natural logarithm of the n 1-H absorption *
+* cross section at the j_th energy point *
+* Clg21h (k,l) = l_th Legendre coefficient for the n 1-H *
+* elastic scattering angular distribution *
+* at the k_th energy point of the 2nd tabulation*
+* range *
+* Clg31h (k,l) = l_th Legendre coefficient for the n 1-H *
+* elastic scattering angular distribution *
+* at the k_th energy point of the 3rd tabulation*
+* range *
+* Npoi1h (i) = number of energy points of the i_th tabulation*
+* range *
+* Nlgi1h (i) = number of Legendre coeff. of the i_th tabula- *
+* tion range *
+* Nene1h = number of tabulation energy ranges *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / H1PWXS / EKEI1H (3) , ELNI1H (3) , DLNI1H (3) ,
+ & SELN1H (230) , SABN1H (230), CLG21H (101,6),
+ & CLG31H (30,14), NPOI1H (3) , NLGI1H (3) ,
+ & NENE1H
+
--- /dev/null
+*$ CREATE HADFLG.ADD
+*COPY HADFLG
+*
+*=== hadflg ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 13 september 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-sep-00 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* Blkdt4 *
+* Eventv *
+* Ferhav *
+* Hadriv *
+* Hdncin *
+* Hhflev *
+* Hncnev *
+* Nucdcy *
+* Nuncln *
+* Phycrd *
+* Rchanv *
+* Twopar *
+* *
+* Lnwhdr = flag for using the (still on development)*
+* new Hadriv *
+* Ielflg = Flag to control the elastic channel *
+* in Hadriv: *
+* -1: elastic channel reduced according *
+* to a rough Pauli blocking factor *
+* 0: elastic channel fully accounted for *
+* +1: elastic channel suppressed *
+* Icxflg = Flag to control the charge exchange *
+* channel in Hadriv: *
+* -1: ch. ex. channel reduced according *
+* to a rough Pauli blocking factor *
+* 0: ch. ex. channel fully accounted for *
+* +1: ch. ex. channel suppressed *
+* Istflg = Flag to control the strangeness exchange *
+* channel in Hadriv: *
+* -1: st. ex. channel reduced according *
+* to a rough Pauli blocking factor *
+* 0: st. ex. channel fully accounted for *
+* +1: st. ex. channel suppressed *
+* Ianflg = Flag to control the annhiliation channel *
+* in Hadriv: *
+* -1: annih. channel only one accounted *
+* for (!!! note please !!!) *
+* 0: annih. channel fully accounted for *
+* +1: annih. channel suppressed *
+* Innure(1,1,k) = Projectile index for the Hadriv reaction *
+* k (first entrance channel) *
+* Innure(2,1,k) = Target index for the Hadriv reaction *
+* k (first entrance channel) *
+* Innure(1,2,k) = Projectile index for the Hadriv reaction *
+* k (second entrance channel, if any) *
+* Innure(2,2,k) = Target index for the Hadriv reaction *
+* k (second entrance channel, if any) *
+* It holds: *
+* Nure (Innure(1,j,k),(Innure(2,j,k)/8+1)) = k *
+* Areso1/2 = mass of the 1st/2nd resonance produced *
+* in Hadriv *
+* Greso1/2 = width of the 1st/2nd resonance produced *
+* in Hadriv *
+* Ereso1/2 = energy of the 1st/2nd resonance produced *
+* in Hadriv *
+* Preso1/2 = momen. of the 1st/2nd resonance produced *
+* in Hadriv *
+* Px,y,zres1/2 = mom. comp. of the 1st/2nd resonance pro- *
+* duced in Hadrin *
+* Jreso1/2 = index of the 1st/2nd resonance produced *
+* in Hadriv *
+* Kreso1/2(m) = pointer (inside ...j arrays) of 1st decay*
+* particles originating from the 1st/2nd *
+* resonance produced in Hadriv *
+* Kreso.. = k1 + 1000 * k2 + 1000000 * k3 *
+* Nreso1/2 = number of final particles originating *
+* from the 1st/2nd resonance produced in *
+* Hadriv *
+* Aresoj(i) = mass of the i_th intermediate resonance*
+* produced in Hadriv *
+* Gresoj(i) = width of the i_th intermediate resonance*
+* produced in Hadriv *
+* Eresoj(i) = energy of the i_th intermediate resonance*
+* produced in Hadriv *
+* Presoj(i) = momen. of the i_th intermediate resonance*
+* produced in Hadriv *
+* Px,y,zresj(i) = mom. comp. of the i_th intermediate reso-*
+* nance produced in Hadrin *
+* Jresoj(i) = index of the i_th intermediate resonance *
+* produced in Hadriv *
+* Kresoj(i) = pointer (inside ...j arrays) of the decay*
+* particles originating from the i_th int- *
+* ermediate resonance produced in Hadriv *
+* Kresoj = k1 + 1000 * k2 + 1000000 * k3 *
+* Qqreso = Q^2=-t of the resonance creation process *
+* in Hadriv (projectile and resonance 1) *
+* Uureso = u of the resonance creation process in *
+* Hadriv (target and resonance 1) *
+* Rhresp = local proton nuclear density (fm^-3) *
+* Rhresn = local neutron nuclear density (fm^-3) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXRSDC = 25 )
+ PARAMETER ( PPAMXB = 0.6 D+00 )
+ PARAMETER ( PAUMXB = 2.D+00 * 0.8 D+00 )
+ PARAMETER ( PPAMXM = 0.6 D+00 )
+ PARAMETER ( PAUMXM = 2.D+00 * 0.4 D+00 )
+*
+ COMMON / HADFLG / QQRESO, UURESO, RHRESP, RHRESN,
+ & ARESOJ (MXRSDC), GRESOJ (MXRSDC), ERESOJ (MXRSDC),
+ & PRESOJ (MXRSDC), PXRESJ (MXRSDC), PYRESJ (MXRSDC),
+ & PZRESJ (MXRSDC), JRESOJ (MXRSDC), KDCRSJ (MXRSDC),
+ & IELFLG, ICXFLG, ISTFLG, IANFLG, IOLDHD, LNWHDR,
+ & INNURE (2,2,16), IKCHXG (16),
+ & NRESO1, NRESO2
+ LOGICAL LNWHDR
+ EQUIVALENCE ( ARESO1, ARESOJ (1) ), ( ARESO2, ARESOJ (2) )
+ EQUIVALENCE ( GRESO1, GRESOJ (1) ), ( GRESO2, GRESOJ (2) )
+ EQUIVALENCE ( ERESO1, ERESOJ (1) ), ( ERESO2, ERESOJ (2) )
+ EQUIVALENCE ( PRESO1, PRESOJ (1) ), ( PRESO2, PRESOJ (2) )
+ EQUIVALENCE ( PXRES1, PXRESJ (1) ), ( PXRES2, PXRESJ (2) )
+ EQUIVALENCE ( PYRES1, PYRESJ (1) ), ( PYRES2, PYRESJ (2) )
+ EQUIVALENCE ( PZRES1, PZRESJ (1) ), ( PZRES2, PZRESJ (2) )
+ EQUIVALENCE ( KRESO1, KDCRSJ (1) ), ( KRESO2, KDCRSJ (2) )
+ EQUIVALENCE ( JRESO1, JRESOJ (1) ), ( JRESO2, JRESOJ (2) )
+
--- /dev/null
+*$ CREATE HADPAR.ADD
+*COPY HADPAR
+*
+*=== Hadpar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of Hadpar: *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-dec-97 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Pxh(i) = X-component of the momentum of the i_th produced *
+* particle *
+* Pyh(i) = Y-component of the momentum of the i_th produced *
+* particle *
+* Pzh(i) = Z-component of the momentum of the i_th produced *
+* particle *
+* Heph(i) = Total energy of the i_th produced particle *
+* Amh(i) = Mass of the i_th produced particle *
+* Ichh(i) = Charge of the i_th produced particle *
+* Ibarh(i) = Baryon number of the i_th produced particle *
+* Nreh(i) = Identity (part scheme) of the i_th produced particle *
+* Ichnh(3,i) = Array containing additional informations about prod- *
+* uction verteces, ranking etc *
+* Infoh(i) = chain # of the i_th produced particle *
+* Anh(i) = Literal name of the i_th produced particle *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANH
+ COMMON / HADPAR / PXH (MXPDPM), PYH (MXPDPM), PZH (MXPDPM),
+ & HEPH (MXPDPM), AMH (MXPDPM), ICHH (MXPDPM),
+ & IBARH (MXPDPM), NREH (MXPDPM), INFOH (MXPDPM),
+ & ICHNH (3,MXPDPM)
+ COMMON / CHHDPR / ANH (MXPDPM)
+
--- /dev/null
+*$ CREATE HAMCIN.ADD
+*COPY HAMCIN
+*
+*=== Hamcin ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file Hamcin *
+* *
+* PDG particle id's corresponding to the FLUKA internal numbering *
+* scheme *
+* *
+* Created on 07 july 1995 by Johannes Ranft *
+* *
+* *
+* Introduced into FLUKA on 12-jan-96 by Alfredo Ferrari *
+* Infn - Milan *
+* *
+* Last change on 23-aug-00 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / HAMCIN / KHMCIN (MXMCIN)
--- /dev/null
+*$ CREATE HBMP96.ADD
+*COPY HBMP96
+*
+*=== Hbmp96 ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 24 january 2001 by Giuseppe Battistoni *
+* Infn - Milan *
+* *
+* Last change on 24-jan-01 by Giuseppe Battistoni *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / HBMP96 / DGSM(49,92)
+ REAL * 4 DGSM
--- /dev/null
+*$ CREATE HDSLCM.ADD
+*COPY HDSLCM
+*
+*=== Hdslcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* HaDron SeLection CoMmon: *
+* *
+* Created on 21 october 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 25-mar-98 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXIDSL = 10 )
+ PARAMETER ( MXHDSL = 2 )
+*
+ COMMON / HDSLCM / AIDSEL (MXIDSL,MXHDSL), ATDSEL (MXIDSL,MXHDSL),
+ & PXDSEL (MXIDSL,MXHDSL), PYDSEL (MXIDSL,MXHDSL),
+ & PZDSEL (MXIDSL,MXHDSL), PIDSEL (MXIDSL,MXHDSL),
+ & PXSDSL (MXIDSL,MXHDSL), PYSDSL (MXIDSL,MXHDSL),
+ & FIDSEL (MXIDSL,MXHDSL), RIDSEL (MXHDSL) ,
+ & PSDSLX , PSDSLY ,
+ & KIDSEL (MXIDSL,MXHDSL), NIDSEL (MXHDSL) ,
+ & IBDSEL (MXHDSL) , NQDSEL (MXHDSL) ,
+ & JIDSEL (MXHDSL) , MIDSEL
+
--- /dev/null
+*$ CREATE HIGFIS.ADD
+*COPY HIGFIS
+*
+*=== higfis ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* HIGh energy FISsion common: *
+* *
+* Created on 9 april 1993 by Alfredo Ferrari & Paola Sala *
+* INFN - Milan *
+* Last change on 26-jul-97 by Alfredo Ferrari, INFN - Milan *
+* *
+* Fisinh = logical flag for HE fission *
+* Lfrgmn = logical flag for fragmentation *
+* Lagoes = logical flag for controlling the Agoes correction *
+* in the high energy fission module *
+* Afis(i)= ith fragment mass number just after fission *
+* Zfis(i)= ith fragment atomic number just after fission *
+* Ufis(i)= ith fragment excitation energy (MeV) just after *
+* fission *
+* Ekfis(i)= ith fragment kinetic(MeV) energy just after fission*
+* Amfis(i)= ith fragment atomic mass (MeV) just after fission *
+* Ppfis(i)= ith fragment momentum (MeV/c) just after fission *
+* Atfis(i)= ith fragment mass number after evaporation *
+* Ztfis(i)= ith fragment atomic number after evaporation *
+* Utfis(i)= ith fragment excitation energy (MeV) after evapora-*
+* tion *
+* Recfis(i)= ith fragment kinetic(MeV) energy after evaporation *
+* Atmfis(i)= ith fragment atomic mass (MeV) after evaporation *
+* Pptfis(i)= ith fragment momentum (MeV/c) after evaporation *
+* Bhyfis(k,i)= (Nuclear) binding energy of the k_th bound hyperon *
+* for the ith fission /fragmentation remnant (MeV) *
+* Ebfiss = fission barrier (MeV) *
+* Amdiff = Fission fragment kinetic energy (MeV) *
+* Apr0 = Mass number of the (first) fissioning nucleus *
+* Zpr0 = Atomic number of the (first) fissioning nucleus *
+* Uu0 = Excitation energy (MeV) of the (first) fissioning *
+* nucleus *
+* Erec0 = Recoil kinetic energy (MeV) of the (first) fissio- *
+* ning nucleus *
+* Npartf(j,i)= Number of evaporated particle of type j after the *
+* evaporation of the ith fragment *
+* Hevfis(i)= Evaporated "heavies" kinetic energy (MeV) after the*
+* evaporation of the ith fragment *
+* Istfis(i) = Particle stable state index for the ith fission/ *
+* fragmentation remnant *
+* Ismfis(i) = Isomeric state index for the ith fission/fragmen- *
+* tation remnant *
+* Ihyfis(i) = Number of (possible) bound hyperons for the ith *
+* fission/fragmentation remnant *
+* Khyfis(k,i) = Id of the k_th bound hyperon for the ith fission *
+* /fragmentation remnant *
+* Nfiss = Number of fission/fragmentation fragments in the *
+* stack *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum Z for which fission is allowed: original value
+* PARAMETER ( IZFSMX = 66 )
+* New value with new Fprob settings:
+ PARAMETER ( IZFSMX = 61 )
+ LOGICAL FISINH, LFRGMN, LAGOES
+ COMMON / HIGFIS / AFIS (10), ZFIS (10), UFIS (10), EKFIS (10),
+ & AMFIS (10), PPFIS (10), COSLFF(3,0:10),
+ & ATFIS (10), ZTFIS (10), UTFIS (10), RECFIS (10),
+ & AMTFIS(10), PPTFIS(10), BHYFIS (IHYPMX,10),
+ & EBFISS, AMDIFF, APR0, ZPR0, EREC0, UU0,
+ & HEVFIS (0:10),
+ & ISTFIS(10), ISMFIS(10), IHYFIS(10),
+ & KHYFIS(IHYPMX,10), NPARTF (0:6,0:10),
+ & NFISS, FISINH, LFRGMN, LAGOES
+ DIMENSION COSLF0 (3)
+ EQUIVALENCE ( COSLF0 (1), COSLFF (1,0) )
+
--- /dev/null
+*$ CREATE ICATHR.ADD
+*COPY ICATHR
+*
+*=== Icathr ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* ICArus THResholds and miscellaneous: *
+* *
+* Created on 1 february 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-apr-01 by Alfredo Ferrari *
+* *
+* Dvicwp(i) = drift velocity for the i_th wire plane *
+* Mricwp(i) = region into which the i_th wire plane must be *
+* "confined" *
+* Kficwp(i) = extra flag for the i_th wire plane *
+* *
+*----------------------------------------------------------------------*
+*
+* Drift velocity: 1.5 mm / us
+ PARAMETER ( VDRIFT = 0.15 D+06 )
+* Drift axis = +y (drift is along +y)
+ PARAMETER ( KDRIFT = 2 )
+* Maximum number of Icarus wire planes:
+ PARAMETER ( MXICWP = 24 )
+*
+ COMMON / ICATHR / DELTTH, BREMTH, ENTRTH, DVICWP (MXICWP),
+ & NUSICA, MTWIRE, LUNZBI, LUNZBO, LICPRN, LICMEM,
+ & LZBROU, LJTINP, LNOECL, MNOEFA, MNOEFB, MNOEFM,
+ & MRICWP (MXICWP), KFICWP (MXICWP)
+ LOGICAL LICPRN, LICMEM, LZBROU, LJTINP, LNOECL
+
--- /dev/null
+*$ CREATE ICVXCM.ADD
+*COPY ICVXCM
+*
+*=== Icvxcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* ICarus VerteX CoMmon: *
+* *
+* Created on 02 february 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-jul-99 by Alfredo Ferrari *
+* *
+* Nicvtx = number of currently recorded verteces *
+* Kicvtx(i) = pointer to the i_th vertex information *
+* Kvxbgn = starting location (I*4) for verteces information *
+* in blank common *
+* Kvxlst = last location (I*4) for verteces information *
+* in blank common *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXICVX = 1000 )
+*
+ INTEGER NICVTX, KICVTX, KVXBGN, KVXLST
+ COMMON / ICVXCM / NICVTX, KICVTX (MXICVX), KVXBGN, KVXLST
+
--- /dev/null
+*$ CREATE INPDAT.ADD
+*COPY INPDAT
+*
+*=== inpdat ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: inpdat copy created 29/3/90 by A. Ferrari*
+* *
+* changes: last change on 14-oct-00 by Alfredo Ferrari, INFN Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* IFRBMJ = Fragmentation flag: Ifr0 + Ifr1 x 10 + Ifr2 x 100 *
+* + Ifr3 x 1000 + Ifr4 x 1000 *
+* + Ifr5 x 100000 + Ifr6 x 1000000 *
+* + Ifr7 x 10000000 *
+* Ifr0 = 0: no resampling of hadron id for possible mass *
+* dependent terms in the fragmentation function*
+* (but of course resampling of z for the same *
+* id) no term [1-m^2/sz]^2 included *
+* = 1: resampling of hadron id for possible mass *
+* dependent terms in the fragmentation function*
+* no term [1-m^2/sz]^2 included *
+* = 2: term [1-m^2/s]^2 with no z dependence inclu- *
+* ded and rest like for Ifr0 = 1 *
+* = 3: term [1-m^2/sz]^2 with z dependence inclu- *
+* ded and the rest like Ifr0 = 2 *
+* Ifr1 = 0: resampling of hadron id for possible mass *
+* dependent terms in the fragmentation function*
+* performed inside Energi *
+* >= 1: resampling of hadron id for possible mass *
+* dependent terms in the fragmentation function*
+* performed after returning to Bamjev for pos- *
+* sible, more complex, resampling schemes *
+* Ifr2 = 0: z fractions are to be intended as energy fra-*
+* ctions *
+* = 1: z fractions are to be intended as momentum *
+* fractions *
+* = 2: z fractions are to be intended as energy + *
+* momentum fractions, but for a (possible) *
+* z-dependent mass threshold factor where they *
+* are intended as energy fractions *
+* = 3: z fractions are to be intended as energy + *
+* momentum fractions including a (possible) *
+* z-dependent mass threshold factor *
+* = 4: z fractions are to be intended as energy + *
+* momentum fractions for the whole dijet light *
+* cone variables *
+* Ifr3 = 0: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used integrated over p_t^2 when sel- *
+* ecting particles from multiplets and their z *
+* fractions *
+* = 1: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t=m when sel- *
+* ecting particles from multiplets and their z *
+* fractions *
+* = 2: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution using the*
+* smallest mass hadron. *
+* = 3: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons. Rescaling *
+* is done within the physical maximum energy *
+* for all particles *
+* = 4: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons. Rescaling *
+* is done taking the same maximum transverse *
+* kinetic energy (the one of the minimal mass *
+* hadron) for all particles *
+* = 5: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons. Rescaling *
+* is done taking the same maximum transverse *
+* momentum (the one of the minimal mass hadron *
+* ) for all particles *
+* = 6: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons as in 3. *
+* When finally applied it must be rescaled for *
+* the different maximum energies in the two *
+* cases *
+* = 7: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons as in 4. *
+* When finally applied it must be rescaled for *
+* the different maximum energies in the two *
+* cases *
+* = 8: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution and res- *
+* caled according to the masses/max. energies *
+* of the possibly produced hadrons as in 5. *
+* When finally applied it must be rescaled for *
+* the different maximum energies in the two *
+* cases *
+* = 9: the mass dependent term 1/z exp(-b m_t^2/z) *
+* must be used evaluated at m_t with p_t pre- *
+* selected from a proper distribution using *
+* the smallest mass hadron. When finally app- *
+* lied it must be rescaled for the different *
+* maximum energies in the two cases *
+* Ifr4 = 0: 1-z fractions are to be intended as excluding*
+* mass energy ( using (1-z)/(1-z_min) ) *
+* = 1: z fractions are to be intended as including *
+* mass energy *
+* Ifr5 = 0: standard Bamjet way of treating before the *
+* LL=0/LL=1 jets *
+* = 1: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized as first one *
+* = 2: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized at the first step *
+* and then swap at each step, according to the *
+* scheme (ie 0 the first one): 01010101... *
+* = 3: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized at the first step *
+* and then swap at each odd step, according to *
+* the scheme (ie 0 the first one): 0110011... *
+* = 4: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized at each step *
+* = 5: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized at the first step *
+* and then decide randomly the one for the next*
+* step with probability proportional to the *
+* residual energies of each jet *
+* = 6: swap randomly 50% which one of the LL=0/LL=1 *
+* jets has to be hadronized at the first step *
+* and then decide randomly the one for the next*
+* step with probability proportional to the *
+* residual (long.) momenta of each jet *
+* = 7: like 5 but with the 2nd step swapped anyway *
+* = 8: like 6 but with the 2nd step swapped anyway *
+* Ifr6 = 0: standard Bamjet way of treating chain cut *
+* through Rx/Rxmnm *
+* = 1: treat chain cut through invariant masses *
+* allowing for crossover of the two jets *
+* = 2: treat chain cut through invariant masses *
+* allowing for crossover of the two jets but *
+* with limitations to the available energy of *
+* the jet under consideration *
+* Ifr7 = 0: standard Lctsqs way of considering p_t as *
+* given in the residual cms *
+* = 1: treat p_t as sampled in the transverse chain *
+* cms and not in the residual overall cms, but *
+* for final junction particles *
+* = 2: treat p_t as sampled in the transverse chain *
+* cms and not in the residual overall cms, *
+* for final junction particles too (*** not *
+* operational and not true ***) *
+* = 3: treat p_t as R3bamj correlated with the resi-*
+* dual one, in the transverse chain cms (for *
+* Ifr6 > 0), or in the chain system, assuming *
+* it a the sum of R3 x p_t_resid and a (1-R3) *
+* x p_t_smpld with a properly selected angle *
+* between the two vectors but for final junct- *
+* ion particles *
+* = 4: like 3, with a special angular correlation *
+* for final junction particles to try to do the*
+* R3 correlation as much as possible. The p_t *
+* of final junction particles is anyway sampled*
+* in the overall residual cms *
+* cms and not in the residual overall cms, *
+* for final junction particles too *
+* = 5: treat p_t as the opposite of the last samp- *
+* led one, in the transverse chain cms (for *
+* Ifr6 > 0), or in the chain system, assuming *
+* it a the sum of -p_t_prev and a (1-R3) *
+* x p_t_smpld with a properly selected angle *
+* between the two vectors but for final junct- *
+* ion particles *
+* = 6: like 5, with a special angular correlation *
+* for final junction particles to try to do the*
+* R3 correlation as much as possible. The p_t *
+* of final junction particles is anyway sampled*
+* in the overall residual cms *
+* cms and not in the residual overall cms, *
+* for final junction particles too *
+* *
+* IVLBMJ = Valence quark fragmentation flag: Ivl + ... *
+* Ivl = 0: no account for valence/non-valence quarks *
+* when applying the chain end fragmentation *
+* parameters (A1VBBJ, A1VMBJ, AVBBMJ, AVMBMJ, *
+* BVBBMJ, BVMBMJ, A1OBBJ, A1OMBJ, AOBBMJ, *
+* AOMBMJ, BOBBMJ, BOMBMJ) *
+* = 1: chain end fragmentation parameters (A1VBBJ, *
+* A1VMBJ, AVBBMJ, AVMBMJ, BVBBMJ, BVMBMJ, *
+* A1OBBJ, A1OMBJ, AOBBMJ, AOMBMJ, BOBBMJ, *
+* BOMBMJ), applied to valence quarks only *
+* IQQBMJ = Flag for fragmentation parameters for verteces with *
+* qq-aqaq excited from the sea: Iqq *
+* Iqq = 0: fragmentation parameters for (anti)ba- *
+* ryons used for q-qq + aqaq (anti)ba- *
+* ryon production (default ones, even if *
+* the original (anti)quark is a (valence) *
+* chain end one) *
+* = 1: fragmentation parameters for (valence) *
+* mesons used for q-qq + aqaq (anti)ba- *
+* ryon production (those for (valence) *
+* chain ends if the original (anti)quark *
+* is a (valence) chain end one) *
+* = 2: fragmentation parameters for possibly *
+* (valence) (anti)baryons used for q-qq *
+* + aqaq (anti)baryon production (those *
+* for (valence) chain ends if the original*
+* (anti)quark is a (valence) chain end *
+* one) *
+* = 3: like 1, but 50% randomly wrt 0 *
+* = 4: like 2, but 50% randomly wrt 0 *
+* A1VBBJ = A1 parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex originating from an initial *
+* (anti)diquark chain end (possibly restricted to *
+* valence (anti)diquarks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* This parameter applies to aq-q chains *
+* A1VMBJ = A1 parameter in the fragmentation function for a *
+* meson vertex originating from an initial (anti)quark *
+* chain end (possibly restricted to valence (anti)qua- *
+* rks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* This parameter applies to aq-q chains *
+* A1OBBJ = A1 parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex originating from an initial *
+* (anti)diquark chain end (possibly restricted to *
+* valence (anti)diquarks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* A1OMBJ = A1 parameter in the fragmentation function for a *
+* meson vertex originating from an initial (anti)quark *
+* chain end (possibly restricted to valence (anti)qua- *
+* rks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* A1BBMJ = A1 parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex ( P(z) = 1-A1 + (n+1)A1 (1-z)^n )*
+* A1MBMJ = A1 parameter in the fragmentation function for a *
+* meson vertex ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* AMEBAM = AME parameter, it is the probability for creating a *
+* qqbar couple during the chain hadronization, rather *
+* than a (qq)(qbarqbar) one *
+* AVBBMJ = n parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex originating from an initial *
+* (anti)diquark chain end (possibly restricted to *
+* valence (anti)diquarks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* This parameter applies to aq-q chains *
+* AVMBMJ = n parameter in the fragmentation function for a *
+* meson vertex originating from an initial (anti)quark *
+* chain end (possibly restricted to valence (anti)quar-*
+* ks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* This parameter applies to aq-q chains *
+* AOBBMJ = n parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex originating from an initial *
+* (anti)diquark chain end (possibly restricted to *
+* valence (anti)diquarks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* AOMBMJ = n parameter in the fragmentation function for a *
+* meson vertex originating from an initial (anti)quark *
+* chain end (possibly restricted to valence (anti)quar-*
+* ks according to Ivl) *
+* ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* ANBBMJ = n parameter in the fragmentation function for a(n) *
+* (anti)baryon vertex ( P(z) = 1-A1 + (n+1)A1 (1-z)^n )*
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* ANMBMJ = n parameter in the fragmentation function for a *
+* meson vertex ( P(z) = 1-A1 + (n+1)A1 (1-z)^n ) *
+* A value >= 1000 is taken as a flag and forces to call*
+* a user defined routine *
+* BVBBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a(n) (anti)baryon vertex originating from *
+* an original (anti)diquark chain end (possibly restr- *
+* icted to valence (anti)diquarks according to Ivl) *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* This parameter applies to aq-q chains *
+* BVMBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a meson vertex originating from an *
+* original (anti)quark chain end (possibly restricted *
+* to valence (anti)quarks according to Ivl) *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* This parameter applies to aq-q chains *
+* BOBBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a(n) (anti)baryon vertex originating from *
+* an original (anti)diquark chain end (possibly restr- *
+* icted to valence (anti)diquarks according to Ivl) *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* BOMBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a meson vertex originating from an *
+* original (anti)quark chain end (possibly restricted *
+* to valence (anti)quarks according to Ivl) *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* This parameter applies to (a)q-(a)q(a)q and aqaq-qq *
+* chains *
+* BZBBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a(n) (anti)baryon vertex *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* BZMBMJ = b parameter in the mass cutoff fragmentation function*
+* factor for a meson vertex *
+* ( X(z) = exp ( - b m_t^2 / z ) / z ) *
+* EPCBMJ = eta parameter in the popcorn cutoff fragmentation *
+* function factor for a popcorn meson *
+* ( Y(z) = exp ( - eta m_meson ) ) *
+* DM0BMJ = extra energy for a diquark to be applied to the naive*
+* quark mass sum for M_0 and/or the minimum energy to *
+* be left after hadronizing the current hadron if the *
+* quark mass options are selected *
+* FM0BMJ = FM_0 multiplicative factor for the minimum energy to *
+* be left after hadronizing the current hadron *
+* SM0BMJ = SM_0 sigma (fraction) for randomizing the minimum en-*
+* ergy to be left after hadronizing the current hadron *
+* RM0BMJ = RM_0 maximum reduction of the minimum energy to be *
+* left after hadronizing the current hadron to be used *
+* during hadron selection *
+* BM0BMJ = Smearing parameter for M_0, it give the (approximate)*
+* fractional sigma for M_0 around the nominal M_00 *
+* value using a log-normal distribution *
+* exp [- BM0^2/2 ln^2(M_0/M_00)] *
+* P (M_0) = ---------------------------------- *
+* M_0 Sqrt[2 pi / BM0^2] *
+* EM0BMJ = Smearing parameter for the transition to reduced *
+* thresholds inside Abbrch. The transition is full for *
+* original/current (depending on option) jet energy *
+* Em0bmj below the nominal corresponding meson/baryon *
+* (depending on option) mass and null a Em0bmj above *
+* TM0BMJ = "Typical" transverse kinetic energy to be used for *
+* jets unequal energy sharing, for special "a priori" *
+* popcorn and for minimal residual energies during *
+* hadronization *
+* UR0BMJ = u quark mass reduction for low original/current *
+* (depending on option) jet energy *
+* DR0BMJ = d quark mass reduction for low original/current *
+* (depending on option) jet energy *
+* SR0BMJ = s quark mass reduction for low original/current *
+* (depending on option) jet energy *
+* IM0BMJ = Flag for the management of the mass cut-off inside *
+* Abbrch and Bamjev: Im0bmj = Im0 + Jm0 x 10 *
+* + Km0 x 100 + Lm0 x 1000 *
+* + Mm0 x 10000 + Nn0 x 100000 *
+* + Ic0 x 1000000 *
+* + Jc0 x 10000000 *
+* + Is0 x 100000000 *
+* Im0 = 0, M_0 generated according to the initial *
+* jet energy *
+* = 1, M_0 generated according to the current *
+* jet energy *
+* = 2, M_0 generated according to the current *
+* jet quark masses *
+* = 3, M_0 generated according to the current *
+* jet quark masses and corrected according to *
+* M_0 = M_0 / [ 1 + (M_0/(E_jet+M_0))^2 ] *
+* = 4, M_0 generated according to the current *
+* jet quark masses and corrected for low *
+* initial jet energies going down to *
+* m_u(d)(s) = m_u(d)(s)_ori / u(d)(s)r0 *
+* = 5, M_0 generated according to the current *
+* jet quark masses and corrected for low *
+* current jet energies going down to *
+* m_u(d)(s) = m_u(d)(s)_ori / u(d)(s)r0 *
+* = 6, like 4 but with a diquark possibly taken *
+* into account when generating the check *
+* energy for reducing quark masses *
+* = 7, like 5 but with a diquark possibly taken *
+* into account when generating the check *
+* energy for reducing quark masses *
+* Jm0 = 0, exponential prob. form for generating *
+* M_cut and P_cut (see B1,B2, etc) *
+* = 1, gaussian prob. form for generating *
+* M_cut and P_cut (see B1,B2, etc) *
+* = 2, gaussian prob. form for generating *
+* M_cut and P_cut (see B1,B2, etc) *
+* = 3, gaussian prob. form for generating *
+* M_cut and P_cut (see B1,B2, etc) *
+* = 4, gaussian prob. form for generating *
+* M_cut and P_cut (see B1,B2, etc) *
+* = 5, gaussian prob. for generating M_cut, *
+* log-normal prob. form for generating E_k_cut*
+* /P_cut (see B1,B2, etc) *
+* = 6, gaussian prob. for generating M_cut, *
+* log-normal prob. form for generating E_k_cut*
+* /P_cut (see B1,B2, etc) *
+* = 7, delta function for generating M_cut *
+* log-normal prob. form for generating E_k_cut*
+* /P_cut (see B1,B2, etc) *
+* = 8, delta function for generating M_cut *
+* log-normal prob. form for generating E_k_cut*
+* /P_cut (see B1,B2, etc) *
+* = 9, delta function for generating M_cut *
+* gaussian prob. for generating P_x,y_cur *
+* with variance 1/B1 for B1 > 0 or RX/B1 for *
+* B1<0, the same for P_z_cut with B2 *
+* Km0 = 0, no minimal energy must be left after cre-*
+* ation of the current hadron *
+* = 1, FM_0 x M_0 minimal energy to be left *
+* after creation of the current hadron *
+* = 2, minimal energy to be left after creation *
+* of the current hadron corresponding to the *
+* masses of the residual quarks times FM_0 *
+* = 4,5,6,7 minimal energy to be left after cre-*
+* ation of the current hadron corresponding to*
+* the masses of the residual quarks corrected *
+* as for Im0=4,5,6,7 times FM_0 *
+* Lm0 = 0, the (anti)diquark extra energy is added *
+* anyway when quark mass based minimal resi- *
+* dual cut-offs are used *
+* = 1, the (anti)diquark extra energy is added *
+* only if the current residual (anti)quarks *
+* of other jet are consistent with a hadron *
+* residual *
+* = 2, the (anti)diquark extra energy is added *
+* only if the current residual (anti)quarks *
+* of other jet are consistent with a hadron *
+* residual, the other jet (anti)quark masses *
+* are accounted for (never reduced also for *
+* Km0=4-7) and the other jet current residual *
+* energy is considered *
+* = 3, the (anti)diquark extra energy is added *
+* only if the current residual (anti)quarks *
+* of other jet are consistent with a hadron *
+* residual, the other jet (anti)quark masses *
+* are accounted for (possibly reduced for *
+* Km0=4-7) and the other jet current residual *
+* energy is considered *
+* Mm0 = 0, no extra energy added to the Abbrch one *
+* for selecting a vertex with qq-aqaq from *
+* the sea *
+* = 1, a diquark (DM0) extra energy and a u/d *
+* mass (possibly) reduced according to Im0 *
+* added to the Abbrch one for selecting a *
+* vertex with qq-aqaq from the sea *
+* = 2, no diquark production allowed close to a *
+* baryon vertex *
+* = 3, as 1 and 2 together *
+* Nm0 = 0, no forced production from one (randomly) *
+* of the two jets *
+* = 1, forced particle production from one *
+* (randomly) of the two jets in case in the *
+* previous attempt both were immediately *
+* cut-offed *
+* Ic0 = 0, normal RX check *
+* = 1, normal RX check corrected for Sqrt(s) *
+* as: Rx_eff = Rx x [Sqrt(s) - E_min_oth] *
+* / [Rx + Rx_oth - E_min_oth] *
+* where E_min_oth is the quark mass of the *
+* other jet residual plus (possibly) the *
+* diquark extra, plus EM0 *
+* = 2, RX check corrected for Sqrt(s) almost ex-*
+* actly making the split of the available *
+* invariant mass between M_0 of the current*
+* jet computed according to Im0 recipes and*
+* M_min_oth, where M_min_oth is the quark *
+* mass of the other jet residual plus (pos-*
+* sibly) the diquark extra *
+* = 9, Sqrt(s) check inside Abbrch *
+* Jc0 = 0, residual energy/Sqrt(s) used inside *
+* FLAVOR for flavour selection *
+* = 1, residual energy/Sqrt(s) approximately *
+* corrected for residual quarks masses used*
+* inside FLAVOR for flavour selection *
+* = 2, residual energy/Sqrt(s) fully corrected *
+* for residual quarks masses, diquark extra*
+* factors, etc, used inside FLAVOR for *
+* flavour selection *
+* Is0 = 0, no B1,B2 rescaling *
+* = 1, B1, B2 rescaled according to the chain *
+* energy *
+* PVCBMJ = PVC parameter: X.xxxx.... + Y.yyyy x 10^5 *
+* Pvcpr1 = Y.yyyy (note 4 decimal digits only) *
+* Pvcpr2 = X.xxxx.... *
+* Pvcpr1 = probability of avoiding the resampling of *
+* the whole chain when the remaining energy *
+* is no longer enough to create the current *
+* hadron, via resampling of the current hadron*
+* vertex, flavor and id *
+* Pvcpr2 = probability of avoiding the resampling of *
+* the whole chain when the remaining energy *
+* is no longer enough to create the current *
+* hadron, via a call to verein directly (if *
+* both jets have been hadronized) or going to *
+* the 2nd one (a la Abbrch) *
+*
+* B1BAMJ = B1 parameter used when generating the energy cut-off *
+* for chain hadronization *
+* B2BAMJ = B2 parameter used when generating the energy cut-off *
+* for chain hadronization *
+* C1BAMJ = C1 parameter used when generating the energy cut-off *
+* for chain hadronization *
+* C2BAMJ = C2 parameter used when generating the energy cut-off *
+* for chain hadronization *
+* B1SBMJ = B1 scaling parameter (GeV) *
+* B2SBMJ = B2 scaling parameter (GeV) *
+* B1DBMJ = B1 "derivative" *
+* B2DBMJ = B2 "derivative" *
+* D12BMJ = D12 parameter used when generating the energy cut-off*
+* for chain hadronization *
+* The cut-off is generated according to: *
+* B1_eff = B1 + C1 / ( E_curr_chain / |D12| ) *
+* B2_eff = B2 + C2 / ( E_curr_chain / |D12| ) *
+* where: *
+* E_curr_chain = E_oth + R_x, for D12 > 0 *
+* E_curr_chain = R_x, for D12 < 0 *
+* (R_x = current residual jet energy) *
+* (E_o = current residual other jet energy, it *
+* could well be stiil the total other jet *
+* energy) *
+* M_cut = M_0 + M_rndm *
+* ( P(M_rndm) = B1_eff exp [-B1_eff M_rndm] *
+* for Jm0 = 0, or *
+* 2 exp [-B1_eff^2/2 M_rndm^2] *
+* P(M_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B1_eff^2] *
+* M_rndm >=0, for Jm0 = 1, or *
+* 2 exp [-B1_eff^2/2 M_rndm^2] *
+* P(M_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B1_eff^2] *
+* M_rndm >=0, for Jm0 = 2, or *
+* 2 exp{-B1_eff^2/2[M_rndm/(R_x-M_0)]^2}*
+* P(M_rndm) = ---------------------------------- *
+* Sqrt{2 pi [(R_x-M_0)/B1_eff]^2} *
+* R_x = current residual jet energy *
+* M_rndm >=0, for Jm0 = 3, or *
+* 2 exp{-B1_eff^2/2[M_rndm/(R_x-M_0)]^2}*
+* P(M_rndm) = ---------------------------------- *
+* Sqrt{2 pi [(R_x-M_0)/B1_eff]^2} *
+* R_x = current residual jet energy *
+* M_rndm >=0, for Jm0 = 4, or *
+* 2 exp [-B1_eff^2/2 M_rndm^2] *
+* P(M_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B1_eff^2] *
+* M_rndm >=0, for Jm0 = 5, or *
+* 2 exp [-B1_eff^2/2 M_rndm^2] *
+* P(M_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B1_eff^2] *
+* M_rndm >=0, for Jm0 = 6, or *
+* P (M_cut) = delta (M_cut-M_0) *
+* for Jm0 = 7, or *
+* P (M_cut) = delta (M_cut-M_0) *
+* for Jm0 = 8, or *
+* P (M_cut) = delta (M_cut-M_0) *
+* for Jm0 = 9 ) *
+* E_cut0 = M_0 + E_k_rndm *
+* ( P(E_k_rndm) = B2_eff exp [-B2_eff E_k_rndm] *
+* for Jm0 = 0, or *
+* 2 exp [-B2_eff^2/2 E_k_rndm^2] *
+* P(E_k_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B2_eff^2] *
+* E_k_rndm >=0, for Jm0 = 1, or *
+* 2 exp{-B2_eff^2/2[E_k_rndm/(R_x-M_0]^2}*
+* P(E_k_rndm) = ---------------------------------- *
+* Sqrt{2 pi [(R_x-M_0)/B2_eff]^2} *
+* R_x = current residual jet energy *
+* E_k_rndm >=0, for Jm0 = 2, or *
+* 2 exp [-B2_eff^2/2 E_k_rndm^2] *
+* P(E_k_rndm) = ---------------------------------- *
+* Sqrt[2 pi / B2_eff^2] *
+* E_k_rndm >=0, for Jm0 = 3, or *
+* 2 exp{-B2_eff^2/2[E_k_rndm/(R_x-M_0]^2}*
+* P(E_k_rndm) = ---------------------------------- *
+* Sqrt{2 pi [(R_x-M_0)/B2_eff]^2} *
+* R_x = current residual jet energy *
+* E_k_rndm >=0, for Jm0 = 4, or *
+* exp [- ln^2(E_k_rndm B2_eff)/2] *
+* P(E_k_rndm) = ---------------------------------- *
+* E_k_rndm Sqrt[2 pi] *
+* for Jm0 = 5, or *
+* exp [-B2_eff^2/2 ln^2(E_k_rndm/E_0)] *
+* P(E_k_rndm) = ---------------------------------- *
+* E_k_rndm Sqrt[2 pi / B2_eff^2] *
+* E_0 = R_x / B2_eff *
+* for Jm0 = 6, or *
+* exp [-B1_eff^2/2 ln^2(E_k_rndm/E_0)] *
+* P(E_k_rndm) = ---------------------------------- *
+* E_k_rndm Sqrt[2 pi / B1_eff^2] *
+* E_0 = R_x / B2_eff *
+* for Jm0 = 7, or *
+* exp [-B1_eff^2/2 ln^2(E_k_rndm B2_eff)]*
+* P(E_k_rndm) = ---------------------------------- *
+* E_k_rndm Sqrt[2 pi / B1_eff^2] *
+* for Jm0 = 8 ) *
+* P_cut = Sqrt [E_k_rndm (E_k_rndm + 2 M_0)] *
+* E_cut = Sqrt [ M_cut^2 + P_cut^2 ] *
+* B3BAMJ = B3 [GeV/c]^-1 slope parameter in the p_t generation *
+* function, it is usedin generating the slope parameter*
+* C3BAMJ = C3 reduction parameter for the p_t slope used when *
+* giving chains intrinsic p_t before hadronization *
+* D3BAMJ = D3 (GeV) scale parameter for the p_t generation fun- *
+* ction, it is used in generating the slope parameter *
+* The slope parameter is generated according to: *
+* D3 > 0: *
+* B3 * Log10(D3) *
+* B_slope = ------------------------------------ *
+* Log10 [1+(E_chain/D3)^2] + Log10 (D3) *
+* *
+* / initial chain energy (Islflg=0) *
+* E_chain: *
+* \ current chain energy (Islflg=1) *
+* *
+* D3 < 0: *
+* B_slope = B3 - D3 * Log(E_chain) *
+* *
+* / initial chain energy (Islflg=0) *
+* E_chain: *
+* \ current chain energy (Islflg=1) *
+* *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!!! Please note that it would be more consistent !!!!! *
+* !!!!! with the concept of independent chain whose !!!!! *
+* !!!!! hadronization depends only on current energy !!!!! *
+* !!!!! and flavor ends, to make B_slope dependent !!!!! *
+* !!!!! on the current jet residual energy rather !!!!! *
+* !!!!! than on the initial chain energy !!!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* *
+* E3BAMJ = E3 parameter in the p_t distribution generation *
+* for Jptflg=2,3, E3>=0: *
+* E3 [GeV/c]^-2 quadratic parameter in the p_t genera- *
+* tion function, it controls a (possible) p_t^2 term *
+* for Jptflg=4: *
+* E3 = F_mul x 10000.0 + Prob_tail *
+* Prob_tail (0=<Prob_tail< 1) is the probability *
+* for selecting p_t from the the high p_t tail *
+* which is gaussian (see the Jptflg explaination) *
+* with sigma_tail = sigma _pt x F_mul *
+* for Jptflg=2,3 E3=<0: *
+* E3 = F_mul x 10000.0 + Prob_tail *
+* Prob_tail (0=<Prob_tail< 1) is the probability *
+* for selecting p_t from the the high p_t tail *
+* which uses B3 = B3 x F_mul. See Ptintr for *
+* details *
+* F3BAMJ = F3 parameter in the p_t distribution generation: it *
+* modifies the default B3 (intended for mesons) into *
+* F3 x B3 for (anti)baryons *
+* Q3BAMJ = Q3 parameter in the p_t distribution generation: it *
+* modifies the default (F3 x )B3 (intended for produced*
+* particles) into Q3 x (F3 x )B3 for those hadrons *
+* carrying one or more of the original chain *
+* (anti)quarks, according to the Icrrpt and Kcrrpt flags*
+* See below for the modifications due to T3. *
+* T3BAMJ = T3 parameter in the p_t distribution generation: if *
+* different from zero, it modifies the Q3 parameter as *
+* Q3_eff = Q3 x [n_tot_quark/(n_tot_quark-n_ori_quark)]^T3 *
+* P3BAMJ = P3 parameter in the p_t distribution generation: if *
+* different from zero, it modifies the Q3 (and P3) pa- *
+* rameters for popcorn mesons as: *
+* Q3_eff = Q3 x [(n_tot_quark+P3)/(n_tot_quark-n_ori_quark+P3)]^T3 *
+* R3BAMJ = R3 parameter in the p_t distribution generation: if *
+* different from zero, together with S3 it sets the *
+* correlation for the sqrt(s) calculations between the *
+* newly created p_t and a possible previous p_t *
+* S3BAMJ = S3 parameter in the p_t distribution generation: if *
+* different from zero, together with R3 it sets the *
+* correlation for the sqrt(s) calculations between the *
+* newly created p_t and a possible previous p_t *
+* IPTBMJ = IPT flag in the p_t generation function, it controls *
+* the p_t option: *
+* IPT = Jptsgn x ( Jptflg + 10 x Kptflg *
+* + 100 x Lptflg + 1000 x Mptflg *
+* + 10000 x Nptflg *
+* + 100000 x Islflg ) *
+* Jptflg is controlling the p_t generating distribution*
+* Jptflg = 1: old bamjet sampling *
+* Jptflg = 2: exponential in transverse energy *
+* P(E_t)dE_t = A exp[-B_slope E_t - E3 p_t^2] dE_t *
+* Jptflg = 3: invariant cross section exponential *
+* in transverse energy, which transl- *
+* ates into: *
+* A exp[-B_slope E_t - E3 p_t^2] *
+* P(E_t)dp_t^2 = ------------------------------- dp_t^2 *
+* Sqrt [ E^2 - E_t^2 ] *
+* Jptflg = 4: p_t generated at parton level assu- *
+* ming a gaussian distribution for each*
+* (parton) p_t component which transl- *
+* ates into (for partons): *
+* P(p_t)dp_t^2 = A exp[-B_part^2 p_t^2/2] dp_t^2 *
+* B_part = 1/sigma_pt_part *
+* and for hadrons (two partons involved) *
+* P(p_t)dp_t^2 = A exp[-B_slope^2 p_t^2/2] dp_t^2 *
+* B_slope = 1/sigma_pt_hadr = B_part/Sqrt(2) *
+* Kptflg controls the mass used when generating the *
+* intrinsic p_t of chains (meaningful only for *
+* Jptsgn = 1, please note that for some of the Jptflg *
+* values Kptflg is irrelevant): *
+* Kptflg = 0: chains treated like massless objects *
+* Kptflg = 1: largest chain mass used *
+* Kptflg = 2: largest mass among the hadrons *
+* corresponding to the 1 particle state*
+* of the chains *
+* Kptflg = 3: smallest chain mass used *
+* Kptflg = 4: smallest mass among the hadrons *
+* corresponding to the 1 particle state*
+* of the chains *
+* Kptflg = 5: largest mass among the hadrons *
+* corresponding to the minimal mass 1 *
+* particle state of the chains *
+* Kptflg = 6: smallest chain mass used, unless it *
+* is smaller than the (constrained) *
+* mass of the other chain *
+* Lptflg controls whether the chain intrinsic p_t has *
+* to be generated according to the individual p_t's of *
+* the constituents or not: *
+* Lptflg = 0: no chain p_t generation according to *
+* individual p_t's of constituents *
+* = 1: chain p_t generation according to *
+* individual p_t's of constituents *
+* Mptflg controls how the chain intrinsic p_t has to *
+* be treated when sampled in the backward emisphere: *
+* Mptflg = 0: p_t accepted regardless whether it is*
+* forward or backward (and implicitly *
+* used always as forward) *
+* = 1: p_t accepted only if it is forward *
+* = 2: p_t accepted both if forward or *
+* bacward and the forward chain becomes*
+* the backward (and viceversa) and the *
+* chain products are inverted in dire- *
+* ction too: *
+* Example for a baryon-baryon collision: *
+* qq q *
+* <----- --> \ *
+* | *
+* <--- x ---> | Starting "longitudinal" situation before *
+* q qq | p_t application *
+* <- ----> / *
+* *
+* qq q *
+* <- --> \ *
+* | *
+* <- x -> | Final situation (note the q/qq of the *
+* q qq | projectile are still forward, and those *
+* <--- -> / of the target are still backward) *
+* = 3: p_t accepted both if forward or *
+* bacward and the forward chain becomes*
+* the backward (and viceversa) and the *
+* chain products are inverted in dire- *
+* ction randomly (50% probability) *
+* Nptflg controls how the Lorentz transformation due *
+* to the chain intrinsic p_t is performed: *
+* Nptflg = 0: "parallel" transformation (untilted *
+* chain axis) *
+* = 1: "rotated" transformation (tilted *
+* chain axis) *
+* = 2: mixed "parallel" and "rotated" acco- *
+* rding to chain end intrinsic p_t *
+* Note: Nptflg > 0 is incompatible with most *
+* Ioqrpt, Joqrpt etc options which *
+* assume a "parallel" transformation *
+* Islflg = 0: rescale B3 according to the initial *
+* chain energy *
+* = 1: rescale B3 according to the current *
+* chain energy *
+* Jptsgn < 0: old way of selecting the mass *
+* I3BAMJ = I3 parameter in the p_t generation function, it *
+* controls the matching of the right and left jet p_ts *
+* during chain hadronization *
+* I3 = Iptreo + Icrrpt x 10 + Ioqrpt x 100 *
+* + Joqrpt x 1000 + Kcrrpt x 10000 *
+* + Jfjnpt x 100000 + Koqrpt x 1000000 *
+* Iptreo controls the p_t "re-orientation" procedure *
+* before "gluing" together the right and left jets: *
+* Iptreo = 0: no reorientation *
+* Iptreo = 1: simple reorientation with two batches*
+* Iptreo = 2: random reorientation with 2/4/8 *
+* batches *
+* Iptreo = 3: reorientation with 2/4/8 batches *
+* with coupling of the batches such as *
+* to minimize the global p_t *
+* Iptreo = 4: like 1 but with no random swapping *
+* of the particles *
+* Iptreo = 5: like 2 but with no random swapping *
+* of the particles *
+* Iptreo = 6: like 3 but with no random swapping *
+* of the particles *
+* Icrrpt controls whether or not p_t of two consecutive*
+* particles produced in the same jet during the hadro- *
+* dization procedure are correlated ot not (if so they *
+* are thought as the sum of the p_t left by the pre- *
+* vious remnant plus the p_t of the new parton and the *
+* (anti)parton left for the next stage will carry the *
+* opposite p_t) *
+* Icrrpt = 0: no correlation *
+* Icrrpt = 1: full correlation *
+* Icrrpt = 2: full correlation with end chain *
+* hadrons sampled with a B3 x Q3 *
+* parameter in order to account *
+* roughly for the intrinsic p_t of *
+* the chains *
+* Icrrpt = 3: full correlation with end chain *
+* hadrons sampled with a B3 x Q3 *
+* parameter and zero mass in order *
+* to account roughly for the intrinsic *
+* p_t of the chains *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!! In case Sqrt(s) calculations with jet !!! *
+* !!! crossover are selected (Ifr6>=1) with !!! *
+* !!! "a priori" transverse momentum selec- !!! *
+* !!! tion, the meaning of Icrrpt is diffe- !!! *
+* !!! rent (the azimuthal angle is created !!! *
+* !!! "a priori" too) and explained below: !!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* Icrrpt = 0: no correlation *
+* Icrrpt = 1: reorientation of the produced hadron *
+* and the minimal mass remnant such to *
+* minimize the sum of the squared p_t *
+* of both after the transverse boost *
+* to the global chain cms *
+* Icrrpt = 3: reorientation of the produced hadron *
+* and the minimal mass remnant such to *
+* minimize the difference of (vector) *
+* p_t of the two objects after the *
+* transverse boost to the global chain *
+* cms *
+* Note: for final junction hadrons Jfjnpt takes the*
+* precedence over Icrrpt *
+* *
+* Kcrrpt controls possible p_t slope increase factors *
+* for particles carrying the original chain quarks *
+* when transverse momentum is computed "a priori". *
+* Please note that if Kcrrpt is non zero it overrides *
+* Icrrpt for this specific aspect *
+* Kcrrpt = 0: no slope increase *
+* Kcrrpt = 1: slope increase (Q3) for ALL *
+* particles carrying original quarks *
+* Kcrrpt = 2: slope increase (Q3) for the *
+* particles carrying original quarks *
+* but those coming (or following) from *
+* popcorn *
+* Kcrrpt = 3: slope increase (Q3) for the *
+* particles carrying original quarks *
+* but those coming from the final *
+* two-jet junction *
+* Kcrrpt = 4: slope increase (Q3) for the *
+* particles carrying original quarks *
+* but those coming from the final *
+* two-jet junction unless they are the *
+* first of the jet *
+* Kcrrpt = 5: like 2 and 3 together *
+* Kcrrpt = 6: like 2 and 4 together *
+* Ioqrpt controls whether or not an azimuthal reorien- *
+* tation of the p_t of produced hadrons must be perfor-*
+* med such that the p_t of hadrons carrying one or more*
+* of the (anti)quarks belonging to the original chain *
+* ends is reoriented in a special way wrt the global *
+* chain p_t, in case these hadrons are a subset of the *
+* total hadrons produced *
+* Ioqrpt = 0: no reorientation *
+* Ioqrpt = 1: reorientation of all hadrons such to *
+* minimize the total (vector) p_t of *
+* the hadrons with "original" quarks *
+* after the transverse boost due to the*
+* chain intrinsic p_t *
+* Ioqrpt = 2: reorientation of all hadrons such to *
+* minimize the difference of total *
+* (vector) p_t of the hadrons with *
+* "original" quarks and the intrinsic *
+* chain p_t after the transverse boost *
+* due to the chain intrinsic p_t *
+* Ioqrpt = 3: reorientation of all hadrons such to *
+* minimize the difference of (vector) *
+* p_t of two (random) batches of the *
+* hadrons with "original" quarks *
+* after the transverse boost due to the*
+* chain intrinsic p_t *
+* Joqrpt controls whether or not the p_t of hadrons *
+* carrying one or more of the (anti)quarks belonging *
+* to the original chain ends must be reoriented in a *
+* special way wrt the global chain p_t, in case these *
+* hadrons include all produced hadrons *
+* Joqrpt = 0: no reorientation *
+* Joqrpt = 1: reorientation of the hadrons such to *
+* minimize the sum of the squared p_t *
+* of hadrons after the transverse boost*
+* due to the chain intrinsic p_t *
+* Joqrpt = 3: reorientation of the hadrons such to *
+* minimize the difference of (vector) *
+* p_t of two (random) batches of the *
+* hadrons after the transverse boost *
+* due to the chain intrinsic p_t *
+* Jfjrpt controls whether or not an azimuthal reorien- *
+* tation of the p_t of the 2 final junction hadrons *
+* must be performed such that the p_t of these hadrons *
+* is reoriented in a special way in their own cms *
+* system *
+* Jfjnpt = 0: no reorientation *
+* Jfjnpt = 1: reorientation of the hadrons such to *
+* minimize the sum of the squared p_t *
+* of hadrons after the transverse boost*
+* to the global chain cms *
+* Jfjnpt = 3: reorientation of the hadrons such to *
+* minimize the difference of (vector) *
+* p_t of the two hadrons after the *
+* transverse boost to the global chain *
+* cms *
+* Koqrpt controls the way the p_t reduction for hadrons*
+* carrying original quarks is applied for "a priori" *
+* p_t sampling: *
+* Koqrpt = 0: reduction applied to the p_t parame- *
+* ter before sampling *
+* = 1: reduction applied to the sampled *
+* p_t *
+* BETBBJ = BET [GeV]^-1 parameter for quark selection for a(n) *
+* (anti)baryon vertex *
+* BETMBJ = BET [GeV]^-1 parameter for quark selection for a *
+* meson vertex *
+* BETMCH = BET [GeV]^-1 parameter for quark selection for charm *
+* meson production *
+* BETBCH = BET [GeV]^-1 parameter for quark selection for charm *
+* (anti)baryon production *
+* BETMBT = BET [GeV]^-1 parameter for quark selection for *
+* bottom meson production *
+* BETBBT = BET [GeV]^-1 parameter for quark selection for *
+* bottom (anti)baryon production *
+* BETMTP = BET [GeV]^-1 parameter for quark selection for top *
+* meson production *
+* BETBTP = BET [GeV]^-1 parameter for quark selection for top *
+* (anti)baryon production *
+* /E_chain *
+* P(q) = C | 2 E exp[-BET E] dE *
+* /m_q *
+* UQMBMJ = u quark mass (used for flavor selection only) *
+* *
+* DQMBMJ = d quark mass (used for flavor selection only) *
+* *
+* SQMBMJ = s quark mass (used for flavor selection only) *
+* *
+* CQMBMJ = c quark mass (used for flavor selection only) *
+* *
+* BQMBMJ = b quark mass (used for flavor selection only) *
+* *
+* TQMBMJ = t quark mass (used for flavor selection only) *
+* *
+* DIQBMJ = diquark extra mass (used for flavor selection only) *
+* *
+* QRKMSS(1)= u quark mass (used for particle production thresh- *
+* olds only) *
+* QRKMSS(2)= d quark mass (used for particle production thresh- *
+* olds only) *
+* QRKMSS(3)= s quark mass (used for particle production thresh- *
+* olds only) *
+* QRKMSS(4)= c quark mass (used for particle production thresh- *
+* olds only) *
+* QRKMSS(5)= b quark mass (used for particle production thresh- *
+* olds only) *
+* QRKMSS(6)= t quark mass (used for particle production thresh- *
+* olds only) *
+* UUUBMJ = correction to the (anti)diquark extra mass in case *
+* of uuu/ddd (anti)baryons *
+* SUUBMJ = correction to the (anti)diquark extra mass in case *
+* of suu/sdd/sud (anti)hyperons *
+* SSUBMJ = correction to the (anti)diquark extra mass in case *
+* of ssu/ssd (anti)hyperons *
+* SSSBMJ = correction to the (anti)diquark extra mass in case *
+* of sss (anti)hyperons *
+* IE0BMJ = IE0 parameter (energy sharing between the left and *
+* right jets of a chain): Ie0 + Je0 x 10 + Ke0 x 100 *
+* Ie0 = 0: equal energy sharing regardless of the *
+* chain ends *
+* Ie0 = 1: energy sharing according to pseudo- *
+* scalar meson/baryon octet masses *
+* Ie0 = 2: energy sharing according to vector me- *
+* son/baryon decuplet masses *
+* For unequal sharing, given M_right and M_left accor- *
+* ding to IE0: *
+* M_right + 1/2 [E_chain-M_right-M_left], for *
+* E_chain > M_right+M_left *
+* E_right = < E_chain *
+* M_right --------------- for E_chain=< M_right+M_left *
+* M_right + M_left *
+* Je0 = 0: momentum assumed for massless partons *
+* taken as the lowest of the jet energies *
+* calculated according to Ie0) *
+* Je0 = 1: momentum according to pseudoscalar *
+* meson/baryon octet masses *
+* Je0 = 2: momentum according to vector meson/ *
+* baryon decuplet masses *
+* Ke0 =..: not used *
+* ASBAMJ = AS parameter: *
+* Prob [pseudoscalar-meson] *
+* AS = ------------------------------------------- *
+* Prob[pseudoscalar-meson]+Prob[vector-meson] *
+* B8BAMJ = B8 parameter: *
+* Prob [(a)baryon-octet] *
+* B8 = --------------------------------------------- *
+* Prob[(a)baryon-octet]+Prob[(a)baryon-decuplet] *
+* P1BAMJ = P1 parameter: *
+* Prob [(a)baryon-I=0] *
+* P1 = --------------------------------------------- *
+* Prob[(a)baryon-I=0]+Prob[(a)baryon-I=1] *
+* P2BAMJ = P2 parameter: *
+* Prob [meson-I=0] *
+* P2 = --------------------------------------------- *
+* Prob[meson-I=0]+Prob[meson-I=1] *
+* ESTBMJ = EST parameter: *
+* Prob [eta*] *
+* EST = --------------------------------------------- *
+* Prob[eta*]+Prob[eta] *
+* IKMBMJ = IKM parameter, it controls the selection of the mini-*
+* mum mass hadron in case of missing energy for that *
+* one selected according to B8 and AS *
+* Ikm <10: Ikm trials are allowed when putting *
+* together the right and left jets in *
+* order to select hadron(s0 in such a way *
+* to comply with the available energy *
+* Ikm>=10: check anyway the possibility of select- *
+* ing the minimum mass hadron(s) when *
+* putting together the right and left *
+* jets (Verein routine) *
+* Ikm>=20: check anyway the possibility of select- *
+* ing the minimum mass hadron when *
+* hadronizing one of the jet in Bamjev *
+* the remaining energy is < M_selected *
+* DIQBMJ = diquark (extra) mass factor (used for flavor selec- *
+* tion only *
+* POPBMJ = POP parameter used to determine the Popcorn probabi- *
+* lity *
+* POLWBJ = POLW parameter used to control the Popcorn probabi- *
+* lity al low chain energies *
+* POPEBJ = POPE [GeV] energy scale parameter setting the scale *
+* for the low energy behaviour of the Popcorn parameter*
+* q-aq chains: *
+* Prob(popcorn) = 1 - POP *
+* (a)q-(a)q(a)q chains: *
+* Max [0,E_chain-POPE] *
+* Prob(popcorn) = 1-POLW - [POP-POLW] ------------------- *
+* E_chain *
+* (a)q(a)q-(a)q(a)q chains: *
+* Max [0,E_chain-2 POPE]*
+* Prob(popcorn) = 1-POLW - [POP-POLW] ------------------- *
+* E_chain *
+* POPSBJ = like Popbmj, but for s quarks, the use of Polwbj and *
+* Popebj is the same *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* !!!!! Please note that it would be more consistent !!!!! *
+* !!!!! with the concept of independent chain whose !!!!! *
+* !!!!! hadronization depends only on current energy !!!!! *
+* !!!!! and flavor ends, to make P(Popcorn) depend- !!!!! *
+* !!!!! ent on the current jet residual energy rath- !!!!! *
+* !!!!! er than on the initial chain energy !!!!! *
+* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
+* IPPBMJ = IPP parameter controlling the behaviour at very low *
+* energies of dijet chains and other popcorn related *
+* business. For q-qq,aq-aqaq, Ipp controls a sort of *
+* "a priori" popcorn, for the others it is a sort of *
+* random swap. *
+* Ippbmj = Ipp + Jpp x 10 + Kpp x 100 + Lpp x 1000 *
+* + Mpp x 10000 + Npp x 100000 *
+* + Ipc x 1000000 *
+* Ipp = 0: no change *
+* = odd : Popcorn change according to pseudo- *
+* scalar meson/baryon octet masses *
+* = even: Popcorn change according to vector *
+* meson/baryon decuplet masses *
+* = 1,2 : Popcorn/swap applied to (a)q-(a)q(a)q*
+* only *
+* = 3,4 : Popcorn/swap applied to (a)q-(a)q(a)q*
+* and q-aq only *
+* = 5,6 : Popcorn/swap applied to (a)q-(a)q(a)q*
+* and aqaq-qq only *
+* = 7,8 : Popcorn/swap applied to (a)q-(a)q(a)q*
+* q-aq and aqaq-qq *
+* Jpp = 0: fragmentation parameters for mesons *
+* used for popcorn meson production *
+* (those for non (valence) chain end *
+* mesons) *
+* = 1: fragmentation parameters for (anti)bar- *
+* yons used for popcorn meson production *
+* (those for (valence) chain ends (anti-) *
+* baryons if the original (anti)diquark is*
+* a (valence) chain end one) *
+* = 2: fragmentation parameters for chain end *
+* (valence) mesons used for popcorn meson *
+* production (those for (valence) chain *
+* ends if the original (anti)diquark is a *
+* (valence) chain end one) *
+* = 3: like 1, but 50% randomly wrt 0 *
+* = 4: like 2, but 50% randomly wrt 0 *
+* Kpp = 0: no change to the popcorn probability *
+* = 1: the popcorn probability is zeroed if the*
+* cut-off energy coming from Abbrch, when *
+* increased for 2 m_u/m_d masses is larger*
+* than the available energy. The quark *
+* masses are (possibly) reduced according *
+* to the Im0 option. The available energy *
+* is taking or not into account the other *
+* jet quark masses and energy according *
+* to Lm0flg *
+* = 2: the popcorn probability is checked *
+* against a carefully computed threshold *
+* including also the other jet energy *
+* and quarks. Meaningful mainly for *
+* Ifr6 = 1. *
+* Lpp = 0: when making "a priori" popcorn (see *
+* below) the (new) diquark is going in *
+* the opposite direction wrt the old one *
+* = 1: when making "a priori" popcorn (see *
+* below) the (new) diquark is going in *
+* the opposite direction wrt the old one *
+* for 50% of the cases *
+* = 2: when making "a priori" popcorn (see *
+* below) the (new) diquark is going in *
+* the opposite direction wrt the old one *
+* for m_q1/(m_q1+m_q3) of the cases *
+* Mpp = 0: no change to the popcorn probability *
+* = 1: the popcorn probability is used inside *
+* Abbrch to select a reduced threshold *
+* according to popcorn chance in case the *
+* option with quark masses is used *
+* = 2: like the previous one but with unit *
+* probability for the first particle, that*
+* is if no hadronization is possible but *
+* for popcorn, popcorn is always selected *
+* Npp = 0: no change to the popcorn probability *
+* = 1: if popcorn is selected and eta_popcorn *
+* (Epcbmj) is not null, the probability of*
+* selecting a xxbar different from uubar/ *
+* ddbar is weighted by: *
+* exp[-eta_pop(m_qx-m_qu)] *
+* where q is the current (anti)quark used *
+* to form the meson *
+* = 2: during popcorn selection, if the current*
+* (anti)quark q possibly used to form the *
+* meson is not a u(bar)/d(bar), the pop- *
+* corn selection for this (anti)quark is *
+* weighted by exp[-eta_pop(m_uq-m_uu)] *
+* = 3: as 2 and 3 together *
+* Ipc = 0: if eta_popcorn is not null it is applied*
+* to all popcorn verteces, including those*
+* originating from valence (anti)diquarks *
+* = 1: eta_popcorn not applied (set =0) to *
+* popcorn verteces originating from va- *
+* lence (anti)diquark *
+* = 2: eta_popcorn not applied (set =0) to *
+* popcorn verteces originating from va- *
+* lence (anti)diquark, and popcorn prob- *
+* ability for these verteces rescaled *
+* times exp[eta_pop m_pi] *
+* = 3: like 1 but eta_popcorn still applied to *
+* popcorn verteces originating from va- *
+* lence (anti)diquark for charm only *
+* = 4: like 2 but eta_popcorn still applied to *
+* popcorn verteces originating from va- *
+* lence (anti)diquark for charm only *
+* Suppose the current popcorn probability (for q-qq, *
+* aq-aqaq) or swap probability (for the other dijets, *
+* assumed 1/2 anyway) as resulting from the previous *
+* parameters is 1-POC, then: *
+* given M_right and M_left according to IPP: *
+* 1-POC for E_chain=< M_right+M_left+2 Eextr*
+* Prob(q-swap)= < (E_chain-M_right-M_left)/2Eextr *
+* [1-POC] for E_chain=< M_right+M_left+2 Eextr*
+* / Tm0 , for Tm0 > 0 *
+* Eextr= *
+* \ m_pi, for Tm0 =<0 *
+* then with Prob(q-swap) the (a)q is swapped randomly *
+* and direction reversed, *
+* so, for a q1-q2q3 chain we change from: *
+* <--- q2 *
+* <--- q3 *
+* q1 ---> *
+* to (and symmetric with 3 swapped): *
+* <--- q2 *
+* q3 ---> *
+* q1 ---> *
+* which swap is a "a-priori" popcorn, the probability *
+* for popcorn is then changed into [1-POC]-Prob(q-swap)*
+* While for a q-aq chain: *
+* <--- aq *
+* q ---> *
+* to: *
+* <--- q *
+* aq ---> *
+* PSSBMJ = PSS probability for creating a ssbar couple from the *
+* projectile hadron or a target nucleon with respect *
+* to P(uubar)=P(ddbar)=1 for very large energies *
+* DSSBMJ = DSS mass scale [GeV/c^2] for modifying PSS at low *
+* energies *
+* PSS_eff = PSS 2/pi Atan [(E_qqbar-M_phi)/DSS] *
+* PCCBMJ = PCC probability for creating a ccbar couple from the *
+* projectile hadron or a target nucleon with respect *
+* to P(uubar)=P(ddbar)=1 for very large energies *
+* DCCBMJ = DCC mass scale [GeV/c^2] for modifying PCC at low *
+* energies *
+* PCC_eff = PCC 2/pi Atan [(E_qqbar-M_J/psi)/DCC] *
+* ISUBMJ = ISU flag for controlling flavor creation *
+* Isu = 1: only u(bar) quarks permitted in the *
+* chain hadronization process *
+* Isu = 2: u(bar)/d(bar) quarks permitted in the *
+* chain hadronization process *
+* Isu = 3: u(bar)/d(bar)/s(bar) permitted in the *
+* chain hadronization process *
+* Isu = 4: u(bar)/d(bar)/s(bar)/c(bar) permitted *
+* in the chain hadronization process *
+* Isu = 5: u(bar)/d(bar)/s(bar)/c(bar)/b(bar) *
+* permitted in the chain hadronization *
+* process *
+* Isu = 6: u(bar)/d(bar)/s(bar)/c(bar)/b(bar)/ *
+* t(bar) permitted in the chain hadroni- *
+* zation process *
+* IUDBMJ = IUD parameter controlling isospin modifications to *
+* flavor selection *
+* Iudbmj = Iud + Jud x 10 *
+* Iud = 0: no change *
+* = 1: isospin changes applied both to meson *
+* and (anti)baryon verteces (but for *
+* baryon ones they are not fully correct) *
+* = 2: isospin changes applied to meson ver- *
+* teces only *
+* Jud = 0: popcorn treated like a normal meson *
+* vertex *
+* = 1: no isospin change applied to popcorn *
+* verteces *
+* = 2: isospin applied to popcorn verteces *
+* considering the original (anti)diquark *
+* (then depending on Iud it makes some- *
+* thing or not) *
+* = 3:(hopefully) full treatment of isospin for*
+* popcorn verteces *
+* ITCHBJ = flag for t-dependent chain intrinsic p_t *
+* ICHBMJ = flag for s-dependent charm selection probability *
+* Bet(m/b)ch(s) = Bet(m/b)c_0 - Betpch *
+* x log10 (s_chain/1 GeV) *
+* BETPCH = see above *
+* CH3BMJ = multiplicative factor for B3 for charmed had./quarks *
+* B0CHBJ = the slope for the t-dependent chain intrinsic p_t *
+* is given by B0 + B'log(s^2/M^2_ch1/M^2_ch2) *
+* where B0 and B' are given by B0CHBJ and BPCHBJ *
+* BPCHBJ = see above *
+* C0CHBJ = the curvature for the t-dependent chain intrinsic p_t*
+* is given by C0 + C'log(s^2/M^2_ch1/M^2_ch2) *
+* where C0 and C' are given by C0CHBJ and CPCHBJ *
+* CPCHBJ = see above *
+* *
+*----------------------------------------------------------------------*
+*
+* Probability of having a I=1 u(bar)d(bar) diquark when originating
+* from a p(bar)/n(bar):
+ PARAMETER ( PRNUD1 = ONETHI )
+* Probability of having a I=0 u(bar)d(bar) diquark when originating
+* from a p(bar)/n(bar):
+ PARAMETER ( PRNUD0 = ONEONE - PRNUD1 )
+* Probability of having a I=1 generic u(bar)d(bar) diquark
+ PARAMETER ( PRBUD1 = HLFHLF )
+* Probability of having a I=0 generic u(bar)d(bar) diquark
+ PARAMETER ( PRBUD0 = ONEONE - PRBUD1 )
+*
+ COMMON /INPDAT/ A1VBBJ, A1VMBJ, A1OBBJ, A1OMBJ, A1BBMJ, A1MBMJ,
+ & AMEBAM, AVBBMJ, AVMBMJ, AOBBMJ, AOMBMJ, ANBBMJ,
+ & ANMBMJ, BVBBMJ, BVMBMJ, BOBBMJ, BOMBMJ, BZBBMJ,
+ & BZMBMJ, EPCBMJ, B1BAMJ, B2BAMJ, C1BAMJ, C2BAMJ,
+ & D12BMJ, B1SBMJ, B2SBMJ, B1DBMJ, B2DBMJ, B3BAMJ,
+ & C3BAMJ, D3BAMJ, E3BAMJ, F3BAMJ, Q3BAMJ, T3BAMJ,
+ & P3BAMJ, R3BAMJ, S3BAMJ, BETMBJ, BETBBJ, BETMCH,
+ & BETBCH, BETMBT, BETBBT, BETMTP, BETBTP, ASBAMJ,
+ & B8BAMJ, P1BAMJ, P2BAMJ, ESTBMJ, DIQBMJ, POPBMJ,
+ & POLWBJ, POPEBJ, POPSBJ, PSSBMJ, DSSBMJ, PCCBMJ,
+ & DCCBMJ, PVCBMJ, UQMBMJ, DQMBMJ, CQMBMJ, SQMBMJ,
+ & BQMBMJ, TQMBMJ, QRKMSS (0:6), DM0BMJ, FM0BMJ,
+ & RM0BMJ, SM0BMJ, BM0BMJ, EM0BMJ, TM0BMJ, UR0BMJ,
+ & DR0BMJ, SR0BMJ, UUUBMJ, SUUBMJ, SSUBMJ, SSSBMJ,
+ & B0CHBJ, BPCHBJ, C0CHBJ, CPCHBJ, CH3BMJ, BETPCH,
+ & IMPS (6,6), IMVE (6,6), IB08 (6,21),
+ & IB10 (6,21), IA08 (6,21), IA10 (6,21),
+ & LTBAMJ, LEBAMJ, ISUBAM, IPTBMJ, I3BAMJ, IE0BMJ,
+ & IUDBMJ, IKMBMJ, IPPBMJ, IFRBMJ, IM0BMJ, IVLBMJ,
+ & IQQBMJ, ITCHBJ, ICHBMJ
+
--- /dev/null
+*$ CREATE IOUNIT.ADD
+*COPY IOUNIT
+* *
+*=== iounit ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Iounit: included in any routine *
+* *
+* Created on 01 june 1990 by Alfredo Ferrari, INFN -Milan *
+* *
+* Last change on 20-jan-99 by Alfredo Ferrari *
+* *
+* lunin = standard input unit *
+* lunout = standard output unit *
+* lunerr = standard error unit *
+* lunber = input file for bertini nuclear data *
+* lunech = echo file for pegs dat *
+* lunflu = input file for photoelectric edges and X-ray fluo- *
+* rescence data *
+* lungeo = scratch file for combinatorial geometry *
+* lunpmf = input file for pegs material data *
+* lunran = output file for the final random number seed *
+* lunxsc = input file for low energy neutron cross sections *
+* lundet = output file for the detect option *
+* lunray = output file for ray-tracing options *
+* lunrdb = unit number for reading (extra) auxiliary external *
+* files to be closed just after reading *
+* lunrd2 = unit number for reading (extra) auxiliary external *
+* files to be closed just after reading *
+* lunscr = unit number to be used for temporary scratch files *
+* lunpgo = output file for plotgeom *
+* lunpgs = store (formatted/unformatted) file for plotgeom *
+* *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER ( LUNIN = 5 )
+* Start_VAX_seq
+* PARAMETER ( LUNOUT = 6 )
+* End_VAX_seq
+* Start_IBM_seq
+* PARAMETER ( LUNOUT = 6 )
+* End_IBM_seq
+* Start_UNIX_seq
+ PARAMETER ( LUNOUT = 11 )
+* End_UNIX_seq
+ PARAMETER ( LUNERR = 15 )
+ PARAMETER ( LUNBER = 14 )
+ PARAMETER ( LUNECH = 8 )
+ PARAMETER ( LUNFLU = 13 )
+ PARAMETER ( LUNGEO = 16 )
+ PARAMETER ( LUNPMF = 12 )
+ PARAMETER ( LUNRAN = 2 )
+ PARAMETER ( LUNXSC = 9 )
+ PARAMETER ( LUNDET = 17 )
+ PARAMETER ( LUNRAY = 10 )
+ PARAMETER ( LUNRDB = 1 )
+ PARAMETER ( LUNRD2 = 18 )
+ PARAMETER ( LUNPGO = 7 )
+ PARAMETER ( LUNPGS = 4 )
+ PARAMETER ( LUNSCR = 3 )
+
--- /dev/null
+*$ CREATE ISOTOP.ADD
+*COPY ISOTOP
+*
+*=== isotop ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* *
+* Created on 23 september 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 17-dec-96 by Alfredo Ferrari *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* Isondx = Initial and final indexes in the abuiso and isomnm *
+* for a given atomic number *
+* Isomnm = Mass numbers of the isotopes *
+* Abuiso = Natural abundances of the isotopes *
+* Astlin(1,iz) = "average" A of the stability line versus the *
+* atomic number Z *
+* Astlin(2,iz) = Dispersion of A of the stability line versus *
+* the atomic number Z *
+* Zstlin(1,ia) = "average" Z of the stability line versus the *
+* mass number A *
+* Zstlin(2,ia) = Dispersion of Z of the stability line versus *
+* the mass number A *
+* Amssst(iz) = Atomic weight of iz_th element according to *
+* the tabulated mass tables *
+* Waps (ia,iz) = Atomic excess mass (MeV), for mass number Ia *
+* and atomic number given by Z = Z_start+Iz-1, *
+* where Z_start is stored into Inwaps (ia) *
+* T12nuc(ia,iz) = Half-life (s) for mass number Ia and Z like *
+* for Waps *
+* Brdecy(ia,iz) = Branching ratio for the first decay channel, *
+* for mass number Ia and Z like for Waps *
+* Jspnuc(ia,iz) = Spin (hbar/2 units) for mass number Ia and Z *
+* like for Waps *
+* Jptnuc(ia,iz) = Parity for mass number Ia and Z like for Waps *
+* Idcnuc(k,ia,iz) = k_th (k=1,2) decay channel for mass number Ia *
+* and Z like for Waps *
+* Wapism (ism) = Atomic excess mass (MeV) of the ism_th isomer *
+* T12ism (ism) = Half-life (s) of the ism_th isomer *
+* Wapism (ism) = Atomic excess mass of the ism_th isomer *
+* Bdcism (ism) = Branching ratio for the first decay channel *
+* of the ism_th isomer *
+* Jspism (ism) = Spin (hbar/2 units) of the ism_th isomer *
+* Jptism (ism) = Parity (hbar/2 units) of the ism_th isomer *
+* Idcism(k,ism) = k_th (k=1,2) decay channel for the ism_th *
+* isomer *
+* Inwism (ia) = (Cumulative) number of isomers with mass *
+* number =< Ia *
+* IdcydA (j) = Delta-A for the j_th type decay channel *
+* IdcydZ (j) = Delta-Z for the j_th type decay channel *
+* *
+* Decay channel index: *
+* *
+* -1: Unknown *
+* 0: Stable *
+* 1: IT Internal Transition *
+* 2: A Alpha *
+* 3: N Neutron emission *
+* 4: P Proton emission *
+* 5: 2P Proton + Proton emission *
+* 6: 12C 12-C emission *
+* 7: 14C 14-C emission *
+* 8: B+ Beta+ *
+* 9: EC Electron Capture *
+* 10: ECP Electron Capture + Proton *
+* 11: ECA Electron Capture + Alpha *
+* 12: EC2P Electron Capture + Proton + Proton *
+* 13: EC2A Electron Capture + Alpha + Alpha *
+* 14: ECF Electron Capture + Fission *
+* 15: B- Beta- *
+* 16: B-N Beta- + Neutron *
+* 17: B-A Beta- + Alpha *
+* 18: B-2N Beta- + Neutron + Neutron *
+* 19: B-NA Beta- + Neutron + Alpha *
+* 20: B-2A Beta- + Alpha + Alpha *
+* 21: B-B- Beta- + Beta- *
+* 22: SF Spontaneous Fission *
+* *
+*----------------------------------------------------------------------*
+*
+* PARAMETER ( NAMSMX = 250 )
+* PARAMETER ( NZGVAX = 10 )
+*
+ PARAMETER ( NAMSMX = 270 )
+ PARAMETER ( NZGVAX = 16 )
+* Maximum number of isomers:
+ PARAMETER ( NISMMX = 591 )
+* Maximum number of types of decay channels:
+ PARAMETER ( NDCYMX = 22 )
+ COMMON / ISOTOP / WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
+ & BRDECY (NAMSMX,NZGVAX), WAPISM (NISMMX),
+ & T12ISM (NISMMX), BRDISM (NISMMX),
+ & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
+ & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
+ & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
+ & IDCNUC (2,NAMSMX,NZGVAX), INWAPS (NAMSMX),
+ & JSPISM (NISMMX), JPTISM (NISMMX),
+ & IDCISM (2,NISMMX), IZWISM (NISMMX),
+ & INWISM (0:NAMSMX), IDCYDZ (NDCYMX),
+ & IDCYDA (NDCYMX)
+ COMMON / CHISTP / CHDECY (NDCYMX)
+ CHARACTER CHDECY*5
+
--- /dev/null
+*$ CREATE KAXSCM.ADD
+*COPY KASXCM
+*
+*=== Kaxscm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 12 january 2000 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 16-sep-00 by Alfredo Ferrari *
+* *
+* Xskpnc (i,k,n) = xsec for K+ N (mb), i is the momentum index, *
+* k the reaction index (1=el.,2=ine.), n the *
+* nucleon index (1=p,2=n) *
+* Xskmnc (i,k,n) = xsec for K- N (mb), i is the momentum index, *
+* k the reaction index (1=el.,2=ine.), n the *
+* nucleon index (1=p,2=n) *
+* Xsklnc (j,k,n) = xsec for KlongN (mb), j is the momentum index,*
+* k the reaction index (1=el.,2=ine.,3=reg.), *
+* n the nucleon index (1=p,2=n) *
+* Pkpmnc (i) = momenta (GeV/c) for K+/- N xsecs *
+* Pklonc (j) = momenta (GeV/c) for Klong N xsecs *
+* Pkpmax (l) = momenta (GeV/c) for K+/- A xsecs *
+* Pkloax (l) = momenta (GeV/c) for Klong A xsecs *
+* Akaxsc (m) = atomic weights for K's A xsecs *
+* A23kxs (m) = (atomic weights)^2/3 for K's A xsecs *
+* Xskpla (l,k,m) = xsec for K+ A (mb), l is the momentum index, *
+* k the reaction index (1=el.,2=ine.), m the *
+* target nucleus index *
+* Xskmia (l,k,m) = xsec for K- A (mb), l is the momentum index, *
+* k the reaction index (1=el.,2=ine.), m the *
+* target nucleus index *
+* Xskloa (l,k,m) = xsec for KlongA (mb), l is the momentum index,*
+* k the reaction index (1=el.,2=ine.,3=reg.), *
+* m the target nucleus index *
+* *
+* *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / KAXSCM / XSKPNC (6,2,2), XSKMNC (6,2,2), XSKLNC (7,3,2),
+ & PKPMNC (6), PKLONC (7), PKPMAX (10),
+ & PKLOAX (11), AKAXSC (7), A23KXS (7),
+ & XSKPLA (10,2,7), XSKMIA (10,2,7),
+ & XSKLOA (11,3,7)
+
--- /dev/null
+*$ CREATE LABCOS.ADD
+*COPY LABCOS
+* *
+*=== labcos ===========================================================*
+* *
+ COMMON /LABCOS/ COSLBP(3),COSLBR(3)
+
--- /dev/null
+*$ CREATE LANDAU.ADD
+*COPY LANDAU
+*
+*=== landau ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: landau (version for Fluka95 on) *
+* *
+* Created on 12 december 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 24-apr-97 by Alfredo Ferrari INFN-Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of variable(s) *
+* *
+* Landfl (m) = logical flag for restricted Landau fluctua- *
+* tions for the m_th Fluka medium for hadrons *
+* and muons *
+* Landhl (m) = logical flag for restricted Landau fluctua- *
+* tions for the m_th Fluka medium for EM par- *
+* ticles *
+* Ilvlfl = Cumulant level for restricted Landau fluct- *
+* uations for the m_th Fluka medium for hadr- *
+* ons and muons *
+* Ilvlhl = Cumulant level for restricted Landau fluct- *
+* uations for the m_th Fluka medium for EM *
+* particles *
+* Nerflk = Ermilova max term for restricted Landau fl- *
+* uctuations for the m_th Fluka medium for *
+* hadrons and muons *
+* Nerhlp = Ermilova max term for restricted Landau fl- *
+* uctuations for the m_th Fluka medium for EM *
+* particles *
+* Nkdgfl = K-edge max term for restricted Landau fl- *
+* uctuations for the m_th Fluka medium for *
+* hadrons and muons *
+* Nkdghl = K-edge max term for restricted Landau fl- *
+* uctuations for the m_th Fluka medium for EM *
+* particles *
+* *
+*----------------------------------------------------------------------*
+*
+* Fix to 7% the maximum energy loss in a (single) Landau/Vavilov step
+ PARAMETER ( ESTLAN = 0.07D+00 )
+ LOGICAL LANDFL, LANHLP, LANDA
+ COMMON / LANDAU / LANDFL (MXXMDF), LANHLP (MXXMDF), LANDA ,
+ & ILVLFL, ILVLHL, NERFLK, NERHLP, NKDGFL, NKDGHL
+
--- /dev/null
+*$ CREATE LBRCTR.ADD
+*COPY LBRCTR
+*
+*=== lbrctr ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* from/to LaBoratory to/from ReaCtion frame TRansformation *
+* *
+* Created on 18 february 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-dec-92 by Alfredo Ferrari *
+* *
+* Rrlfij = Rij rotation matrix for going from the reaction *
+* to the lab frame *
+* Rlrfij = R'ij rotation matrix for going from the lab to the *
+* reaction frame, of course R'ij=R-1ij *
+* U,V,Wangmo = direction cosines of the angular momentum in the *
+* lab frame (0,0,1 in the reaction frame) *
+* (uangmo=sinthaxcospha,vangmo=sinthaxsinpha,wangmo=costha)*
+* Rgiven = r of the given point *
+* Phigvn = phi of the given point *
+* Pgiven = momentum module at the given point *
+* Pphgvn = phi component of the momentum at the given point *
+* Pprgvn = r component of the momentum at the given point *
+* Phpgvn = phi of the momentum at the given point *
+* Egiven = Energy at the given point *
+* Vgiven = Potential at the given point *
+* Bgiven = impact parameter at the given point *
+* Cosgvn = cos (phigvn) *
+* Singvn = sin (phigvn) *
+* Cspgvn = cos (pphgvn) *
+* Snpgvn = sin (pphgvn) *
+* Angmom = angular momentum modulus *
+* Ppat00 = initial projectile momentum *
+* Epat00 = initial projectile total energy *
+* Biat00 = impact parameter at oo *
+* Phia00 = initial position angle *
+* Phpa00 = initial momentum angle *
+* Csph00 = cos (phpa00) *
+* Snph00 = sin (phpa00) *
+* Note that: *
+* cos (phia00) = cos (phpa00-pi) = - cos (phpa00) = - csph00 *
+* sin (phia00) = sin (phpa00-pi) = - sin (phpa00) = - snph00 *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( COUCST = COUGFM )
+ PARAMETER ( RPLABC = PLABRC )
+*
+ COMMON / LBRCTR / RRLF11, RRLF12, RRLF13, RRLF21, RRLF22, RRLF23,
+ & RRLF31, RRLF32, RRLF33, UANGMO, VANGMO, WANGMO,
+ & SINTA2, SINTHA, SINPHA, COSPHA, PGIVEN, PHPGVN,
+ & EGIVEN, VGIVEN, RGIVEN, BGIVEN, PHIGVN, PPAT00,
+ & PHPA00, EPAT00, BIAT00, PHIA00, COULPT, ANGMOM,
+ & PPHGVN, PPRGVN, PPHA00, PPRA00, COSGVN, SINGVN,
+ & CSPGVN, SNPGVN, CSPH00, SNPH00
+ EQUIVALENCE ( RLRF11, RRLF11 )
+ EQUIVALENCE ( RLRF12, RRLF21 )
+ EQUIVALENCE ( RLRF13, RRLF31 )
+ EQUIVALENCE ( RLRF21, RRLF12 )
+ EQUIVALENCE ( RLRF22, RRLF22 )
+ EQUIVALENCE ( RLRF23, RRLF32 )
+ EQUIVALENCE ( RLRF31, RRLF13 )
+ EQUIVALENCE ( RLRF32, RRLF23 )
+ EQUIVALENCE ( RLRF33, RRLF33 )
+ EQUIVALENCE ( COSTHA, WANGMO )
+
--- /dev/null
+*$ CREATE LI6PWX.ADD
+*COPY LI6PWX
+*
+*=== Li6pwx ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Li-6 Point-Wise Xsec common: *
+* *
+* Created on 27 may 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 26-mar-99 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Ekei1h (i) = initial kinetic energy (GeV) of the i_th *
+* tabulation range *
+* Elni1h (i) = natural logarithm of the initial kinetic *
+* energy (GeV) of the i_th tabulation range *
+* Dlni1h (i) = constant difference in the natural logarithm *
+* of the initial kinetic energy (GeV) of the *
+* i_th tabulation range *
+* Seln1h (j) = natural logarithm of the n 1-H elastic cross *
+* section at the j_th energy point *
+* Sabn1h (j) = natural logarithm of the n 1-H absorption *
+* cross section at the j_th energy point *
+* Clg21h (k,l) = l_th Legendre coefficient for the n 1-H *
+* elastic scattering angular distribution *
+* at the k_th energy point of the 2nd tabulation*
+* range *
+* Clg31h (k,l) = l_th Legendre coefficient for the n 1-H *
+* elastic scattering angular distribution *
+* at the k_th energy point of the 3rd tabulation*
+* range *
+* Npoi1h (i) = number of energy points of the i_th tabulation*
+* range *
+* Nlgi1h (i) = number of Legendre coeff. of the i_th tabula- *
+* tion range *
+* Nene1h = number of tabulation energy ranges *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / LI6PWX / EKE6LI (2) , ELN6LI (2) , DLN6LI (2) ,
+ & STT6LI (201) , STR6LI (201) , SPR6LI (201) ,
+ & SEL6LI (201) , SAB6LI (201) , CLE6LI (101,6),
+ & CLT6LI (101,6), BLI671 , ELI6NP ,
+ & NPO6LI (2) , NLG6LI (2) , NEN6LI
+
--- /dev/null
+*$ CREATE LNPWCG.ADD
+*COPY LNPWCG
+*
+*=== Lnpwcg ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Low energy Neutron Point-Wise Capture Gammas: *
+* *
+* Created on 27 may 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 12-apr-01 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Qpwsgc(i) = capture Q (virtual level) for the i_th point- *
+* wise capture gamma data set *
+* Expwgc(i) = maximum neutron energy up to which the i_th *
+* pointwise capture gamma data set can be used *
+* Kbgpwg(i) = starting location in the special common (0 *
+* address) for the i_th pointwise capture gamma *
+* data set *
+* Iazpwg(i) = isomer code for the i_th pointwise capture *
+* gamma data set *
+* Idpwgc(i) = index for a possible direct transition for the*
+* pointwise capture gamma data set *
+* Nmpwgc = number of defined pointwise cross section *
+* data sets *
+* Klpwgc = last used element in the Gwgcst array *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXPWGC = 1000 )
+*
+ COMMON / LNPWCG / GWGCST (MXPWGC), QPWSGC (MXXMDF),
+ & EXPWGC (MXXMDF), KBGPWG (MXXMDF), IAZPWG (MXXMDF),
+ & IDPWGC (MXXMDF), NMPWGC, KLPWGC
--- /dev/null
+*$ CREATE LOCSIG.ADD
+*COPY LOCSIG
+*
+*=== locsig ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Memory addresses for low energy neutron cross sections: *
+* *
+* ALL THE ADDRESSES ARE FOR INDEX OF ZERO !!!!!!!!!!!!!!!!!!! *
+* *
+* Istart = starting location for the total cross-section *
+* vector for the first medium (absolute address!!) *
+* *
+* Iscang = starting location for the array of the primary *
+* scattering angle matrix (absolute address!!) *
+* *
+* Ifspog = starting location of the primary downscatter *
+* probability matrix (absolute address!!) *
+* *
+* Ings = starting location of the indices for starting *
+* location of the downscatter vector for each *
+* group of primary particles (absolute address!!) *
+* *
+* Innn = starting location for the array of the number of *
+* downscatter groups for each primary group *
+* (absolute address!!) *
+* *
+* Iprbng = starting location of the primary scattering *
+* angle probability matrix (absolute address!!) *
+* *
+* Ifngp = starting location for the primary-secondary *
+* transfer probability matrix (absolute address!!) *
+* *
+* Isporg = size of storage needed for each medium *
+* *
+* Inabog = starting location for the non-absorption vector *
+* for the first medium (absolute address!!) *
+* *
+* Igabog = starting location for the gamma-ray production *
+* vector for the first medium (absolute address!!) *
+* *
+* Nsct = number of discrete angles *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON/LOCSIG/ISTART,ISCCOG,INABOG,IGABOG,IFPORG,IFNGP,IFSPOG,
+ 1 IDSGOG,IPRBNG,IPRBGG,ISCANG,ISCAGG,ISPORG,ISPORT,INPBUF,
+ 2 ISIGOG,INFPOG,IABSOG,ITOTSG,NGP,NDS,NGG,NDSG,INGP,INDS,
+ 3 NMED,NELEM,NMIX,NCOEF,NSCT,NTS,NTG,NDSNGP,NDSNGG,IADJ,
+ 4 NME,LOC,INGS,INSG,I1,I0, KKK,IXTAPE,IDEL,ITEML,ITEMG,IRSG,
+ 5 IRDSG,ISTR,IPRIN,IFMU,IMOM,IDTF,ISTAT,IPUN
+ 6 ,NUS,NGN,IHT,INUS,INUSN,INGN,INGNP,INNN,IGGG
+
--- /dev/null
+*$ CREATE LOWNEU.ADD
+*COPY LOWNEU
+*
+*=== lowneu ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created by Alfredo Ferrari on 6 july 1990 *
+* *
+* Last change on 27-may-97 by Alfredo Ferrari, INFN - Milan *
+* *
+* Lowneu: contains data for the low energy neutron transport *
+* *
+* Included in the following routines: *
+* *
+* Bdnopt *
+* Blnset *
+* Deflts *
+* Epilog *
+* Eveneu *
+* Fluka *
+* Kasneu *
+* Lowres *
+* Lowset *
+* Nsigta *
+* Prolog *
+* Usrbdx *
+* Usrtrk *
+* Usrcll *
+* Xsprnt *
+* Xsread *
+* Zeroin *
+* *
+* Description of the variables: *
+* *
+* Igrthn = number of thermal neutron groups, the groups from *
+* Nmgp - Igrthn + 1 up to Nmgp are considered to be *
+* thermal ones. After initialization it is transfor-*
+* med into the absolute group index of the first *
+* thermal group, that is, Nmgp - Igrthn + 1 *
+* Tmrtln (im) = Temperature ratio with respect to the nominal one *
+* for FLUKA medium im *
+* Tmnmln (im) = Nominal temperature for FLUKA medium im *
+* Igtmrt (im) = First (thermal) group where to apply Tmrtln (must *
+* be such that it is not larger than Nmgp to be *
+* meaningful) for FLUKA medium im. After initializa-*
+* tion it is transformed in absolute group number *
+* Vllnth (ig,im) = Velocity (cm/s) for ig_th thermal group for im_th *
+* FLUKA medium (im=0 means reference 293 K) *
+* This is the average over dN_Maxwell/dv which over *
+* [0,oo) gives v_0 x 2 / sqrt(pi), where v_0 is gi- *
+* ven by: v_0 = sqrt(2KT/m) x c_light *
+* Enlnth (ig,im) = Kinetic energy (GeV) for ig_th thermal group for *
+* the reference 293 K temperature. *
+* This is the average over dN_Maxwell/dE which over *
+* [0,oo) gives 3/2 KT, where the average on the flux*
+* is given by KT *
+* Ablnth (ig,im) = Absorption (and gamma generation) modifying factor*
+* for ig_th thermal group for im_th FLUKA medium *
+* Stlnth (ig,im) = Total cross section modifying factor for ig_th *
+* thermal group for im_th FLUKA medium *
+* Icnmed(mm) = Continuos energy index for the mm_th Morse *
+* medium (if any, =<0 means no information) *
+* Klnrnc(mm) = starting location (0 index) in blank common of *
+* residual nuclei informations for the mm_th Morse *
+* medium (if any, <0 means no information) *
+* Ipwsgc(mm) = index of a (possible) pointwise capture gamma data*
+* set for the mm_th Morse medium (if any, =0 means *
+* no information) *
+* Fnadef = default non-analogue absorption factor to be *
+* applied to neutron groups from nmgp-ngnaof to nmgp*
+* Ngnaof = see above *
+* Lpwxsc = flag for using pointwise cross sections and/or *
+* explicit (n,gamma) generation when available *
+* Lnfcrt = flag for neutron fission criticality problems. It *
+* simply forces the number of fission neutrons to *
+* be 1 with a proper weight *
+* *
+*----------------------------------------------------------------------*
+* Minimum energy for (possible) point-wise treatments:
+ PARAMETER ( ENCNMN = 0.00001 D+00 )
+* Maximum number of thermal neutron groups:
+ PARAMETER ( MXGTHN = 15 )
+* Maximum neutron group number:
+ PARAMETER ( MXGLWN = 200 )
+* Maximum neutron weight profiles:
+ PARAMETER ( MXSHPP = 5 )
+*
+ LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET,
+ & LPWXSC, LNFCRT
+ CHARACTER*10 TITLOW
+ COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
+ & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
+ & VLLNTH (MXGTHN,0:MXXMDF), ENLNTH (MXGTHN),
+ & ABLNTH (MXGTHN,MXXMDF), STLNTH (MXGTHN,MXXMDF),
+ & TMRTLN (MXXMDF), FNADEF,
+ & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
+ & IGTMRT (MXXMDF), NEUMED (MXXMDF),
+ & ID1MED (MXXMDF), ID2MED (MXXMDF),
+ & ID3MED (MXXMDF), MGTMED (MXXMDF),
+ & LCOMPN (MXXMDF), LRECPR (MXXMDF),
+ & ICNMED (MXXMDF), KLNRNC (MXXMDF),
+ & IPWSGC (MXXMDF), KPRLOW, NMGP, NMTG , IGRTHN,
+ & LIMPRN, LBIASN, LDOWNN, LLOWWW, LLOWET, ICLMED,
+ & IKRBGN, INABGN, IDWBGN, IETBGN, I0XSEC, IDXSEC,
+ & ISENAV, ISVELN, ISPNAV, IWWLWB, IWWLWT, IPXBGN,
+ & NPXSEC, NGNAOF, LPWXSC, LNFCRT
+ COMMON / CHLWNT / TITLOW (MXXMDF)
+
--- /dev/null
+*$ CREATE LTCLCM.ADD
+*COPY LTCLCM
+*
+*=== ltclcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* LaTtice CeLl CoMmon: *
+* *
+* Created on 09 december 1993 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-dec-93 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
+
--- /dev/null
+*$ CREATE LWNPWX.ADD
+*COPY LWNPWX
+*
+*=== Lwnpwx ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* LoW energy Neutron Point-Wise Xsec common: *
+* *
+* Created on 27 may 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 22-jan-01 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Kscpwx(j,i) = id. of the jth particle produced in the i_th *
+* reaction channel (gammas not included!) *
+* Kbgpwx(i) = starting location in blank common (i*4, 0 *
+* address) for the i_th pointwise cross section *
+* data set *
+* Kelpwx(i) = starting location in blank common (i*4, 0 *
+* address) for the elastic scattering data of *
+* the i_th pointwise cross section data set *
+* Iazpwx(i) = isomer code for the i_th pointwise cross *
+* section data set *
+* Ktmpwx(i) = temperature (K) for the i_th pointwise cross *
+* section data set *
+* Nrcpwx(i) = number of reactions for the i_th pointwise *
+* cross section data set *
+* Nellcf(i) = number of Legendre coefficients for the i_th *
+* pointwise cross section data set *
+* Nelsen(i) = number of energy points for elastic scattering*
+* angular distributions for the i_th pointwise *
+* cross section data set *
+* Nnglev(i) = number of energy levels (ground state is taken*
+* as level #Nrclev) to be considered for radia- *
+* tive capture for the i_th pointwise cross *
+* section data set *
+* Kngpwx(i) = starting location in blank common (i*4, 0 *
+* address) for the radiative capture data of *
+* the i_th pointwise cross section data set *
+* The data consist of Nnglev(i) energy levels *
+* (ground state included) followed by a matrix *
+* M(k,j), k=1,Nnglev(i), j=1,Nnglev(i)+1 *
+* containing the probabilities for going from *
+* level m=j-1 (m=0 -> virtual capture level) to *
+* level k *
+* Ninlev(i) = number of energy levels to be considered for *
+* inelastic scattering for the i_th pointwise *
+* cross section data set *
+* Kinpwx(i) = starting location in blank common (i*4, 0 *
+* address) for the inelastic scattering data of *
+* the i_th pointwise cross section data set *
+* The data consist of Ninlev(i) energy levels *
+* Ninlen(i) = number of energy points for inelastic scatter-*
+* ing for the i_th pointwise cross section data *
+* set *
+* Nmpwxs = number of defined pointwise cross section *
+* data sets *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXRPWX = 76 )
+ PARAMETER ( KPWXTT = 1 )
+ PARAMETER ( KPWXEL = 2 )
+ PARAMETER ( KPWXIN = 3 )
+ PARAMETER ( KPWXFS = 5 )
+ PARAMETER ( KPWXCP = 6 )
+ PARAMETER ( KPWX1S = 7 )
+ PARAMETER ( KPWXCO = 47 )
+*
+ COMMON / LWNPWX / KSCPWX (4,MXRPWX),
+ & KBGPWX (MXXMDF), KELPWX (MXXMDF),
+ & IAZPWX (MXXMDF), KTMPWX (MXXMDF), NRCPWX (MXXMDF),
+ & NELLCF (MXXMDF), NELSEN (MXXMDF), NNGLEV (MXXMDF),
+ & KNGPWX (MXXMDF), NINLEV (MXXMDF), KINPWX (MXXMDF),
+ & NINLEN (MXXMDF), NMPWXS
+ COMMON / LCHPWX / CHRPWX (MXRPWX)
+ CHARACTER*8 CHRPWX
+
+
+
--- /dev/null
+*$ CREATE MAGPAR.ADD
+*COPY MAGPAR
+* *
+*----------------------------------------------------------------------*
+* include file: magpar copy created 26/11/86 by p*
+* *
+* Last change on 16-jan-92 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /magpar/ contains information about the magnetic/electric fields *
+* bifcom = strength of the homogenous magnetic field (tesla) *
+* btxcom = direction cosines *
+* btycom = = *
+* btzcom = = *
+* elfcom = strength of the homogenous electric field *
+* (kV/cm=MV/m) *
+* etxcom = direction cosines *
+* etycom = = *
+* etzcom = = *
+* delfld = maximum tolerable error of the boundary iteration *
+* both for electric/magnetic transport (cm) *
+* anglmg = biggest angle that particle is allowed to travel *
+* in the magnetic field (deg) *
+* dstpmg = guarantees that step is not forced to be too small. *
+* (if suggested angle is too big, magnetic only) *
+* rkrfra = max. fraction of a 2 pi angle allowed for a single *
+* Runge-Kutta step in magnetic field *
+* dmgfrk = maximum step length with magnetic field if Runge- *
+* -Kutta integration is selected, used only in zones of*
+* zero local field *
+* delfrk = maximum step length with electric field for Runge- *
+* -Kutta integration *
+* denelf = energy gained or lost in the electric field *
+* Lfmgel = flag for first time initialization *
+* Lrkuti = flag for selecting Runge-Kutta integration for an *
+* inhomogeneous magnetic field and no electric field *
+* Runge-Kutta is always selected if an electric field *
+* is present. *
+* Direct constant radius tracking is always selected *
+* only an homogeneous magnetic field is present *
+* Lmgmap = flag for inhomogeneous magnetic field *
+* Lelmap = flag for inhomogeneous electric field *
+* magnon(j) = true if region j has a magnetic field *
+* lelfon(j) = true if region j has an electric field *
+* *
+* Mxxrgn = maximum number of regions *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL MAGNON, LELFON, LFMGEL, LRKUTI, LMGFLD, LELFLD, LMGMAP,
+ & LELMAP, LRKUTT
+ COMMON / MAGPAR / BIFCOM, ELFCOM, BTXCOM, BTYCOM, BTZCOM, ETXCOM,
+ & ETYCOM, ETZCOM, DELFLD, ANGLMG, DSTPMG, RKRFRA,
+ & DMGFRK, DELFRK, DEL000, ONMCTH, ANGLRK, ONMCRK,
+ & DMINMN, DENELF, LFMGEL, LRKUTI, LMGFLD, LELFLD,
+ & LMGMAP, LELMAP, LRKUTT, MAGNON (MXXRGN),
+ & LELFON (MXXRGN)
+
--- /dev/null
+*$ CREATE MAPA.ADD
+*COPY MAPA
+*
+*=== Mapa =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: mapa copy *
+* *
+* !!! Change also mapa2 if you touch this file !!! *
+* *
+* Version for Fluka91/.../99: *
+* *
+* Last change on 14-may-99 by Alfredo Ferrari, INFN-Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* /mapa/ contains the parameters describing the target materials *
+* *
+* Matnam = matnam(i)=name of the material number i *
+* Medium = medium(nreg)=material number of the region nreg *
+* Amss = material atomic weight *
+* Amssem = "effective" material atomic weight for the parametri-*
+* zed EM cascade *
+* Aocmbm = atomic densities in barn**-1 cm**-1 *
+* (Atoms Over Cm times Barn for Materials) *
+* Ztar = material atomic number *
+* Ztarem = "effective" material atomic number for the parametri-*
+* zed EM cascade *
+* Rho = densities of the materials *
+* Zlin = inelastic scattering lengths of the materials *
+* for beam particles at the average beam energy in cm *
+* Zlel = elastic scattering lengths of the materials for *
+* beam particles at average beam energy in cm *
+* Zlrad = radiation lengths of the materials in cm *
+* Zul = inelastic scattering lengths of the materials *
+* for neutrons at threshold energy in cm *
+* Mulflg = flags for multiple scattering options *
+* Icomp = 0 if the material is not a compound *
+* Mssnum = mass number of the target nucleus, if =< 0 it means *
+* that it is in the natural isotopic composition *
+* Msindx = index for tabulations for the given isotope of the *
+* target nucleus (meaningful only for mssnum > 0) *
+* that it is in the natural isotopic composition *
+* Nregs = total number of the regions *
+* Nmat = total number of the materials *
+* Mtbsnm = medium for which inelastic interaction biasing must *
+* be done *
+* *
+* Mxxrgn = maximum number of regions *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 MATNAM
+ COMMON / MAPA / AOCMBM(MXXMDF), AMSS (MXXMDF), AMSSEM(MXXMDF),
+ & RHO (MXXMDF), ZTAR (MXXMDF), ZTAREM(MXXMDF),
+ & ZLIN (MXXMDF), ZLEL (MXXMDF), ZLRAD (MXXMDF),
+ & ZUL (MXXMDF), MEDIUM(MXXRGN), MULFLG(MXXMDF),
+ & ICOMP (MXXMDF), MSSNUM(MXXMDF), MSINDX(MXXMDF),
+ & NREGS, NMAT, MTBSNM
+ COMMON / CHMAPA / MATNAM(MXXMDF)
+
--- /dev/null
+*$ CREATE MAPA2.ADD
+*COPY MAPA2
+*
+*=== Mapa2 ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: mapa2 copy *
+* *
+* !!! Change also mapa if you touch this file !!! *
+* *
+* Version for Fluka91/.../99: *
+* *
+* Last change on 14-may-99 by Alfredo Ferrari, INFN-Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* *
+* /mapa/ contains the parameters describing the target materials *
+* *
+* Matnam = matnam(i)=name of the material number i *
+* Medium = medium(nreg)=material number of the region nreg *
+* Amss = material atomic weight *
+* Amssem = "effective" material atomic weight for the parametri-*
+* zed EM cascade *
+* Aocmbm = atomic densities in barn**-1 cm**-1 *
+* (Atoms Over Cm times Barn for Materials) *
+* Ztar = material atomic number *
+* Ztarem = "effective" material atomic number for the parametri-*
+* zed EM cascade *
+* Rrho = densities of the materials *
+* Zlin = inelastic scattering lengths of the materials *
+* for beam particles at the average beam energy in cm *
+* Zlel = elastic scattering lengths of the materials for *
+* beam particles at average beam energy in cm *
+* Zlrad = radiation lengths of the materials in cm *
+* Zul = inelastic scattering lengths of the materials *
+* for neutrons at threshold energy in cm *
+* Mulflg = flags for multiple scattering options *
+* Icomp = 0 if the material is not a compound *
+* Mssnum = mass number of the target nucleus, if =< 0 it means *
+* that it is in the natural isotopic composition *
+* Msindx = index for tabulations for the given isotope of the *
+* target nucleus (meaningful only for mssnum > 0) *
+* that it is in the natural isotopic composition *
+* Nregs = total number of the regions *
+* Nmat = total number of the materials *
+* Mtbsnm = medium for which inelastic interaction biasing must *
+* be done *
+* *
+* Mxxrgn = maximum number of regions *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 MATNAM
+ COMMON / MAPA / AOCMBM(MXXMDF), AMSS (MXXMDF), AMSSEM(MXXMDF),
+ & RRHO (MXXMDF), ZTAR (MXXMDF), ZTAREM(MXXMDF),
+ & ZLIN (MXXMDF), ZLEL (MXXMDF), ZLRAD (MXXMDF),
+ & ZUL (MXXMDF), MEDIUM(MXXRGN), MULFLG(MXXMDF),
+ & ICOMP (MXXMDF), MSSNUM(MXXMDF), MSINDX(MXXMDF),
+ & NREGS, NMAT, MTBSNM
+ COMMON / CHMAPA / MATNAM(MXXMDF)
+
--- /dev/null
+*$ CREATE MCSHLP.ADD
+*COPY MCSHLP
+*
+*=== mcshlp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file Multiple Coulomb Scattering HeLP: *
+* *
+* Created on 26 october 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 15-nov-95 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LSMPAN, LSTMN , LPLC , LACLDA
+ COMMON / MCSHLP / UOLD , VOLD , WOLD , SINT02, SINTH0, COSPH0,
+ & SINPH0, COSTHE, SINTHE, COSPHI, SINPHI, COSETA,
+ & SINETA, UPRIME, VPRIME, UIPRIM, VIPRIM, LSMPAN,
+ & LSTMN , LPLC , LACLDA
+
--- /dev/null
+*$ CREATE MEDIA.ADD
+*COPY MEDIA
+*
+*=== media ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Last change on 24-apr-97 by Alfredo Ferrari, INFN-Milan *
+* *
+* Commons Fxtmx, Media and Mediac for EMF *
+* Common Fxtmx is used for the fractional fixed step option *
+* Any change in common Fxtmx must be done also in the module Fxtmx *
+* of Egsadd!!!!!!!!!!!!!!!! *
+* Mxxmde = maximum number of media in Emf *
+* Estepe = maximum fractional energy loss allowed for the gi- *
+* ven medium *
+* Ltmin = logical array to flag whether or not has the step *
+* to be larger or equal than the minimum allowed *
+* by Moliere's theory, regardless of the energy loss: *
+* default is .true. *
+* *
+*----------------------------------------------------------------------*
+*
+* Fix to 7% the maximum energy loss in a (single) Landau/Vavilov step
+ PARAMETER ( ESTLEM = 0.07D+00 )
+ LOGICAL LTMIN, LFXTMX, LPEMDT, LXFLUO, LEMFLA
+ COMMON /FXTMX/ ESTEPE (MXXMDE), ISTPE (MXXMDE), LTMIN (MXXMDE),
+ & LPEMDT (MXXMDE), LFXTMX
+ COMMON /MEDIA/ RLC (MXXMDE), RLDU (MXXMDE), RHO (MXXMDE),
+ & AIPEMF (MXXMDE), D0DEMF (MXXMDE),
+ & MSGE (MXXMDE), MGE (MXXMDE), MSEKE (MXXMDE),
+ & MEKE (MXXMDE), MLEKE (MXXMDE), MCMFP (MXXMDE),
+ & MRANGE (MXXMDE), IRAYLM (MXXMDE), LXFLUO (MXXMDE),
+ & IEKEDG (MXXMDE), LEMFLA (MXXMDE), NMED , ILVLEM ,
+ & NEREMF, NKDGEM
+ COMMON /MEDIAC/ MEDIA(24,MXXMDE)
+ CHARACTER*4 MEDIA
+
--- /dev/null
+*$ CREATE METLSP.ADD
+*COPY METLSP
+*
+*=== Metlsp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of Metlsp: *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-dec-97 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Cxs(i) = X-cosine of the i_th produced particle *
+* Cys(i) = Y-cosine of the i_th produced particle *
+* Czs(i) = Z-cosine of the i_th produced particle *
+* Els(i) = Total energy of the i_th produced particle *
+* Pls(i) = Momentum of the i_th produced particle *
+* Ams(i) = Mass of the i_th produced particle *
+* Its(i) = Identity (part scheme) of the i_th produced particle *
+* Ichns(3,i) = Array containing additional information about pro- *
+* duction verteces, ranking etc *
+* Is = Number of produced particles *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / METLSP / CXS (MXPDPM), CYS (MXPDPM), CZS (MXPDPM),
+ & ELS (MXPDPM), PLS (MXPDPM), AMS (MXPDPM),
+ & ITS (MXPDPM), ICHNS (3,MXPDPM), IS
+
--- /dev/null
+*$ CREATE MGDDCM.ADD
+*COPY MGDDCM
+*
+*=== mgddcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* MGDraw Dump CoMmon: *
+* *
+* Last change on 06-jul-00 by Alfredo Ferrari, INFN - Milan *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* iodraw = logical unit for the output of the trajectory/energy*
+* deposition dump *
+* lddraw = logical flag for the trajectory/continuos energy *
+* deposition dumping *
+* ledraw = logical flag for the "on spot" energy deposition *
+* dumping *
+* lsdraw = logical flag for source particle dumping *
+* ludraw = logical flag for calling the dumping routine for *
+* user events *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LDDRAW, LEDRAW, LSDRAW, LUDRAW
+ CHARACTER CFDRAW*10
+ COMMON / MGDDCM / IODRAW, LDDRAW, LEDRAW, LSDRAW, LUDRAW
+ COMMON / CHMGDD / CFDRAW
+
--- /dev/null
+*$ CREATE MISC.ADD
+*COPY MISC
+*----------------------------------------------------------------------*
+* *
+* Common Misc for EMF *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /MISC/ RHOR(MXXRGN), DUNIT, EMREJE, EMSAMP, EMSNGL, KMPI,
+ & KMPO, NOSCAT, MED(MXXRGN), IRAYLR(MXXRGN), NRGEMF,
+ & NOLLDA
+
--- /dev/null
+*$ CREATE MULBOU.ADD
+*COPY MULBOU
+*
+*=== mulbou ==========================================================*
+*
+*---------------------------------------------------------------------*
+* *
+* Module MULBOU: *
+* *
+* Last change A. Ferrari 21-jan-1999 *
+* Created on 26-05-1991 by A. Ferrari, Infn-Milan *
+* *
+* Included in: *
+* BDNOPT *
+* COMFAR *
+* COMMTR *
+* ELECTR *
+* EMFGEO *
+* EMFLNK *
+* EMFSCO *
+* GEOFAR *
+* GEOMTR *
+* G1 *
+* KASHEA *
+* KASKAD *
+* KASNEU *
+* KASRAY *
+* LBXRFL *
+* MAGEAS *
+* MAGMOV *
+* MAGNEW *
+* MOVE *
+* PHOTON *
+* *
+*---------------------------------------------------------------------*
+*
+ LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR,
+ & LSNSCT, LPLGNL, LNWGHS, LMAGEA
+ COMMON / MULBOU / XOLD , YOLD , ZOLD , XMIDDL, YMIDDL, ZMIDDL,
+ & UMIDDL, VMIDDL, WMIDDL, PSTEP1, PSTEP2,
+ & UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
+ & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
+ & XNORML, YNORML, ZNORML, TSENSE, DDSENS, DSMALL,
+ & TSLTTC (0:2000),
+ & MULTTC (0:2000), NSSENS, NULTTC, IPLGNL,
+ & LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE,
+ & LMGNOR, LSNSCT, LPLGNL, LNWGHS, LMAGEA
+
--- /dev/null
+*$ CREATE MULHD.ADD
+*COPY MULHD
+*
+*=== mulhd ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common mulhd for the new multiple scattering in Fluka *
+* created by A. Ferrari & P. Sala on 23-oct-1989 *
+* *
+* Last change on 18-jun-97 by Alfredo Ferrari, INFN-Milan *
+* included in: *
+* bdnopt *
+* epilog *
+* flukam *
+* hmulrt *
+* kaskad *
+* mulhad *
+* mulmix *
+* stepop *
+* *
+* Mxxmdf = maximum number of media *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXXPT1 = 1 )
+* PARAMETER ( TIMESS = 3.00D+00 )
+ PARAMETER ( TIMESS = 2.00D+00 )
+* Tmsrlx: times "relaxed" if the nuclear finite size correction must
+* not be taken into account
+* PARAMETER ( TMSRLX = 2.00D+00 )
+ PARAMETER ( TMSRLX = 1.50D+00 )
+* PARAMETER ( EPSINS = 0.10D+00 )
+ PARAMETER ( EPSINS = 0.15D+00 )
+* Epsrlx: epsins "relaxed" if the nuclear finite size correction must
+* not be taken into account
+* PARAMETER ( EPSRLX = 0.15D+00 )
+ PARAMETER ( EPSRLX = 0.50D+00 )
+* Sqepsn = sqrt (epsins)
+* PARAMETER ( SQEPSN = 0.3162277660168379 D+00 )
+ PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
+* Sqepsr = sqrt (epsrlx)
+* PARAMETER ( SQEPSR = 0.3872983346207417 D+00 )
+ PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
+ PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
+ PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
+* PARAMETER ( R0NCMS = 1.12 D+00 )
+ PARAMETER ( R0NCMS = 1.20 D+00 )
+ LOGICAL LTOPT, LSRCRH, LNSCRH, LHFANO, LMLRGH
+*
+ COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
+ & FANOLC ( MXXMDF ), ZDFANO ( MXXMDF ),
+ & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
+ & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
+ & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
+ & XR0 ( MXXMDF ), ECUTM ( MXXMDF, -6:NALLWP,2),
+ & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, -6:NALLWP ),
+ & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
+ & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
+ & HMREJE, HMSNGL,
+ & LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
+ & LTOPT ( MXXMDF ), LHFANO ( MXXMDF ),
+ & NFSCAT, NFLLDA, LMLRGH, MULPRI, MULSEC
+
--- /dev/null
+*$ CREATE MULTS.ADD
+*COPY MULTS
+*
+*=== Mults ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common Mults for EMF *
+* Mxxmde = maximum number of media in Emf *
+* (Alpfsc = alpha, fine structure constant = 1/137) *
+* Ztilde = "effective" Zeta for the spin relativistic correc- *
+* tion *
+* Alpztl = Alpfsc * Ztilde *
+* Alpzt2 = Alpztl **2
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LSRCRE, LNSCRE, LMLRGE
+ COMMON /MULTS/ ZTILDE (MXXMDE), ALPZTL (MXXMDE), ALPZT2 (MXXMDE),
+ & AE1O3E (MXXMDE), B0G21 , B1G21 , G210(7), G211(7),
+ & G212(7), B0G22 , B1G22 , G220(8), G221(8), G222(8),
+ & B0G31, B1G31 , G310(11), G311(11), G312(11), B0G32,
+ & B1G32, G320(25), G321(25), G322(25), B0BGB , B1BGB,
+ & BGB0(8), BGB1(8), BGB2(8), FUDEMF (MXXMDE),
+ & LSRCRE (MXXMDE), LNSCRE (MXXMDE), LMLRGE (-1:1),
+ & NG21, NG22, NG31, NG32, NBGB
+
--- /dev/null
+*$ CREATE NCDNVP.ADD
+*COPY NCDNVP
+*
+*=== ncdnvp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Used only by PReequilibrium INitialization routines *
+* *
+* Created on 22 june 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 02-oct-95 by Alfredo Ferrari *
+* *
+* Rhapsf (i,l) = a (skin) parameter for the density distribution, *
+* or s-shell armonic oscillator constant (a_s) for *
+* nuclei using shell model density distributions *
+* already including (possible) folding distributions*
+* Rhcpsf (i,l) = c (R1/2) parameter for the density distribution, *
+* or p-shell armonic oscillator constant (a_p) for *
+* nuclei using shell model density distributions *
+* already including (possible) folding distributions*
+* Rh0psf (i,l) = Rh0 (central density) parameter for the density *
+* distribution, or p-shell armonic oscillator *
+* constant (a_p) for nuclei using shell model dens- *
+* ity distributions NOT including (possible) fold- *
+* ing distributions *
+* Rhcesf (i,l) = Rhocen, central density for the p/n density *
+* distribution *
+* Rhrdsf (i,l) = radius at which the i,l density distribution drops*
+* at Rhfrsf (i,l) times the central value *
+* Rrmssf (i,l) = r-rms (<r^2>) parameter for the density distri- *
+* bution *
+* Rreqsf (i,l) = equivalent sharp sphere radius for the density *
+* distributions *
+* ( i = 1 : proton, i = 2 : neutron *
+* l = 1 charge (matter) proton (neutron) distribu- *
+* tion, integral = Z (N) *
+* l = 2 point/centre proton or neutron distribu- *
+* tion, folded with folrms, integral = Z (N) *
+* l = 3 point/centre proton or neutron distribu- *
+* tion, folded with folrms, integral = Z (N) *
+* l = 4 point/centre proton or neutron distribu- *
+* tion, folded with folrms, integral = Z (N) *
+* l = 5 point/centre proton (neutron) distribution, *
+* integral = Z (N) *
+* l = 6 proton (neutron) distribution, folded for *
+* pion potential, integral = Z (N) ) *
+* Sshlnc (i) = Number of nucleons of type i in the s shell (for *
+* shell model like calculations, i = 1 : proton, *
+* i = 2 : neutron ) *
+* Pshlnc (i) = Number of nucleons of type i in the p shell (for *
+* shell model like calculations, i = 1 : proton, *
+* i = 2 : neutron ) *
+* Vpapsf (i,k) = a (skin) parameter for the potential distribution *
+* or s-shell armonic oscillator constant (a_s) for *
+* nuclei using shell model density like potential *
+* distributions already including (possible) fold- *
+* ing distributions *
+* Vpcpsf (i,k) = c (R1/2) parameter for the potential distribution *
+* or p-shell armonic oscillator constant (a_p) for *
+* nuclei using shell model density like potential *
+* distributions already including (possible) fold- *
+* ing distributions *
+* Vp0psf (i,k) = Vp0 (central potential) parameter for the poten- *
+* tial distribution distribution, or p-shell armo- *
+* nic oscillator constant (a_p) for nuclei using *
+* shell model density distributions NOT including *
+* (possible) folding distributions *
+* Vpdpsf (i,k) = Vp (central potential) depth for the potential *
+* distribution *
+* Vpedsf (i,k) = Vp "edge" depth at the nucleus p/n radius *
+* Vprdsf (i,k) = Radius defining the potential "edge" *
+* Rcvpsf (i,k) = correlation r_0 for saturation correction for po- *
+* tential distributions *
+* Vpbpsf (i,k) = b (skin-like) parameter for the potential distri- *
+* bution *
+* Vrmssf (i,k) = r-rms (<r^2>) parameter for the potential distri- *
+* bution *
+* Vreqsf (i,k) = sharp radius parameter for the potential distri- *
+* bution *
+* Pcvpsf (k) = density exponent for saturation correction for po-*
+* tential distributions *
+* Vpexsf (k) = volume integral of the contact like (Pauli) part *
+* of the exchange interaction *
+* Akvppp = relative strength of pp(nn) interaction *
+* Akvppn = relative strength of pn(np) interaction *
+* Bkvppp = relative strength of pp(nn) exchange interaction *
+* Bkvppn = relative strength of pn(np) exchange interaction *
+* Vbarnn (k) = volume integral of the NN interaction (GeV x fm^3)*
+* Jnrhvp = present nucleon index (1=proton, 2=neutron) *
+* Jbouvp = present bound or unbound nucleon index (1=bound, *
+* 2=unbound) *
+* Jrhodn = present density index 1-6 *
+* Jrhofl = density index (1-6) to be (un)folded *
+* Lshmdu = flag for shell model like density calculations *
+* *
+*----------------------------------------------------------------------*
+*
+* R_0 for the equivalent sharp sphere radius for the proton density
+* (or charge) distribution
+ PARAMETER ( R0PRCH = 1.128 D+00 )
+* R_0 fundamental one according to Myers
+ PARAMETER ( R0DRPM = 1.18 D+00 )
+* Various parameters of the Droplet model *
+ PARAMETER ( CKDRPM = 240. D+00 )
+ PARAMETER ( CJDRPM = 36.8 D+00 )
+ PARAMETER ( CLDRPM = 100. D+00 )
+ PARAMETER ( CMDRPM = 0. D+00 )
+ PARAMETER ( CQDRPM = 17. D+00 )
+ PARAMETER ( CA1DRP = 15.96 D+00 )
+ PARAMETER ( CA2DRP = 20.69 D+00 )
+ PARAMETER ( CA3DRP = 0. D+00 )
+ PARAMETER ( CC1DRP = THRTHR / FIVFIV * COUGFM / R0DRPM * GEVMEV )
+ PARAMETER ( CC2DRP = CC1DRP / 336.D+00 * ( ONEONE / CJDRPM
+ & + 18.D+00 / CKDRPM ) )
+ PARAMETER ( HC3DRP = CC1DRP * HLFHLF * FIVFIV / R0DRPM / R0DRPM )
+* ( 3 / 2 pi )^2/3
+ PARAMETER ( HC4DRP = 0.610887057710857 D+00 )
+ PARAMETER ( CC4DRP = FIVFIV / FOUFOU * HC4DRP * CC1DRP )
+ PARAMETER ( CC5DRP = CC1DRP * CC1DRP / CQDRPM / 64.D+00 )
+ PARAMETER ( R3TOVL = FOUFOU * PIPIPI / THRTHR )
+ PARAMETER ( R0SSHM = HLFHLF / PIPIPI / ERFA00 )
+ PARAMETER ( R0PSHM = ONETHI / PIPIPI / ERFA00 )
+ LOGICAL LSHMDU, LUNFRU
+ COMMON / NCDNVP / RHCPSF (2,8), RHAPSF (2,8), RH0PSF (2,8),
+ & RHCESF (2,8), RHRDSF (2,8), RHFRSF (2,8),
+ & RRMSSF (2,8), RREQSF (2,8), VPCPSF (2,2),
+ & VPAPSF (2,2), VP0PSF (2,2), VPDPSF (2,2),
+ & VPEDSF (2,2), VPRDSF (2,2), VRMSSF (2,2),
+ & VREQSF (2,2), VPBPSF (2,2), RCVPSF (2,2),
+ & PCVPSF (2) , VBARNN (2) , VPEXSF (2),
+ & SSHLNC (2) , PSHLNC (2) , AKVPPP, AKVPPN,
+ & BKVPPP, BKVPPN,
+ & JRHDNF (2) , JNRHVP, JBOUVP, JRHODN, JRHOFL,
+ & LSHMDU, LUNFRU
+
--- /dev/null
+*$ CREATE NCSFTA.ADD
+*COPY NCSFTA
+*
+*=== ncsfta ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NuClear Symmetrized Fermi/woods-saxon density and potential *
+* tabulations Addresses *
+* *
+* kasftb(i) = starting address in blank common for the *
+* tabulations for the ith isotope: the isotope *
+* numeration is the one of the corresponding po- *
+* sition in the arrays of common Isotop for all *
+* materials with natural elemental composition, *
+* it is the number of stable isotopes (Nstbis) *
+* plus the material number for materials with a *
+* fixed isotope set *
+* This is for 0 address, real*4 alignment *
+* The layout is as following: *
+* (given k0=kasftb(i)) *
+* ibtar =nstor(k0+1) *
+* ichtar=nstor(k0+2) *
+* mrsfbn=nstor(k0+3) *
+* mvsfbn=nstor(k0+4) *
+* mcsfbn=nstor(k0+5) *
+* mrsfbn=nstor(k0+6) *
+* isfaut=nstor(k0+7) *
+* isfrat=nstor(k0+8) *
+* isfrpt=nstor(k0+9) *
+* isfrnt=nstor(k0+10) *
+* nsfrht=nstor(k0+11) *
+* isfrit=nstor(k0+12) *
+* isfvpt=nstor(k0+13) *
+* isfcot=nstor(k0+14) *
+* isfpft=nstor(k0+15) *
+* isflvt=nstor(k0+16) *
+* isfrlt=nstor(k0+17) *
+* isflpt=nstor(k0+18) *
+* isflpt=nstor(k0+19) *
+* ivcomx=nstor(k0+20) *
+* lexpif(1)=lbstor(k0+21) *
+* lexpif(2)=lbstor(k0+22) *
+* lexpkf(1)=lbstor(k0+23) *
+* lexpkf(2)=lbstor(k0+24) *
+* lexpln(1)=lbstor(k0+25) *
+* lexpln(2)=lbstor(k0+26) *
+* lrhfl1=lbstor(k0+27) *
+* lrhfl2=lbstor(k0+28) *
+* lrhfl3=lbstor(k0+29) *
+* lpnrho=lbstor(k0+30) *
+* lshmdl=lbstor(k0+31) *
+* lflvsl=lbstor(k0+32) *
+* lrlvsl=lbstor(k0+33) *
+* leqsbs=lbstor(k0+34) *
+* radiu0=gmstor(isfaut+1) *
+* radiu1=gmstor(isfaut+2) *
+* radtot=gmstor(isfaut+3) *
+* Energy dep. pot.: vpsqmx(1)=gmstor(isfaut+4) *
+* vpsqmx(2)=gmstor(isfaut+5) *
+* Energy indep. pot.: vparvp(1)=gmstor(isfaut+4) *
+* vparvp(2)=gmstor(isfaut+5) *
+* cparvp(1)=gmstor(isfaut+6) *
+* cparvp(2)=gmstor(isfaut+7) *
+* aparvp(1)=gmstor(isfaut+8) *
+* aparvp(2)=gmstor(isfaut+9) *
+* ravpsf(1)=gmstor(isfaut+10) *
+* ravpsf(2)=gmstor(isfaut+11) *
+* bnvpsf(1)=gmstor(isfaut+12) *
+* bnvpsf(2)=gmstor(isfaut+13) *
+* Energy dep. pot.: spauni(1)=gmstor(isfaut+15) *
+* spauni(2)=gmstor(isfaut+14) *
+* evsfmx(1)=gmstor(isfaut+16) *
+* evsfmx(2)=gmstor(isfaut+17) *
+* vpemax(1)=gmstor(isfaut+18) *
+* vpemax(2)=gmstor(isfaut+19) *
+* Energy indep. pot.: v0cesf(1)=gmstor(isfaut+14) *
+* v0cesf(2)=gmstor(isfaut+15) *
+* evsfmx(1)=gmstor(isfaut+16) *
+* evsfmx(2)=gmstor(isfaut+17) *
+* pvsfmx(1)=gmstor(isfaut+18) *
+* pvsfmx(2)=gmstor(isfaut+19) *
+* Energy dep. pot.: vcoumx=gmstor(isfaut+20) *
+* v0ccou=gmstor(isfaut+21) *
+* vpedge(1)=gmstor(isfaut+22) *
+* vpedge(2)=gmstor(isfaut+23) *
+* Energy indep. pot.: ravcou=gmstor(isfaut+20) *
+* vcoumx=gmstor(isfaut+21) *
+* v0ccou=gmstor(isfaut+22) *
+* zvpcou=gmstor(isfaut+23) *
+* eaprad(1)=gmstor(isfaut+24) *
+* eaprad(2)=gmstor(isfaut+25) *
+* ecprad(1)=gmstor(isfaut+26) *
+* ecprad(2)=gmstor(isfaut+27) *
+* frmano(1)=gmstor(isfaut+28) *
+* frmano(2)=gmstor(isfaut+29) *
+* efrano=gmstor(isfaut+30) *
+* e0fran=gmstor(isfaut+31) *
+* etmrad(1)=gmstor(isfaut+32) *
+* etmrad(2)=gmstor(isfaut+33) *
+* tmedge(1)=gmstor(isfaut+34) *
+* tmedge(2)=gmstor(isfaut+35) *
+* tmedge(1)=gmstor(isfaut+34) *
+* tmedge(2)=gmstor(isfaut+35) *
+* vpmxrd(1)=gmstor(isfaut+36) *
+* vpmxrd(2)=gmstor(isfaut+37) *
+* vqmxrd(1)=gmstor(isfaut+38) *
+* vqmxrd(2)=gmstor(isfaut+39) *
+* evrdmx(1)=gmstor(isfaut+40) *
+* evrdmx(2)=gmstor(isfaut+41) *
+* v0cesf(1)=gmstor(isfaut+42) *
+* v0cesf(2)=gmstor(isfaut+43) *
+* aparsf=gmstor(isfaut+44) *
+* cparsf=gmstor(isfaut+45) *
+* rhoave=gmstor(isfaut+46) *
+* pfrave=gmstor(isfaut+47) *
+* ekfave=gmstor(isfaut+48) *
+* zbourd=gmstor(isfaut+49) *
+* mrsfbn = number of rho intervals for tabulations *
+* mvsfbn = number of Vnuc intervals for tabulations *
+* mcsfbn = number of Vcoul intervals for tabulations *
+* isfaut = starting location in blank common (0 address, *
+* double precision alignment) of auxiliary vari- *
+* able tabulations *
+* lations for the current target isotope *
+* isfrat = starting location in blank common (0 address, *
+* double precision alignment) of the radius tabu- *
+* lations for the current target isotope *
+* Note: *
+* equivalence (gmstor(isfrat+0:mcsfbn),radsft(0:mcsfbn)) *
+* isfrpt = starting location in blank common (0 address, *
+* double precision alignment) of the proton den- *
+* sity tabulations for the current target isotope:*
+* isfrnt = starting location in blank common (0 address, *
+* double precision alignment) of the neutron rho *
+* tabulations for the current target isotope: *
+* there are up to 6 density distribution extending*
+* also out of the nominal radius: *
+* rhosft(i,1,n) = usual density distribution *
+* rhosft(i,2,n) = 1 folded with rmspro *
+* rhosft(i,3,n) = 1 folded with 1.5 rmspro *
+* rhosft(i,4,n) = 1 folded with 2 rmspro *
+* rhosft(i,5,n) = nucleon centre density distr. *
+* rhosft(i,6,n) = to be used for pion potential *
+* Note: *
+* equivalence (gmstor(isfrpt+1:mvsfbn),rhosft(1:mvsfbn,1,1))*
+* equivalence (gmstor(isfrpt+mvsfbn:2*mvsfbn),rhosft(1:mvsfbn,2,1))*
+* equivalence (gmstor(isfrnt+1:mvsfbn),rhosft(1:mvsfbn,1,2))*
+* equivalence (gmstor(isfrnt+mvsfbn:2*mvsfbn),rhosft(1:mvsfbn,2,2))*
+* ..... *
+* nsfrht = number of rho tabulations (from 2 up to 6) *
+* 1 and "5" are always present *
+* isfrit = starting location in blank common (0 address, *
+* double precision alignment) of the cumulative *
+* density tabulations for the current target iso- *
+* tope *
+* Note: *
+* equivalence (gmstor(isfrit+0:mrsfbn),rhisft(0:mrsfbn)) *
+* isfvpt = starting location in blank common (0 address, *
+* double precision alignment) of the nuclear po- *
+* tential tabulations for the current target iso- *
+* tope, for protons and neutrons *
+* Note: *
+* equivalence (gmstor(isfvpt+1:mvsfbn),vposft(1:mvsfbn,1))*
+* equivalence (gmstor(isfvpt+mvsfbn+1:mvsfbn),vposft(1:mvsfbn,2))*
+* isfcot = starting location in blank common (0 address, *
+* double precision alignment) of the Coulomb po- *
+* tential tabulations for the current target iso- *
+* tope *
+* Note: *
+* equivalence (gmstor(isfcot+1:mcsfbn),vcosft(1:mcsfbn)) *
+* isfpft = starting location in blank common (0 address, *
+* double precision alignment) of the Fermi momen- *
+* tum tabulations for the current target isotope *
+* Note: *
+* inpair = ( ibtar - ichtar + 1 ) / 2, paired levels *
+* izpair = ( ichtar + 1 ) / 2, paired levels *
+* inpair = ibtar - ichtar, unpaired levels *
+* izpair = ichtar, unpaired levels *
+* equivalence (gmstor(isfpft+1:mrsfbn),pfrsft(1:mrsfbn,1))*
+* equivalence (gmstor(isfpft+mrsfbn+1:mrsfbn),pfrsft(1:mrsfbn,2))*
+* isflvt = starting location in blank common (0 address, *
+* double precision alignment) of the nuclear le- *
+* vel tabulations for the current target isotope *
+* Note: *
+* equivalence (gmstor(isflvt+1:izpair),ennclv(1:izpair,1))*
+* equivalence (gmstor(isflvt+izpair+1:inpair),ennclv(1:inpair,2))*
+* isfrlt = starting location in blank common (0 address, *
+* double precision alignment) of the max radius *
+* for a a given nuclear level tabulations for the *
+* current target isotope *
+* Note: *
+* equivalence (gmstor(isfrlt+1:izpair),ranclv(1:izpair,1))*
+* equivalence (gmstor(isfrlt+izpair+1:inpair),ranclv(1:inpair,2))*
+* isflpt = starting location in blank common (0 address, *
+* double precision alignment) of the rho and rho^2*
+* laplacian tabulations for the current target *
+* isotope *
+* equivalence (gmstor(isflpt+1:mvsfbn),rlpsft(1:mvsfbn,1)) *
+* equivalence (gmstor(isflpt+mvsfbn:2*mvsfbn),rlpsft(1:mvsfbn,2))*
+* isfvet = starting location in blank common (0 address, *
+* double precision alignment) of the E=oo nuclear *
+* potential tabulations for the current target *
+* isotope, for protons and neutrons *
+* Note: *
+* equivalence (gmstor(isfvet+1:mvsfbn),vpesft(1:mvsfbn,1))*
+* isfrpp = starting location in blank common (0 address, *
+* double precision alignment) of the proton rho *
+* for pion potential tabulations for the current *
+* target isotope, it is chosen at run time accor- *
+* ding to Lrhfl3 *
+* isfrnp = starting location in blank common (0 address, *
+* double precision alignment) of the neutron rho *
+* for pion potential tabulations for the current *
+* target isotope, it is chosen at run time accor- *
+* ding to Lrhfl3 *
+* isfrpc = starting location in blank common (0 address, *
+* double precision alignment) of the p centre rho *
+* for pion potential tabulations for the current *
+* target isotope, it is set at run time *
+* isfrnc = starting location in blank common (0 address, *
+* double precision alignment) of the n centre rho *
+* for pion potential tabulations for the current *
+* target isotope, it is set at run time *
+* equivalence (gmstor(isfvet+mvsfbn+1:mvsfbn),vpesft(1:mvsfbn,2))*
+* icriso = number of the current isotope (see kasftb ex- *
+* plaination) *
+* isfpon = location in blank common of the dummy proton/ *
+* neutron arrays *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NRSFBN = 12 )
+ PARAMETER ( NVSFBN = NRSFBN + 8 )
+ PARAMETER ( NCSFBN = NVSFBN + 5 )
+ PARAMETER ( MXTAIS = NSTBIS + MXXMDF )
+ COMMON / NCSFTA / KASFTB (MXTAIS), MRSFBN, MVSFBN, MCSFBN, ISFAUT,
+ & ISFRAT , ISFRPT, ISFRNT, NSFRHT, ISFRIT, ISFVPT,
+ & ISFCOT , ISFPFT, ISFLVT, ISFRLT, ISFLPT, ISFVET,
+ & ISFRPP , ISFRNP, ISFRPC, ISFRNC, ICRISO, ISFPON
+
--- /dev/null
+*$ CREATE NDNICM.ADD
+*COPY NDNICM
+*
+*=== ndnicm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Nucleon Decay and Neutrino Interaction CoMmon: *
+* *
+* Created on 12 january 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 05-oct-98 by Alfredo Ferrari *
+* *
+* Ndnitr = target nucleon id. or decaying nucleon id *
+* Nuproj = (anti)neutrino projectile *
+* (-)1=(anti)nue *
+* (-)2=(anti)numu *
+* (-)3=(anti)nutau *
+* 0=nucleon decay *
+* Nuclid = neutrino interaction kind *
+* -1 = tape or external generator *
+* 0 = as set otherwise (Nuinfo) *
+* > 0 = Iqe + Ires x 10 + Idis x 100 *
+* Iqe: *
+* 0 = no QE NC and CC *
+* 1 = QE NC *
+* 2 = QE CC *
+* 3 = QE NC and CC *
+* Ires: *
+* 0 = no RES NC and CC *
+* 1 = RES NC *
+* 2 = RES CC *
+* 3 = RES NC and CC *
+* Idis: *
+* 0 = no DIS NC and CC *
+* 1 = DIS NC *
+* 2 = DIS CC *
+* 3 = DIS NC and CC *
+* Ncdcsc = nucleon decay secondary number or neutrino *
+* interaction from tape secondary number *
+* Kncdcs(i) = nucleon decay / neutrino interaction secondary *
+* id. (Part numbering) *
+* Etndni(i) = total energy of i_th secondary (i>=1), *
+* total energy of primary neutrino (i=0) *
+* Pxndni(i) = x momentum of i_th secondary (i>=1), *
+* x momentum of primary neutrino (i=0) *
+* Pyndni(i) = y momentum of i_th secondary (i>=1), *
+* y momentum of primary neutrino (i=0) *
+* Pzndni(i) = z momentum of i_th secondary (i>=1), *
+* z momentum of primary neutrino (i=0) *
+* Po0lpt,Pollpt(j) = Polarization 4-vector for the outcoming lepton *
+* in the frame where the incident neutrino is along *
+* the positive z axis *
+* Polprl = Polarization component along the particle direc- *
+* tion in the final frame *
+* Nnitdc = number of decay products for a (possible) prere- *
+* corded tau decay *
+* Knitdc(i) = tau decay products id. (Part numbering) *
+* Etnitd(i) = total energy in the particle cms (particle flying *
+* along +z) of j_th decay product of a possible *
+* prerecorded tau decay *
+* Pxnitd(i) = x momentum in the particle cms (particle flying *
+* along +z) of j_th decay product of a possible *
+* prerecorded tau decay *
+* Pynitd(i) = y momentum in the particle cms (particle flying *
+* along +z) of j_th decay product of a possible *
+* prerecorded tau decay *
+* Pznitd(i) = z momentum in the particle cms (particle flying *
+* along +z) of j_th decay product of a possible *
+* prerecorded tau decay *
+* Lnitdc = flag for a (possible) prerecorded tau decay *
+* Lnditp = flag for a (possible) tape recorded or external *
+* event generator *
+* Lndixg = flag for a (possible) external event generator *
+* (Lnditp=.true. ,Lndixg=.false. -> tape event, *
+* Lnditp=.true. ,Lndixg=.true. -> ext. generator, *
+* Lnditp=.false.,Lndixg=.false. -> int. generator) *
+* Jntpcl = event selected for the current collision from a *
+* possibile neutrino interaction tape *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXNDNI =100 )
+ PARAMETER ( MXNITD = 10 )
+*
+ LOGICAL LNITDC, LNDITP, LNDIXG
+ COMMON / NDNICM / ETNDNI (0:MXNDNI), PXNDNI (0:MXNDNI),
+ & PYNDNI (0:MXNDNI), PZNDNI (0:MXNDNI),
+ & ETNITD (MXNITD), PXNITD (MXNITD),
+ & PYNITD (MXNITD), PZNITD (MXNITD),
+ & POLLPT (3), PO0LPT, POLPRL,
+ & NDNITR, NUPROJ, NUCLID, NCDCSC, NNITDC,
+ & KNCDCS (MXNDNI), KNITDC (MXNITD),
+ & LNITDC, LNDITP, LNDIXG, JNTPCL
+
--- /dev/null
+*$ CREATE NIKNCM.ADD
+*COPY NIKNCM
+*
+*=== Nikncm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Neutrino Interaction KiNematics CoMmon: *
+* *
+* Created on 03 july 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 18-jan-99 by Alfredo Ferrari *
+* *
+* Icnikn = 1: charged current, 0: neutral current *
+* Idnikn = 1: Quasi-Elastic, 2: Resonance production, 3: DIS *
+* Isnikn =-1: Neutrino projectile, 1: Antineutrino projectile *
+* Itnikn = 2 x T_z of the target nucleon *
+* Ipnikn = Projectile neutrino id (Paprop numeration) *
+* Kpnikn = Projectile neutrino id (Part numeration) *
+* Ktnikn = Target nucleon id (Part numeration) *
+* Klnikn = Outgoing lepton/neutrino id (Part numeration) *
+* Kbnikn = Outgoing baryon id (Part numeration) *
+* Axlmss = axial mass *
+* Vctmss = vector mass *
+* Ampnik = Projectile neutrino mass (it should be zero) *
+* Amtnik = Target nucleon mass *
+* Amlnik = Outgoing lepton/neutrino mass *
+* Ambnik = Outgoing baryon mass *
+* Eneink = Lab. energy of the incoming neutrino *
+* Umnikn = sqrt (s): center-of-mass energy *
+* Umnksq = s : center-of-mass energy squared *
+* Pcmink = cms momentum of the incoming neutrino/target nucleon *
+* Pcmonk = cms momentum of the outgoing lepton-neutrino/baryon *
+* Ecmlnk = cms energy of the outgoing lepton-neutrino *
+* Q2mnnk = Q^2_min *
+* Q2mxnk = Q^2_max *
+* Q2nikn = actual Q^2 *
+* W2mnnk = W^2_min *
+* W2mxnk = W^2_max *
+* W2nikn = actual W^2 *
+* Omcsnk = 1 - cos theta_cms *
+* Cxplnk = X-cosine of the polarization vector in the outgoing *
+* lepton rest frame or in the lab frame for an outgoing *
+* neutrino *
+* Cyplnk = Y-cosine of the polarization vector in the outgoing *
+* lepton rest frame or in the lab frame for an outgoing *
+* neutrino *
+* Czplnk = Z-cosine of the polarization vector in the outgoing *
+* lepton rest frame or in the lab frame for an outgoing *
+* neutrino *
+* *
+*----------------------------------------------------------------------*
+*
+* FA (0) ******!!!! Controversial sign .
+* Keep minus from Lewellyn-Smith, Cavanna, MACRO PhD, massive nu.
+* somehow linked to the sign of the "B" term
+ PARAMETER ( FAFFQE =-1.262 D+00 )
+* Axial mass ( from bubble chamber aver. (Cavanna, MACRO PhD )
+ PARAMETER ( AXLMRF = 1.03 D+00 )
+* PARAMETER ( AXLMRF = 0.73 D+00 )
+* Vector mass
+ PARAMETER ( VCTMRF = 0.84 D+00 )
+* PARAMETER ( VCTMRF = 0.73 D+00 )
+* anomalous mu_p - mu_n in nuclear magneton
+ PARAMETER ( CSIAPN = PRMGNM - ANMGNM - ONEONE )
+ PARAMETER ( CSTHCB = 0.9737D+00 )
+* From Lew.-Sm = G^2 * Cos(theta_Cabibbo)^2 / 8 / pi )
+ PARAMETER ( CSTNIK = GFOHB3 * GFOHB3 * CSTHCB * CSTHCB * PLABRC
+ & * PLABRC * TENTEN / EIGEIG / PIPIPI )
+*
+ COMMON / NIKNCM / AXLMSS, VCTMSS, AMPNIK, AMTNIK, AMLNIK, AMBNIK,
+ & ENEINK, UMNIKN, UMNKSQ, PCMINK, PCMONK, ECMLNK,
+ & Q2MNNK, Q2MXNK, Q2NIKN, W2MNNK, W2MXNK, W2NIKN,
+ & OMCSNK, XMTIKN, KPNIKN, KTNIKN, KLNIKN, KBNIKN,
+ & ICNIKN, IDNIKN, ISNIKN, ITNIKN, IPNIKN
+
--- /dev/null
+*$ CREATE NNXINM.ADD
+*COPY NNXINM
+*
+*=== nnxinm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Nucleon-Nucleon elastic Xsec IN Medium: *
+* *
+* Created on 16 september 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 16-sep-94 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BIMSEL *
+* NUCNUC *
+* NWISEL *
+* PREPRE *
+* SIGFER *
+* *
+* Description of the variables (nnxinm): *
+* *
+* Fnnxim (i) = Modification factor for N-N in medium*
+* elastic scattering for the current *
+* (nucleon) projectile: i=1, for target *
+* proton, i=2 for target neutron *
+* Innimf = flag for the cascade part for N-N in *
+* medium effects for elastic scattering*
+* Nnnimf = flag for the preeq. part for N-N in *
+* medium effects for elastic scattering*
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( RH0INM = 0.18 D+00 )
+ PARAMETER ( ALINM0 = HLFHLF )
+ PARAMETER ( EALINM = 0.260D+00 )
+ PARAMETER ( DEAINM = 0.010D+00 )
+ PARAMETER ( EBLINM = 0.055D+00 )
+ PARAMETER ( DEBINM = 0.005D+00 )
+ PARAMETER ( EMLINM = EALINM + TENTEN * DEAINM )
+ COMMON / NNXINM / FNNXIM (2), INNIMF, NNNIMF
+
--- /dev/null
+*$ CREATE NUCDAT.ADD
+*COPY NUCDAT
+* *
+*=== nucdat ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Include file Nucdat *
+* *
+* Created on 20 april 1990 by Alfredo Ferrari *
+* INFN Milan *
+* *
+* Last change on 08-nov-96 *
+* *
+* Included in the following routines: *
+* *
+* COREVT *
+* CORRIN *
+* DISTNU *
+* DRES *
+* EVDEEX *
+* EVENTV *
+* EVEVAP *
+* FEREVV *
+* FERHAV *
+* FEFCAV *
+* FEKFAV *
+* FPFCAV *
+* FPFRAV *
+* FVCOUL *
+* FVPESF *
+* FVPOSF *
+* FRBKIN *
+* INCINI *
+* NUCEVV *
+* NUCRIV *
+* PEANUT *
+* RAKEKV *
+* RBKEKV *
+* WSTOAP *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( AMUAMU = AMUGEV )
+* PARAMETER ( AMPROT = 0.9382796 D+00 )
+ PARAMETER ( AMPROT = AMPRTN )
+* PARAMETER ( AMNEUT = 0.9395731 D+00 )
+ PARAMETER ( AMNEUT = AMNTRN )
+ PARAMETER ( AMELEC = AMELCT )
+ PARAMETER ( R0NUCL = 1.12 D+00 )
+ PARAMETER ( RCCOUL = 1.7 D+00 )
+ PARAMETER ( COULPR = COUGFM )
+ PARAMETER ( AMHYDR = AMPRTN + AMELCT )
+ PARAMETER ( AMHTON = AMHYDR - AMNTRN )
+ PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
+ PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
+ PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
+* Gammin : threshold for deexcitation gammas production, set to 1 keV
+* (this means that up to 1 keV of energy unbalancing can occur
+* during an event)
+ PARAMETER ( GAMMIN = 1.0D-06 )
+ PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
+* Tvepsi : "epsilon" for excitation energy, set to gammin / 100
+ PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
+*
+ COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
+ & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
+ & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
+ & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
+ & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
+ & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
+ & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
+ & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
+ & ELBNDE (0:100)
+
--- /dev/null
+*$ CREATE NUCGEO.ADD
+*COPY NUCGEO
+*
+*=== nucgeo ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear GEOmetry common: *
+* *
+* Created on 20 july 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 05-apr-01 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* AHYVPI *
+* ANCVPI *
+* BDPREE *
+* BERTTP *
+* BIMCAL *
+* BIMSEL *
+* BIMSTR *
+* COUINI *
+* COUSET *
+* CRCNFG *
+* DEFLTS *
+* DELTAR *
+* DEUSTR *
+* EVENTV *
+* FEFCAV *
+* FEKFAV *
+* FINAPV *
+* FINCPV *
+* FINCRD *
+* FINRMS *
+* FINRSF *
+* FINRWS *
+* FINSPA *
+* FINSPE *
+* FINVPE *
+* FINVPO *
+* FPFCAV *
+* FPFRAV *
+* FRDPFT *
+* FRHAVE *
+* FRHINC *
+* FRHOWS *
+* FRMSWS *
+* FRRHNC *
+* FRRHWS *
+* FTMRAD *
+* FTTMRD *
+* FVCOUL *
+* FVPESF *
+* FVPOSF *
+* FVVESF *
+* FVVPSF *
+* FRHONC *
+* FVQESF *
+* FVQPSF *
+* HDNCIN *
+* HYPVPI *
+* KAONUC *
+* KAOVPI *
+* KBANUC *
+* KBAVPI *
+* KBSNUC *
+* KHYNUC *
+* LSPMSS *
+* MUMRAT *
+* MUOABS *
+* NIZLNW *
+* NCLVIN *
+* NCLVST *
+* NUCNUC *
+* NUCVPI *
+* NWISEL *
+* PEANUT *
+* PFNCLV *
+* PFCSCR *
+* PIABTH *
+* PIOABS *
+* PIONUC *
+* PIOVPI *
+* PMPRAB *
+* PREPRE *
+* RCFSET *
+* RNCCRR *
+* RSTSEL *
+* RTAUFR *
+* SBCOMP *
+* SETITB *
+* SETIPW *
+* SIGFER *
+* UMFNST *
+* UMOFIN *
+* WSTOAP *
+* VPOAHY *
+* VPOANC *
+* VPOBRS *
+* VPOHYP *
+* VPOKAO *
+* VPOKBA *
+* VPONUC *
+* VPOPIO *
+* *
+* Description of the variables (NUCGEO): *
+* *
+* Radtot = total radius of the nucleus *
+* Radiu0 = radius of the nucleus constant *
+* density core *
+* Radiu1 = radius at the nucleus skin depth *
+* end *
+* Rad1o2 = half density radius of the nucleus *
+* Skindp = Skin depth of the nucleus ( where *
+* density decreases linearly with the *
+* radius from rhocen to rhoskn, *
+* Radiu1 = Radiu0 + Skindp and *
+* Rad1o2 = Radiu0 + 1/(2 Omalhl) *
+* x Skindp ) *
+* Rhoskn = Rhocen * Alphal *
+* Halodp = Halo depth of the nucleus ( where *
+* density decreases linearly with the *
+* radius from rhoskn to 0, *
+* Radtot = Radiu0 + Skindp + Halodp *
+* Alphal = fraction of the central density the *
+* transition from skin to halo occurs *
+* at *
+* Omalhl = 1 - Alphal *
+* Radskn = Radius at which the density would be *
+* zero if the skin depth behaviour is *
+* continued (Radskn = Radiu0 + Skindp *
+* / Omalhl) *
+* Skneff = "effective" skin depth corresponding *
+* to Radskn, Skneff = Skindp / Omalhl *
+* Radpro = equivalent radius of the projectile *
+* Bimptr = "true" impact parameter of the proj- *
+* ectile (referred to the centre of *
+* the projectile) *
+* Rimptr = "true" radius of the interaction *
+* point (referred to the centre of *
+* the projectile) *
+* X,Y,Zimptr = "true" position of the interaction *
+* point (referred to the centre of *
+* the projectile) *
+* Rhocen = central density of the nucleus *
+* Rhocor = density at the transition point from *
+* core to skin *
+* Rhoskn = density at the transition point from *
+* skin to halo, Rhoskn = Alphal Rhocen *
+* Rhoipp = proton density at the position *
+* of the 1st target nucleon *
+* Rhoinp = neutron density at the position *
+* of the 1st target nucleon *
+* Rhoimp = density of the nucleus at the posi- *
+* tion of the 1st target nucleon *
+* Rhoip2 = proton density at the position *
+* of the 2nd target nucleon *
+* Rhoin2 = neutron density at the position *
+* of the 2nd target nucleon *
+* Rhoim2 = density of the nucleus at the posi- *
+* tion of the 2nd target nucleon *
+* Rhoip3 = proton density at the position *
+* of the 3rd target nucleon *
+* Rhoin3 = neutron density at the position *
+* of the 3rd target nucleon *
+* Rhoim3 = density of the nucleus at the posi- *
+* tion of the 3rd target nucleon *
+* Rhoncj(i,j) = proton(i=1) and neutron(i=2) density *
+* of the nucleus at the position of *
+* the jth target nucleon *
+* Rhoimj(j) = (total) density of the nucleus at *
+* the position of the jth target nuc- *
+* leon *
+* Rhoipt = proton density at the position *
+* of the projectile *
+* Rhoint = neutron density at the position *
+* of the projectile *
+* Rhoimt = density of the nucleus at the posi- *
+* tion of the projectile *
+* Pfr,Ekfcen = Maximum Fermi momentum/energy in the *
+* central core *
+* Pfr,Ekfpro = Maximum Fermi momentum/energy at the *
+* true interaction point for the proj- *
+* ectile (they are computed as for nu- *
+* cleons without any reduction factor) *
+* Pfr,Ekfimp = Maximum Fermi momentum/energy at the *
+* "effective" interaction point for *
+* the 1st target nucleon *
+* Pfr,Ekfim2 = Maximum Fermi momentum/energy at the *
+* "effective" interaction point for *
+* the 2nd target nucleon *
+* Pfr,Ekfim3 = Maximum Fermi momentum/energy at the *
+* "effective" interaction point for *
+* the 3rd target nucleon *
+* Pfr,Ekfimj(j) = Maximum Fermi momentum/energy at the *
+* "effective" interaction point for *
+* the jth target nucleon *
+* Pfr,Ekfbim = Maximum Fermi momentum/energy at *
+* r = " effective" impact parameter *
+* (Bimpct) for the nucleon with the *
+* deepest well *
+* Vprwll = well depth for the present projectile*
+* at the "true" interaction point *
+* Bimpct = "effective" impact parameter of the *
+* projectile (referred to the centre *
+* of the target nucleon) *
+* Rimpct = "effective" radius of the interac- *
+* tion point (referred to the centre *
+* of the 1st target nucleon) *
+* X,Y,Zimpct = "effective" position of the interac- *
+* tion point (referred to the centre *
+* of the 1st target nucleon) *
+* Rimpc2 = "effective" radius of the interac- *
+* tion point (referred to the centre *
+* of the 2nd target nucleon) *
+* X,Y,Zimpc2 = "effective" position of the interac- *
+* tion point (referred to the centre *
+* of the 2nd target nucleon) *
+* Rimpc3 = "effective" radius of the interac- *
+* tion point (referred to the centre *
+* of the 3rd target nucleon) *
+* X,Y,Zimpc3 = "effective" position of the interac- *
+* tion point (referred to the centre *
+* of the 3rd target nucleon) *
+* Rimpcj(j) = "effective" radius of the interac- *
+* tion point (referred to the centre *
+* of the jth target nucleon) *
+* X,Y,Zimpcj(j) = "effective" position of the interac- *
+* tion point (referred to the centre *
+* of the jth target nucleon) *
+* Ekferm = actual Fermi energy of the 1st tar- *
+* get nucleon *
+* Ekfext = part of actual Fermi energy of the *
+* 1st target nucleon due to (random) *
+* extra contributions *
+* Pnfrmi = actual Fermi momentum of the 1st tar-*
+* get nucleon *
+* Px,y,zferm = actual Fermi momentum components of *
+* the 1st target nucleon *
+* Ekfer2 = actual Fermi energy of the 2nd tar- *
+* get nucleon *
+* Ekfex2 = part of actual Fermi energy of the *
+* 2nd target nucleon due to (random) *
+* extra contributions *
+* Pnfrm2 = actual Fermi momentum of the 2nd tar-*
+* get nucleon *
+* Px,y,zfer2 = actual Fermi momentum components of *
+* the 2nd target nucleon *
+* Ekfer3 = actual Fermi energy of the 3rd tar- *
+* get nucleon *
+* Ekfex3 = part of actual Fermi energy of the *
+* 3rd target nucleon due to (random) *
+* extra contributions *
+* Pnfrm3 = actual Fermi momentum of the 3rd tar-*
+* get nucleon *
+* Px,y,zfer3 = actual Fermi momentum components of *
+* the 3rd target nucleon *
+* Ekferj(j) = actual Fermi energy of the jth tar-*
+* get nucleon *
+* Pnfrmj(j) = actual Fermi momentum of the jth tar-*
+* get nucleon *
+* Px,y,zferm(j) = actual Fermi momentum components of *
+* the jth target nucleon *
+* Px,y,zfevt = total Fermi momentum for the present *
+* interaction *
+* Ekewll = actual kinetic energy of the projec- *
+* tile including nuclear potential *
+* Pprwll = actual momentum of the projectile *
+* Px,y,zproj = actual momentum components of the *
+* projectile *
+* Wllred = reduction factor to be applied to *
+* the Ipwell well to get the proper *
+* well for the projectile *
+* Amothr = total mass of particles other than *
+* nucleons still going around in the *
+* nucleus *
+* Ekothr = total kinetic energy with respect to *
+* the "standard" free level of parti- *
+* cles other than nucleons still going *
+* around in the nucleus *
+* Amcrea = total created/annihilated mass in in-*
+* elastic interactions (positive for *
+* creation, say Mprod > Mproj + Mtarg) *
+* Ekncln = total kinetic energy with respect to *
+* the "standard" free level of nucleons*
+* still going around in the nucleus *
+* Clmbbr = Coulomb barrier for the present pro- *
+* jectile *
+* Rdclmb = radius corresponding to the Coulomb *
+* barrier at which Coulomb effects are *
+* supposed to be overcome by the nuc- *
+* lear potential: *
+* Rdclmb = Clmbbr / (zZe^2) *
+* Bfclmb = correction factor for the impact pa- *
+* rameter, for boo such that the actual*
+* b =< Rdclmb: *
+* Bfclmb = sqrt ( 1 - Clmbbr/Ekproj ) *
+* Bfceff = actual correction factor for the imp-*
+* act parameter, b = boo / Bfceff *
+* for boo =< Rdclmb x Bfclmb: *
+* Bfceff = Bfclmb *
+* for boo > Rdclmb x Bfclmb: *
+* Bfceff = 1 / ( x + sqrt (1+x^2) ) *
+* x = Clmbbr x Rdclmb / (2 Ekproj boo)*
+* Vcoucn = Coulomb potential at center (>0) *
+* Fpnblc,Dpnblc = meaningful only if Lpnrho=.true.: *
+* the ratio of the Myers b_lepto para- *
+* meter for neutrons with respect to *
+* protons is given by: *
+* b_neu / b_pro = Fpnblc + Dpnblc x ( R_n - R_p ) / R_p *
+* Hcrfrm(i) = Whenever a Fermi momentum is selected*
+* it is not changed until the particle *
+* travelled a distance (x=pro,neu): *
+* Hcrfrm(1) + Hcrfrm(2) *
+* x [Rho_loc_x / Rho_cen_x]^Hcrfrm(3) *
+* Hcrfrm(i) = Particle formation zones/hard cores *
+* are reduced for n-body absorption *
+* by a distance: *
+* Sqrt(n-1) x {Hcrabs(1) + Hcrabs(2) *
+* x [Rho_loc / Rho_cen]^Hcrabs(3)} *
+* Rdttnc(i) = The same as Radtot but specialized *
+* for protons and neutrons in the case *
+* the p/n density distributions are *
+* different *
+* Agepri = "age" (fm/c) of current particle *
+* Akprin = mass of the projectile *
+* Ethrnd = random smearing of the reinteraction *
+* threshold for explicit interactions *
+* Ipwell = index of the target nucleon well to *
+* be used in computing the one for the *
+* projectile *
+* ( 1 = proton, 2 = neutron ) *
+* Itncmx = index of the target nucleon with *
+* largest Fermi momentum *
+* ( 1 = proton, 2 = neutron ) *
+* Kprin = particle index of the projectile *
+* Ntargt = number of target nucleons (3 at max) *
+* Knucim = particle index of the target nucleon *
+* ( 1 = proton, 8 = neutron ) *
+* Knuci2 = particle index of the 2nd target *
+* nucleon for absorption on a couple *
+* of nucleons *
+* Knuci3 = particle index of the 3rd target *
+* nucleon for absorption on a triplet *
+* of nucleons *
+* Knucij(j) = particle index of the jth target *
+* nucleon *
+* Isfcol = bin number of the present collision *
+* point (projectile) *
+* Isftar = bin number of the present collision *
+* point (target nucleon) *
+* Isfta2 = bin number of the present collision *
+* point (2nd target nucleon) *
+* Isfta3 = bin number of the present collision *
+* point (3rd target nucleon) *
+* Isftaj(j) = bin number of the present collision *
+* point (jth target nucleon) *
+* Npothr = number of particles other than nuc- *
+* leons still going around in the nuc- *
+* leus *
+* Icothr = total charge of particles other than *
+* nucleons still going around in the *
+* nucleus *
+* Ibothr = baryon number of particles other than*
+* nucleons still going around in the *
+* nucleus *
+* Npumfn = number of emitted particles which *
+* must still be treated for recoil *
+* Iabcou = counter for multibody absorption *
+* events (+1 for each extra nucleon) *
+* Iadflg = flag for angular distribution options*
+* in preequilibrium *
+* Itaucm = flag for "coherence" length (tautau) *
+* options in preequilibrium *
+* Igsflg = flag for g (single particle level *
+* density parameter option) in preequi-*
+* librium *
+* Igsflg = i0 + i1 * 10 *
+* i0 is the flag for the single parti- *
+* cle level density approach *
+* i1 > 0: nucleon independent g parame-*
+* ters *
+* i1 = 0: nucleon dependent g parame- *
+* ters *
+* Ialflg = flag for a (level density parameter *
+* option) in preequilibrium *
+* Icbflg = flag for centriphugal barrier for *
+* preequilibrium (-1 -> no barrier, *
+* 0 -> naive barrier, 1 less naive *
+* barrier) *
+* Iftflg = flag specifying the option for forma-*
+* tion time competition: meaningful *
+* only for Lftcmp=.true. *
+* Iftflg = isign x ( i0 + 100 x i1 *
+* + 10000 x i2 ) *
+* isign =0,+1: formation time competition app- *
+* lied to all interactions *
+* -1: formation zone competition applied*
+* to primary interactions only *
+* (in order to get isign =-1, i0,i1,i2 *
+* all 0 set =-1000000) *
+* i0 = 0: no account for nucleon correlation*
+* distance and antisymmetrization *
+* effects *
+* = 1: interactions within nucleon corre-*
+* lation distance or antisymmetriza-*
+* tion distance are not allowed *
+* = 2: interactions within nucleon corre-*
+* lation distance are not allowed, *
+* no account for antisymmetrization *
+* effects *
+* = 3: interactions within antisymmetri- *
+* zation distance are not allowed, *
+* no account for nucleon correla- *
+* tions *
+* i1 = 0: formation time competition among *
+* all kind of interactions *
+* = 1: formation time competition only *
+* among different kind of inter- *
+* actions (ie elastic vs inelastic) *
+* ch.exc. like elastic *
+* Irdflg = flag specifying the option for max. *
+* nuclear radii calculations inside *
+* Wstoap: *
+* Irdflg = I0 + 100 x I1 *
+* I0 = flag for rho radii *
+* I1 = flag for mass radii *
+* Fftflg = factor for the option for formation *
+* time competition: meaningful only *
+* for Lftcmp=.true. *
+* Lpreeq = logical flag for the new preequili- *
+* brium *
+* Lnphtc = logical flag for the new coherence *
+* length, hard core and Pauli correla- *
+* tion implementation into prepre *
+* Lpnrho = logical flag for switching on the *
+* calculation with separate densities *
+* for p and n *
+* Lnwrad = logical flag for computing nuclear *
+* radii according to a fraction in mass*
+* and not in density *
+* Lftcmp = logical flag for allowing formation *
+* time competition between interactions*
+* Lftcac = logical flag for activated formation *
+* time competition *
+* *
+* Description of the variables (NUCPWI): *
+* *
+* Almbar = Reduced De Broglie wavelength *
+* Bimmax = maximum impact parameter (at oo from *
+* the nucleus) *
+* Siggeo = Geometrical cross section summed *
+* over all partial waves (assuming *
+* opacity=1 for any l) *
+* Siggeo = pi ( Almbar(lmax+1) )^2 *
+* Lllmax = highest partial wave, it corresponds *
+* to: Almbar Lllmax >= Bimmax, where *
+* the >= means that the smallest *
+* integer >= Bimmax / Almbar is used *
+* Lllact = partial wave index of the present *
+* interaction *
+* *
+* Description of the variables (NUCGII): *
+* *
+* Holexp(j) = hole depth for explicit INC interac- *
+* tions for the jth hit nucleon *
+* Nncexi(i) = number of interacting (target) nuc- *
+* leons for the ith explicit INC in- *
+* teraction *
+* Ncexpi(k,i) = identity of kth nucleon participating*
+* to the ith explicit INC interaction *
+* X,Y,Zexpin(k,i) = position of kth nucleon participating*
+* to the ith explicit INC interaction *
+* Ncexpi(k,i) = identity of kth nucleon participating*
+* to the ith explicit INC interaction *
+* Nuscin = number of explicit INC interactions *
+* Ndeust = number of deuteron stripping inter. *
+* Irsrei = flag for various resonance reinterac-*
+* tions options *
+* = 0 standard decay length possibly mo- *
+* dified by ftfrdc *
+* = 1 two resonance interaction with for-*
+* mation time according to q^2 *
+* = 2 two resonance interaction with for-*
+* mation time according to q^2 for sta-*
+* ble products and to standard decay *
+* length for real resonances *
+* Labrst = flag for absorption at rest or s-wave*
+* two body absorption for pions *
+* Lelstc = flag for elastic scattering *
+* Linels = flag for inelastic scattering *
+* Lchexc = flag for charge exchange *
+* Labsrp = flag for resonant two body pion *
+* absorption *
+* Labsth = flag for three body absorption *
+* Lncdcy = flag for nucleon decay *
+* Lnusct = flag for neutrino scattering *
+* Lprabs = flag for current proj. absorption *
+* Ldeust = flag for deuteron stripping *
+* Lrsdcy = flag for resonance decay *
+* Lpntrg = flag for proton/neutron targets *
+* Lrsrei = flag for resonance explicit reinter- *
+* actions (true <-> activated) *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( PI = PIPIPI )
+ PARAMETER ( PISQ = PIPISQ )
+* This is log(11)/(4log(3)), it is ok for alphal = 0.1, bethal = 0.01 )
+ PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
+* This is log(99/19)/(4log(3)), it is ok for alphal = 0.05,
+* bethal = 0.01 )
+* PARAMETER ( SKTOHL = 0.3756286198494407D+00 )
+* This is log(99/4)/(4log(3)), it is ok for alphal = 0.2,
+* bethal = 0.01 )
+* PARAMETER ( SKTOHL = 0.7301997078753058D+00 )
+* This is log(99/4)/(4log(3)), it is ok for alphal = 0.02,
+* bethal = 0.001 )
+* PARAMETER ( SKTOHL = 0.7301997078753058D+00 )
+ PARAMETER ( RZNUCL = 1.12 D+00 )
+ PARAMETER ( RMSPRO = 0.8 D+00 )
+ PARAMETER ( R0PROT = RMSPRO / SQRT12 )
+ PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
+ & / R0PROT )
+ PARAMETER ( RLLE04 = RZNUCL )
+ PARAMETER ( RLLE16 = RZNUCL )
+ PARAMETER ( RLGT16 = RZNUCL )
+ PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
+ PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
+ PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
+ PARAMETER ( SKLE04 = 1.4D+00 )
+ PARAMETER ( SKLE16 = 1.9D+00 )
+ PARAMETER ( SKGT16 = 2.4D+00 )
+ PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
+ PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
+ PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
+ PARAMETER ( ALPHA0 = 0.1D+00 )
+*2 PARAMETER ( ALPHA0 = 0.05D+00 )
+*0 PARAMETER ( ALPHA0 = 0.2D+00 )
+*3 PARAMETER ( ALPHA0 = 0.02D+00 )
+*4 PARAMETER ( ALPHA0 = 0.25D+00 )
+ PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
+ PARAMETER ( GAMSK0 = 0.9D+00 )
+*0 PARAMETER ( GAMSK0 = 0.8D+00 )
+*2 PARAMETER ( GAMSK0 = 0.9D+00 )
+*3 PARAMETER ( GAMSK0 = 0.9D+00 )
+*4 PARAMETER ( GAMSK0 = 0.75D+00 )
+ PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
+ PARAMETER ( POTME0 = 0.6666666666666667D+00 )
+ PARAMETER ( POTBA0 = 1.D+00 )
+* This parameter is the Panofsky ratio
+ PARAMETER ( PNFRAT = 1.533D+00 )
+* This parameter set the branching ratio for radiative pi- capture
+* at rest in complex nuclei (it is a bit larger than the experimental
+* one to compensate for Pauli blocking etc etc ). This value is
+* for A=oo
+ PARAMETER ( RADPIM = 0.035D+00 )
+ PARAMETER ( RDPMHL = 14.D+00 )
+* Probability for pi- absorption to have a second proton in the couple
+* of nucleons ( the first one must be a proton )
+ PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
+* Probability for pi- absorption to have a second proton in the couple
+* of nucleons ( the first one must be a proton )
+ PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
+* Probability for pi+ absorption to have a proton in the couple
+* of nucleons ( the first one must be a neutron )
+ PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
+* Probability for pi0 absorption to have a p in the couple
+* as first particle
+ PARAMETER ( AP0PFS = 0.5D+00 )
+* Probability for pi0 absorption to have a p in the couple
+* as second particle for a p first particle
+ PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
+* Probability for pi0 absorption to have a p in the couple
+* as second particle for a n first particle
+ PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
+* This parameter is the width of a square well like Pauli correlation
+* function with F'(X) = 1/2, X < Xpauco, F'(X) = 1, X > Xpauco, and
+* such that (Xb >> X_pauli), where F(X) is the actual function:
+* /Xb /Xb
+* | dX F(X) = | dX F'(X) = Xb - 1/2 * X_pauli
+* /0 /0
+ PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
+* Maximum number of explicit collisions:
+ PARAMETER ( MXSCIN = 260 )
+*
+ LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LSTEXC, LABSRP, LABSTH,
+ & LNCDCY, LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP,
+ & LFTCAC, LPRABS, LDEUST, LRSDCY, LPNTRG, LRSREI
+* NUClear Geometry Input data
+ COMMON / NUCGID / RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
+ & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
+ & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
+ & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
+ & PFRTAB (2:260)
+* NUClear GEOmetry
+ COMMON / NUCGEO / RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
+ & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
+ & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
+ & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
+ & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
+ & PFRBIM, VPRWLL, BIMPCT, XBIMPC, YBIMPC, ZBIMPC,
+ & CXIMPC, CYIMPC, CZIMPC, SQRIMP,
+ & RHOIMJ (MXHTTR), EKFIMJ (MXHTTR),
+ & PFRIMJ (MXHTTR), RIMPCJ (MXHTTR),
+ & XIMPCJ (MXHTTR), YIMPCJ (MXHTTR),
+ & ZIMPCJ (MXHTTR), EKFERJ (MXHTTR),
+ & EKFEXJ (MXHTTR), PNFRMJ (MXHTTR),
+ & PXFERJ (MXHTTR), PYFERJ (MXHTTR),
+ & PZFERJ (MXHTTR), SIGMAP, SIGMAN, SIGMAA,
+ & RHORED, R0TRAJ, R1TRAJ, SBUSED, SBTOT , SBRES ,
+ & RHOAVE, EKFAVE, PFRAVE, AVEBIN, ACOLL , ZCOLL ,
+ & RADSIG, OPACTY, EKECON, PNUCCO, EKEWLL, PPRWLL,
+ & PXPROJ, PYPROJ, PZPROJ, RHOMEM, EKFMEM, BIMMEM,
+ & WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN, VCOUCN
+ COMMON / NUCGE2 / RDTTNC (2), RHONCJ (2,MXHTTR),
+ & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
+ & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
+ & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
+ & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
+ & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, AKPRIN,
+ & BNENRG (3), DEFNUC (2), SIGMPR (6), SIGMNU (6),
+ & SIGSXP (4), SIGSXN (4), SIGPAB (3), SIGNAB (3),
+ & HHLP (2), FORTOT (2), FPNBLC, DPNBLC, FFTFLG,
+ & HCRFRM (3), HCRABS (3), PXFEVT, PYFEVT, PZFEVT,
+ & IFTFLG, IPWELL, ITNCMX, IEVPRE, KPRIN , ISFCOL,
+ & NTARGT, KNUCIJ (MXHTTR), ISFTAJ (MXHTTR),
+ & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
+ & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, IRDFLG,
+ & LPREEQ, LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
+* NUClear Partial Waves Informations
+ COMMON / NUCPWI / ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
+* NUClear Geometry Interaction Informations
+ COMMON / NUCGII / HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
+ & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
+ & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
+ & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
+ & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
+ & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, NDEUST,
+ & IRSREI, ININDX, LABRST, LELSTC, LINELS, LCHEXC,
+ & LSTEXC, LABSRP, LABSTH, LNCDCY, LNUSCT, LPRABS,
+ & LDEUST, LRSDCY, LPNTRG, LRSREI
+ DIMENSION AWSTAB (2:260), SIGMAB (3), RHONCP (2), RHONC2 (2),
+ & RHONC3 (2)
+ EQUIVALENCE ( DEFPRO, DEFNUC (1) )
+ EQUIVALENCE ( DEFNEU, DEFNUC (2) )
+* First target nucleon equivalences:
+ EQUIVALENCE ( RHONCP (1), RHONCJ (1,1) )
+ EQUIVALENCE ( RHOIPP, RHONCJ (1,1) )
+ EQUIVALENCE ( RHOINP, RHONCJ (2,1) )
+ EQUIVALENCE ( RHOIMP, RHOIMJ (1) )
+ EQUIVALENCE ( EKFIMP, EKFIMJ (1) )
+ EQUIVALENCE ( PFRIMP, PFRIMJ (1) )
+ EQUIVALENCE ( RIMPCT, RIMPCJ (1) )
+ EQUIVALENCE ( XIMPCT, XIMPCJ (1) )
+ EQUIVALENCE ( YIMPCT, YIMPCJ (1) )
+ EQUIVALENCE ( ZIMPCT, ZIMPCJ (1) )
+ EQUIVALENCE ( EKFERM, EKFERJ (1) )
+ EQUIVALENCE ( EKFEXT, EKFEXJ (1) )
+ EQUIVALENCE ( PNFRMI, PNFRMJ (1) )
+ EQUIVALENCE ( PXFERM, PXFERJ (1) )
+ EQUIVALENCE ( PYFERM, PYFERJ (1) )
+ EQUIVALENCE ( PZFERM, PZFERJ (1) )
+ EQUIVALENCE ( ISFTAR, ISFTAJ (1) )
+ EQUIVALENCE ( KNUCIM, KNUCIJ (1) )
+* Second target nucleon equivalences:
+ EQUIVALENCE ( RHONC2 (1), RHONCJ (1,2) )
+ EQUIVALENCE ( RHOIP2, RHONCJ (1,2) )
+ EQUIVALENCE ( RHOIN2, RHONCJ (2,2) )
+ EQUIVALENCE ( RHOIM2, RHOIMJ (2) )
+ EQUIVALENCE ( EKFIM2, EKFIMJ (2) )
+ EQUIVALENCE ( PFRIM2, PFRIMJ (2) )
+ EQUIVALENCE ( RIMPC2, RIMPCJ (2) )
+ EQUIVALENCE ( XIMPC2, XIMPCJ (2) )
+ EQUIVALENCE ( YIMPC2, YIMPCJ (2) )
+ EQUIVALENCE ( ZIMPC2, ZIMPCJ (2) )
+ EQUIVALENCE ( EKFER2, EKFERJ (2) )
+ EQUIVALENCE ( EKFEX2, EKFEXJ (2) )
+ EQUIVALENCE ( PNFRM2, PNFRMJ (2) )
+ EQUIVALENCE ( PXFER2, PXFERJ (2) )
+ EQUIVALENCE ( PYFER2, PYFERJ (2) )
+ EQUIVALENCE ( PZFER2, PZFERJ (2) )
+ EQUIVALENCE ( ISFTA2, ISFTAJ (2) )
+ EQUIVALENCE ( KNUCI2, KNUCIJ (2) )
+* Third target nucleon equivalences:
+ EQUIVALENCE ( RHONC3 (1), RHONCJ (1,3) )
+ EQUIVALENCE ( RHOIP3, RHONCJ (1,3) )
+ EQUIVALENCE ( RHOIN3, RHONCJ (2,3) )
+ EQUIVALENCE ( RHOIM3, RHOIMJ (3) )
+ EQUIVALENCE ( EKFIM3, EKFIMJ (3) )
+ EQUIVALENCE ( PFRIM3, PFRIMJ (3) )
+ EQUIVALENCE ( RIMPC3, RIMPCJ (3) )
+ EQUIVALENCE ( XIMPC3, XIMPCJ (3) )
+ EQUIVALENCE ( YIMPC3, YIMPCJ (3) )
+ EQUIVALENCE ( ZIMPC3, ZIMPCJ (3) )
+ EQUIVALENCE ( EKFER3, EKFERJ (3) )
+ EQUIVALENCE ( EKFEX3, EKFEXJ (3) )
+ EQUIVALENCE ( PNFRM3, PNFRMJ (3) )
+ EQUIVALENCE ( PXFER3, PXFERJ (3) )
+ EQUIVALENCE ( PYFER3, PYFERJ (3) )
+ EQUIVALENCE ( PZFER3, PZFERJ (3) )
+ EQUIVALENCE ( ISFTA3, ISFTAJ (3) )
+ EQUIVALENCE ( KNUCI3, KNUCIJ (3) )
+* Projectile equivalences:
+ EQUIVALENCE ( RHOIPT, RHONCT (1) )
+ EQUIVALENCE ( RHOINT, RHONCT (2) )
+ EQUIVALENCE ( OMALHL, SK3PAR )
+ EQUIVALENCE ( ALPHAL, HABPAR )
+ EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
+ EQUIVALENCE ( SIGMPE, SIGMPR (1) )
+ EQUIVALENCE ( SIGMPC, SIGMPR (2) )
+ EQUIVALENCE ( SIGMPI, SIGMPR (3) )
+ EQUIVALENCE ( SIGMPA, SIGMPR (4) )
+ EQUIVALENCE ( SIGMPS, SIGMPR (5) )
+ EQUIVALENCE ( SIGMPH, SIGMPR (6) )
+ EQUIVALENCE ( SIGMNE, SIGMNU (1) )
+ EQUIVALENCE ( SIGMNC, SIGMNU (2) )
+ EQUIVALENCE ( SIGMNI, SIGMNU (3) )
+ EQUIVALENCE ( SIGMNA, SIGMNU (4) )
+ EQUIVALENCE ( SIGMNS, SIGMNU (5) )
+ EQUIVALENCE ( SIGMNH, SIGMNU (6) )
+ EQUIVALENCE ( SIGMA2, SIGPAB (1) )
+ EQUIVALENCE ( SIGMA3, SIGPAB (2) )
+ EQUIVALENCE ( SIGMAS, SIGPAB (3) )
+ EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
+
+
--- /dev/null
+*$ CREATE NUCLEV.ADD
+*COPY NUCLEV
+*
+*=== nuclev ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear LEVel common: *
+* *
+* Created on 10 january 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 20-oct-96 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BERTTP *
+* BIMSEL *
+* NCLVIN *
+* NCLVGT *
+* NCLVST *
+* NUCNUC *
+* NWISEL *
+* PEANUT *
+* PFNCLV *
+* PIOABS *
+* *
+* Description of the variables (nuclev): *
+* *
+* paenuc(k,i) = pairing energies (GeV), for i=1 pro- *
+* ton pairing energy for Z=k, for i=2 *
+* neutron pairing energy for N=k *
+* shenuc(k,i) = shell energies (GeV), for i=1 pro- *
+* ton shell energy for Z=k, for i=2 *
+* neutron shell energy for N=k *
+* defrmi(i) = level spacing at the Fermi level ac- *
+* cording to a Fermi gas *
+* defmag(i) = extra energy needed to overcome the *
+* gap between the closed shell and the *
+* next level for nuclei with magic *
+* numbers of protons or neutrons *
+* ennclv(k,i) = level energy computed from the well *
+* bottom at nucleus centre (for poten- *
+* tial not dependent on energy) or from*
+* the Fermi level (for energy dependent*
+* potential) *
+* ranclv(k,i) = maximum possible radius for the kth *
+* level *
+* cumrad(k,i) = sum for j=1,k of 1 /Rj where Ri is *
+* the maximum radius at which can be *
+* found the jth nucleon of type i *
+* (i=1 proton, i=2 neutron) *
+* ruspro = maximum radius at which protons can *
+* still be found *
+* rusneu = maximum radius at which neutrons can *
+* still be found *
+* juspro = index for flagging that the jth *
+* proton has been already used if *
+* = inuclv *
+* jusneu = index for flagging that the jth *
+* neutron has been already used if *
+* = inuclv *
+* ntapro = number of protons in the target *
+* ntaneu = number of neutrons in the target *
+* navpro = number of available proton levels in *
+* the target *
+* navneu = number of available neutron levels *
+* in the target *
+* nlspro = number of protons in the last level *
+* nlsneu = number of neutrons in the last level *
+* ncopro = number of protons in the core *
+* nconeu = number of neutrons in the core *
+* nskpro = number of protons in the skin *
+* nskneu = number of neutrons in the skin *
+* nhapro = number of protons in the halo *
+* nhaneu = number of neutrons in the halo *
+* nuspro = number of "used" protons *
+* nusneu = number of "used" neutrons *
+* nacpro = number of still not "used" protons *
+* nacneu = number of still not "used" neutrons *
+* jmxpro = index of the highest energy avai- *
+* lable proton *
+* jmxneu = index of the highest energy avai- *
+* lable neutron *
+* nprnuc = number of presently used nucleons *
+* (max 3) *
+* iprnuc = type of the presently considered *
+* nucleon *
+* jprnuc = index of the presently considered *
+* nucleon *
+* magnum = magic numbers *
+* magpro = last (possibly not filled) proton *
+* shell *
+* magneu = last (possibly not filled) neutron *
+* shell *
+* mgspro(k) = status of the kth proton shell: *
+* -2 not filled but paired *
+* -1 not filled and unpaired *
+* 0 filled (paired of course) *
+* +1 originally filled but now unpai- *
+* red *
+* mgsneu(k) = status of the kth neutron shell *
+* mgsspr(k) = (cumulative) number of protons in *
+* the kth proton subshell *
+* mgssne(k) = (cumulative) number of neutrons in *
+* the kth neutron subshell *
+* nmnsbs(k) = minimum number of nucleons of ith *
+* kind to group together subshell *
+* levels (if < Fermi spacing is used) *
+* Immaterial for Lflvsl = .true. *
+* inuclv = index of the present event *
+* lclvsl = flag for radius-dependent (local) *
+* energy selection *
+* lflvsl = flag for Fermi-like spaced level se- *
+* lection rather than shell model like *
+* lrlvsl = flag for rho like level maximum rad- *
+* ius selection *
+* leqsbl = flag indicating equal levels for *
+* each subshell: *
+* leqsbl=.not.lflvsl.and.not.lrlvsl *
+* *
+*----------------------------------------------------------------------*
+*
+* NUClear LEVel
+ LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
+ COMMON / NUCLEV / PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
+ & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
+ & CUMRAD (0:160,2), RUSNUC (2),
+ & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
+ & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
+ & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
+ & JMXNUC (2), MAGNUM (8), MAGNUC (2), NSBSHL (2),
+ & NMNSBS (2), IPRNUC (MXHTTR), JPRNUC (MXHTTR),
+ & MGSNUC (8,2), MGSSNC (25,2), NPRNUC, INUCLV,
+ & LCLVSL, LFLVSL, LRLVSL, LEQSBL
+ DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
+ & MGSSPR (19) , MGSSNE (25)
+ EQUIVALENCE ( RUSNUC (1), RUSPRO )
+ EQUIVALENCE ( RUSNUC (2), RUSNEU )
+ EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
+ EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
+ EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
+ EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
+ EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
+ EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
+ EQUIVALENCE ( NTANUC (1), NTAPRO )
+ EQUIVALENCE ( NTANUC (2), NTANEU )
+ EQUIVALENCE ( NAVNUC (1), NAVPRO )
+ EQUIVALENCE ( NAVNUC (2), NAVNEU )
+ EQUIVALENCE ( NLSNUC (1), NLSPRO )
+ EQUIVALENCE ( NLSNUC (2), NLSNEU )
+ EQUIVALENCE ( NCONUC (1), NCOPRO )
+ EQUIVALENCE ( NCONUC (2), NCONEU )
+ EQUIVALENCE ( NSKNUC (1), NSKPRO )
+ EQUIVALENCE ( NSKNUC (2), NSKNEU )
+ EQUIVALENCE ( NHANUC (1), NHAPRO )
+ EQUIVALENCE ( NHANUC (2), NHANEU )
+ EQUIVALENCE ( NUSNUC (1), NUSPRO )
+ EQUIVALENCE ( NUSNUC (2), NUSNEU )
+ EQUIVALENCE ( NACNUC (1), NACPRO )
+ EQUIVALENCE ( NACNUC (2), NACNEU )
+ EQUIVALENCE ( JMXNUC (1), JMXPRO )
+ EQUIVALENCE ( JMXNUC (2), JMXNEU )
+ EQUIVALENCE ( MAGNUC (1), MAGPRO )
+ EQUIVALENCE ( MAGNUC (2), MAGNEU )
+
--- /dev/null
+*$ CREATE NUCPAR.ADD
+*COPY NUCPAR
+*
+*=== Nucpar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* New version of Nucpar: *
+* *
+* Created on 20-january-1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 20-dec-97 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: not updated *
+* *
+* distnu *
+* eventv *
+* evxtes *
+* nucevv *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Pxnu(i) = X-component of the momentum of the i_th produced *
+* particle *
+* Pynu(i) = Y-component of the momentum of the i_th produced *
+* particle *
+* Pznu(i) = Z-component of the momentum of the i_th produced *
+* particle *
+* Hepnu(i) = Total energy of the i_th produced particle *
+* Amnu(i) = Mass of the i_th produced particle *
+* Ichnu(i) = Charge of the i_th produced particle *
+* Ibarnu(i) = Baryon number of the i_th produced particle *
+* Nrenu(i) = Identity (part scheme) of the i_th produced particle *
+* Infonu(i) = chain # of the i_th produced particle *
+* Ichnnu(3,i) = Several informations about production vertex, rank- *
+* ing, decay generation etc. *
+* Annu(i) = Literal name of the i_th produced particle *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANNU
+ COMMON / NUCPAR / PXNU (MXPDPM), PYNU (MXPDPM), PZNU (MXPDPM),
+ & HEPNU (MXPDPM), AMNU (MXPDPM), ICHNU (MXPDPM),
+ & IBARNU(MXPDPM), NRENU (MXPDPM), INFONU(MXPDPM),
+ & ICHNNU(3,MXPDPM)
+ COMMON / CHNCPR / ANNU (MXPDPM)
+
--- /dev/null
+*$ CREATE NUCPOT.ADD
+*COPY NUCPOT
+*
+*=== nucpot ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear POTential informations: *
+* *
+* Created on 29-march-1993 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 03-mar-97 by Alfredo Ferrari, INFN-Milan *
+* *
+* Iflgnp = nuclear potential flag: *
+* (Kflgnp = nuclear potential flag for unbound nucleons:) *
+* 100: ordinary constant Fermi potential for both *
+* target and projectile nucleons + binding *
+* energy going down as given by bnddst and *
+* bndams *
+* 110: as above but with well depth given by the *
+* shell model energy level sequence times *
+* 41 / A^1/3 MeV *
+* 200: SWS constant potential+binding for nuc+Coul *
+* for both target and projectile nucleons, with*
+* central depth fitted at the Fermi one, bind. *
+* energy going down as given by bnddst and *
+* bndams *
+* ("Tallahassee" one) *
+* 210: as above but with well depth given by the *
+* shell model energy level sequence times *
+* 41 / A^1/3 MeV *
+* ================================================================ *
+* 300: SWS energy dependent nuclear potential for *
+* both target and projectile nucleons *
+* Subcases: *
+* c1a=311: with given Vpemax, Vpsqmx and "natural" *
+* shell model energy spacing, central well *
+* depth given by Ekfermi(0) *
+* c1b=312: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given by Ekfermi(0) *
+* c2a=321: with Vpemax, Vpsqmx and central well *
+* depth given according to the optical pot., *
+* and "natural" shell model energy spacing *
+* c2b=322: with Vpemax, Vpsqmx given and spacing *
+* given by the potential itself, central well *
+* depth given according to the optical pot. *
+* c3a=331: as above but with given unity of spacing *
+* ("natural" shell model spacing), central well*
+* depth given by Ekfermi(0), Vpemax computed *
+* according to the unity of spacing *
+* c3b=332: as above but with given Vpemax, central well *
+* depth given by Ekfermi(0), unity of spacing *
+* computed according to Vpemax *
+* c4a=333: as above but with given Vpemax, Vpsqmx, *
+* central well computed according to the level *
+* sequence and the "natural" unity of spacing *
+* ================================================================ *
+* 400: energy dependent, local Fermi level fitted *
+* energy dependent (--> "a la Chen") potential *
+* for projectile and bound nucleons *
+* Subcases: *
+* d1a=411: as above but with Vpemax given and "natural" *
+* shell model energy spacing, both central *
+* depth well and radial behaviour given by *
+* Ekfermi(r) *
+* d1b=412: as above but with Vpemax given and spacing *
+* given by the potential itself, both central *
+* depth well and radial behaviour given by *
+* Ekfermi(r) *
+* d2a=421: as above but with Vpemax and central well *
+* depth given according to the optical pot., *
+* and "natural" shell model energy spacing, and*
+* radial behaviour according to Ekfermi(r) *
+* d2b=422: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given according to the optical pot. and*
+* radial behaviour according to Ekfermi(r) *
+* d3a=431: as above but with given unity of spacing *
+* ("natural" shell model spacing), central well*
+* depth and radial behaviour according to *
+* Ekfermi(r), Vpemax computed according to the *
+* unity of spacing *
+* d3b=432: as above but with given Vpemax, central well *
+* depth and radial behaviour according to *
+* Ekfermi(r), unity of spacing computed accor- *
+* ding to Vpemax *
+* d4a=433: as above but with given Vpemax, Vpsqmx, *
+* central well according to the level sequence *
+* and the "natural" unity of spacing, *
+* radial behaviour according to Ekfermi(r) *
+* ================================================================ *
+* 500: energy dependent, "our" WS for the potential *
+* shape not including the binding energy, with *
+* central depth fitted to the central Fermi *
+* level, (--> "a la Chen") potential *
+* for projectile and bound nucleons *
+* Subcases: *
+* e1a=511: as above but with Vpemax given and "natural" *
+* shell model energy spacing, central well *
+* depth given by Ekfermi(0) *
+* e1b=512: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given by Ekfermi(0) *
+* e2a=521: as above but with Vpemax and central well *
+* depth given according to the optical pot., *
+* and "natural" shell model energy spacing *
+* e2b=522: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given according to the optical pot. *
+* e3a=531: as above but with given unity of spacing *
+* ("natural" shell model spacing), central well*
+* depth given by Ekfermi(0), Vpemax computed *
+* according to the unity of spacing *
+* e3b=532: as above but with given Vpemax, central well *
+* depth given by Ekfermi(0), unity of spacing *
+* computed according to Vpemax *
+* e4a=533: as above but with given Vpemax, Vpsqmx, *
+* central well computed according to the level *
+* sequence and the "natural" unity of spacing *
+* ================================================================ *
+* 600: energy dependent, SWS like potential, with *
+* "saturation" like central part fitted to *
+* nuclear plus Coulomb at the centre and at *
+* the nuclear radius, for projectile and bound *
+* nucleons *
+* Subcases: *
+* f1a=611: as above but with Vpemax given and "natural" *
+* shell model energy spacing, central depth *
+* well given by Ekfermi(0)+bndng+Vcoul *
+* f1b=612: as above but with Vpemax given and spacing *
+* given by the potential itself, central depth *
+* well given by Ekfermi(0)+bndng+Vcoul *
+* f2a=621: as above but with Vpemax and central well *
+* depth given according to the optical pot., *
+* and "natural" shell model energy spacing *
+* f2b=622: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given according to the optical pot. *
+* f3a=631: as above but with given unity of spacing *
+* ("natural" shell model spacing), central well*
+* depth given by Ekfermi(0), Vpemax computed *
+* according to the unity of spacing *
+* f3b=632: as above but with given Vpemax, central well *
+* depth according to Ekfermi(0)+bndng+Vcoul, *
+* unity of spacing computed according to Vpemax*
+* f4a=633: as above but with given Vpemax, Vpsqmx, *
+* central well according to the level sequence *
+* and the "natural" unity of spacing *
+* ================================================================ *
+* 700: energy dependent, self-consistent folding *
+* of rho's with NN and pn interaction rms *
+* for the potential radial behaviour *
+* energy dependent (--> "a la Chen") potential *
+* for projectile and bound nucleons *
+* Subcases: *
+* g1a=711: as above but with Vpemax given and "natural" *
+* shell model energy spacing, central depth *
+* well given by Ekfermi(0) *
+* g1b=712: as above but with Vpemax given and spacing *
+* given by the potential itself, central depth *
+* well given by Ekfermi(0) *
+* g2a=721: as above but with Vpemax and central well *
+* depth given according to the optical pot., *
+* and "natural" shell model energy spacing *
+* g2b=722: as above but with Vpemax given and spacing *
+* given by the potential itself, central well *
+* depth given according to the optical pot. *
+* g3a=731: as above but with given unity of spacing *
+* ("natural" shell model spacing), central well*
+* depth according to Ekfermi(0), Vpemax com- *
+* puted according to the unity of spacing *
+* g3b=732: as above but with given Vpemax, central well *
+* depth according to Ekfermi(0), unity of spa- *
+* cing computed according to Vpemax *
+* g4a=733: as above but with given Vpemax, Vpsqmx, *
+* central well according to the level sequence *
+* and the "natural" unity of spacing *
+* ================================================================ *
+* Vptbpr = total projectile potential according to the *
+* "true" binding energy (Bndpot) for the *
+* various radial bins *
+* Rdbnmd = Radial bin median point *
+* Vpemax = energy scaling variable of the potential *
+* Vpsqmx = energy scaling variable of the quadratic *
+* term of the potential *
+* Spauni = spacing unit of the level sequence *
+* Spa2nd = 2nd parameter for spacing unit of the level *
+* sequence *
+* Spapwr = exponent for the 2nd parameter for spacing *
+* unit of the level sequence *
+* Vpmxrd = energy scaling variable of the potential for *
+* unbound nucleons *
+* Vpsqmx = energy scaling variable of the quadratic *
+* term of the potential for unbound nucleons *
+* Spunrd = spacing unit of the level sequence for un- *
+* bound nucleons *
+* Spu2nd = 2nd parameter for spacing unit of the level *
+* sequence for unbound nucleons *
+* Spupwr = exponent for the 2nd parameter for spacing *
+* unit of the level sequence for unbound nucl. *
+* Vpedge = Vnuc (r=Rnuc,E=-Bnvpsf) *
+* x [ Vpemax+Vcoul(Rnuc)-Ekcopo ] *
+* / [ Vpemax+Vcoul(Rnuc)+Bnvpsf ] *
+* *
+* Efabun = energy "above" (usually it is below..) the *
+* Fermi level for the considered target *
+* nucleon(s) *
+* Ekcopo = oo energy with respect to the potential zero *
+* energy level=Min(Vpemax,Ekecon-Bndnuc+Bnvpsf)*
+* =Min(Vpemax,Eknnuc-Bndpot+Bnvpsf)*
+* Vprnuc = Vnuc (r=Rnuc,E=Ekcopo)=Vpedge *
+* x [ Vpemax+Vcoul(Rnuc)-Ekcopo ] *
+* / [ Vpemax+Vcoul(Rnuc)+Bnvpsf ] *
+* Frmano = maximum amplitude of the Fermi anomaly *
+* Efrano = energy scale of the Fermi anomaly *
+* E0fran = energy offset of the Fermi anomaly *
+* X0fran = offset of the Fermi anomaly *
+* Franmx = maximum value of the Fermi anomaly shaping *
+* Eaprad = energy scale for the aparvp energy dependence*
+* Ecprad = energy scale for the cparvp energy dependence*
+* Etmrad = energy scale for hte rad. term dep. term *
+* Veprad = V_0 term for the potential shape at oo energy*
+* Ravprd = potent. radius for the pot. at oo energy *
+* Tmedge = rad. dep. red. term at nucleus boundary *
+* Folrms = folding rms radii used to build the rho tab. *
+* Rcrsat(l) = (computed) radial parameter for saturation *
+* for 600-like potential calculations *
+* ( l=1 bound nucleons, l=2 unbound nucleons) *
+* Rcrpow(l) = given exponent for the density dependent sa- *
+* turating component 600-like potential calcu- *
+* lations *
+* ( l=1 bound nucleons, l=2 unbound nucleons) *
+* Effrms = effective rms for the present projectile *
+* Radeff = effective nuclear radius for the present *
+* projectile *
+* Rhoeff(k) = effective nuclear density tabulations for the*
+* present projectile ( k=1 protons, *
+* k=2 neutrons ) *
+* Ppreff = projectile momentum in the potential tabula- *
+* tions *
+* Rmseff = projectile spreading RMS in the potential ta-*
+* bulations *
+* Mesfbn = index of the last bin for which the effective*
+* density is not zero *
+* Iflgft = formation time flag (see the corresponding *
+* coding, translation put into Jflgft(i,1) ) *
+* Iflgnc = nucleon correlation flag (see the correspon- *
+* ding coding) *
+* Nflgft = formation time flag (see the corresponding *
+* coding, translation put into Jflgft(i,1) ) *
+* for the preeq. part *
+* Nflgnc = nucleon correlation flag (see the correspon- *
+* ding coding) for the preeq. part *
+* Ieptrd = flag for radial dependence of the energy de- *
+* pendence of the potential for bound nuc- *
+* leons (1,2) (see routine vecdrd) *
+* Keptrd = flag for radial dependence of the energy de- *
+* pendence of the potential for unbound nuc- *
+* leons (1,2) (see routine vecdrd) *
+* Ivpsws = applicable only for 3.. options: flag for *
+* computing the SWS potential parameters for *
+* bound nucleons (1,2). *
+* It is applicable also to 6.. options, just *
+* to request density folding with an effective *
+* nucleon-nucleon interaction, if so only = 0 *
+* or > 0 matters. *
+* 1 = take the input parameters *
+* 2 = fold the proton rms *
+* 3 = match the binding energy at the neutron *
+* /proton radius (folded or centre depending*
+* on Lrhfl1) *
+* Kvpsws = applicable only for 3.. options: flag for *
+* computing the SWS potential parameters for *
+* unbound nucleons (1,2). *
+* It is applicable also to 6.. options, just *
+* to request density folding with an effective *
+* nucleon-nucleon interaction, if so only = 0 *
+* or > 0 matters. *
+* 1 = take the input parameters *
+* 2 = fold the proton rms *
+* 3 = match the binding energy at the neutron *
+* /proton radius (folded or centre depending*
+* on Lrhfl2) *
+* Lrhfl1 = flag for target nucleon rho folding *
+* Lrhfl2 = flag for projectile rho folding *
+* Lrhfl3 = flag for pion potential rho folding *
+* Lrhfla = flag for interaction radius rho folding in *
+* absorption events *
+* Laprad = flag to have cparvp/aparvp energy dependent *
+* Listrm = logical flag for modifying the "natural" *
+* Fermi energy for protons and neutrons with an*
+* isospin dependent term *
+* Lncptf = flag for (bound) nucleon potential folding *
+* with the target nucleon rms *
+* Lfpshf = flag for considering a charge-exchange reac- *
+* tion the p-n(n-p) scattering when *
+* cos(theta)<0 *
+* Ifpshf = flag for the different options when consi- *
+* dering a charge-exchange reaction the p-n *
+* (n-p) scattering when cos(theta)<0 *
+* Lptbar = flag for considering a barrier penetration *
+* factor for nucleons *
+* Lexpif = flag for an energy-dependent exponential pot.*
+* for target nucleons *
+* Lexpkf = flag for an energy-dependent exponential pot.*
+* for projectile nucleons *
+* Lexpln = flag for an energy-dependent exponential pot.*
+* for projectile nucleons and a linear depen- *
+* dent one for target nucleons *
+* If an exponential potential is chosen, *
+* V = V0 + V1 x exp ( - f (E-E_f) / V1 ) *
+* then Vpemax/Vpmxrd become V1 / f, and Vpsqmx/Vqmxrd V0/(V1+V0) *
+* For an exp/lin potential for bound nucleons: *
+* V = V0 + V1 - f (E-E_f) *
+* Lpreen = flag for using the potential energy depen- *
+* dence in the preequilibrium part too *
+* Lshmdl = flag for using the shell model density distr.*
+* for A =< 16 *
+* Lsrmss = flag for computing sigmas using the invariant*
+* mass of the produced state intermediate *
+* resonance, instead of computing it according *
+* to the entrance particle cms energy, inclu- *
+* ding potentials *
+* Linvar = logical flag for selecting direction invaria-*
+* nce in n-n collisions after applying the en- *
+* ergy dependent potential or the more sophi- *
+* sticated algorithm(s) *
+* Iinvar = flag for selecting which of the more sophi- *
+* cated algorithms has to be used in n-n colli-*
+* sions in n-n collisions after applying the *
+* energy dependent potential *
+* Linvan = like Linvar but for antinucleons-n *
+* Iinvan = like Iinvar but for antinucleons-n *
+* Linvpi = like Linvar but for pions-n *
+* Iinvpi = like Iinvar but for pions-n *
+* Linvka = like Linvar but for kaons-n *
+* Iinvka = like Iinvar but for kaons-n *
+* Linvhy = like Linvar but for hyperons-n *
+* Iinvhy = like Iinvar but for hyperons-n *
+* Linvah = like Linvar but for antihyperons-n *
+* Iinvah = like Iinvar but for antihyperons-n *
+* Lncedp = flag to control how to apply the energy de- *
+* pendent potential after a nucleon-nucleon *
+* elastic or a 2 or 3 nucleon absorption event *
+* See the interaction routines for details *
+* Lanedp = flag to control how to apply the energy de- *
+* pendent potential after a antinucleon-nucleon*
+* event. *
+* See the interaction routines for details *
+* Lpiedp = flag to control how to apply the energy de- *
+* pendent potential after a pion-nucleon event *
+* See the interaction routines for details *
+* Lkaedp = flag to control how to apply the energy de- *
+* pendent potential after a kaon-nucleon event *
+* See the interaction routines for details *
+* Lhyedp = flag to control how to apply the energy de- *
+* pendent potential after a hyperon-nucleon *
+* event. *
+* See the interaction routines for details *
+* Lahedp = flag to control how to apply the energy de- *
+* pendent potential after a antihyperon-nucleon*
+* event *
+* See the interaction routines for details *
+* Linedp = flag to control how to apply the energy de- *
+* pendent potential after an inelastic event *
+* See the interaction routines for details *
+* Lsacou = flag to control how to apply the energy de- *
+* pendent potential after an inelastic event *
+* If .true. Coulomb potential is adjusted on a *
+* standalone basis using charge conservation *
+* while nuclear potential is adjusted in the *
+* usual way *
+* Lnptun = flag to control whether to unfold or not the *
+* nucleon rms from the density distribution *
+* when computing the unbound nucleon nuclear *
+* potential according to Ekfermi(r) *
+* Liblob = flag for excluding potential effects in the *
+* volume connected with interaction "blobs" *
+* (hard core zone and formation time zone) *
+* Lrhblb = flag for using a density dependent excluding *
+* potential effect volume connected with hard *
+* core zone. It has no meaning for *
+* Liblob=.false. *
+* Frblob = multiplicative factor to be applied to hard *
+* core correl. dist. for computing the blob *
+* Ftblob = multiplicative factor to be applied to for- *
+* mation time dist. for computing the blob *
+* Labvpr = flag for removing (.true.) or not the proje- *
+* ctile potential energy in absorption events *
+* Funfrm = dummy factor for uncertainty related (extra) *
+* Fermi motion (average) *
+* Lunfrm = flag for uncertainty related (extra) Fermi *
+* motion (average) *
+* Funrnf = sigma factor for uncertainty related (extra) *
+* random run time Fermi motion (1 sigma in fm) *
+* Runrnf = radial expansion factor for uncertainty rel- *
+* ated (extra) random run time Fermi motion *
+* (particles are allowed to exist up to Runrnf *
+* beyond the energetically allowed radius ) *
+* Lunrnf = flag for uncertainty related (extra) random *
+* run time Fermi motion *
+* Fftail = dummy factor for Fermi motion high momentum *
+* tails *
+* Lftail = flag for Fermi motion high momentum tails *
+* Lbnzm1 = flag for using Z-1 rather than Z for bound *
+* nucleons when computing Coulomb effects *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum number of trials during interaction radius rho unfolding
+* for absorption events:
+ PARAMETER ( NRHFLA = 3 )
+* Method of interaction radius rho unfolding for absorption events:
+ PARAMETER ( IRHFLA = 1 )
+* Interaction radius for rho unfolding for absorption events:
+ PARAMETER ( DRHFLA = PLABRC / 0.1396D+00 / SQRT12 )
+*
+ LOGICAL LISTRM, LAPRAD, LRHFL1, LRHFL2, LRHFL3, LRHFLA, LNCPTF,
+ & LFPSHF, LPTBAR, LEXPIF, LEXPKF, LEXPLN, LPREEN, LSHMDL,
+ & LSRMSS, LINVAR, LINVAN, LINVPI, LINVKA, LINVHY, LINVAH,
+ & LNCEDP, LANEDP, LPIEDP, LKAEDP, LHYEDP, LAHEDP, LINEDP,
+ & LNPTUN, LIBLOB, LABVPR, LRHBLB, LUNFRM, LBNZM1, LSACOU,
+ & LUNRNF, LFTAIL
+ COMMON / NUCPOT / RHOEFF(100,2), PPREFF (100), RMSEFF (100),
+ & VPTBPR (0:50), RDBNMD (0:50), EFABUN (MXHTTR),
+ & VPEMAX (2), VPSQMX (2), SPAUNI (2), SPA2ND (2),
+ & SPAPWR (2), VPEDGE (2), FRMANO (2), EAPRAD (2),
+ & ECPRAD (2), VEPRAD (2), ETMRAD (2), RAVPRD (2),
+ & TMEDGE (2), VPMXRD (2), VQMXRD (2), SPUNRD (2),
+ & SPU2ND (2), SPUPWR (2), PVRDMX (2), EVRDMX (2),
+ & FOLRMS (4), RCRSAT (2), RCRPOW (2), BNDDST,
+ & BNDAMS, VPRNUC, BNDDFF, BNDFCO, EKCOPO, EFRANO,
+ & E0FRAN, X0FRAN, FRANMX, EFFRMS, RADEFF, FRBLOB,
+ & FTBLOB, FUNFRM, FUNRNF, FFTAIL, RUNRNF
+ COMMON / INCPOT / NFLGNC, MESFBN, IFLGFT, IFLGNC, NFLGFT,
+ & IFPSHF, IINVAR, IINVAN, IINVPI, IINVKA, IINVHY,
+ & IINVAH, JFLGFT (4,2), IFLGNP (2), KFLGNP (2),
+ & IEPTRD (2), KEPTRD (2), IVPSWS (2), KVPSWS (2),
+ & LISTRM (2), LAPRAD (2), LPTBAR (2), LEXPIF (2),
+ & LEXPKF (2), LEXPLN (2), LRHFL1, LRHFL2, LRHFL3,
+ & LRHFLA, LNCPTF, LFPSHF, LPREEN, LSHMDL, LSRMSS,
+ & LINVAR, LINVAN, LINVPI, LINVKA, LINVHY, LINVAH,
+ & LNCEDP, LANEDP, LPIEDP, LKAEDP, LHYEDP, LAHEDP,
+ & LINEDP, LNPTUN, LIBLOB, LABVPR, LRHBLB, LUNFRM,
+ & LBNZM1, LSACOU, LUNRNF, LFTAIL
+
--- /dev/null
+*$ CREATE NUCSFT.ADD
+*COPY NUCSFT
+*
+*=== nucsft ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear Symmetrized Fermi/woods-saxon density and potential *
+* tabulations *
+* *
+* Last change on 20-jun-94 by Alfredo Ferrari, INFN-Milan *
+* *
+* Vparvp, cparvp, aparvp (bparvp auxiliary parameter *
+* for Cparvp calculations): *
+* *
+* V0 (r) = Vparvp * sinh (cparvp/aparvp) *
+* / ( cosh (cparvp/aparvp) + cosh (r/aparvp) ) *
+* expvca = exp ( -cparvp / aparvp ) *
+* expvra = exp ( rcursf / aparvp ) *
+* bnvpsf = "average" binding energy used when generating *
+* the potential tabulations *
+* v0cesf = well depth at r=0 for the "average" potential *
+* evsfmx = Max. Fermi energy for the ip nucleon potential *
+* evsfmx = |v0cesf| - bnvpsf *
+* pvsfmx = Max. Fermi momentum for proton/neutron *
+* pfsksf = Fermi momentum for proton/neutron computed at *
+* radiu1 defined ad the (mrsfbn-5)th bin limit *
+* vcoumx = maximum height of the Coulomb barrier *
+* (for Z=Zvpcou), modified during tracking to *
+* get the real barrier *
+* vcousv = maximum height of the Coulomb barrier *
+* (for Z=Zvpcou) *
+* v0ccou = Coulomb potential at R=Radtot *
+* zvpcou = Z for which the barrier has been computed *
+* zbourd = Z reduction factor to be used for bound nucleons*
+* when computing Coulomb effects *
+* ravpsf = radius at which the "average" nuclear potential *
+* stops *
+* ravcou = radius at which the Coulomb potential stops *
+* ravpot = radius at which the nuclear potential stops *
+* dradsf = radial increment used from radiu0 up to radtot *
+* dravsf = radial increment used from radtot up to ravpot *
+* ivsfmn = index of the innermost potential shell which *
+* can be reached by the current particle accord- *
+* ing to its angular momentum *
+* ivsfmx = index of the outermost potential shell which *
+* can be reached by the current particle accord- *
+* ing to its energy and angular momentum *
+* ivcomx = bin index of the maximum height of the Coulomb *
+* barrier *
+* isfint = current tabulation index *
+* ibsfmn = index of the radial bin of the the minimum *
+* approach point *
+* ibsfmx = index of the radial bin of the the maximum *
+* approach point *
+* *
+* The actual potential is given by (Preeqmvax version with no *
+* energy dependence of the potential): *
+* for r < radtot (note V_nuc < 0): *
+* neutral particles : *
+* V_true(r) = V_nuc(r,ip) + bnvpsf (ip) - bn_true (ip) *
+* charged particles : *
+* V_true(r) = V_nuc(r,ip) + bnvpsf (ip) - bn_true (ip) *
+* + Zproj * V_coul(r) *
+* for ravpsf > r > radtot (note V_nuc < 0): *
+* V_true(r) = V_nuc(r,ip) / bnvpsf (ip) x bn_true (ip) *
+* + Znow / Zvpcou x Zproj x V_coul(r) *
+* for r > ravpsf : *
+* V_true(r) = Znow / Zvpcou x Zproj x V_coul(r) *
+* Please note that Ekfcen(ip)=Evsfmx(ip), for ip=1,2 *
+* For the actual potential with the Preeqmvax version with the *
+* energy dependence of the potential, see the relevant routines *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / NUCSFT / VPARVP (2), CPARVP (2), APARVP (2), BPARVP (2),
+ & EXPVCA (2), EXPVRA (2), RAVPSF (2), BNVPSF (2),
+ & V0CESF (2), EVSFMX (2), VSFHLP (2), PVSFMX (2),
+ & PFSKSF (2), RAVCOU, RAVPOT, VCOUMX, V0CCOU,
+ & ZVPCOU, ZBOURD, VPSFA0, VPSFA1, VPSFAE, DRADSF,
+ & DRAVSF, VCOUSV,
+ & IVSFMN, IVSFMX, IVCOMX, ISFINT, IBSFMN, IBSFMX
+
--- /dev/null
+*$ CREATE NUCSFX.ADD
+*COPY NUCSFX
+*
+*=== nucsfx ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear Symmetrized Fermi/woods-saXon *
+* *
+* rh0sfx, cparsf, aparsf: *
+* *
+* rho (r) = rh0sfx * sinh (cparfx/aparfx) *
+* / ( cosh (cparfx/aparfx) + cosh (r/aparfx) ) *
+* *
+* radsfx(i) = max ( 0, asfhlf x (nsfxbf+i) + cparsf ) *
+* rhosfx(i) = rho (radsfx(i)) *
+* rhpsfx(i) = d rho / dr |radsfx(i) *
+* / radsfx(i) *
+* rhisfx(i) = | 4 pi r^2 rho dr *
+* / radsfx (i-1) *
+* exisfx(i) = exp ((radsfx(i)-cparsf)/asfhlf) = *
+* exp((nsfxbf+i)/2) *
+* asfhlf = aparsf / 2 *
+* expcoa = exp ( -cparsf / aparsf ) *
+* exproa = exp ( rcursf / aparsf ) *
+* x,y,zcursf= current position *
+* u,v,wcursf= current direction *
+* ecursf = current (total) energy *
+* pcursf = current momentum *
+* vpcrsf = current potential *
+* rcursf = current radius *
+* lingng = logical flag to signal if the current particle *
+* is approaching the nucleus centre *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NINSFX = +21 )
+ PARAMETER ( NSFXBF = -11 )
+ LOGICAL LINGNG
+ COMMON / NUCSFX / RHOSFX (0:NINSFX), RHPSFX (0:NINSFX),
+ & RADSFX (0:NINSFX), RHISFX (NINSFX),
+ & EXISFX (0:NINSFX), RH0SFX, CPARSF, APARSF,
+ & ASFHLF, EXPROA, XCURSF, YCURSF, ZCURSF, UCURSF,
+ & VCURSF, WCURSF, ECURSF, PCURSF, VPCRSF, RCURSF,
+ & RHOCUR, RPCRSF, R13CUR, ISFX , LINGNG
+ EQUIVALENCE ( EXPCOA, EXISFX (0) )
+
--- /dev/null
+*$ CREATE NUCSTF.ADD
+*COPY NUCSTF
+*
+*=== nucstf ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NUClear STatement Functions: *
+* *
+* Created on 14 january 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 04-feb-92 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* FPFRNC *
+* FRADNC *
+* FRHINC *
+* FRHONC *
+* SBCOMP *
+* *
+*----------------------------------------------------------------------*
+*
+* NUClear STatement Functions: nucleus with a costant core and
+* linearly decreasing skin and halo
+* rho (r):
+* Statement functions:
+ RHCORE (R) = RHOCEN
+ RHSKIN (R) = RHOCEN * ( RADSKN - R ) / SKNEFF
+ RHHALO (R) = RHOSKN * ( RADTOT - R ) / HALODP
+* other
+* RHCORE (R) = RHOCEN
+* Skin with a linear and a cubic term:
+* RHSKIN (R) = RHOCEN * ( ( RADSKN - R ) / SKNEFF + SK3PAR * ( R
+* & - CPARWS )**3 )
+* Skin with a linear, a cubic and a quartic term:
+* RHSKIN (R) = RHOCEN * ( ( RADSKN - R ) / SKNEFF
+* & + ( R - CPARWS )**3 * ( SK3PAR + SK4PAR
+* & * ( R - CPARWS ) ) )
+* RHHALO (R) = RHOCEN * HABPAR * ( RADTOT - R )**1.5D+00
+* / r 2
+* | 4 pi r' rho (r') dr':
+* / 0
+* Statement functions:
+ RICORE (R) = 4.D+00 * PI / 3.D+00 * RHOCEN * R**3
+ RISKIN (R) = RICORE (RADIU0) + 4.D+00 * PI / 3.D+00 * RHOCEN
+ & * ( RADSKN / SKNEFF * ( R**3 - RADIU0**3 )
+ & - 0.75D+00 * ( R**4 - RADIU0**4 ) / SKNEFF )
+ RIHALO (R) = RISKIN (RADIU1) + 4.D+00 * PI / 3.D+00 * RHOSKN
+ & * ( RADTOT / HALODP * ( R**3 - RADIU1**3 )
+ & - 0.75D+00 * ( R**4 - RADIU1**4 ) / HALODP )
+* Other:
+* RICORE (R) = 4.D+00 * PI / 3.D+00 * RHOCEN * R**3
+* Skin with a linear and a cubic term:
+* RISKIN (R) = RICORE (RADIU0) + 4.D+00 * PI / 3.D+00 * RHOCEN
+* & * ( ( RADSKN / SKNEFF - CPARWS**3 * SK3PAR )
+* & * ( R**3 - RADIU0**3 ) - 0.75D+00 * ( 1.D+00 / SKNEFF
+* & - 3.D+00 * SK3PAR * CPARWS**2 ) * ( R**4 - RADIU0**4 )
+* & - 1.8D+00 * SK3PAR * CPARWS * ( R**5 - RADIU0**5 )
+* & + 0.5D+00 * SK3PAR * ( R**6 - RADIU0**6 ) )
+* Skin with a linear, a cubic and a quartic term:
+* RISKIN (R) = RICORE (RADIU0) + 4.D+00 * PI / 3.D+00 * RHOCEN
+* & * ( ( RADSKN / SKNEFF - CPARWS**3 * ( SK3PAR - CPARWS
+* & * SK4PAR ) ) * ( R**3 - RADIU0**3 ) - 0.75D+00
+* & * ( 1.D+00 / SKNEFF - CPARWS**2 * ( 3.D+00 * SK3PAR
+* & - 4.D+00 * SK4PAR * CPARWS ) ) * ( R**4 - RADIU0**4 )
+* & - 1.8D+00 * CPARWS * ( SK3PAR - 2.D+00 * SK4PAR
+* & * CPARWS ) * ( R**5 - RADIU0**5 )
+* & - ( 2.D+00 * SK4PAR * CPARWS - 0.5D+00 * SK3PAR )
+* & * ( R**6 - RADIU0**6 ) + 3.D+00 / 7.D+00 * SK4PAR
+* & * ( R**7 - RADIU0**7 ) )
+* RIHALO (R) = RISKIN (RADIU1) + 8.D+00 * PI * RHOCEN
+* & * HABPAR * ( ( 0.2D+00 * RADTOT**2 - 2.D+00 / 7.D+00
+* & * RADTOT * HALODP + HALODP**2 / 9.D+00 )
+* & * ( SQRT (HALODP) )**5 - ( 0.2D+00 * RADTOT**2
+* & - 2.D+00 / 7.D+00 * RADTOT * ( RADTOT - R )
+* & + ( RADTOT - R )**2 / 9.D+00 )
+* & * ( RADTOT - R )**2.5D+00 )
+* r (rho):
+* Statement functions:
+ RACORE (RHO) = RADIU0
+ RASKIN (RHO) = RADSKN - SKNEFF * RHO / RHOCEN
+ RAHALO (RHO) = RADTOT - HALODP * RHO / RHOSKN
+* p_f (rho,i), i=1 proton, 2 neutron:
+* Statement functions:
+ PFCORE (RHO,I) = PFRCEN (I)
+ PFSKIN (RHO,I) = PFRCEN (I) * (RHO/RHOCEN)**0.3333333333333333D+00
+ PFHALO (RHO,I) = PFRCEN (I) * (RHO/RHOCEN)**0.3333333333333333D+00
+* end NUClear STatement Functions
+
--- /dev/null
+*$ CREATE NUINFO.ADD
+*COPY NUINFO
+*
+*=== Nuinfo ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NeUtrino interaction INFOrmations common: *
+* *
+* Created on 05 july 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-jul-99 by Alfredo Ferrari *
+* *
+* Global run parameters: *
+* *
+* Lqelcc = logical flag for performing QE CC interactions *
+* Lqelnc = logical flag for performing QE NC interactions *
+* Lrescc = logical flag for performing RES CC interactions *
+* Lresnc = logical flag for performing RES NC interactions *
+* Ldiscc = logical flag for performing DIS CC interactions *
+* Ldisnc = logical flag for performing DIS NC interactions *
+* Lchacc = logical flag for performing CHARM CC interactions *
+* Lchanc = logical flag for performing CHARM NC interactions *
+* Lfrnui = flag for forced neutrino interactions *
+* Lnuxqe = flag for QE interactions through NUX *
+* Sfrnui = safety factor for neutrino forced scatterings *
+* Fcnusc = multiplication factor for neutrino scatterings *
+* Sfnunc = safety factor during tracking for neutrino *
+* nucleon scattering *
+* Efnunc = (maximum) Fermi energy to be used for Xsec calc- *
+* ulations for neutrino nucleon scattering *
+* Pfnunc = (maximum) Fermi momentum to be used for Xsec calc- *
+* ulations for neutrino nucleon scattering *
+* *
+* Run time variables: *
+* *
+* Stnusc = (nuclear) sigma for the current material *
+* (10^-11 mb) *
+* Sgrtcc (i) = run time cross section (10^-11 mb) for CC on i-type*
+* target nucleon (1=proton,2=neutron) *
+* Sgrtnc (i) = run time cross section (10^-11 mb) for NC on i-type*
+* target nucleon (1=proton,2=neutron) *
+* Sgqecc (i) = cross section (10^-11 mb) for QE CC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgqenc (i) = cross section (10^-11 mb) for QE NC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgrscc (i) = cross section (10^-11 mb) for RES CC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgrsnc (i) = cross section (10^-11 mb) for RES NC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgdscc (i) = cross section (10^-11 mb) for DIS CC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgdsnc (i) = cross section (10^-11 mb) for DIS NC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgchcc (i) = cross section (10^-11 mb) for CHARM CC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* Sgchnc (i) = cross section (10^-11 mb) for CHARM NC for i-type *
+* target nucleon (1=proton,2=neutron) *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LQELCC, LQELNC, LRESCC, LRESNC, LDISCC, LDISNC, LCHACC,
+ & LCHANC, LFRNUI, LNUXQE
+*
+ COMMON / NUINFO / SFRNUI, FCNUSC, SFNUNC, EFNUNC, PFNUNC, STNUSC,
+ & SGRTCC (2), SGRTNC (2), SGQECC (2), SGQENC (2),
+ & SGRSCC (2), SGRSNC (2), SGDSCC (2), SGDSNC (2),
+ & SGCHCC (2), SGCHNC (2),
+ & LQELCC, LQELNC, LRESCC, LRESNC, LDISCC, LDISNC,
+ & LCHACC, LCHANC, LFRNUI, LNUXQE
+
--- /dev/null
+*$ CREATE NUXSAR.ADD
+*COPY NUXSAR
+*
+*=== Nuxsar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* NeUtrino X-Secs on ARgon: *
+* *
+* Created on 27 may 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-jul-99 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXNUEB = 130 )
+ CHARACTER NUNAME*8
+*
+ COMMON / NUXSAR / XSCCQE (MXNUEB,6), ENCCQE (MXNUEB,6),
+ & XSNCQE (MXNUEB,2), ENNCQE (MXNUEB,2),
+ & XSCCRS (MXNUEB,2,6), ENCCRS (MXNUEB,2,6),
+ & XSNCRS (MXNUEB,2,2), ENNCRS (MXNUEB,2,2),
+ & XSCCDS (MXNUEB,2,6), ENCCDS (MXNUEB,2,6),
+ & XSNCDS (MXNUEB,2,2), ENNCDS (MXNUEB,2,2),
+ & XSCCCH (MXNUEB,2,6), ENCCCH (MXNUEB,2,6),
+ & XSNCCH (MXNUEB,2,2), ENNCCH (MXNUEB,2,2),
+ & NECCQE (6) , NENCQE (2) , NECCRS (2,6),
+ & NENCRS (2,2), NECCDS (2,6), NENCDS (2,2),
+ & NECCCH (2,6), NENCCH (2,2)
+ COMMON / CHNXAR / NUNAME (6)
+
--- /dev/null
+*$ CREATE NUXSNC.ADD
+*COPY NUXSNC
+*
+*=== Nuxsnc ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* NeUtrino X-Secs on NuCleons: *
+* *
+* Created on 27 may 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-jul-99 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXEBNU = 160 )
+ LOGICAL LFRSDS
+*
+ COMMON / NUXSNC / XSRSCC (0:MXEBNU,2,6), XSRSNC (0:MXEBNU,2,2),
+ & XSDSCC (0:MXEBNU,2,6), XSDSNC (0:MXEBNU,2,2),
+ & XSCHCC (0:MXEBNU,2,6), XSCHNC (0:MXEBNU,2,2),
+ & E0RSCC (2,6), A0RSCC (2,6), DARSCC (2,6),
+ & E0RSNC (2,2), A0RSNC (2,2), DARSNC (2,2),
+ & E0DSCC (2,6), A0DSCC (2,6), DADSCC (2,6),
+ & E0DSNC (2,2), A0DSNC (2,2), DADSNC (2,2),
+ & E0CHCC (2,6), A0CHCC (2,6), DACHCC (2,6),
+ & E0CHNC (2,2), A0CHNC (2,2), DACHNC (2,2),
+ & MERSCC (2,6), MERSNC (2,2), MEDSCC (2,6),
+ & MEDSNC (2,2), MECHCC (2,6), MECHNC (2,2),
+ & NERSCC (2,6), NERSNC (2,2), NEDSCC (2,6),
+ & NEDSNC (2,2), NECHCC (2,6), NECHNC (2,2),
+ & LFRSDS
+
--- /dev/null
+*$ CREATE OPPHCM.ADD
+*COPY OPPHCM
+*
+*=== Opphcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* OPtical PHoton CoMmon: *
+* *
+* Created on 19 september 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 11-jan-99 by Alfredo Ferrari *
+* *
+* Opphpr (ip,im) = ip_th optical property parameter of the im_th *
+* material (non metal) *
+* ip = *
+* 1: refraction index *
+* 2: absorption coeff. (cm^-1) *
+* 3: diffusion coeff. (cm^-1) *
+* 4: refraction index 1st derivative *
+* 5: absorption 1st derivative *
+* 6: diffusion 1st derivative *
+* 7: refraction index 2nd derivative *
+* 8: absorption 2nd derivative *
+* 9: diffusion 2nd derivative *
+* 10: refraction index 3rd derivative *
+* 11: absorption 3rd derivative *
+* 12: diffusion 3rd derivative *
+* metal: *
+* ip = *
+* 1: refraction index (not used) *
+* 2: absorption coeff. (cm^-1) (not used) *
+* 3: 1 - reflectivity index *
+* 7: 1 - reflectivity index 1st derivative *
+* 9: 1 - reflectivity index 2nd derivative *
+* 12: 1 - reflectivity index 3rd derivative *
+* Emncer (im) = minimum energy for Cerenkov photon production *
+* for im_th medium *
+* Emxcer (im) = maximum energy for Cerenkov photon production *
+* for im_th medium *
+* Rmxcer (im) = maximum refractive index in the energy range *
+* of interest for Cerenkov photon production *
+* for im_th medium *
+* Emntrd (im) = minimum energy for transition radiation photon*
+* production for im_th medium *
+* Emxtrd (im) = maximum energy for transition radiation photon*
+* production for im_th medium *
+* Wvmnop (im) = minimum wavelength for opt. photon transport *
+* for im_th medium (default: 250 nm) *
+* Wvcnop (im) = central wavelength for opt. photon transport *
+* for im_th medium (default: 589 nm, Na D) *
+* Wvmxop (im) = maximum wavelength for opt. photon transport *
+* for im_th medium (default: 600 nm) *
+* Ommnop (im) = minimum 2pi x freq. for opt. photon transport *
+* for im_th medium *
+* Omcnop (im) = central 2pi x freq. for opt. photon transport *
+* for im_th medium *
+* Ommxop (im) = maximum 2pi x freq. for opt. photon transport *
+* for im_th medium *
+* Wvmnsn = minimum wavelength for opt. photon sensitivity*
+* (default: 25 nm) *
+* Wvcnsn = central wavelength for opt. photon sensitivity*
+* (default: 589 nm, Na D) *
+* Wvmxsn = maximum wavelength for opt. photon sensitivity*
+* for im_th medium (default: 6000 nm) *
+* Ommnsn = minimum 2pi x freq. for opt. photon sensiti- *
+* vity *
+* Omcnsn = central 2pi x freq. for opt. photon sensiti- *
+* vity *
+* Ommxsn = maximum 2pi x freq. for opt. photon sensiti- *
+* vity *
+* Opsnmx = maximum of optical photon sensitivity *
+* Rghnss (ib) = Roughness parameter for ib_th material-to-ma- *
+* terial boundary ib_th *
+* M1rghn (ib) = 1st material of ib_th material-to-material *
+* boundary *
+* M2rghn (ib) = 2nd material of ib_th material-to-material *
+* boundary *
+* Lopprp (im) = logical flag for optical properties of im_th *
+* material *
+* Lopmtl (im) = logical flag whether the im_th optical mate- *
+* rial is a metal or not *
+* Lwvopp (im) = logical flag whether optical properties of *
+* im_th material are expressed as a function of *
+* wavelength (true) or 2pi x frequency (false). *
+* By default it is true. *
+* Lwvops = logical flag whether optical photon sensiti- *
+* vities are expressed as a function of wave- *
+* length (true) or 2pi x frequency (false). *
+* By default it is true. *
+* Lcrnkv (im) = logical flag for Cerenkov photon production *
+* for im_th material *
+* Ltrrad (im) = logical flag for transition radiation photon *
+* production for im_th material *
+* Nxoppb = number of material boundaries for which the *
+* roughness has been defined *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXOPSN = 4 )
+ PARAMETER ( MXOPPR = 12 )
+ PARAMETER ( MXOPPB = 20 )
+ PARAMETER ( WVMNTR = 250.D-07 )
+ PARAMETER ( WVCNTR = 589.D-07 )
+ PARAMETER ( WVMXTR = 600.D-07 )
+ LOGICAL LOPPRP, LOPMTL, LWVOPP, LCRNKV, LTRRAD, LWVOPS
+ COMMON / OPPHCM / WVMNSN, WVCNSN, WVMXSN, OMMNSN, OMCNSN, OMMXSN,
+ & OPSNMX, OPSNPR (MXOPSN),OPPHPR (MXOPPR,MXXMDF),
+ & EMNCER (MXXMDF), EMXCER (MXXMDF), RMXCER (MXXMDF),
+ & EMNTRD (MXXMDF), EMXTRD (MXXMDF), WVMNOP (MXXMDF),
+ & WVMXOP (MXXMDF), WVCNOP (MXXMDF), OMMNOP (MXXMDF),
+ & OMMXOP (MXXMDF), OMCNOP (MXXMDF), RGHNSS (MXOPPB),
+ & M1RGHN (MXOPPB), M2RGHN (MXOPPB), LOPPRP (MXXMDF),
+ & LOPMTL (MXXMDF), LWVOPP (MXXMDF), LCRNKV (MXXMDF),
+ & LTRRAD (MXXMDF), LWVOPS, NXOPPB
+
--- /dev/null
+*$ CREATE OPPHST.ADD
+*COPY OPPHST
+*
+*=== Opphst ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* OPtical PHoton STack: *
+* *
+* Created on 19 september 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-oct-98 by Alfredo Ferrari *
+* *
+* wtopph = weight of the photon *
+* poptph = laboratory momentum of the photon in GeV/c *
+* xoptph = x-coordinate of the photon *
+* yoptph = y-coordinate of the photon *
+* zoptph = z-coordinate of the photon *
+* txopph = direction cosine of the photon *
+* with respect to x-axis *
+* tyopph = direction cosine of the photon *
+* with respect to y-axis *
+* tzopph = direction cosine of the photon *
+* with respect to z-axis *
+* txpopp = direction cosine of the photon polarization *
+* typopp = direction cosine of the photon polarization *
+* tzpopp = direction cosine of the photon polarization *
+* donear = distance to the nearest boundary *
+* agopph = age of the photon (seconds) *
+* loopph = generation of the photon *
+* louopp = user flag *
+* nregop = number of the region of the photon *
+* nlatop = number of the lattice cell of the photon *
+* tpropp = kinetic energy of parent particle of the photon *
+* apropp = age of the parent particle of the photon (seconds) *
+* ipropp = id (paprop) of the parent particle of the photon *
+* lpropp = generation of the parent particle of the photon *
+* npropp = # of the primary track which generated the photon *
+* (not used for the moment) *
+* lstopp = stack pointer *
+* lmxopp = highest value of the stack pointer encountered *
+* in the run *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / OPPHST / WTOPPH (MOSTCK), POPTPH (MOSTCK),
+ & XOPTPH (MOSTCK), YOPTPH (MOSTCK), ZOPTPH (MOSTCK),
+ & TXOPPH (MOSTCK), TYOPPH (MOSTCK), TZOPPH (MOSTCK),
+ & TXPOPP (MOSTCK), TYPOPP (MOSTCK), TZPOPP (MOSTCK),
+ & DONEAR (MOSTCK), AGOPPH (MOSTCK), TPROPP (MOSTCK),
+ & APROPP (MOSTCK), SPAROK (MKBMX1,MOSTCK),
+ & ISPORK (MKBMX2,MOSTCK), LOOPPH (MOSTCK),
+ & LOUOPP (MOSTCK), NREGOP (MOSTCK), NLATOP (MOSTCK),
+ & IPROPP (MOSTCK), LPROPP (MOSTCK), NPROPP (MOSTCK),
+ & LSTOPP, LMXOPP
+
--- /dev/null
+*$ CREATE PAPROP.ADD
+*COPY PAPROP
+*
+*=== paprop ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: paprop copy *
+* *
+* !!!! N E W V E R S I O N !!!! *
+* *
+* Created on 07 may 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 03-jul-97 by Alfredo Ferrari *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /paprop/ contains particle properties *
+* btype = literal name of the particle *
+* am = particle mass in GeV *
+* ichrge = electric charge of the particle *
+* ibarch = baryonic charge of the particle *
+* iscore = explanations for the scored distribution *
+* genpar = names of the generalized particles *
+* ijdisc = list of the particle types to be discarded *
+* thalf = half life of the particle in sec *
+* biasdc = decay biasing factors *
+* biasin = inelastic interaction biasing factors *
+* lhadro = flag for hadrons *
+* jspinp = particle spin (in units of 1/2) *
+* iparty = particle parity (when defined) *
+* iparid = flag used to identify particle types *
+* lbsdcy = logical flag for biased decay: if .true. the biasing *
+* factor is used as an upper limit to the decay length *
+* lprbsd = logical flag for biased decay: if .true. the biasing *
+* factor is applied only to primaries *
+* lprbsi = logical flag for inelastic interaction biasing: if *
+* .true. the biasing factor is applied only to prima- *
+* ries *
+* lsclwf = logical flag for low energy neutron fission scoring *
+* lscnbl = logical flag for neutron balance scoring *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LHADRO, LBSDCY, LPRBSD, LPRBSI, LSCLWF, LSCNBL
+ CHARACTER*8 BTYPE,GENPAR
+ COMMON / PAPROP / AM (-6:NALLWP), AMDISC (-6:NALLWP),
+ & THALF (-6:NALLWP), BIASDC (-6:NALLWP),
+ & BIASIN (-6:NALLWP), ICHRGE (-6:NALLWP),
+ & IBARCH (-6:NALLWP), IJDISC (-6:NALLWP),
+ & JSPINP (-6:NALLWP), IPARTY (-6:NALLWP),
+ & IPARID (-6:NALLWP),
+ & LHADRO (-6:NALLWP), LBSDCY (-6:NALLWP),
+ & ISCORE ( 10), LPRBSD, LPRBSI, LSCLWF, LSCNBL
+ COMMON / CHPPRP / BTYPE (-6:NALLWP), GENPAR (30)
+
--- /dev/null
+*$ CREATE PAREVT.ADD
+*COPY PAREVT
+* *
+*=== parevt ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* Created on 28-3-90 by A. Ferrari, INFN - Milan *
+* *
+* Last change on 24-aug-00 by Alfredo Ferrari *
+* *
+* included in: *
+* *
+* flukam *
+* bdnopt *
+* berttp *
+* bimsel *
+* bselsc *
+* clbmjt *
+* corevt *
+* corrin *
+* deflts *
+* difevv *
+* difpro *
+* difevv *
+* difpro *
+* distnu *
+* epilog *
+* evdeex *
+* eventv *
+* evevap *
+* evxtes *
+* evvini *
+* ferevv *
+* ferhav *
+* frmbrk *
+* frbkjp *
+* ferevv *
+* ferhav *
+* frmbrk *
+* frbkjp *
+* geta *
+* hdncin *
+* kaonuc *
+* kaskad *
+* kasneu *
+* incini *
+* muoabs *
+* muprab *
+* nucdcy *
+* nucnuc *
+* nucevv *
+* nwisel *
+* peanut *
+* phnsch *
+* phncev *
+* phnvev *
+* piabth *
+* pioabs *
+* pionuc *
+* pmprab *
+* prepre *
+* prolog *
+* rakekv *
+* rcfset *
+* rsncli *
+* rstsel *
+* umofin *
+* usrsrn *
+* *
+* frdiff = fraction of the total number of events which are *
+* diffractive ones (obsolete, no longer used) *
+* fsprd0 = asymptotic reduction factor for cascade particle *
+* energy slope parameter *
+* fshpfn = modifying factor for bamjet momentum sharing jet *
+* function *
+* rn1gsc = correlation factor between shower and grey part- *
+* ticle multiplicities *
+* rn2gsc = correlation factor between shower and grey part- *
+* ticle multiplicities *
+* dpower = power exponent used in the binomial distributions *
+* for grey particles *
+* lpower = flag to signal if dpower is different from the *
+* default option (dpower=2) *
+* ldiffr = flag for particles undergoing diffractive events *
+* linctv = flag to switch on/off cascade nucleons and exci- *
+* tation energy (it is important for testing the *
+* generator *
+* levprt = flag for nuclear evaporation *
+* ldeexg = flag for nuclear deexcitation gammas *
+* lgdhpr = flag for geometry dependent calculations in the *
+* preequilibrium part *
+* lpreex = flag for explicit treatment of the first inte- *
+* ctions in the preequilibrium part *
+* lhlfix = flag for "freezing" the hole depth of the holes *
+* produced in the explicitly treated interactions *
+* in the preequilibrium part *
+* lprfix = flag for "freezing" the already sampled particle *
+* exciton energy in the preequilibrium part *
+* lparwv = flag to apply the Heisenberg principle according *
+* to the reduced DeBroglie wavelength in the calcu- *
+* lation of the impact parameter and in computing *
+* the particle position after interactions *
+* ilvmod = flag to select the level density option (T=0) *
+* jlvmod = 2nd flag to select the level density option (T=oo)*
+* llvmod = logical flag for using Cook's modified pairing *
+* energies *
+* lsngch = logical flag for allowing single chain events *
+* lschdf = logical flag for allowing single chain events *
+* in diffractive interactions *
+* lhadri = logical flag for indicating whether the resonance *
+* model was used or not for primary interactions *
+* lnucri = logical flag for indicating whether the Nucriv *
+* model was used or not for the current interaction *
+* lpeanu = logical flag for indicating whether the Peanut *
+* model was used or not for the current interaction *
+* lphdrc = logical flag for indicating whether a photonuc- *
+* lear interaction is a "direct" one or not *
+* latmss = logical flag for indicating whether to use ato- *
+* mic masses during evaporation *
+* lismrs = logical flag for indicating whether isomer calcu- *
+* lations are possible *
+* loldev = logical flag for indicating for using the old *
+* evaporation model rather than the new one *
+* *
+*----------------------------------------------------------------------*
+*
+*
+* 30% of events, randomly choosen, are diffractive events!!
+* Now 20% (J. Ranft & A. Ferrari, 25-3-90)
+* Actually it is no longer used!!
+ PARAMETER ( FRDIFF = 0.2D+00 )
+ PARAMETER ( ETHSEA = 1.0D+00 )
+*
+ LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+ & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF,
+ & LHADRI, LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LOLDEV,
+ & LCHDCY
+ COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
+ & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+ & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+ & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF, LHADRI,
+ & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LOLDEV,
+ & LCHDCY
+
--- /dev/null
+*$ CREATE PARNUC.ADD
+*COPY PARNUC
+*
+*=== parnuc ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 2 august 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-sep-00 by Alfredo Ferrari *
+* *
+* included in : *
+* *
+* Bdpree *
+* Bimsel *
+* Couset *
+* Muoabs *
+* Nucdcy *
+* Nucnuc *
+* Nwisel *
+* Peanut *
+* Phdset *
+* Phdwll *
+* Pioabs *
+* Pionuc *
+* Pmprab *
+* Pncset *
+* Pncset *
+* Prepre *
+* Sbcomp *
+* Umofin *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( PIGRK = PIPIPI )
+ PARAMETER ( ALEVEL = 8.D-03 )
+* Standard parameter for central density: it is exactly r0nucl of
+* Parevt
+ PARAMETER ( RCNUCL = 1.12D+00 )
+* "Naive" r0 for sigmas
+ PARAMETER ( R0SIG = 1.3D+00 )
+* r0 for sigmas according to Kikuchi & Kawai
+ PARAMETER ( R0SIGK = 1.5D+00 )
+* r0 for Coulomb barrier according to Kikuchi & Kawai
+ PARAMETER ( RCOULB = 1.5D+00 )
+* Parameter for Coulomb barrier according to Hermes (Evap-5)
+ PARAMETER ( COULBH = 0.88235D-03 )
+* Central density in nuclei
+ PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
+* For Taufor, Aefrav & Rhonuc the combinations 1 and 3 are ok. If the
+* Hannes expression for Taufor is used we must use Taufor from
+* combination 3 and Aefrav and Rhonuc from combination 1
+* Combination 3:
+*3 PARAMETER ( TAUFO0 = 3.0D+00 )
+* Combination 1:
+* PARAMETER ( TAUFO0 = 5.0 D+00 )
+ PARAMETER ( TAUFO0 = 10.0D+00 )
+* Thresholds for explicit interactions:
+* Primary projectile:
+ PARAMETER ( EKEEXP = 0.03D+00 )
+* Secondary nucleons:
+ PARAMETER ( EKREXP = 0.05D+00 )
+* Just for Pauli checks:
+ PARAMETER ( EKEMNM = 0.01D+00 )
+*
+ PARAMETER ( NCPMX = 350 )
+ PARAMETER ( NRSMX = 10 )
+ PARAMETER ( NDCMX = 5 )
+ LOGICAL LATAUF
+ COMMON / PARNUC / EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
+ & TFRABS, TFRDCY, TEXTAU, TEXQEL, TEXNUT, FRPMBY,
+ & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
+ & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
+ & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
+ & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
+ & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
+ & TAUFPA (NCPMX), RHNUCL(NCPMX,2),
+ & AMSSRS (NRSMX), GAMMRS (NRSMX),
+ & ENRSDC (NDCMX,NRSMX), PXRSDC (NDCMX,NRSMX),
+ & PYRSDC (NDCMX,NRSMX), PZRSDC (NDCMX,NRSMX),
+ & BNDGAV, DEFMIN, FTFRDC,
+ & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
+ & INUCTS (NCPMX), ISFNUC (NCPMX), LATAUF (NCPMX),
+ & KRSNCE (NCPMX), KRSDCY (NDCMX,NRSMX), KPORI ,
+ & IBORI , IBNUCL, NPNUC , NNUCTS
+
+
--- /dev/null
+*$ CREATE PART.ADD
+*COPY PART
+*
+*=== part =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: part copy Revised on 20-08-96 by A. Ferrari *
+* *
+* Last change on 14-oct-00 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: *
+* *
+* W A R N I N G !!!! check also part2 and part3 for any change!!! *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Am = particle mass (GeV/c^2) *
+* Ga = particle width (GeV) *
+* Tau = particle mean life (s) *
+* Amdisc = "effective" particle mass for energy balance (GeV) *
+* Zmnabs = lower width (adimensional unit) to be used during *
+* particle decay to assure that at least one decay *
+* channel is physically open *
+* Atnmna = atan (Zmnabs) *
+* Ich = particle electric charge *
+* Ibar = particle baryon number *
+* Isosym = index of the isospin reversed (T_z --> -T_z) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* Ichcon = index of the charge conjugated (antiparticle) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* K1 = index of first decay channel *
+* K2 = index of last decay channel *
+* Kptoip = conversion from part to paprop numbering *
+* Iptokp = conversion from paprop to part numbering *
+* Kptoia = conversion from part to abltis numbering *
+* Iatokp = conversion from abltis to part numbering *
+* Idcflg = decay flag *
+* Iptype = particle type *
+* -1: heavy fragments *
+* 0: unknown particle or lepton *
+* 1: nucleon *
+* 2: antinucleon *
+* 3: pion *
+* 4: K+/K0 *
+* -4: Kshrt/Klong *
+* 5: K-/K0bar *
+* 6: Lamda/Sigma (strangeness -1 hyperon) *
+* 7: Xsi (strangeness -2 hyperon) *
+* 8: Omega (strangeness -3 hyperon) *
+* 9: ALamda/ASigma (strangeness +1 antihyperon) *
+* 10: AXsi (strangeness +2 antihyperon) *
+* 11: AOmega (strangeness +3 antihyperon) *
+* 12: D+/D0 *
+* 13: D-/D0bar *
+* 14: D_s+/D_s- *
+* 15: Lambda_c+ *
+* 16: Xsi_c+/Xsi_c0 *
+* 17: Xsi'_c+/Xsi'_c0 *
+* 18: Omega_c *
+* 19: ALambda_c+ *
+* 20: AXsi_c-/AXsi_c0 *
+* 21: AXsi'_c-/AXsi'_c0 *
+* 22: AOmega_c *
+* Aname = particle literal name *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANAME
+ COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
+ & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
+ & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
+ & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
+ & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
+ & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
+ & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
+ & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
+ & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
+ COMMON / CHPART / ANAME (-6:IDMAXP)
+
--- /dev/null
+*$ CREATE PART2.ADD
+*COPY PART2
+*
+*=== part2 ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: part2 copy Revised on 20-08-96 by A. Ferrari *
+* *
+* Last change on 14-oct-00 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: *
+* *
+* W A R N I N G !!!! check also part and part3 for any change!!! *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Aam = particle mass (GeV/c^2) *
+* Ga = particle width (GeV) *
+* Tau = particle mean life (s) *
+* Aamdsc = "effective" particle mass for energy balance (GeV) *
+* Zmnabs = lower width (adimensional unit) to be used during *
+* particle decay to assure that at least one decay *
+* channel is physically open *
+* Atnmna = atan (Zmnabs) *
+* Iich = particle electric charge *
+* Iibar = particle baryon number *
+* Isosym = index of the isospin reversed (T_z --> -T_z) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* Ichcon = index of the charge conjugated (antiparticle) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* K1 = index of first decay channel *
+* K2 = index of last decay channel *
+* Kptoip = conversion from part to paprop numbering *
+* Iptokp = conversion from paprop to part numbering *
+* Kptoia = conversion from part to abltis numbering *
+* Iatokp = conversion from abltis to part numbering *
+* Idcflg = decay flag *
+* Iptype = particle type *
+* -1: heavy fragments *
+* 0: unknown particle or lepton *
+* 1: nucleon *
+* 2: antinucleon *
+* 3: pion *
+* 4: K+/K0 *
+* -4: Kshrt/Klong *
+* 5: K-/K0bar *
+* 6: Lamda/Sigma (strangeness -1 hyperon) *
+* 7: Xsi (strangeness -2 hyperon) *
+* 8: Omega (strangeness -3 hyperon) *
+* 9: ALamda/ASigma (strangeness +1 antihyperon) *
+* 10: AXsi (strangeness +2 antihyperon) *
+* 11: AOmega (strangeness +3 antihyperon) *
+* 12: D+/D0 *
+* 13: D-/D0bar *
+* 14: D_s+/D_s- *
+* 15: Lambda_c+ *
+* 16: Xsi_c+/Xsi_c0 *
+* 17: Xsi'_c+/Xsi'_c0 *
+* 18: Omega_c *
+* 19: ALambda_c+ *
+* 20: AXsi_c-/AXsi_c0 *
+* 21: AXsi'_c-/AXsi'_c0 *
+* 22: AOmega_c *
+* Aname = particle literal name *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANAME
+ COMMON / PART / AAM (-6:IDMAXP), GA (-6:IDMAXP),
+ & TAU (-6:IDMAXP), AAMDSC (-6:IDMAXP),
+ & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
+ & IICH (-6:IDMAXP), IIBAR (-6:IDMAXP),
+ & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
+ & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
+ & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
+ & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
+ & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
+ COMMON / CHPART / ANAME (-6:IDMAXP)
+
--- /dev/null
+*$ CREATE PART3.ADD
+*COPY PART3
+*
+*=== part3 ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: part3 copy Revised on 20-08-96 by A. Ferrari *
+* *
+* Last change on 14-oct-00 by Alfredo Ferrari *
+* *
+* Included in the following subroutines or functions: *
+* *
+* W A R N I N G !!!! check also part and part2 for any change!!! *
+* *
+* Description of the common block(s) and variable(s) *
+* *
+* Amc = particle mass (GeV/c^2) *
+* Gac = particle width (GeV) *
+* Tauc = particle mean life (s) *
+* Amdcsc = "effective" particle mass for energy balance (GeV) *
+* Zmnabs = lower width (adimensional unit) to be used during *
+* particle decay to assure that at least one decay *
+* channel is physically open *
+* Atnmna = atan (Zmnabs) *
+* Ichc = particle electric charge *
+* Ibarc = particle baryon number *
+* Isosym = index of the isospin reversed (T_z --> -T_z) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* Ichcon = index of the charge conjugated (antiparticle) *
+* particle (if any, if 0 no such particle is available*
+* in the part listing) *
+* K1c = index of first decay channel *
+* K2c = index of last decay channel *
+* Kptoip = conversion from part to paprop numbering *
+* Iptokp = conversion from paprop to part numbering *
+* Kptoia = conversion from part to abltis numbering *
+* Iatokp = conversion from abltis to part numbering *
+* Idcflg = decay flag *
+* Iptype = particle type *
+* -1: heavy fragments *
+* 0: unknown particle or lepton *
+* 1: nucleon *
+* 2: antinucleon *
+* 3: pion *
+* 4: K+/K0 *
+* -4: Kshrt/Klong *
+* 5: K-/K0bar *
+* 6: Lamda/Sigma (strangeness -1 hyperon) *
+* 7: Xsi (strangeness -2 hyperon) *
+* 8: Omega (strangeness -3 hyperon) *
+* 9: ALamda/ASigma (strangeness +1 antihyperon) *
+* 10: AXsi (strangeness +2 antihyperon) *
+* 11: AOmega (strangeness +3 antihyperon) *
+* 12: D+/D0 *
+* 13: D-/D0bar *
+* 14: D_s+/D_s- *
+* 15: Lambda_c+ *
+* 16: Xsi_c+/Xsi_c0 *
+* 17: Xsi'_c+/Xsi'_c0 *
+* 18: Omega_c *
+* 19: ALambda_c+ *
+* 20: AXsi_c-/AXsi_c0 *
+* 21: AXsi'_c-/AXsi'_c0 *
+* 22: AOmega_c *
+* Aname = particle literal name *
+* *
+*----------------------------------------------------------------------*
+*
+ CHARACTER*8 ANAMC
+ COMMON / PART / AMC (-6:IDMAXP), GAC (-6:IDMAXP),
+ & TAUC (-6:IDMAXP), AMCDSC (-6:IDMAXP),
+ & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
+ & ICHC (-6:IDMAXP), IBARC (-6:IDMAXP),
+ & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
+ & K1C (-6:IDMAXP), K2C (-6:IDMAXP),
+ & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
+ & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
+ & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
+ COMMON / CHPART / ANAMC (-6:IDMAXP)
+
--- /dev/null
+*$ CREATE PATHCM.ADD
+*COPY PATHCM
+*----------------------------------------------------------------------*
+* *
+* Common Pathcm for EGS4 *
+* *
+*----------------------------------------------------------------------*
+ COMMON /PATHCM/ B0PTH, B1PTH, PTH0(6), PTH1(6), PTH2(6), NPTH
+
--- /dev/null
+*$ CREATE PHNCCM.ADD
+*COPY PHNCCM
+*
+*=== phnccm ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* PHotoNuClear interaction CoMmon: *
+* *
+* Created on 02 january 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 31-jan-94 by Alfredo Ferrari *
+* *
+* Rhphnc (i) = density used for photonuclear cross section tabula- *
+* tions *
+* Wquade = weight to be applied to the quasi-deuteron cross *
+* section *
+* Wgdrtt = weight to be applied to the GDR cross section *
+* Wgdelt = weight to be applied to the delta cross section *
+* Wgamhg = weight to be applied to the high-energy cross sec- *
+* tion *
+* Squade = quasi-deuteron cross section *
+* Sgdrtt = GDR cross section *
+* Sgdelt = delta cross section *
+* Sgamhg = high-energy cross section *
+* Ifphnc (i) = flag for photonuclear interactions for ith material *
+* Jphflg = flag for the kind of interaction selected: *
+* 1) Quasideuteron *
+* 2) GDR *
+* 3) Delta *
+* 4) High energy *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( PHNCSF = 1.25D+00 )
+ COMMON / PHNCCM / RHPHNC (MXXMDF), WQUADE, WGDRTT, WGDELT, WGAMHG,
+ & SQUADE, SGDRTT, SGDELT, SGAMHG, IFPHNC (MXXMDF),
+ & JPHFLG
+
--- /dev/null
+*$ CREATE PHOINP.ADD
+*CREATE PHOINP
+*
+*=== Phoinp ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Common PHOINP for EMF (it supersedes the old Photin from EGS4) *
+* *
+* Created on 19 april 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-apr-97 by Alfredo Ferrari *
+* *
+* IGMFP0, IGMFP1 etc are the starting locations for 0 address *
+* in blank common of the GMFP0 etc arrays *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /PHOINP/ EBINDA (MXXMDE), GE0 (MXXMDE), GE1 (MXXMDE),
+ & RCO0 (MXXMDE), RCO1 (MXXMDE), NGR (MXXMDE),
+ & IGMFP0 (MXXMDE), IGMFP1 (MXXMDE),
+ & IGBR10 (MXXMDE), IGBR11 (MXXMDE),
+ & IGBR20 (MXXMDE), IGBR21 (MXXMDE),
+ & IRSCT0 (MXXMDE), IRSCT1 (MXXMDE),
+ & ICOHE0 (MXXMDE), ICOHE1 (MXXMDE)
+
+
--- /dev/null
+*$ CREATE PHOTEL.ADD
+*COPY PHOTEL
+*
+*=== photel ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file photel: *
+* created on 24-october-1990 by A. Ferrari & P. Sala *
+* INFN - Milan *
+* *
+* Included in the following routines: *
+* *
+* Photo (new version) *
+* Phoflu (version with fluorescence of photo) *
+* Bdphfl (block data for photoelectrons and *
+* fluorescence data) *
+* Variable: *
+* Umuphe (i,j) = tabulated emission cosines of emitted *
+* photoelectrons at given cumulative pro-*
+* bability ( prob = j / nphumu ) and at *
+* given electron beta**2 ( beta2 = *
+* (i-1) x dphbt2 ), computed according *
+* to the relativistic theory of F. Von *
+* Sauter *
+* *
+* Dumphe (i,j) = tabulated derivatives of the inverse *
+* function computed at umuphe *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( PHB2MX = 9.800000000000000D-01 )
+ PARAMETER ( DPHBT2 = 7.000000000000000D-02 )
+ PARAMETER ( BETA00 = 2.645751311064591D-01 )
+ PARAMETER ( NPHUMU = 30 )
+ PARAMETER ( NPHBET = 15 )
+*
+ COMMON / PHOTEL / UMUPHE ( 0:NPHUMU, NPHBET ),
+ & DUMPHE ( 0:NPHUMU, NPHBET )
+
--- /dev/null
+*$ CREATE PMRNCM.ADD
+*COPY PMRNCM
+*
+*=== Pmrncm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* PoMeRoN exchange related CoMmon: *
+* *
+* Created on 15-september-1997 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 24-mar-98 by Alfredo Ferrari, INFN-Milan *
+* *
+* B0popp = asymptotic (amplitude) B_slope for pp(bar) elastic *
+* scattering, *
+* B_slope = 2 B0popp + 2 aprdff ln [ s / s_0 ] *
+* *
+* Aprpom = alpha' of Pomeron trajectory *
+* a(t) = 1 + eps + a't *
+* *
+* Epspom = epsilon of Pomeron trajectory (0 for a critical *
+* pomeron, >0 for a supercritical one) *
+* *
+* Lmclsn = Flag for performing multiple soft collisions *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LMCLSN
+*
+ COMMON / PMRNCM / B0POPP, APRPOM, EPSPOM, LMCLSN
+
--- /dev/null
+*$ CREATE POTART.ADD
+*COPY POTART
+*
+*=== potart ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 25 february 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 25-feb-94 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LRLBAR, LPOART, LTRART, LBRPEN
+ COMMON / POTART / EPXART (20), VPXART (20), ANMXAR (20), ANGACT,
+ & ANGASQ, RDVVPO, FBRPEN, IFLGPN, ISFPEN (2,20),
+ & NSFPEN, ISFART (2,20), NSFART, LRLBAR, LPOART,
+ & LTRART, LBRPEN
+
--- /dev/null
+*$ CREATE PRECMM.ADD
+*COPY PRECMM
+******** Common for Peanut:
+ LOGICAL LUPPEA, LUSPEA, LUEPEA, LTAPEA
+ REAL XXXPEA, YYYPEA, QQ2PEA, WW2PEA, XR1PEA, XR2PEA, XR3PEA,
+ & PPPPEA
+ INTEGER ICOPEA, ICUPEA, ITRPEA, NOUPEA, NEVPEA, MEVPEA, MSCPEA,
+ & NOKPEA
+ PARAMETER ( MEVPEA = 10 )
+ PARAMETER ( MSCPEA =300 )
+ COMMON / PRECMM / XXXPEA (0:MEVPEA), YYYPEA (0:MEVPEA),
+ & QQ2PEA (0:MEVPEA), WW2PEA (0:MEVPEA),
+ & XR1PEA (MSCPEA,0:MEVPEA),
+ & XR2PEA (MSCPEA,0:MEVPEA),
+ & XR3PEA (MSCPEA,0:MEVPEA),
+ & PPPPEA (MSCPEA,0:MEVPEA),
+ & ICOPEA (MSCPEA,0:MEVPEA), LUSPEA (0:MEVPEA),
+ & ICUPEA (0:MEVPEA), ITRPEA (0:MEVPEA),
+ & NOUPEA (0:MEVPEA), LUEPEA (0:MEVPEA),
+ & LTAPEA (0:MEVPEA), NEVPEA, LUPPEA, NOKPEA
+********
+
--- /dev/null
+*$ CREATE QDEBUG.ADD
+*COPY QDEBUG
+*----------------------------------------------------------------------*
+* *
+* Common Qdebug for EGS4 *
+* *
+*----------------------------------------------------------------------*
+ COMMON /QDEBUG/ QDEBUG
+ LOGICAL QDEBUG
+
--- /dev/null
+*$ CREATE QQUARK.ADD
+*COPY QQUARK
+*
+*=== qquark ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 6 february 1991 by Alfredo Ferrari *
+* INFN - Milan *
+* *
+* Last change on 6 february 1996 by Alfredo Ferrari *
+* *
+* Included in the following routines : *
+* *
+* COREVT *
+* CORRIN *
+* HADEVV *
+* HADEVT *
+* NUCEVV *
+* NUCEVT *
+* *
+* Quark content of particles: *
+* index quark el. charge bar. charge isospin isospin3 *
+* 1 = u 2/3 1/3 1/2 1/2 *
+* -1 = ubar -2/3 -1/3 1/2 -1/2 *
+* 2 = d -1/3 1/3 1/2 -1/2 *
+* -2 = dbar 1/3 -1/3 1/2 1/2 *
+* 3 = s -1/3 1/3 0 0 *
+* -3 = sbar 1/3 -1/3 0 0 *
+* 4 = c 2/3 1/3 0 0 *
+* -4 = cbar -2/3 -1/3 0 0 *
+* 5 = b -1/3 1/3 0 0 *
+* -5 = bbar 1/3 -1/3 0 0 *
+* 6 = t 2/3 1/3 0 0 *
+* -6 = tbar -2/3 -1/3 0 0 *
+* *
+* 7 = used for nucleon decay *
+* *
+* Mquark = particle quark composition (Paprop numbering) *
+* Iqechr = electric charge ( in 1/3 unit ) *
+* Iqbchr = baryonic charge ( in 1/3 unit ) *
+* Iqichr = isospin ( in 1/2 unit ), z component *
+* Iqschr = strangeness *
+* Iqcchr = charm *
+* Iquchr = beauty *
+* Iqtchr = ...... *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / QQUARK / IQECHR (-6:7), IQBCHR (-6:7), IQICHR (-6:7),
+ & IQSCHR (-6:7), IQCCHR (-6:7), IQUCHR (-6:7),
+ & IQTCHR (-6:7), MQUARK (3,NALLWP)
+
--- /dev/null
+*$ CREATE RANDOM.ADD
+*COPY RANDOM
+*----------------------------------------------------------------------*
+* *
+* Common Random for EGS4 *
+* *
+*----------------------------------------------------------------------*
+ COMMON /RANDOM/ IXX
+ INTEGER IX(2)
+ REAL*8 DRN
+ EQUIVALENCE( IX(1), DRN )
+ DATA IX(1)/Z46000000/
+
--- /dev/null
+*$ CREATE RDCYCM.ADD
+*COPY RDCYCM
+*
+*=== Rdcycm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Radioactive DeCaY CoMmon: *
+* *
+* Created on 15-september-1993 by Alfredo Ferrari & Paola Sala *
+* INFN - MIlan *
+* *
+* Last change on 16-sep-99 by Alfredo Ferrari, CERN *
+* *
+* Sirrdt (i) = starting time of the i_th irradiation period *
+* Tirrdt (i) = length (s) of the i_th irradiation period *
+* Birrdt (i) = relative intensity of the i_th irradiation *
+* period, please note that *
+* Sum_1=1,Nirrdt Birrdt=1 *
+* Tirdcy (j) = j_th decay time at which scoring is requested *
+* Werdcy (j) = relative weight of the present particle at the *
+* j_th decay time *
+* Dlrdcy = delay (s) wrt the nominal beam "0" time for *
+* production of the current particle (i.e. for *
+* the decay products of the daughter of another *
+* decay) *
+* Nirrdt = number of irradiation preiods *
+* Ntrdcy = number of decay times for which scoring is re- *
+* quested *
+* Ldordc = global Fluka flag for performing radioactive *
+* decays *
+* Lrddcy = flag for the current particle being produced *
+* in a radioactive decay *
+* Lardcy = flag for "analogue" radioactive decays *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXIRRD = 100 )
+ PARAMETER ( MXTRDC = 100 )
+ LOGICAL LRDDCY, LDORDC, LARDCY
+ COMMON / RDCYCM / SIRRDT (MXIRRD), TIRRDT (MXIRRD),
+ & BIRRDT (MXIRRD), TIRDCY (MXTRDC),
+ & WERDCY (MXTRDC), DLRDCY, NIRRDT, NTRDCY, LDORDC,
+ & LRDDCY, LARDCY
+
--- /dev/null
+*$ CREATE REAC.ADD
+*COPY REAC
+*
+*=== reac =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-dec-91 by Alfredo Ferrari *
+* *
+* This is the original common reac of Hadrin *
+* *
+* Included in the following routines: *
+* *
+* CALUMV *
+* DATESH *
+* HADRIV *
+* RCHANV *
+* BLKDT3 *
+* HADRIN *
+* IEFUN *
+* SIGINT *
+* CALUMO *
+* RCHANW *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /REAC/ UMO ( 296), PLABF ( 296), SIIN ( 296),
+ + WK (5184), NRK (2,268), NURE (30,2)
+
--- /dev/null
+*$ CREATE REDVER.ADD
+*COPY REDVER
+*
+*=== redver ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-dec-91 by Alfredo Ferrari *
+* *
+* This is the original common redver of Hadrin *
+* *
+* Included in the following routines: *
+* *
+* CALUMV *
+* DATESH *
+* HADRIV *
+* RCHANV *
+* BLKDT4 *
+* HADRIN *
+* IEFUN *
+* SIGINT *
+* CALUMO *
+* RCHANW *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / REDVER / THRESH (268), IRII (17) , IKII (17) , IEII (17)
+
--- /dev/null
+*$ CREATE RESNUC.ADD
+*COPY RESNUC
+* *
+*=== resnuc ==========================================================*
+* *
+*---------------------------------------------------------------------*
+* *
+* Include file Resnuc *
+* *
+* Created on 20 april 1990 by Alfredo Ferrari *
+* INFN Milan *
+* *
+* Last change on 09-nov-99 by Alfredo Ferrari, INFN - Milan *
+* *
+* Included in the following routines: *
+* *
+* BDNOPT *
+* BIMSEL *
+* BSELSC *
+* COREVT *
+* CORRIN *
+* DISTNU *
+* EVDEEX *
+* EVENTV *
+* EVEVAP *
+* EVXTES *
+* FEREVV *
+* FERHAV *
+* FKBIRK *
+* FVCOUL *
+* HDNCIN *
+* KAONUC *
+* KASKAD *
+* KASHEA *
+* KASNEU *
+* LOWRES *
+* MUOABS *
+* MUPRAB *
+* NUCDCY *
+* NUCEVV *
+* NUCNUC *
+* NUCREL *
+* NUCRIV *
+* PEANUT *
+* PHNCEV *
+* PHNVEV *
+* PIABTH *
+* PIOABS *
+* PIONUC *
+* PMPRAB *
+* PPHCHO *
+* PREPRE *
+* RAKEKV *
+* RSTSEL *
+* UMFNST *
+* UMOFIN *
+* USRSRN *
+* WSTOAP *
+* VPOKAO *
+* VPOPIO *
+* *
+* Description of variables (incomplete): *
+* *
+* Icres = residual nucleus atomic number *
+* Ibres = residual nucleus mass number *
+* Istres = residual nucleus stable level index *
+* Ismres = residual nucleus isomeric state index *
+* Ihyres = residual nucleus hyperon number *
+* Amnres = residual nucleus nuclear mass *
+* Ammres = residual nucleus atomic mass *
+* Eres = residual nucleus total energy *
+* Ekres = residual nucleus kinetic energy *
+* Px,y,zres = residual nucleus momentum components *
+* Ptres2 = residual nucleus squared momentum *
+* Angres = residual nucleus angular momentum (GeV/c fm) *
+* Anx,y,zres = residual nucleus angular momentum components *
+* Khyres(jp) = id of the jp_th hyperon in the residual nucleus *
+* Bhyres(jp) = (nuclear) binding energy of the jp_th hyperon *
+* in the residual nucleus *
+* *
+* *
+* *
+*---------------------------------------------------------------------*
+*
+ LOGICAL LRNFSS, LFRAGM
+ COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
+ & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
+ & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
+ & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
+ & ANZRES, BHYRES (IHYPMX),
+ & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
+ & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
+ & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
+ & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
+ & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
+ & IOTHER, KHYRES (IHYPMX), LRNFSS, LFRAGM
+
--- /dev/null
+*$ CREATE RHOHAR.ADD
+*COPY RHOHAR
+*
+*=== rhohar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 03 august 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 03-aug-94 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+* Statement function:
+ RHOHAR (ISF,ITN) = RHOEFF (ISF,1) + RHOEFF (ISF,2)
+* RHOHAR (ISF,ITN) = RHOEFF (ISF,ITN)
+
--- /dev/null
+*$ CREATE RRCOUN.ADD
+*COPY RRCOUN
+*
+*=== Rrcoun ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Last change on 17-jun-97 by Alfredo Ferrari *
+* Module RRCOUN: *
+* Russian Roulette counters, A. Fasso' 1987 *
+* Modified by A. Ferrari to introduce importance biassing *
+* *
+* Lmducl = Logical flag for MeDium dependent User CaLl *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum importance splitting factor:
+ PARAMETER ( IMSPMX = 5 )
+* Minimum importance RR killing factor (in priciple for symmetry
+* back and forth it should 1/imspmx, but it is not mandatory):
+ PARAMETER ( RRIMMN = 0.2D+00 )
+ LOGICAL LIMPRH, LIMPRT, LIMPPR, LIMPRU, LEXPTR, LEXPTH, LRROUL,
+ & LIMPCO, LMDUCL
+ COMMON / RRCOUN / WEIKIL, EKIL , WEISUR, ESUR , WEINOR, ENOR ,
+ & WEIWEI, EWEI , REDUCT, EXTIMP(-6:NALLWP),
+ & EXTEXT(-6:NALLWP), JETBGN, IRRBGN, ICHBGN,
+ & ICEBGN, ICNBGN, LRROUL, LIMPRH, LIMPRT, LEXPTH,
+ & LEXPTR, LIMPCO, LIMPPR, LIMPRU, LMDUCL (MXXMDF)
+
--- /dev/null
+*$ CREATE RTDFCM.ADD
+*COPY RTDFCM
+*
+*=== rtdfcm ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* RoTation DeFinition CoMmon: *
+* *
+* Created on 12 february 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-feb-97 by Alfredo Ferrari *
+* *
+* Rtmtrx(i,j,k) = R_ij rotation matrix for the k_th transfor- *
+* mation *
+* Rimtrx(i,j,k) = R^-1_ij rotation matrix for the k_th transfor- *
+* mation *
+* Rtofst(i,k) = Traslation vector (i=1,2,3->x,y,z) for the k_th *
+* transformation *
+* Thertn (k) = Polar angle (degrees) for the k_th transfor- *
+* mation *
+* Phirtn (k) = Azimuthal angle (degrees) for the k_th transfor- *
+* mation *
+* Jaxrtn (k) = Axis used to define the angles for the k_th *
+* transformation *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXRTNS = 25 )
+ COMMON / RTDFCM / RTMTRX (3,3,MXRTNS), RIMTRX (3,3,MXRTNS),
+ & RTOFST (3,MXRTNS), THERTN (MXRTNS),
+ & PHIRTN (MXRTNS), JAXRTN (MXRTNS)
+
--- /dev/null
+*$ CREATE RTFLGS.ADD
+*COPY RTFLGS
+*
+*=== Rtflgs ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: Run Time FLaGS: *
+* *
+* Created on 28 may 1999 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 28-may-99 by Alfredo Ferrari *
+* *
+* Lrtcml = run time flag for the cumlalnt dE/dx algorithm *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LRTCML
+*
+ COMMON / RTFLGS / LRTCML
+
--- /dev/null
+*$ CREATE RTGMMV.ADD
+*COPY RTGMMV
+*
+*=== Rtgmmv ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Run-Time GeoMetry MoVements: *
+* *
+* Created on 26 may 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 26-may-98 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / RTGMMV / XRTGMV, YRTGMV, ZRTGMV
+
--- /dev/null
+*$ CREATE SBUSFL.ADD
+*COPY SBUSFL
+*
+*=== sbusfl ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 28 january 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 28-jan-92 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* SBCOMP *
+* BREFRA *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / SBUSFL / R0HLA , R0HLB , R0SKA , R0SKB , R0CEA , R0CEB ,
+ & R1CEA , R1CEB , R1SKA , R1SKB , R1HLA , R1HLB ,
+ & SQRH0A, SQRH0B, SQRS0A, SQRS0B, SQRC0A, SQRC0B,
+ & SQRC1A, SQRC1B, SQRS1A, SQRS1B, SQRH1A, SQRH1B
+
--- /dev/null
+*$ CREATE SCEXFL.ADD
+*COPY SCEXFL
+*
+*=== Scexfl ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SCoring EXtra FLags *
+* *
+* New version of the old comsec by Alfredo Ferrari, INFN - Milan *
+* *
+* Created on 04 january 1994 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 13-apr-01 by Alfredo Ferrari, INFN - Milan *
+* *
+* The comsco array is now dinamically allocated into the blank *
+* common, Icmbgn is the (0 address) beginning of Comsco(nregs,4) *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LDENO2, LDENO3, LDENOD
+ COMMON / COMSEC / LDENO2, LDENO3, LDENOD, ICMBGN
--- /dev/null
+*$ CREATE SCOHLP.ADD
+*COPY SCOHLP
+*
+*=== scohlp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 05 august 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 29-oct-94 by Alfredo Ferrari *
+* *
+* Energy/Star binnings/scorings (Comscw): *
+* ISCRNG = 1 --> Energy density binning *
+* ISCRNG = 2 --> Star density binning *
+* ISCRNG = 3 --> Residual nuclei scoring *
+* JSCRNG = # of the binning *
+* Flux like binnings/estimators (Fluscw): *
+* ISCRNG = 1 --> Boundary crossing estimator *
+* ISCRNG = 2 --> Track length binning *
+* ISCRNG = 3 --> Track length estimator *
+* ISCRNG = 4 --> Collision density estimator *
+* ISCRNG = 5 --> Yield estimator *
+* JSCRNG = # of the binning/estimator *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LSCZER
+ COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
+
--- /dev/null
+*$ CREATE SFELIN.ADD
+*COPY SFELIN
+*
+*=== Sfelin ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Statement Functions for Common ELeINp for EMF *
+* *
+* Created on 19 april 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-apr-97 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ ESIG0 (J,I) = GMSTOR ( IESIG0 (I) + J )
+ ESIG1 (J,I) = GMSTOR ( IESIG1 (I) + J )
+ PSIG0 (J,I) = GMSTOR ( IPSIG0 (I) + J )
+ PSIG1 (J,I) = GMSTOR ( IPSIG1 (I) + J )
+ EDEDX0 (J,I) = GMSTOR ( IEDDX0 (I) + J )
+ EDEDX1 (J,I) = GMSTOR ( IEDDX1 (I) + J )
+ PDEDX0 (J,I) = GMSTOR ( IPDDX0 (I) + J )
+ PDEDX1 (J,I) = GMSTOR ( IPDDX1 (I) + J )
+ EBR10 (J,I) = GMSTOR ( IEBR10 (I) + J )
+ EBR11 (J,I) = GMSTOR ( IEBR11 (I) + J )
+ PBR10 (J,I) = GMSTOR ( IPBR10 (I) + J )
+ PBR11 (J,I) = GMSTOR ( IPBR11 (I) + J )
+ PBR20 (J,I) = GMSTOR ( IPBR20 (I) + J )
+ PBR21 (J,I) = GMSTOR ( IPBR21 (I) + J )
+ TMXS0 (J,I) = GMSTOR ( ITXSE0 (I) + J )
+ TMXS1 (J,I) = GMSTOR ( ITXSE1 (I) + J )
+ TMXSP0 (J,I) = GMSTOR ( ITXSP0 (I) + J )
+ TMXSP1 (J,I) = GMSTOR ( ITXSP1 (I) + J )
+
--- /dev/null
+*$ CREATE SFPHIN.ADD
+*COPY SFPHIN
+*
+*=== Sfphin ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Statement Functions for Common PHoINp for EMF *
+* *
+* Created on 19 april 1997 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-apr-97 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ GMFP0 (J,I) = GMSTOR ( IGMFP0 (I) + J )
+ GMFP1 (J,I) = GMSTOR ( IGMFP1 (I) + J )
+ GBR10 (J,I) = GMSTOR ( IGBR10 (I) + J )
+ GBR11 (J,I) = GMSTOR ( IGBR11 (I) + J )
+ GBR20 (J,I) = GMSTOR ( IGBR20 (I) + J )
+ GBR21 (J,I) = GMSTOR ( IGBR21 (I) + J )
+ RSCT0 (J,I) = GMSTOR ( IRSCT0 (I) + J )
+ RSCT1 (J,I) = GMSTOR ( IRSCT1 (I) + J )
+ COHE0 (J,I) = GMSTOR ( ICOHE0 (I) + J )
+ COHE1 (J,I) = GMSTOR ( ICOHE1 (I) + J )
+
+
--- /dev/null
+*$ CREATE SGTBCM.ADD
+*COPY SGTBCM
+*
+*=== sgtbcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Include file: sgtbcm *
+* *
+* Created on 26 august 1991 by Alfredo Ferrari *
+* INFN - Milan *
+* *
+* Last change on 15-mar-99 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BLKDT1 *
+* KASKAD *
+* KASHEA *
+* PHNCVR *
+* SGTELS *
+* SGTINL *
+* SGTTOT *
+* SIGTAB *
+* *
+*----------------------------------------------------------------------*
+*
+* Minimum energy ratio for which cross section are computed
+* (that is the minimum energy down which the cross sections presently
+* used are reliable)
+ PARAMETER ( EKRTMN = 0.6000000000000000000D+00 )
+* Sqr1p5 = sqrt ( 1 / ekrtmn )
+ PARAMETER ( SQR1P5 = 1.2909944487358056284D+00 )
+* Alg1p5 = log ( 1 / ekrtmn )
+ PARAMETER ( ALG1P5 = 0.5108256237659906832D+00 )
+* Minimum energy ratio before computing again cross sections
+* (roughly geometric mean between 1 and ekrtmn )
+ PARAMETER ( EKRTEF = 0.7750000000000000000D+00 )
+ PARAMETER ( EKSIG0 = 1.104746407608999714039030918809046D-03 )
+* PARAMETER ( EKSIG0 = 6.14229867868362340504446476139873D-03 )
+ PARAMETER ( EKSIG1 = 50.0000000000000000000000000000000D-03 )
+ PARAMETER ( EKSIG2 = 641.959232274432000000000000000000D-03 )
+ PARAMETER ( EKSIG3 = 11677.1704101562500000000000000000D-03 )
+ PARAMETER ( ELKEG0 =-6.80813946572698539519330850737315D+00 )
+* PARAMETER ( ELKEG0 =-5.09255622924913791440217028831937D+00 )
+ PARAMETER ( ELKEG1 =-2.99573227355399099343522357614254D+00 )
+ PARAMETER ( ELKEG2 =-4.43230478438626226471171223979336D-01 )
+ PARAMETER ( ELKEG3 = 2.45763568864610059849066495004851D+00 )
+ PARAMETER ( SIGRT0 = 1.1000000000000000000D+00 )
+ PARAMETER ( SIGRT1 = 1.2000000000000000000D+00 )
+ PARAMETER ( SIGRT2 = 1.2500000000000000000D+00 )
+ PARAMETER ( SIGRT3 = 1.4000000000000000000D+00 )
+ PARAMETER ( ASGRT0 = 9.531017980432486004395212328076517D-02 )
+ PARAMETER ( ASGRT1 = 0.182321556793954626211718025154515D+00 )
+ PARAMETER ( ASGRT2 = 0.223143551314209755766295090309834D+00 )
+ PARAMETER ( ASGRT3 = 0.336472236621212930504593410216992D+00 )
+ PARAMETER ( NPSIG0 = 40 )
+* PARAMETER ( NPSIG0 = 22 )
+ PARAMETER ( NPSIG1 = 14 )
+ PARAMETER ( NPSIG2 = 13 )
+ PARAMETER ( MPSIGT = 35 )
+ PARAMETER ( MPSIGE = 33 )
+ PARAMETER ( MPSIGI = 38 )
+ PARAMETER ( MPSIGB = 13 )
+ PARAMETER ( MPSIGH = 4 )
+*
+ LOGICAL LKSHRT, LK0BAR, LKAON0, LKAOSL, LEXDCY
+ COMMON / SGTBCM / EKSIG4, ELKE0, ELKE1, ESSGTB, DESGTB,
+ & KTSIGT (MPSIGT,MXXMDF), KESIGT (MPSIGE,MXXMDF),
+ & KISIGT (MPSIGI,MXXMDF), KBSIGT (MPSIGB,MXXMDF),
+ & KPSIGT (MPSIGB,MXXMDF), IJSIGT (-6:NALLWP),
+ & IJSIGE (-6:NALLWP), IJSIGI (-6:NALLWP),
+ & IJSIGB (-6:NALLWP), NPSIG3, IESGTB, NPSGMN,
+ & NPSGMX, LKSHRT, LK0BAR, LKAON0, LKAOSL, LEXDCY
+
--- /dev/null
+*$ CREATE SLHDCM.ADD
+*COPY SLHDCM
+*
+*=== Slhdcm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SLopes for HaDrin (CoMmon): *
+* *
+* Created on 01 february 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 19-sep-00 by Alfredo Ferrari *
+* *
+* Smashd is the old SM (Masses for the slope B(M) in GeV) *
+* Bbmhad is the old BBM (Slope for a mesonic system) *
+* Bbbhad is the old BBB (Slope for a baryonic system) *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / SLHDCM / SMASHD (25), BBMHAD (25), BBBHAD (25)
--- /dev/null
+*$ CREATE SLNUCM.ADD
+*COPY SLNUCM
+*
+*=== slnucm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SoLar ( and supernova) NeUtrino CoMmon: *
+* *
+* Created on 29 february 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 03-feb-01 by Alfredo Ferrari *
+* *
+* *
+* Slnasg(j,i) = absorption cross section for jth level and ith *
+* energy *
+* Qugtfr = reaction Q for absorption on 40-Ar (40-Ar -> 40-K) *
+* Spsngt(i) = differential spectrum x cross section for solar *
+* for Gamow-Teller vue absorption on 40-Ar *
+* Cusngt(i) = cumulative spectrum x cross section for solar neu- *
+* trino for Gamow-Teller vue absorption on 40-Ar *
+* Sngtcn = total interaction rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Ppcogt = pp interaction rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* B8cogt = 8-B interaction rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Hepcog = hep interaction rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Be71cg = 7-Be (1st) inter. rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Be72cg = 7-Be (2nd) inter. rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Pepcog = pep interaction rate per year per kTon x f(40-Ar)*
+* for Gamow-Teller vue absorption on 40-Ar *
+* Spsnfr(i) = differential spectrum x cross section for solar *
+* for Fermi vue absorption on 40-Ar *
+* Cusnfr(i) = cumulative spectrum x cross section for solar neu- *
+* trino for Fermi vue absorption on 40-Ar *
+* Snfrcn = total interaction rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Ppcofr = pp interaction rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* B8cofr = 8-B interaction rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Hepcof = hep interaction rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Be71cf = 7-Be (1st) inter. rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Be72cf = 7-Be (2nd) inter. rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Pepcof = pep interaction rate per year per kTon x f(40-Ar)*
+* for Fermi vue absorption on 40-Ar *
+* Spsntt(i) = differential spectrum x cross section for solar *
+* neutrino nue-electron elastic interactions *
+* Cusntt(i) = cumulative spectrum x cross section for solar neu- *
+* trino nue-electron elastic interactions *
+* Snttcn = total interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Ppcont = pp interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* B8cont = 8-B interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Hepcon = hep interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Be71cn = 7-Be (1st) inter. rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Be72cn = 7-Be (2nd) inter. rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Pepcon = pep interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Spsnot(i) = differential spectrum x cross section for oscilla- *
+* ted numu-electron elastic interactions *
+* Cusnot(i) = cumulative spectrum x cross section for oscillated *
+* numu-electron elastic interactions *
+* Snotcn = total interaction rate per year per kTon x <Z/A> *
+* for elastic vue-electron interactions *
+* Ppocon = pp interaction rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* B8ocon = 8-B interaction rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* Hepocn = hep interaction rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* Be71oc = 7-Be (1st) inter. rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* Be72oc = 7-Be (2nd) inter. rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* Pepocn = pep interaction rate per year per kTon x <Z/A> *
+* for elastic oscillated vumu-electron interactions *
+* Tesnmn = secondary electron minimum kinetic energy (GeV) *
+* Elv40a(k) = kth energy level of 40-K (produced by vue absorp- *
+* tion on 40-Ar) *
+* Inuosc = oscillation option flag *
+* Ior40a(j) = index of the jth level accessible for vue absorp- *
+* tion on 40-Ar (levels are of 40-K) in the 40-K *
+* level scheme (see also Elv40a) *
+* *
+*----------------------------------------------------------------------*
+*
+* Number of 40-Ar levels for which absorption cross section data are
+* given:
+ PARAMETER ( NFGTAR = 21 )
+* Number of (neutrino) energy bins for Gamow-Teller and Fermi
+* absorption cross sections
+ PARAMETER ( NFGTEN = 200 )
+* Index of the Fermi transition for 40-Ar
+ PARAMETER ( IFR40A = 8 )
+* Initial (0 index) energy for Gamow-Teller and Fermi
+* absorption cross sections
+ PARAMETER ( E0FRGT = ZERZER )
+* Energy step for Gamow-Teller and Fermi
+* absorption cross sections
+ PARAMETER ( DEFRGT = 0.0001 D+00 )
+* Recorded levels of 40-K (produced by vue absoprtion on 40-Ar)
+ PARAMETER ( NLV40A = 40 )
+* Maximum number of branching to other levels of 40-K (produced
+* by vue absoprtion on 40-Ar)
+ PARAMETER ( NBR40A = 10 )
+* Number of energy bins for elastic neutrino scattering
+ PARAMETER ( NFSNTT = 1880 )
+* Energy step for elastic neutrino scattering
+ PARAMETER ( DEFLSN = 0.00001 D+00 )
+* Energy of 1st 7-Be neutrino line
+ PARAMETER ( ENBE71 = 0.000384D+00 )
+* Energy of 2nd 7-Be neutrino line
+ PARAMETER ( ENBE72 = 0.000862D+00 )
+* Energy of pep neutrino line
+ PARAMETER ( ENLPEP = 0.001442D+00 )
+*
+ COMMON / SLNUCM / SLNASG (NFGTAR,NFGTEN), BRT40A (NBR40A,NLV40A),
+ & SPSNGT (0:NFGTEN), CUSNGT (0:NFGTEN), SNGTCN,
+ & PPCOGT, B8COGT, HEPCOG, BE71CG, BE72CG, PEPCOG,
+ & SPSNFR (0:NFGTEN), CUSNFR (0:NFGTEN), SNFRCN,
+ & PPCOFR, B8COFR, HEPCOF, BE71CF, BE72CF, PEPCOF,
+ & SPSNTT (0:NFSNTT), CUSNTT (0:NFSNTT), SNTTCN,
+ & PPCONT, B8CONT, HEPCON, BE71CN, BE72CN, PEPCON,
+ & SPSNOT (0:NFSNTT), CUSNOT (0:NFSNTT), SNOTCN,
+ & PPOCON, B8OCON, HEPOCN, BE71OC, BE72OC, PEPOCN,
+ & ELV40A (NLV40A), QUGTFR, TESNMN, INUOSC,
+ & IBG40A (NBR40A,NLV40A), IOR40A (NFGTAR)
+
--- /dev/null
+*$ CREATE SNNUCM.ADD
+*COPY SNNUCM
+*
+*=== snnucm ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SuperNova NeUtrino CoMmon: *
+* *
+* Created on 29 february 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 21-feb-01 by Alfredo Ferrari *
+* *
+* *
+* Tmpsnn(i) = temperature (MeV) of the emission spectrum for the *
+* i_th neutrino specie *
+* Alpsnn(i) = alpha term of the emission spectrum for the *
+* i_th neutrino specie *
+* Fnrsnn(i) = normalization factor for the emission spectrum for *
+* the i_th neutrino specie *
+* Ftsnnu(i) = total flux (at 10 kpc) for the emission spectrum *
+* for the i_th neutrino specie *
+* Rtsnnu(i) = total rate (ev/kTon at 10 kpc) for the i_th *
+* neutrino specie *
+* Resnnu(i) = electron elastic rate (ev/kTon at 10 kpc) for *
+* the i_th neutrino specie *
+* Rgsnnu(i) = Gamow-Teller rate (ev/kTon at 10 kpc) for the i_th *
+* neutrino specie *
+* Rfsnnu(i) = Fermi rate (ev/kTon at 10 kpc) for the i_th *
+* neutrino specie *
+* Weisnn(i) = weight of the emission spectrum for the i_th *
+* neutrino specie *
+* *
+*----------------------------------------------------------------------*
+*
+* Number of energy bins for elastic supernova neutrino scattering
+ PARAMETER ( NSNESC = 3000 )
+* Number of energy bins for Gamow-Teller and Fermi supernova neutrino
+* absorptions
+ PARAMETER ( NSNGTF = 1200 )
+* Energy step for elastic supernova neutrino scattering
+ PARAMETER ( DESNES = 0.00002D+00 )
+* Energy step for Gamow-Teller and Fermi supernova neutrino
+* absorptions
+ PARAMETER ( DESNGF = 0.00005D+00 )
+ COMMON / SNNUCM / TMPSNN (6), ALPSNN (6), FNRSNN (6), FTSNNU (6),
+ & RTSNNU (6), RESNNU (6), RGSNNU (6), RFSNNU (6),
+ & WEISNN (6),
+ & SPESSN (0:NSNESC,6), CUESSN (0:NSNESC,6),
+ & SPGTSN (0:NSNGTF,6), CUGTSN (0:NSNGTF,6),
+ & SPFRSN (0:NSNGTF,2), CUFRSN (0:NSNGTF,2)
+
+
--- /dev/null
+*$ CREATE SOUEVT.ADD
+*COPY SOUEVT
+*
+*=== Souevt ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SOUrce EVenT: *
+* *
+* Created on 14 november 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 16-mar-98 by Alfredo Ferrari *
+* *
+* X,Y,Zsoevt(i) = position of the i_th source particle *
+* TX,Y,Zsoev(i) = direction of the i_th source particle *
+* Wtsoev(i) = weight of the i_th source particle *
+* Pmsoev(i) = momentum of the i_th source particle *
+* Tksoev(i) = kin. energy of the i_th source particle *
+* Agsoev(i) = age of the i_th source particle *
+* Aksoev(i) = Kaon ampl. of the i_th source particle *
+* Ussoev(j,i) = user var. of the i_th source particle *
+* Ijsoev(i) = identity of the i_th source particle *
+* Nrsoev(i) = region of the i_th source particle *
+* Nlsoev(i) = lattice of the i_th source particle *
+* Losoev(i) = user flag of the i_th source particle *
+* Iusoev(j,i) = user flags of the i_th source particle *
+* Npsoev = number of the source particles *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXSOEV = 100 )
+ COMMON / SOUEVT / XSOEVT (MXSOEV), YSOEVT (MXSOEV),
+ & ZSOEVT (MXSOEV), TXSOEV (MXSOEV),
+ & TYSOEV (MXSOEV), TZSOEV (MXSOEV),
+ & TXPSOV (MXSOEV), TYPSOV (MXSOEV),
+ & TZPSOV (MXSOEV), WTSOEV (MXSOEV),
+ & PMSOEV (MXSOEV), TKSOEV (MXSOEV),
+ & AGSOEV (MXSOEV), AKSOEV (MXSOEV),
+ & USSOEV (MKBMX1,MXSOEV),
+ & IJSOEV (MXSOEV), NRSOEV (MXSOEV),
+ & NLSOEV (MXSOEV), LOSOEV (MXSOEV),
+ & IUSOEV (MKBMX2,MXSOEV), NPSOEV
+
--- /dev/null
+*$ CREATE SPCSMP.ADD
+*COPY SPCSMP
+*
+*=== spcsmp ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* SPeCtrum SaMPling: *
+* *
+* Created on 29 may 1996 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 05-feb-99 by Alfredo Ferrari *
+* *
+* Description of variables: *
+* *
+* Xspcsm(it) = cross section used for spectrum sampling on indi- *
+* vidual nucleons (1=p,2=n) *
+* Lspcsm = logical flag indicating whether spectrum sampling *
+* is activated *
+* Lspcrs = logical flag indicating that spectrum re-sampling *
+* is requested *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LSPCSM, LSPCRS
+*
+ COMMON / SPCSMP / XSPCSM (2), LSPCSM, LSPCRS
+
--- /dev/null
+*$ CREATE SPEEDE.ADD
+*COPY SPEEDE
+*
+*=== speede ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 07 november 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 07-nov-90 by Alfredo Ferrari *
+* *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NBNSPD = 150 )
+ PARAMETER ( EMNSPD = 1.0 D-04 )
+ PARAMETER ( EMXSPD = 5.0 D+00 )
+* This is the natural logarithm of the previos one less something
+* PARAMETER ( ELMXSP = 1.609437912434100 D+00 )
+ PARAMETER ( ELMXSP = 1.609437912434100 D+00 - 10.D+00 * ANGLGB )
+*
+ COMMON / SPEEDE / SPEED1 (0:NBNSPD), SPEED0 (0:NBNSPD),
+ & ESPEE1, ESPEE0
+
--- /dev/null
+*$ CREATE SPLIT.ADD
+*COPY SPLIT
+*
+*=== split ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 17-may-95 by Alfredo Ferrari *
+* *
+* Actual common name changed from SPLIT to SPLTCM on 22-jan-01 *
+* to get around a bug in the Linux compiler/linker *
+* *
+* This is the original common split of Hadrin *
+* *
+* Included in the following routines: *
+* *
+* CALUMV *
+* DATESH *
+* HADRIV *
+* RCHANV *
+* BLKDT3 *
+* HADDEN *
+* CALUMO *
+* RCHANW *
+* *
+*----------------------------------------------------------------------*
+*
+* There should be some safety in this dimension, it was originally
+* 460 = K2 (94) + 153 = 307 + 153:
+ PARAMETER ( IDMXSP = IDMXDC / 2 + 170 )
+ COMMON / SPLTCM / WT (-6:IDMXSP), NZK (-6:IDMXSP,3)
+ COMMON / NAMSDC / ANAME (-6:MXPABL), ZKNAME (-6:IDMXSP)
+ CHARACTER*8 ANAME, ZKNAME
+
--- /dev/null
+*$ CREATE STACK.ADD
+*COPY STACK
+*
+*=== stack ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* include file: stack copy created 26/11/86 by p*
+* *
+* changes: last change on 16-sep-1999 by Alfredo Ferrari *
+* INFN, Milan *
+* *
+* included in the following subroutines or functions: not updated *
+* *
+* AEMSHH *
+* BEAMDV *
+* BEAMEM *
+* BEAMSO *
+* DELTHR *
+* DPLSTK *
+* EPILOG *
+* FEEDER *
+* FLNWST *
+* FLUKAM *
+* GEOFAR *
+* GEOMTR *
+* KASHEA *
+* KASKAD *
+* KASNEU *
+* KASRAY *
+* MGDRAW *
+* PPHNEV *
+* SOEVSV *
+* SOURCE *
+* STCKAD *
+* STUPRF *
+* ZEROIN *
+* *
+* description of the common block(s) and variable(s) *
+* *
+* /stack/ stack for the primaries *
+* wt = weight of the particle *
+* pmom = laboratory momentum of the particle in GeV/c *
+* tke = laboratory kinetic energy of the particle in GeV *
+* xa = x-coordinate of the particle *
+* ya = y-coordinate of the particle *
+* za = z-coordinate of the particle *
+* tx = direction cosine of the particle *
+* with respect to x-axis *
+* ty = direction cosine of the particle *
+* with respect to y-axis *
+* tz = direction cosine of the particle *
+* with respect to z-axis *
+* txpol = direction cosine of the particle polarization *
+* typol = direction cosine of the particle polarization *
+* tzpol = direction cosine of the particle polarization *
+* txnor = direction cosine of a (possible) surface normal *
+* tynor = direction cosine of a (possible) surface normal *
+* tznor = direction cosine of a (possible) surface normal *
+* dfnear = distance to the nearest boundary *
+* agestk = age of the particle (seconds) *
+* aknshr = Kshort component of K0/K0bar *
+* raddly = delay (s) in production wrt the nominal primary "0" *
+* time for particle produced in radioactive decays *
+* (i.e. those coming from decays of daughter isotopes) *
+* sparek = spare real variables available for K.W.Burn *
+* ispark = spare integer variables available for K.W.Burn *
+* ilo = type of the particle (see btype in /paprop/) *
+* igroup = energy group for low energy neutrons *
+* lo = generation of the particle *
+* louse = user flag *
+* nreg = number of the region of the particle *
+* nlattc = number of the lattice cell of the particle *
+* nhspnt = pointer to the history object (Geant4 geometry) *
+* nevent = number of the event which created the particle *
+* numpar = particle number *
+* lraddc = flag for particles generated in radioactive decyas *
+* nparma = biggest particle number encountered *
+* mstack = size of the stack *
+* lstmax = highest value of the stack pointer encountered *
+* in the run *
+* lstack = stack pointer *
+* lstaol = stack pointer of the last processed particle *
+* igroun = energy group number of the last processed particle *
+* if it is a low energy neutron *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /STACK/
+ & XA (0:MFSTCK), YA (0:MFSTCK), ZA (0:MFSTCK),
+ & TX (0:MFSTCK), TY (0:MFSTCK), TZ (0:MFSTCK),
+ & TXPOL (0:MFSTCK), TYPOL (0:MFSTCK), TZPOL (0:MFSTCK),
+ & TXNOR (0:MFSTCK), TYNOR (0:MFSTCK), TZNOR (0:MFSTCK),
+ & WT (0:MFSTCK), PMOM (0:MFSTCK), TKE (0:MFSTCK),
+ & DFNEAR (0:MFSTCK), AGESTK (0:MFSTCK), AKNSHR (0:MFSTCK),
+ & RADDLY (0:MFSTCK), SPAREK (MKBMX1,0:MFSTCK),
+ & ISPARK (MKBMX2,0:MFSTCK), ILO (0:MFSTCK),
+ & IGROUP (0:MFSTCK), LO (0:MFSTCK), LOUSE (0:MFSTCK),
+ & NREG (0:MFSTCK), NLATTC (0:MFSTCK), NHSPNT (0:MFSTCK),
+ & NEVENT (0:MFSTCK), NUMPAR (0:MFSTCK), LRADDC (0:MFSTCK),
+ & NPARMA, MSTACK, LSTMAX, LSTACK, LSTAOL, IGROUN
+ LOGICAL LRADDC
+
--- /dev/null
+*$ CREATE STARS.ADD
+*COPY STARS
+*
+*=== stars ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* STARS common for FLUKA: *
+* *
+* Version for FLUKA90/99/... of the original one of FLUKA86 *
+* *
+* *
+* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 07-oct-99 by Alfredo Ferrari *
+* *
+* *
+* description of the common variable(s): *
+* *
+* Ntstar = total number of stars generated (modulo 1000000000) *
+* Neulow = total number of low energy neutron interactions *
+* (modulo 1000000000) *
+* Numdec = total number of decays (modulo 1000000000) *
+* Mtstar = total number of stars generated / 100000000 *
+* Meulow = total number of low energy neutron interactions *
+* / 1000000000 *
+* Mumdec = total number of decays (modulo 1000000000) *
+* Wstars = total weight of the stars generated *
+* Wneulw = total weight of the low energy neutron interactions *
+* Westar = weight of the stars generated by *
+* different particle types *
+* Westop = total weight of the particles stopped *
+* Wstop = weight of particles of different types stopped *
+* Weisec = total weight of the secondaries created *
+* Weifis = total weight of high energy fissions *
+* Weipri = total weight of the primaries handled *
+* Edi = deposited energy *
+* Edi(1) = by ionisation *
+* Edi(2) = by pi-zeros and/or EM cascade *
+* Edi(3) = by nuclear excitation (or nuclear recoil *
+* and heavies if the evaporation module is *
+* activated) *
+* Edi(4) = by stopped particles *
+* Edi(5) = energy leaving the system *
+* Edi(6) = energy carried by discarded particles *
+* Edi(7) = by residual excitation energy (only if the *
+* evaporation module is activated) *
+* Edi(8) = by low energy neutrons (kerma due to low *
+* energy neutrons transport is in effect) *
+* Edi(9) = energy carried by time killed particles *
+* Edi(10)= energy wasted for nuclear binding energy *
+* effects for E > 50 MeV *
+* Edi(11)= energy wasted for nuclear binding energy *
+* effects for low energy neutrons *
+* Wdec = weight of the particles decayed *
+* Wdau = weight of the decay-products *
+* Wtkll = weight of the time-killed particles *
+* Wtdec = total weight of the particles decayed *
+* Wtdau = total weight of the decay products *
+* Wttkll = total weight of the time killed particles *
+* Wlwnsc = weight of the low energy neutrons interaction secon- *
+* daries *
+* Wdecct = weight of the particles decayed for which a c tau *
+* scoring is done *
+* Deccts = decay c tau scoring *
+*----------------------------------------------------------------------*
+*
+ COMMON / STARS /
+ & WESTAR (-6:NALLWP), WSTOP (-6:NALLWP),
+ & WDAU (-6:NALLWP), WTKLL (-6:NALLWP),
+ & WDEC (-6:NALLWP), WEIFIS (-6:NALLWP),
+ & DECCTS (-6:NALLWP), WDECCT (-6:NALLWP),
+ & WEISEC (-6:NALLWP+12), WLWNSC (4), EDI (11),
+ & WNEULW, WESTOP, WSTARS, WEIPRI, WTDEC , WTDAU ,
+ & WTTKLL, NUMDEC, NTSTAR, NEULOW, MUMDEC, MTSTAR,
+ & MEULOW
+
--- /dev/null
+*$ CREATE STCKA.ADD
+*COPY STCKA
+
+*----------------------------------------------------------------------*
+* *
+* Stcka: included in *
+* STCKAD *
+* KASKAD *
+* FEEDER *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER (MAXUST=MFSTCK)
+ COMMON /STCKA/ UST(0:MAXUST), LUST(0:MAXUST)
+
--- /dev/null
+*$ CREATE STEPSZ.ADD
+*COPY STEPSZ
+*
+*=== stepsz ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common stepsz for setting the minimum and maximum step sizes on a *
+* a region by region basis: very useful for vacuum re- *
+* gions with magnetic filed and for saving time ( and *
+* accuracy ) with the new plc and lca algorithm in *
+* Emf and Fluka *
+* *
+* W A R N I N G !!!!! At the moment implemented only for *
+* electron and positron transport in Emf and for charged *
+* particles transport in Fluka with the new multiple scat- *
+* tering module!!!!!! *
+* *
+* created by A. Ferrari & P. Sala on 14-jan-1990 *
+* *
+* included in: *
+* bdnopt *
+* fluka (main) *
+* prolog *
+* electr (new version) *
+* *
+* Stepmn = minimum step size (cm) *
+* Stepmx = maximum step size (cm) *
+* Mxxrgn = maximum number of regions *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / STEPSZ / STEPMN ( MXXRGN ), STEPMX ( MXXRGN )
+
--- /dev/null
+*$ CREATE THR.ADD
+*COPY THR
+*
+*=== thr ==============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* THReshold (for FLUKA) common: *
+* *
+* Version for FLUKA92/.../99 of the original one of FLUKA86 *
+* *
+* *
+* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 18-may-00 by Alfredo Ferrari *
+* *
+* *
+* description of the variable(s) *
+* *
+* ethr = threshold kinetic energy in GeV for particle prod. *
+* ethrin = threshold kinetic energy in GeV for inelastic inter. *
+* ethrel = threshold kinetic energy in GeV for elastic inter. *
+* ethr = threshold kinetic energy in GeV for particle prod. *
+* fluthr = threshold kinetic energy in GeV for flux scoring *
+* ethstr = threshold kinetic energy in GeV for star scoring *
+* ethrij = threshold kinetic energy in GeV for each kind of *
+* particle *
+* pthrij = threshold momentum in GeV/c for each kind of *
+* particle *
+* pthneu = neutron momentum at the kinetic energy threshold *
+* khvtrn = max. index for full heavy particle transport *
+* llownt = .true. if low energy neutron production and transport*
+* has to be activated *
+* llmncp = .true. if low energy neutron production and transport*
+* with MCNP has to be activated, .false. for default *
+* multigroup transport *
+* lhvtrn = flag for full heavy particle transport *
+* liontr = flag for full transport of ions heavier than alphas *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LLOWNT, LLMCNP, LHVTRN, LIONTR
+ COMMON / THR / ETHR , ETHRIN, ETHREL, FLUTHR, ETHSTR,
+ & ETHRIJ (-6:NALLWP), PTHRIJ (-6:NALLWP), PTHNEU,
+ & KHVTRN, LLOWNT, LLMCNP, LHVTRN, LIONTR
+
--- /dev/null
+*$ CREATE THRESH.ADD
+*COPY THRESH
+*
+*=== Thresh ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Last change on 15-may-99 by Alfredo Ferrari *
+* *
+* Common Thresh for EMF *
+* Mxxmde = Maximum number of media in Emf *
+* Ecutm = Minimum energy to perform Moliere's scattering *
+* Ethnsz = Minimum energy to apply the nuclear size correction *
+* to the Moliere's scattering Moliere's scattering *
+* Please note that the following arrays use the Fluka material index *
+* rather than the EMF one *
+* Upcmpt = Minimum photon energy to perform Compton scattering *
+* Upphel = Minimum photon energy to perform photoelectric *
+* Uppair = Minimum photon energy to perform pair production *
+* Uprlgh = Minimum photon energy to perform Rayleigh scattering *
+* Upphnc = Minimum photon energy to perform photonucl. interac. *
+* Uebrms = Minimum e+/e- energy to perform bremsstrahlung *
+* Uebhml = Minimum e+/e- energy to perform Bhabha/Moller *
+* Ueannh = Minimum e+ energy to perform annihilation *
+* Uephnc = Minimum e+/e- energy to perform photonucl. interac. *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / THRESH / RMT2 , RMSQ , ESCD2 ,
+ & AP (MXXMDE), AE (MXXMDE),
+ & UP (MXXMDE), UE (MXXMDE),
+ & TE (MXXMDE), THMOLL (MXXMDE),
+ & ECUTM (MXXMDE), ETHNSZ (MXXMDE),
+ & UPCMPT (MXXMDF), UPPHEL (MXXMDF),
+ & UPPAIR (MXXMDF), UPRLGH (MXXMDF),
+ & UPPHNC (MXXMDF), UEBRMS (MXXMDF),
+ & UEBHML (MXXMDF), UEANNH (MXXMDF),
+ & UEPHNC (MXXMDF)
+
--- /dev/null
+*$ CREATE TMPNUC.ADD
+*COPY TMPNUC
+*
+*=== tmpnuc ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* TeMPorary storage for NUClear interaction secondaries: *
+* *
+* Created on 25 june 1995 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 08-sep-00 by Alfredo Ferrari *
+* *
+* This is just a mirror copy of parnuc common, to temporarily save *
+* secondaries coming out from interactions while waiting for *
+* formation time checks *
+* *
+* Nsavin = number of the stored interaction (=nuscin) *
+* Icycsv = Icycl *
+* Nholsv = Nhole *
+* Iabcsv = Iabcou *
+* Ininsv = Inindx *
+* Nhlxsv = Nhlexp *
+* Rhexsv = Rhoexp *
+* Hlexsv = Holexp *
+* Ekexsv = Ekfexp *
+* Amcrsv = Amcrea *
+* Rhmesv = Rhomem *
+* Ekmesv = Ekfmem *
+* Bimesv = Bimmem *
+* Llacsv = Lllact *
+* Nprnsv = Nprnuc *
+* Iprnsv = Iprnuc *
+* Jprnsv = Jprnuc *
+* Nlvlsv = Nlevel *
+* Nmshsv = Nmshll *
+* Rdscsv = Radscb *
+* *
+* Agtrgt = "age" for materialization of the currently *
+* saved interaction *
+* Crrftp = proton correlation variable for the currently*
+* saved interaction *
+* Crrftn = neutron correlation variable for the currently*
+* saved interaction *
+* Pafrft = hard core radius for the currently saved *
+* interaction *
+* Rhexft = Rhoexi for hard core radius for the currently *
+* saved interaction *
+* Rhcmft = Rhocmp for hard core radius for the currently *
+* saved interaction *
+* Rhmnft = Rhomin for hard core radius for the currently *
+* saved interaction *
+* *
+*----------------------------------------------------------------------*
+*
+ LOGICAL LATATM
+ PARAMETER ( NCTMX = 25 )
+ COMMON / TMPNUC / ENCTM (NCTMX), PNCTM (NCTMX), EKFNTM (NCTMX),
+ & XSTNTM (NCTMX), YSTNTM (NCTMX), ZSTNTM (NCTMX),
+ & PXNCTM (NCTMX), PYNCTM (NCTMX), PZNCTM (NCTMX),
+ & RSTNTM (NCTMX), FRPNTM (NCTMX), CRNNTM (NCTMX),
+ & CRPNTM (NCTMX), BSTNTM (NCTMX), AGNCTM (NCTMX),
+ & TFPNTM (NCTMX), RHNCTM(NCTMX,2), RHEXSV (2),
+ & RDSCSV (3), HLEXSV, EKEXSV, AMCRSV, RHMESV,
+ & EKMESV, BIMESV, AGTRGT, CRRFTP, CRRFTN, PAFRFT,
+ & RHCMFT, RHEXFT, RHMNFT,
+ & KPNCTM (NCTMX), KRFNTM (NCTMX), ILINTM (NCTMX),
+ & INTNTM (NCTMX), ISFNTM (NCTMX), LATATM (NCTMX),
+ & KRSNTM (NCTMX), NPNTM , NSAVIN, ICYCSV, NHOLSV,
+ & IABCSV, NHLXSV, LLACSV, NPRNSV, NLVLSV, ININSV,
+ & JPRNSV (3), IPRNSV (3), NMSHSV (3)
+ COMMON / TMPLEV / RADSCB (3), NMSHLL (3), NLEVEL
+
--- /dev/null
+*$ CREATE TRACKR.ADD
+*COPY TRACKR
+* *
+*=== trackr ===========================================================*
+* *
+*----------------------------------------------------------------------*
+* *
+* TRACKs Recording by Alfredo Ferrari, INFN - Milan *
+* *
+* last change 31 january 2001 by Alfredo Ferrari *
+* *
+* included in : *
+* electr *
+* emfsco *
+* kaskad (new version) *
+* kashea *
+* kasneu *
+* geoden (new version) *
+* mageas *
+* magmov *
+* magnew *
+* move *
+* photon *
+* usrsco *
+* *
+* Ntrack = number of track segments *
+* Mtrack = number of energy deposition events along the track *
+* 0 < i < Ntrack *
+* Xtrack = end x-point of the ith track segment *
+* Ytrack = end y-point of the ith track segment *
+* Ztrack = end z-point of the ith track segment *
+* 1 < i < Ntrack *
+* Ttrack = length of the ith track segment *
+* 1 < j < Mtrack *
+* Dtrack = energy deposition of the jth deposition event *
+* *
+* Jtrack = identity number of the particle *
+* Etrack = total energy of the particle *
+* Ptrack = momentum of the particle (not always defined, if *
+* < 0 must be obtained from Etrack) *
+* Cx,y,ztrck = direction cosines of the current particle *
+* Cx,y,ztrpl = polarization cosines of the current particle *
+* Wtrack = weight of the particle *
+* Wscrng = scoring weight: it can differ from Wtrack if some *
+* biasing techniques are used (for example inelastic *
+* interaction length biasing) *
+* Ctrack = total curved path *
+* Zfftrk = <Z_eff> of the particle *
+* Zfrttk = actual Z_eff of the particle *
+* Atrack = age of the particle *
+* Akshrt = Kshrt amplitude for K0/K0bar *
+* Aklong = Klong amplitude for K0/K0bar *
+* Wninou = neutron algebraic balance of interactions (both *
+* for "high" energy particles and "low" energy *
+* neutrons) *
+* Spausr = user defined spare variables for the current *
+* particle *
+* Sttrck = macroscopic total cross section for low energy *
+* neutron collisions *
+* Satrck = macroscopic absorption cross section for low energy*
+* neutron collisions (it can be negative for Pnab>1) *
+* Ktrack = if > 0 neutron group of the particle (neutron) *
+* *
+* Ntrack > 0, Mtrack > 0 : energy loss distributed along the *
+* track *
+* Ntrack > 0, Mtrack = 0 : no energy loss along the track *
+* Ntrack = 0, Mtrack = 0 : local energy deposition (the *
+* value and the point are not re- *
+* corded in Trackr) *
+* Mmtrck = flag recording the material index for low energy *
+* neutron collisions *
+* Lt1trk = initial lattice cell of the current track *
+* (or lattice cell for a point energy deposition) *
+* Lt2trk = final lattice cell of the current track *
+* Ihspnt = current geometry history pointer (not set if -1) *
+* Ltrack = flag recording the generation number *
+* Llouse = user defined flag for the current particle *
+* Ispusr = user defined spare flags for the current particle *
+* Lfsssc = logical flag for inelastic interactions ending with*
+* fission (used also for low energy neutrons) *
+* *
+*----------------------------------------------------------------------*
+* *
+ PARAMETER ( MXTRCK = 2500 )
+ LOGICAL LFSSSC
+ COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
+ & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
+ & DTRACK ( MXTRCK ), ETRACK, PTRACK, CXTRCK,
+ & CYTRCK, CZTRCK, WTRACK, CXTRPL, CYTRPL, CZTRPL,
+ & ZFFTRK, ZFRTTK, ATRACK, CTRACK, AKSHRT, AKLONG,
+ & WSCRNG, WNINOU, SPAUSR(MKBMX1), STTRCK, SATRCK,
+ & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK, LT1TRK,
+ & LT2TRK, IHSPNT, LTRACK, LLOUSE, ISPUSR(MKBMX2),
+ & LFSSSC
+ EQUIVALENCE ( SPAUSE, SPAUSR (1) )
+ EQUIVALENCE ( ISPUSE, ISPUSR (1) )
+
--- /dev/null
+*$ CREATE UNRTSF.ADD
+*COPY UNRTSF
+*
+*=== Unrtsf ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* UNdo RoTation Statement Functions: *
+* *
+* Created on 31 january 1998 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 31-mar-98 by Alfredo Ferrari *
+* *
+* Rotate ux,y,z to the frame where the original z *
+* axis has components (csph0 x snth0, snph0 x snth0, csth0) *
+* *
+*----------------------------------------------------------------------*
+*
+ UNDOXR ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & UX * CSPH0 * CSTH0 - UY * SNPH0 + UZ * CSPH0 * SNTH0
+ UNDOYR ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & UX * SNPH0 * CSTH0 + UY * CSPH0 + UZ * SNPH0 * SNTH0
+ UNDOZR ( UX, UY, UZ, SNPH0, CSPH0, SNTH0, CSTH0 ) =
+ & - UX * SNTH0 + UZ * CSTH0
+
--- /dev/null
+*$ CREATE UPHIIN.ADD
+*COPY UPHIIN
+*----------------------------------------------------------------------*
+* *
+* Common Uphiin for EGS4 *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /UPHIIN/ SINC0, SINC1, SIN0(1002), SIN1(1002)
+
--- /dev/null
+*$ CREATE UPHIOT.ADD
+*COPY UPHIOT
+*----------------------------------------------------------------------*
+* *
+* Common Uphiot for EGS4 *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /UPHIOT/ THETA, SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+
--- /dev/null
+*$ CREATE USEFUL.ADD
+*COPY USEFUL
+*----------------------------------------------------------------------*
+* *
+* Common Useful for EMF *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON /USEFUL/ RM, MEDIUM, MEDOLD, IBLOBE
+
--- /dev/null
+*$ CREATE USER.ADD
+*COPY USER
+*
+*=== user =============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common User for EMF *
+* *
+* Last change: A. Ferrari 3-24-94 *
+* *
+* Lemagn = flag for magnetic field (set by Emfgeo) *
+* *
+* Xemf = x-coordinate of the end point in the magnetic field *
+* Yemf = y-coordinate of the end point in the magnetic field *
+* Zemf = z-coordinate of the end point in the magnetic field *
+* *
+* Uemf = u-cosine of the end point in the magnetic field *
+* Vemf = v-cosine of the end point in the magnetic field *
+* Wemf = w-cosine of the end point in the magnetic field *
+* *
+* dedxem = current de/dx for electrons/positrons *
+* demelf = energy loss/gain in EM fields *
+* *
+* Intrck = flag for tracking initialization: it must be set to *
+* zero every time the trajectory direction has changed *
+* from the previous call to Emfgeo *
+* *
+*----------------------------------------------------------------------*
+*
+ COMMON / USER / XEMF , YEMF , ZEMF , UEMF , VEMF , WEMF ,
+ & DEDXEM, DEMELF, LEMAGN, INTRCK
+ LOGICAL LEMAGN
+
--- /dev/null
+*$ CREATE USPLC.ADD
+*COPY USPLC
+*
+*=== usplc ============================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Common Usplc for the new plc and lca correction in Emf and Fluka *
+* created by A. Ferrari & P. Sala on 23-oct-1989 *
+* *
+* Last change on 05 september 1997 by Alfredo Ferrari *
+* *
+* included in: *
+* bdmuls *
+* electr (new version) *
+* emsnsc *
+* fixtmx (new version) *
+* fluka *
+* hmsnsc *
+* mulemf *
+* mulhad *
+* omegae *
+* stepop *
+* tmxmol *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( NBUCIN = 300 )
+ PARAMETER ( PISQRD = 9.8696044010893585D+00 )
+ PARAMETER ( AP0782 = 7.8152099123863686D-02 )
+ PARAMETER ( AP158 = 0.1583818043657366D+00 )
+*
+*----------------------------------------------------------------------*
+* The following number should be e, but it was slightly increased *
+* to be sure to get blc > 1 in the scattering routine *
+*----------------------------------------------------------------------*
+*
+* PARAMETER ( A2P72 = 2.718281828459045 D+00 )
+ PARAMETER ( A2P72 = 2.720000000000000 D+00 )
+ PARAMETER ( A1P49 = 1.487919357153952 D+00 )
+ PARAMETER ( A3P18 = 3.181183579549088 D+00 )
+ PARAMETER ( A1P79 = 1.787977237735012 D+00 )
+ PARAMETER ( A4P27 = 4.266960033369870 D+00 )
+ PARAMETER ( A1P67 = 1.672042454693153 D+00 )
+ PARAMETER ( A1P56 = 1.557182904603876 D+00 )
+ PARAMETER ( A3P71 = 3.70518458839024 D+00 )
+ PARAMETER ( A3P57 = 3.56952768907613 D+00 )
+ PARAMETER ( A7P70 = 7.69852999760397 D+00 )
+ PARAMETER ( A11P2 = 11.2277672735772 D+00 )
+ PARAMETER ( A3P32 = 3.32238673227802 D+00 )
+ PARAMETER ( A3P81 = 3.81210471399911 D+00 )
+*
+ PARAMETER ( B4P52 = A3P18 - A7P70 )
+ PARAMETER ( B6P96 = A4P27 - A11P2 )
+ PARAMETER ( A2P22 = A3P71 - A1P49 )
+ PARAMETER ( A1P78 = A3P57 - A1P79 )
+ PARAMETER ( A1P65 = A3P32 - A1P67 )
+ PARAMETER ( A2P25 = A3P81 - A1P56 )
+*
+ PARAMETER ( BUC1P5 = 1.5D+00 )
+ PARAMETER ( OME1P5 = 2.987792713558710D+00 )
+ PARAMETER ( BLC1P5 = 1.094534891891836D+00 )
+ PARAMETER ( BUC2P0 = 2.0D+00 )
+ PARAMETER ( OME2P0 = 3.694528049465325D+00 )
+ PARAMETER ( BLC2P0 = 1.306852819440055D+00 )
+ PARAMETER ( BUC3P0 = 3.0D+00 )
+ PARAMETER ( OME3P0 = 6.695178974395889D+00 )
+ PARAMETER ( BLC3P0 = 1.901387711331890D+00 )
+ PARAMETER ( BUC4P0 = 4.0D+00 )
+ PARAMETER ( OME4P0 = 13.64953750828606D+00 )
+ PARAMETER ( BLC4P0 = 2.613705638880109D+00 )
+ PARAMETER ( BUC5P0 = 5.0D+00 )
+ PARAMETER ( OME5P0 = 29.68263182051532D+00 )
+ PARAMETER ( BLC5P0 = 3.390562087565900D+00 )
+* The following 4 parameters are used for the approximation of the
+* correction to the Moliere single scattering cross section
+ PARAMETER ( NCORIN = 50 )
+ PARAMETER ( DBETAC = 2.000000000000000D-02 )
+ PARAMETER ( BETG35 = 9.583148474999099D-01 )
+ PARAMETER ( BE2G35 = 9.183673469387755D-01 )
+*
+*----------------------------------------------------------------------*
+* *
+* Now the parameters defining the minimum and maximum step conditions *
+* *
+* Atmin is the minimum omega0 allowed for using the Moliere's *
+* theory: at the moment it is set to A2p72 for the egsN(ew) *
+* version and to Ome1p5 for the egsX version *
+* Btmin is the upper case B corresponding to omega0 = Atmin: at *
+* the moment it is set = 1 for the egsN(ew) version and to *
+* Buc1p5 for the egsX version *
+* Atmax is the maximum allowed value for the chi-sub-c**2 * B, at *
+* the moment it is set to 1 ( Bethe criterion ) for the *
+* egsN(ew) version and to 1.8 for the egsX version. *
+* Atmnm is the minimum "meaningful" omega0, it is used only in *
+* egsX and is set to Ome3p0 *
+* Btmnm is the upper case B corresponding to omega0 = Atmnm, it is *
+* used only in egsX and is set to Buc3p0 *
+* Atmxa is the maximum "acceptable" value for the chi-sub-c**2 * B,*
+* it is used only in egsX and at the moment it is set to 1 *
+* Thmx0 is the reduced angle besides which the distribution can be *
+* considered = to the single scattering one, for B = 1. It *
+* set to 5 *
+* Thmxh is 8 ( Thmx0**2 - 2 ) *
+* Ldomrn logical flag for randomly distributed domega sampling *
+* Leocrr logical flag for correlated randomly distributed eta and *
+* domega sampling *
+* Laclrg logical flag for using a modified expression for large *
+* a_c's *
+* Mesnsc number of allowed single scatterings for e+/e- *
+* Mhsnsc number of allowed single scatterings for hadrons *
+* and muons *
+* Lesnsc logical flag for single scattering for e+/e- *
+* Lhsnsc logical flag for single scattering for hadrons *
+* and muons *
+* Leplgn logical flag for the "polygonal" approach for e+/e- *
+* Lhplgn logical flag for the "polygonal" approach for hadrons *
+* and muons *
+* *
+*----------------------------------------------------------------------*
+*
+* PARAMETER ( ATMIN = A2P72 )
+ PARAMETER ( ATMIN = OME1P5 )
+* PARAMETER ( BTMIN = 1.D+00 )
+ PARAMETER ( BTMIN = BUC1P5 )
+* PARAMETER ( ATMAX = 1.D+00 )
+ PARAMETER ( ATMAX = 1.8D+0 )
+ PARAMETER ( ATMNM = OME3P0 )
+ PARAMETER ( BTMNM = BUC3P0 )
+ PARAMETER ( ATMXA = 1.D+00 )
+ PARAMETER ( THMX0 = 5.D+00 )
+ PARAMETER ( THMXH = 8.D+00 * ( THMX0 * THMX0 - 2.D+00 ) )
+ PARAMETER ( TMSDFL = 20.D+00 * OME5P0 / ATMNM )
+*
+ PARAMETER ( DLTBLC = -0.4319456220014430D+00 )
+ LOGICAL LESNSC, LESNTH, LHSNSC, LHSNTH, LEXMCS, LHXMCS, LEPLGN,
+ & LHPLGN, LDOMRN, LEOCRR, LACLRG
+*
+ COMMON / USPLC / BUCINT ( 0:NBUCIN ), SINDOM ( 0:NBUCIN ),
+ & TAU1NT ( 0:NBUCIN ), TAU2NT ( 0:NBUCIN ),
+ & TAU3NT ( 0:NBUCIN ), P0UINT ( 0:NBUCIN ),
+ & P1UINT ( 0:NBUCIN ), P2UINT ( 0:NBUCIN ),
+ & ETRNCR ( 0:NCORIN ), DBLC, DBLCI, BLCMAX,
+ & OMEMNM, TMSOPT, ATMNE , BTMNE , ATMXE , ATMNH ,
+ & BTMNH , ATMXH , JFC0RH, JP1CFL, JP2CFL, JP22CF,
+ & IOPSNS, LDOMRN, LEOCRR, LACLRG, LESNSC, LESNTH,
+ & MESNSC, LHSNSC, LHSNTH, MHSNSC, LEXMCS, LHXMCS,
+ & LEPLGN, LHPLGN
+
--- /dev/null
+*$ CREATE USRBDX.ADD
+*COPY USRBDX
+*
+*=== usrbdx ==========================================================*
+*
+*---------------------------------------------------------------------*
+* Module USRBDX: *
+* A. Ferrari : user defined boundary crossing scoring *
+* Last change A. Ferrari 16-may-1990 *
+* *
+* *
+* Up to MXUSBX user defined bdrx are allowed *
+* lusbdx = logical flag, .true. if at least 1 user defined *
+* bdrx is used *
+* nusrbx = number of user defined bdrx used *
+* itusbx = type of binning: 1 = linear energy, linear angle*
+* 2 = linear energy, logarithmic angle, -1 = loga-*
+* rithmic energy, linear angle, -2 = logarithmic *
+* energy, logarithmic angle *
+* idusbx = distribution to be scored: the usual values are *
+* allowed *
+* nr1usx = first region *
+* nr2usx = second region *
+* ausbdx = area (cm**2) of the detector *
+* lwusbx = one way if false, two ways if true *
+* lfusbx = current if false, fluence if true *
+* llnusx = no low energy neutron scoring if false, yes if *
+* true *
+* titusx = bdrx name *
+* ipusbx = logical unit to print the results on: formatted *
+* if > 0, unformatted if < 0 *
+* igmusx = maximum low energy neutron group to be scored *
+* kbusbx = initial location in blank common of the consi- *
+* dered bdrx (real*8 address) *
+* I T I S F O R A D D R E S S OF 1 !!!!! *
+* nebxbn = number of energy intervals *
+* nabxbn = number of angular intervals *
+* ebxlow/ebxhgh = minimum and maximum energies *
+* abxlow/abxhgh = minimum and maximum angle (steradian) *
+* debxbn = energy bin width *
+* dabxbn = angular (steradian) bin width *
+* *
+*---------------------------------------------------------------------*
+*
+ PARAMETER ( MXUSBX = 1100 )
+ LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
+ CHARACTER*10 TITUSX
+ COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
+ & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
+ & AUSBDX(MXUSBX),
+ & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
+ & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
+ & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
+ & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
+ & NUSRBX, LUSBDX
+ COMMON /USXCH/ TITUSX(MXUSBX)
+
--- /dev/null
+*$ CREATE USRBIN.ADD
+*COPY USRBIN
+*
+*=== usrbin ==========================================================*
+*
+*---------------------------------------------------------------------*
+* Module USRBIN: *
+* A. Ferrari & A. Fasso': user defined binnings *
+* *
+* Last change A. Ferrari 12-mar-2000 *
+* *
+* *
+* Up to MXUSBN user defined binnings are allowed *
+* lusbin = logical flag, .true. if at least 1 user defined *
+* binning is used *
+* lusevt = logical flag, .true. if at least 1 user defined *
+* binning event by event is used *
+* lustkb = logical flag, .true. if at least 1 user defined *
+* track-length binning is used. Track length bin- *
+* ning are recognized as binnings where accurate *
+* deposition along the track is requested but *
+* for generalized particles other than 208/211 *
+* nusrbn = number of user defined binnings used *
+* itusbn = type of binning: 0 = cartesian, .ne. 0 = RZ *
+* idusbn = distribution to be scored: the usual values are *
+* allowed. *
+* titusb = binning name *
+* ipusbn = logical unit to print the results on: formatted *
+* if > 0, unformatted if < 0 *
+* kbusbn = initial location in blank common of the consi- *
+* dered binning (for index 1, real*8 address for *
+* lsngbn = .false., real*4 address for lsngbn *
+* = .true.) *
+* nxbin = number of x (r for RZ) intervals *
+* nybin = number of y (1 for RZ) intervals *
+* nzbin = number of z intervals *
+* xlow/high = minimum and maximum x (r for R-Phi-Z) *
+* ylow/high = minimum and maximum y (phi for R-Phi-Z) *
+* zlow/high = minimum and maximum z *
+* dxusbn = x (r) bin width *
+* dyusbn = y bin width *
+* dzusbn = z bin width *
+* tcusbn = time cut-off (seconds) for this binning *
+* bkusbn = 1st Birk's law parameter for this binning *
+* (meaningful only for energy scoring) *
+* b2usbn = 2nd Birk's law parameter for this binning *
+* (meaningful only for energy scoring) *
+* xaxusb = x-axis offset for R-Z binning (not possible for *
+* R-Phi-Z), just for back-compatibility, now it *
+* should be done through rototraslations *
+* yaxusb = y-axis offset for R-Z binning (not possible for *
+* R-Phi-Z), just for back-compatibility, now it *
+* should be done through rototraslations *
+* levtbn = logical flag for binning to be printed at the *
+* end of each event only *
+* lntzer = logical flag for printing only non zero cells *
+* ltrkbn = logical flag for flagging track-length binnings *
+* lsngbn = logical flag for single precision storing of *
+* data *
+* lrmabn = logical flag for reduced memory allocation of *
+* data *
+* narmbn = number of allocated cells for reduced memory *
+* allocation binnings *
+* nusdbn = number of used cells for reduced memory alloca- *
+* tion binnings *
+* kausbn = initial location in blank common of cell indeces*
+* for a reduced memory allocation binning (for *
+* index 1, integer*4 address) *
+* krtnbn = flag of a possible pre-defined rotation (if >0) *
+* to be applied to the binnings before scoring *
+* *
+*---------------------------------------------------------------------*
+*
+ PARAMETER ( MXUSBN = 100 )
+ LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN, LSNGBN,
+ & LRMABN
+ CHARACTER*10 TITUSB
+ COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
+ & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
+ & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
+ & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
+ & XAXUSB(MXUSBN), YAXUSB(MXUSBN),
+ & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
+ & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
+ & KAUSBN(MXUSBN), IPUSBN(MXUSBN), KRTNBN(MXUSBN),
+ & NARMBN(MXUSBN), NUSDBN(MXUSBN), LEVTBN(MXUSBN),
+ & LNTZER(MXUSBN), LSNGBN(MXUSBN), LTRKBN(MXUSBN),
+ & LRMABN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
+ COMMON /USRCH/ TITUSB(MXUSBN)
+
--- /dev/null
+*$ CREATE USRSNC.ADD
+*COPY USRSNC
+*
+*=== usrsnc ==========================================================*
+*
+*---------------------------------------------------------------------*
+* Module usrsnc: *
+* A. Ferrari : user defined residual nuclei scoring *
+* estimators *
+* Last change A. Ferrari 22-jul-1994 *
+* *
+* *
+* Up to MXRSNC user defined track or coll are allowed *
+* lursnc = logical flag, .true. if at least 1 user defined *
+* residual nuclei scoring is activated *
+* nursnc = number of residual nuclei scoring *
+* izrhgh = maximum Z of the scoring (minimum Z: 1) *
+* imrhgh = maximum M=N-Z-NMZ_min of the scoring *
+* (minimum M: 1), please note: *
+* N-Z = M + NMZ_min, N = M + Z + NMZ_min *
+* itursn = type of binning: 1 = spallation products, *
+* 2 = low energy neutrons products, *
+* 3 = all products *
+* nrursn = region *
+* vursnc = volume (cm**3) of the detector *
+* tiursn = scoring name *
+* ipursn = logical unit to print the results on: formatted *
+* if > 0, unformatted if < 0 *
+* kbursn = initial location in blank common of the consi- *
+* dered residual nuclei scoring (real*8 address) *
+* I T I S F O R A D D R E S S OF 0 !!!!! *
+* *
+*---------------------------------------------------------------------*
+*
+ PARAMETER ( MXRSNC = 400 )
+ PARAMETER ( NMZMIN = -5 )
+ LOGICAL LURSNC
+ CHARACTER*10 TIURSN
+ COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
+ & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
+ & IPURSN(MXRSNC), NURSNC, LURSNC
+ COMMON /USRSCH/ TIURSN(MXRSNC)
+
--- /dev/null
+*$ CREATE USRTRC.ADD
+*COPY USRTRC
+*
+*=== usrtrc ==========================================================*
+*
+*---------------------------------------------------------------------*
+* Module usrtrc: *
+* A. Ferrari : user defined track-length & collision density *
+* estimators *
+* Last change A. Ferrari 16-jan-1991 *
+* *
+* *
+* Up to MXUSTC user defined track or coll are allowed *
+* lusrtc = logical flag, .true. if at least 1 user defined *
+* track or coll is used *
+* lustrk = logical flag, .true. if at least 1 user defined *
+* track is used *
+* luscll = logical flag, .true. if at least 1 user defined *
+* coll is used *
+* nusrtc = number of user defined track & coll used *
+* nustrk = number of user defined track used *
+* nuscll = number of user defined coll used *
+* iustrk = list of track-length estimators *
+* iuscll = list of collision density track estimators *
+* 2 = linear energy, coll, -1 = logarithmic ener- *
+* gy, track, -2 = logarithmic energy, coll *
+* itustc = type of binning: 1 = linear energy, track *
+* 2 = linear energy, coll, -1 = logarithmic ener- *
+* gy, track, -2 = logarithmic energy, coll *
+* idustc = distribution to be scored: the usual values are *
+* allowed *
+* nrustc = region *
+* vusrtc = volume (cm**3) of the detector *
+* llnutc = no low energy neutron scoring if false, yes if *
+* true *
+* titutc = track or coll name *
+* ipustc = logical unit to print the results on: formatted *
+* if > 0, unformatted if < 0 *
+* igmutc = maximum low energy neutron group to be scored *
+* kbustc = initial location in blank common of the consi- *
+* dered track or coll (real*8 address) *
+* I T I S F O R A D D R E S S OF 1 !!!!! *
+* netcbn = number of energy intervals *
+* etclow/etchgh = minimum and maximum energies *
+* detcbn = energy bin width *
+* *
+*---------------------------------------------------------------------*
+*
+ PARAMETER ( MXUSTC = 400 )
+ LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
+ CHARACTER*10 TITUTC
+ COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
+ & VUSRTC(MXUSTC),
+ & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
+ & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
+ & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
+ & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
+ & LUSTRK, LUSCLL
+ COMMON /USTCH/ TITUTC(MXUSTC)
+
--- /dev/null
+*$ CREATE USRYLD.ADD
+*COPY USRYLD
+*
+*=== usryld ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Module usryld: *
+* *
+* A. Ferrari : user defined particle yield scoring *
+* *
+* Last change A. Ferrari 14-nov-1996 *
+* *
+* *
+* Up to MXUSYL user defined track or coll are allowed *
+* lusryl = logical flag, .true. if at least 1 user defined *
+* yield estimator is used *
+* lscuyl = logical flag, .true. if at least 1 user defined *
+* yield estimator for secondaries coming out from *
+* hadronic inelastic interactions (nr1=-1, nr2=-2) *
+* is used *
+* nusryl = number of user defined yeld estimators *
+* itusyl = type of binning: itusyl = ie + ia*100 *
+* |ie| = 1 : kinetic energy binning *
+* |ie| = 2 : total momentum binning *
+* |ie| = 3 : lab. rapidity binning *
+* |ie| = 4 : cms rapidity binning *
+* |ie| = 5 : lab. pseudorap. binning *
+* |ie| = 6 : cms pseudorap. binning *
+* |ie| = 7 : lab. x binning *
+* |ie| = 8 : cms Feynmann x binning *
+* |ie| = 9 : transverse mom. binning *
+* |ie| =10 : transverse mass binning *
+* |ie| =11 : lab. long. mom. binning *
+* |ie| =12 : cms long. mom. binning *
+* |ie| =13 : total energy binning *
+* |ie| =14 : lab. angle binning *
+* |ie| =15 : cms angle binning *
+* |ie| =16 : p_t squared binning *
+* |ie| =17 : lab. angle binning *
+* with 1/2pi sin(theta) weight *
+* |ie| =18 : p_t binning *
+* with 1/(2pi p_t) weight *
+* |ie| =19 : frac. lab mom. binning *
+* |ie| =20 : trans. kin. en. binning *
+* |ie| =21 : excitation en. binning *
+* ie > 0 --> linear, ie < 0 --> logarithmic *
+* ia has the same meaning but for the 2nd variable *
+* ixusyl = cross section kind, ixa + ixm * 100 *
+* ixa = 1 : plain d2 sigma / d x1 d x2 where x1,x2 *
+* are the first and second variables *
+* ixa = 2 : invariant cross section E d3 sigma/dp3 *
+* ixa = 3 : plain d2 N / d x1 d x2 where x1,x2 are *
+* the first and second variables *
+* ixa = 4 : d2 (x2 N) / d x1 d x2 where x1,x2 are *
+* the first and second variables *
+* ixa = 5 : d2 (x1 N) / d x1 d x2 where x1,x2 are *
+* the first and second variables *
+* ixa = 6 : d2 N / d x1 d x2 cos(theta) where x1,x2*
+* are the first and second variables, *
+* and theta is the angle with the normal *
+* to the crossed surface *
+* ixm = material number for cross section *
+* calculation *
+* idusyl = distribution to be scored: the usual values are *
+* allowed *
+* nr1uyl = 1st region (from...) *
+* nr2uyl = 2nd region (to ...) *
+* usnryl = normalization factor (itusyl dependent) *
+* sgusyl = normalization cross section (itusyl dependent) *
+* llnuyl = no low energy neutron scoring if false, yes if *
+* true *
+* tituyl = yield estimator name *
+* ipusyl = logical unit to print the results on: formatted *
+* if > 0, unformatted if < 0 *
+* igmuyl = maximum low energy neutron group to be scored *
+* kbusyl = initial location in blank common of the consi- *
+* dered yield estimator (real*8 address) *
+* I T I S F O R A D D R E S S OF 1 !!!!! *
+* neylbn = number of energy or other quantity intervals *
+* eyllow/eylhgh = minimum and maximum energies (or other) *
+* ayllow/aylhgh = minimum and maximum angles (or other) *
+* deylbn = energy (or other) bin width *
+* pusryl = momentum of projectile to be used to define *
+* (possible) Lorentz transformations, Feynmann X *
+* etc. *
+* ijusyl = projectile identity *
+* jtusyl = target identity *
+* u,v,wusryl = laboratory projectile direction *
+* u,v,wcmuyl = cms projectile direction *
+* etx,ety,etzuyl = eta for Lorentz transformation *
+* gamuyl = gamma for Lorentz transformation *
+* sqsuyl = cms energy for Lorentz transformation *
+* iausyl,ieusyl = ausiliary arrays where itusyl is decoded *
+* *
+*----------------------------------------------------------------------*
+*
+ PARAMETER ( MXUSYL = 1000 )
+ LOGICAL LUSRYL, LLNUYL, LSCUYL
+ CHARACTER*10 TITUYL
+ COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
+ & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
+ & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
+ & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
+ & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
+ & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
+ & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
+ & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
+ & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
+ & NUSRYL, LUSRYL, LSCUYL
+ COMMON /USYCH/ TITUYL(MXUSYL)
+
--- /dev/null
+*$ CREATE WWINDW.ADD
+*COPY WWINDW
+*
+*=== wwindw ===========================================================*
+*
+*
+*----------------------------------------------------------------------*
+* *
+* region dependent Weight WINDoW parameters: *
+* *
+* Created on 02 march 1992 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 10-jul-92 by Alfredo Ferrari *
+* *
+* Included in: *
+* *
+* BDNOPT *
+* BLNSET *
+* ELECTR *
+* FLUKA *
+* KASKAD *
+* KASNEU *
+* PHOTON *
+* PROLOG *
+* ZEROIN *
+* *
+* Description of the variables: *
+* *
+* Ethww1(j) = kinetic energy threshold for particle j *
+* *
+* Ethww2(j) = kinetic energy threshold for particle j below *
+* which the asymptotic value of the weight *
+* window is assumed *
+* *
+* Wwexwd(j) = Initial extra width of the the weight window *
+* at Ethww1, if Ethww1 > Ethww2 *
+* *
+* Extwwn(j) = Multiplication factor for particle j for the *
+* weight window: bot and top levels are multi- *
+* plied by this factor *
+* *
+* Iwlbgn = starting location in blank common for the *
+* lower limits of region dependent weight windows*
+* (it is for 0 index, real numeration, that is *
+* R*(4xKalgnm) numeration ) *
+* *
+* Iwhbgn = starting location in blank common for the *
+* upper limits of region dependent weight windows*
+* (it is for 0 index, real numeration, that is *
+* R*(4xKalgnm) numeration ) *
+* *
+* Iwmbgn = starting location in blank common for the mul- *
+* tiplicative factor of region dependent weight *
+* windows *
+* (it is for 0 index, real numeration, that is *
+* R*(4xKalgnm) numeration ) *
+* *
+* Lwwndw = logical flag for setting on weight windows *
+* *
+* Lwwprm = logical flag for setting on weight windows *
+* for primary particles *
+* *
+* Note: if the weight window for region i is given by [RR,SP], *
+* with multiplicative threshold factor FM, a particle *
+* j with energy ekin and weight W will undergo: *
+* - no RR and no splitting if Eke >= FM * Ethww1 (j) *
+* - RR with survival probability given by W / FR, if *
+* W < FR = RR + RR * ( 1 / Wwexwd (j) - 1 ) *
+* x ( Ekin / FM - Ethww2 (j) ) / *
+* ( Ethww1 (j) - Ethww2 (j) ), *
+* for FM * Ethww1 (j) > Ekin > FM * Ethww2 (j) *
+* Note that FR < RR *
+* - Splitting if *
+* W > FS = SP + SP * ( Wwexwd (j) - 1 ) *
+* x ( Ekin / FM - Ethww2 (j) ) / *
+* ( Ethww1 (j) - Ethww2 (j) ), *
+* for FM * Ethww1 (j) > Ekin > FM * Ethww2 (j) *
+* Note that FS < SP *
+* - RR with survival probability given by W / RR *
+* for W < RR, Ekin < FM * Ethww2 (j) *
+* - Splitting for W > SP, Ekin < FM * Ethww2 (j) *
+* *
+*----------------------------------------------------------------------*
+*
+* Maximum number of consecutive splitting operations:
+ PARAMETER ( MXWWSP = 3 )
+* Multiplicative threshold to allow for consecutive splitting
+* operations:
+ PARAMETER ( WWSPMX = 50.D+00 )
+ LOGICAL LWWNDW, LWWPRM
+ COMMON / WWINDW / ETHWW1 (-6:NALLWP), ETHWW2 (-6:NALLWP),
+ & WWEXWD (-6:NALLWP), EXTWWN (-6:NALLWP),
+ & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
+
--- /dev/null
+*$ CREATE XSEPAR.ADD
+*COPY XSEPAR
+*
+*=== xsepar ===========================================================*
+*
+*----------------------------------------------------------------------*
+* *
+* Xsec Parameters for neutrons and protons: *
+* *
+* Created on 20 september 1991 by Alfredo Ferrari & Paola Sala *
+* Infn - Milan *
+* *
+* Last change on 03-jul-96 by Alfredo Ferrari *
+* *
+* Included in the following routines: *
+* *
+* BERRTP *
+* XSENEU *
+* XSEPRO *
+* XSINEU *
+* XSIPRO *
+* PREPRE *
+* *
+*----------------------------------------------------------------------*
+*
+* Deuteron atomic weight:
+ PARAMETER ( ATMDEU = ( AMDEUT + AMELCT - 13.6D-09 ) / AMUGEV )
+ COMMON / XSEPAR / AANXSE (100), BBNXSE (100), CCNXSE (100),
+ & DDNXSE (100), EENXSE (100), ZZNXSE (100),
+ & EMNXSE (100), XMNXSE (100),
+ & AAPXSE (100), BBPXSE (100), CCPXSE (100),
+ & DDPXSE (100), EEPXSE (100), FFPXSE (100),
+ & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
+
--- /dev/null
+**********************************************************************
+* Pb - Pb , sqrt(s)=14TeV*Z/A (LHC)
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR 197.0 79.0
+TARPAR 197.0 79.0
+*
+* energy of interaction
+* ---------------------
+* CMENERGY 5546.0
+BEAM -100.0 -100.0 100.0 0.0
+CENTRAL -1. 0.0 3.0
+*
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 100.0 0.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+**********************************************************************
+* Ca - Ca , sqrt(s)=14TeV*Z/A (LHC)
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR 40.0 20.0
+TARPAR 40.0 20.0
+*
+* energy of interaction
+* ---------------------
+* CMENERGY 7000.0
+BEAM -7000.0 -7000.0 100.0 0.0
+*
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 20000.0 0.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+**********************************************************************
+* Pb - Pb , sqrt(s)=14TeV*Z/A (LHC)
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR 208.0 82.0
+TARPAR 208.0 82.0
+*
+* energy of interaction
+* ---------------------
+CMENERGY 5500.
+BEAM 2750.0 2750.0 200.0 0.0
+*CENTRAL -1. 0.0 3.0
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+*HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 1.0 3.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+**********************************************************************
+* Example for a DTUNUC input file.
+* Uncomment the input-cards according to your requirements.
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR PROTON
+TARPAR 12.0 6.0
+*
+* energy of interaction
+* ---------------------
+ENERGY 920.0
+*
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 50000.0 0.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+**********************************************************************
+* Example for a DTUNUC input file.
+* Uncomment the input-cards according to your requirements.
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR PROTON
+TARPAR 184.0 74.0
+*
+* energy of interaction
+* ---------------------
+ENERGY 920.0
+*
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 10000.0 0.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+**********************************************************************
+* p - p , sqrt(s)=14TeV (LHC)
+*
+* Format: A10,6E10.0,A8
+* (except for the section enclosed by "PHOINPUT" and "ENDINPUT"
+* which is format-free)
+* lines starting with "*" are comment lines
+**********************************************************************
+*
+* projectile / target
+* -------------------
+PROJPAR PROTON
+TARPAR PROTON
+*
+* energy of interaction
+* ---------------------
+* CMENERGY 14000.0
+BEAM 7000.0 7000.0 200.0 0.0
+*
+* PHOJET-specific input
+* ---------------------
+* The following lines control the event-generation with PHOJET for
+* individual photon/nucleon-nucleon collisions.
+* For details see the PHOJET-manual available at
+* http://lepton.bartol.udel.edu/~eng/phojet.html
+* Any options explained in the PHOJET-manual can be used in between
+* the "PHOINPUT" and "ENDINPUT" cards.
+PHOINPUT
+PROCESS 1 0 1 1 1 1 1 1
+ENDINPUT
+*
+* Output
+* ------
+* some default output (particle multiplicities etc.)
+HISTOGRAM 101.0 102.0
+*
+* Start of event generation
+* -------------------------
+START 10000.0 0.0
+STOP
+*...+....1....+....2....+....3....+....4....+....5....+....6....+....7...
--- /dev/null
+FSRCS:= \
+dpmjet3.0-4.f \
+phojet1.12-35c.f \
+pythia6115.f \
+user3.0-4.f
+
+EINCLUDE:=$(ALICE_ROOT)/DPMJET/flukapro
+SHLIB += -L $(ALICE_ROOT)/DPMJET -lflukahp
+PACKFFLAGS:= -fno-second-underscore -malign-double
--- /dev/null
+C***********************************************************************
+C
+C
+C
+C PHOJET version 1.12
+C -------------------
+C
+C
+C ($Revision$, $Date$)
+C
+C
+C Authors: Ralph Engel
+C (eng@lepton.bartol.udel.edu)
+C
+C Johannes Ranft
+C (johannes.ranft@cern.ch)
+C
+C Stefan Roesler
+C (sroesler@SLAC.Stanford.EDU)
+C
+C
+C For the latest version and documentation check
+C http://lepton.bartol.udel.edu/~eng/phojet.html
+C
+C
+C Bug reports, questions, complaints are welcome
+C (please send a mail to eng@lepton.bartol.udel).
+C
+C
+C Note that the code is available with several interfaces to
+C Lund fragmentation programs (JETSET7.x, 1.x and a double
+C precision JETSET version). This file is the code with
+C
+
+C interface to PYTHIA 6.1 (or higher)
+
+C for usage in DPMJET 3.x (Lund common block dimensions increased)
+
+C
+C***********************************************************************
+C
+C
+C List of subroutines and functions
+C ---------------------------------
+C
+C
+C main event simulation routines
+C
+C PHO_EVENT
+C PHO_PARTON
+C PHO_POSPOM
+C
+C PHO_STDPAR
+C PHO_POMSCA
+C
+C
+C user steering interface
+C
+C PHO_SETMDL
+C PHO_PRESEL
+C
+C
+C experimental setup / photon flux calculation
+C
+C PHO_FIXLAB
+C PHO_FIXCOL
+C PHO_GPHERA
+C PHO_GGEPEM
+C PHO_WGEPEM
+C PHO_GGBLSR
+C PHO_GGBEAM
+C PHO_GGHIOF
+C PHO_GGHIOG
+C PHO_GGFLCL
+C PHO_GGFLCR
+C PHO_GGFAUX
+C PHO_GGFNUC
+C PHO_GHHIOF
+C PHO_GHHIAS
+C
+C
+C initialization
+C
+C PHO_INIT
+C PHO_DATINI
+C PHO_PARDAT
+C PHO_MCINI
+C
+C PHO_EVEINI
+C
+C PHO_HARINI
+C PHO_FRAINI
+C
+C PHO_FITPAR
+C
+C
+C cross section calculation
+C
+C PHO_CSINT
+C
+C PHO_XSECT
+C PHO_BORNCS
+C PHO_HARXTO
+C
+C PHO_DSIGDT
+C
+C PHO_TRIREG
+C PHO_LOOREG
+C PHO_TRXPOM
+C
+C PHO_EIKON
+C PHO_CHAN2A
+C
+C PHO_SCALES
+C
+C
+C multiple interaction structure
+C
+C PHO_IMPAMP
+C PHO_PRBDIS
+C PHO_SAMPRO
+C PHO_SAMPRB
+C
+C
+C hadron / photon remnant treatment, soft x selection
+C
+C PHO_HARREM
+C PHO_PARREM
+C
+C PHO_HADSP2
+C PHO_HADSP3
+C PHO_SOFTXX
+C PHO_SELSXR
+C PHO_SELSX2
+C PHO_SELSXS
+C PHO_SELSXI
+C
+C PHO_VALFLA
+C PHO_REGFLA
+C PHO_SEAFLA
+C PHO_FLAUX
+C PHO_BETAF
+C IPHO_DIQU
+C
+C
+C primordial kt and soft parton pt
+C
+C PHO_PRIMKT
+C PHO_PARTPT
+C PHO_SOFTPT
+C PHO_SELPT
+C
+C PHO_CONN0
+C PHO_CONN1
+C
+C
+C simulation of hard scattering, initial state radiation
+C
+C PHO_HARCOL
+C PHO_SELCOL
+C PHO_HARCOR
+C
+C PHO_HARDIR
+C PHO_HARX12
+C PHO_HARDX1
+C PHO_HARKIN
+C PHO_HARWGH
+C PHO_HARSCA
+C PHO_HARFAC
+C PHO_HARWGX
+C PHO_HARWGI
+C PHO_HARINT
+C PHO_HARMCI
+C
+C PHO_HARXR3
+C PHO_HARXR2
+C PHO_HARXD2
+C PHO_HARXPT
+C PHO_HARISR
+C PHO_HARZSP
+C
+C PHO_PTCUT
+C PHO_ALPHAE
+C PHO_ALPHAS
+C
+C
+C diffraction dissociation
+C
+C PHO_DIFDIS
+C PHO_DIFPRO
+C PHO_DIFPAR
+C PHO_QELAST
+C PHO_CDIFF
+C PHO_DFWRAP
+C
+C PHO_SAMASS
+C PHO_DSIGDM
+C PHO_DFMASS
+C
+C PHO_SDECAY
+C PHO_SDECY2
+C PHO_SDECY3
+C
+C PHO_DIFSLP
+C PHO_DIFKIN
+C PHO_VECRES
+C PHO_DIFRES
+C
+C PHO_REGPAR
+C
+C PHO_PECMS
+C PHO_SETPAR
+C
+C
+C fragmentation, treatment of low-mass strings
+C
+C PHO_STRING
+C PHO_STRFRA
+C
+C PHO_ID2STR
+C PHO_MCHECK
+C PHO_POMCOR
+C PHO_MASCOR
+C PHO_PARCOR
+C
+C PHO_GLU2QU
+C PHO_GLUSPL
+C
+C PHO_DQMASS
+C PHO_BAMASS
+C PHO_MEMASS
+C
+C
+C particle code tables, particle numbering conversion
+C
+C PHO_PNAME
+C PHO_PMASS
+C IPHO_CHR3
+C IPHO_BAR3
+C
+C IPHO_ANTI
+C
+C IPHO_PDG2ID
+C IPHO_ID2PDG
+C IPHO_LU2PDG
+C IPHO_PDG2LU
+C
+C IPHO_CNV1
+C PHO_HACODE
+C
+C
+C
+C Lorentz transformations, rotations and mass adjustment
+C
+C PHO_ALTRA
+C PHO_LTRANS
+C PHO_TRANS
+C PHO_TRANI
+C
+C PHO_MKSLTR
+C PHO_GETLTR
+C
+C PHO_LTRHEP
+C
+C PHO_MSHELL
+C PHO_MASSAD
+C
+C
+C program debugging and internal cross-checks
+C
+C PHO_PREVNT
+C PHO_PRSTRG
+C PHO_CHECK
+C
+C PHO_TRACE
+C
+C PHO_REJSTA
+C
+C PHO_ABORT
+C
+C
+C cross section fitting
+C
+C PHO_FITMAI
+C PHO_FITINP
+C PHO_FITDAT
+C PHO_FITOUT
+C PHO_FITAMP
+C PHO_FITTST
+C PHO_FITMSQ
+C PHO_FITVD1
+C PHO_FITCN1
+C PHO_FITINI
+C
+C
+C cross section parametrizations
+C
+C PHO_HADCSL
+C PHO_ALLM97
+C PHO_CSDIFF
+C
+
+C
+C random numbers
+C
+
+C DPMJET random number generator DT_RNDM used
+
+C
+C PHO_SFECFE
+C PHO_RNDBET
+C PHO_RNDGAM
+C
+C
+C auxiliary routines / numerical methods
+C
+C PHO_GAUSET
+C PHO_GAUDAT
+C
+C pho_samp1d
+C
+C PHO_DZEROX
+C PHO_EXPINT
+C PHO_BESSJ0
+C PHO_BESSI0
+C pho_ExpBessI0
+C PHO_BESSI1
+C PHO_BESSK0
+C PHO_BESSK1
+C
+C PHO_XLAM
+C
+C PHO_SWAPD
+C PHO_SWAPI
+C
+C
+C parton density parametrization management / interface
+C
+C PHO_PDF
+C
+C PHO_SETPDF
+C PHO_GETPDF
+C PHO_ACTPDF
+C
+C PHO_QPMPDF
+C
+C PHO_PDFTST
+C
+C
+C parton density parametrizations from other authors
+C
+C PHO_DOR98LO
+C PHO_DOR98SC
+C PHO_DOR94LO
+C PHO_DOR94HO
+C PHO_DOR94DI
+C PHO_DOR92LO
+C PHO_DOR92HO
+C PHO_DORPLO
+C PHO_DORPHO
+C PHO_DORGLO
+C PHO_DORGHO
+C PHO_DORGH0
+C PHO_DOR94FV
+C PHO_DOR94FW
+C PHO_DOR94FS
+C PHO_DOR92FV
+C PHO_DOR92FW
+C PHO_DOR92FS
+C PHO_DORFVP
+C PHO_DORFGP
+C PHO_DORFQP
+C PHO_DORGF
+C PHO_DORGFS
+C PHO_grsf1
+C PHO_grsf2
+C
+C PHO_CKMTPA
+C PHO_CKMTPD
+C PHO_CKMTPO
+C PHO_CKMTFV
+C
+C PHO_DBFINT
+C
+C PHO_SASGAM
+C PHO_SASVMD
+C PHO_SASANO
+C PHO_SASBEH
+C PHO_SASDIR
+C
+C PHO_PHGAL
+C PHVAL
+C
+C
+C***********************************************************************
+
+CDECK ID>, PHO_INIT
+**sr temporarily changed
+C SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
+ SUBROUTINE PHO_INIT(LINP,IREJ)
+**
+C***********************************************************************
+C
+C main subroutine to configure and manage PHOJET calculations
+C
+C input: LINP input unit to read from
+C -1 to skip reading of input file
+C LOUT output unit to write to
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+
+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 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 integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+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)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER KCHG
+ DOUBLE PRECISION PMAS,PARF,VCKM
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+ INTEGER PYCOMP
+
+ DIMENSION ITMP(0:11)
+ CHARACTER*10 CNAME
+ CHARACTER*70 NUMBER,FILENA
+
+ 14 FORMAT(A10,A69)
+ 15 FORMAT(A12)
+
+C define input/output units
+ IF(LINP.GE.0) THEN
+ LI = LINP
+ ELSE
+ LI = 5
+ ENDIF
+**sr temporarily changed
+C LO = LOUT
+ LO = 6
+**
+
+ IREJ = 0
+
+ WRITE(LO,*)
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' '
+ WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
+ WRITE(LO,*) ' '
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' Authors: Ralph Engel (Bartol Res. Inst.)'
+ WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
+ WRITE(LO,*) ' Stefan Roesler (SLAC)'
+ WRITE(LO,*) ' ---------------------------------------------------'
+ WRITE(LO,*) ' Manual, updates, and further information:'
+ WRITE(LO,*) ' http://lepton.bartol.udel.edu/~eng/phojet.html'
+ WRITE(LO,*) ' ---------------------------------------------------'
+ WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
+ WRITE(LO,*) ' eng@lepton.bartol.udel.edu'
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*) ' $Date$'
+ WRITE(LO,*) ' $Revision$'
+
+ WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
+
+ WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
+
+ WRITE(LO,*) ' ==================================================='
+ WRITE(LO,*)
+
+C standard initializations
+ CALL PHO_DATINI
+ CALL PHO_PARDAT
+ DUM = PHO_PMASS(0,-1)
+
+C initialize standard PDFs
+C proton
+ CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
+ CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
+C neutron
+ CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
+ CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
+C photon
+ CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
+C pomeron
+ CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
+C pions
+ CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
+C kaons
+ CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
+ CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
+
+C nothing to be done
+ IF(LINP.LT.0) RETURN
+
+C main loop to read input cards
+ 1200 CONTINUE
+ READ(LINP,14,END=1300) CNAME,NUMBER
+ IF(CNAME.EQ.'ENDINPUT ') THEN
+ GOTO 1300
+ ELSE IF(CNAME.EQ.'STOP ') THEN
+ WRITE(LO,*) 'STOP'
+ STOP
+ ELSE IF(CNAME.EQ.'COMMENT ') THEN
+ WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
+ ELSE IF(CNAME(1:1).EQ.'*') THEN
+ WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
+ ELSE IF(CNAME.EQ.'PTCUT ') THEN
+ READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
+ WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
+ & PARMDL(38),PARMDL(39)
+ ELSE IF(CNAME.EQ.'PROCESS ') THEN
+ READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
+ WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
+ ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
+ READ(NUMBER,*) (ITMP(KK),KK=0,11)
+ WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
+ DO 112 KK=1,8
+ IPRON(KK,ITMP(0)) = ITMP(KK)
+ 112 CONTINUE
+ ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
+ READ(NUMBER,*) IMPRO,IP,ION
+ WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
+ MH_pro_on(IMPRO,IP) = ION
+ ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
+ READ(NUMBER,*) IDPDG,PVIR
+ IHFLS(1) = 1
+ XPSUB = 1.D0
+ CALL PHO_SETPAR(1,IDPDG,0,PVIR)
+ WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
+ ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
+ READ(NUMBER,*) IDPDG,PVIR
+ IHFLS(2) = 1
+ XTSUB = 1.D0
+ CALL PHO_SETPAR(2,IDPDG,0,PVIR)
+ WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
+ ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
+ READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
+ IHFLS(1) = IVAL
+ IHFLD(1,1) = IFL1
+ IHFLD(1,2) = IFL2
+ XPSUB = XSUB
+ PVIR = 0.D0
+ CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
+ WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
+ ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
+ READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
+ IHFLS(2) = IVAL
+ IHFLD(2,1) = IFL1
+ IHFLD(2,2) = IFL2
+ XTSUB = XSUB
+ PVIR = 0.D0
+ CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
+ WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
+ ELSE IF(CNAME.EQ.'PDF ') THEN
+ READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
+ WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
+ CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
+ ELSE IF(CNAME.EQ.'SETMODEL ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'SETMODEL ',I,IVAL
+ CALL PHO_SETMDL(I,IVAL,1)
+ ELSE IF(CNAME.EQ.'SETPARAM ') THEN
+ READ(NUMBER,*) I,PARNEW
+ WRITE(LO,*) 'SETPARAM ',I,PARNEW
+ PARMDL(I) = PARNEW
+ ELSE IF(CNAME.EQ.'DEBUG ') THEN
+ READ(NUMBER,*) IDEBF,IDEBN,IDLEV
+ WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
+ CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
+ ELSE IF(CNAME.EQ.'TRACE ') THEN
+ READ(NUMBER,*) IDEBF,IDLEV
+ WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
+ IDEB(IDEBF) = IDLEV
+ ELSE IF(CNAME.EQ.'SETICUT ') THEN
+ READ(NUMBER,*) I,ICUT
+ WRITE(LO,*) 'SETICUT ',I,ICUT
+ ISWCUT(I) = ICUT
+ ELSE IF(CNAME.EQ.'SETFCUT ') THEN
+ READ(NUMBER,*) I,PARNEW
+ WRITE(LO,*) 'SETFCUT ',I,PARNEW
+ HSWCUT(I) = PARNEW
+ ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'LUND-MSTU ',I,IVAL
+ MSTU(I) = IVAL
+ ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
+ READ(NUMBER,*) I,IVAL
+ WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
+ MSTJ(I) = IVAL
+ ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
+ READ(NUMBER,*) I,EE
+ WRITE(LO,*) 'LUND-PARJ ',I,EE
+ PARJ(I) = REAL(EE)
+ ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
+ READ(NUMBER,*) I,EE
+ WRITE(LO,*) 'LUND-PARU ',I,EE
+ PARU(I) = REAL(EE)
+ ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
+ READ(NUMBER,*) ID,ION
+ WRITE(LO,*) 'LUND-DECAY ',ID,ION
+
+ KC=PYCOMP(ID)
+
+ MDCY(KC,1) = ION
+ ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
+ READ(NUMBER,*) PSOMIN
+ WRITE(LO,*) 'PSOFTMIN ',PSOMIN
+ ELSE IF(CNAME.EQ.'INTPREC ') THEN
+ READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+
+C PDF test utility
+ ELSE IF(CNAME.EQ.'PDFTEST ') THEN
+ READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
+ PVIRT2 = ABS(PVIRT2)
+ WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
+ CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
+
+C mass cut on gamma-gamma or gamma-hadron system
+ ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
+ READ(NUMBER,*) ECMIN,ECMAX
+ WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
+
+C beam lepton (anti-)tagging system
+ ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
+ READ(NUMBER,*) ITAG1,ITAG2
+ WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
+ ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
+ READ(NUMBER,*)
+ & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
+ WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
+ & Q2MIN1,Q2MAX1,THMIN1,THMAX1
+ ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
+ READ(NUMBER,*)
+ & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
+ WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
+ & Q2MIN2,Q2MAX2,THMIN2,THMAX2
+
+C sampling of gamma-p events in ep (HERA)
+ ELSE IF( (CNAME.EQ.'WW-HERA ')
+ & .OR.(CNAME.EQ.'GP-HERA ')) THEN
+ READ(NUMBER,*) EE1,EE2,NEV
+ WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
+ IF(YMAX2.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
+ ELSE
+ CALL PHO_GPHERA(NEV,EE1,EE2)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-gamma events in e+e- (LEP)
+ ELSE IF( (CNAME.EQ.'GG-EPEM ')
+ & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
+ READ(NUMBER,*) EE1,EE2,NEV
+ WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
+ ELSE
+ CALL PHO_GGEPEM(-1,EE1,EE2)
+ CALL PHO_GGEPEM(NEV,EE1,EE2)
+ CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-gamma in heavy-ion collisions
+ ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GGHIOF(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+ ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GGHIOG(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of gamma-hadron events in heavy ion collisions
+ ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
+ READ(NUMBER,*) EE,NA,NZ,NEV
+ WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
+ IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GHHIOF(NEV,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of hadron-gamma events in hadron - heavy ion collisions
+ ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
+ READ(NUMBER,*) EP,EE,NA,NZ,NEV
+ WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
+ IF(YMAX2.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
+ ELSE
+ CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
+ KEVENT = 0
+ ENDIF
+
+C sampling of photoproduction events e+e-, backscattered laser
+ ELSE IF(CNAME.EQ.'BLASER ') THEN
+ READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
+ WRITE(LO,*) 'BLASER ',EE1,EE2,
+ & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
+ CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
+ KEVENT = 0
+
+C sampling of photoproduction events beamstrahlung
+ ELSE IF(CNAME.EQ.'BEAMST ') THEN
+ READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
+ WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
+ IF(YMAX1.LT.0.D0) THEN
+ WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
+ ELSE
+ CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
+ KEVENT = 0
+ ENDIF
+
+C fixed-energy events in LAB system of particle 2
+ ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
+ READ(NUMBER,*) PLAB,NEV
+ WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
+ CALL PHO_FIXLAB(PLAB,NEV)
+ KEVENT = 0
+
+C fixed-energy events in CM system
+ ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
+ READ(NUMBER,*) ECM,NEV
+ WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
+ PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
+ PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
+ CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
+ E1 = EE
+ E2 = ECM-EE
+ THETA = 0.D0
+ PHI = 0.D0
+ CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+ KEVENT = 0
+
+C fixed-energy events for collider setup with crossing angle
+ ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
+ READ(NUMBER,*) E1,E2,THETA,PHI,NEV
+ WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
+ CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+ KEVENT = 0
+
+C unknown data card
+ ELSE
+ WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
+ ENDIF
+
+ GOTO 1200
+ 1300 CONTINUE
+ WRITE(LO,*) ' RETURN'
+
+ END
+
+CDECK ID>, PHO_SETMDL
+ SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
+C**********************************************************************
+C
+C set model switches
+C
+C input: INDX model parameter number
+C (positive: ISWMDL, negative: IPAMDL)
+C IVAL new value
+C IMODE -1 print value of parameter INDX
+C 1 set new value
+C -2 print current settings
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ IF(IMODE.EQ.-2) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
+C & '----------------------------'
+ DO 100 I=1,48,3
+ IF(ISWMDL(I).EQ.-9999) GOTO 200
+ IF(ISWMDL(I+1).EQ.-9999) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
+ GOTO 200
+ ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
+C WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
+C & I+1,':',MDLNA(I+1),ISWMDL(I+1)
+ GOTO 200
+ ELSE
+C WRITE(LO,'(3(5X,I3,A1,A,I6))')
+C & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
+ ENDIF
+ 100 CONTINUE
+ 200 CONTINUE
+ ELSE IF(IMODE.EQ.-1) THEN
+C WRITE(LO,'(1X,A,1X,A,I6)')
+C & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
+ ELSE IF(IMODE.EQ.1) THEN
+ IF(INDX.GT.0) THEN
+ IF(ISWMDL(INDX).NE.IVAL) THEN
+ WRITE(LO,'(1X,A,I4,1X,A,2I6)')
+ & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
+ & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
+ ISWMDL(INDX) = IVAL
+ ENDIF
+ ELSE IF(INDX.LT.0) THEN
+ IF(IPAMDL(-INDX).NE.IVAL) THEN
+ WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
+ & -INDX,IPAMDL(-INDX),IVAL
+ IPAMDL(-INDX) = IVAL
+ ENDIF
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,I6)')
+ & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
+ ENDIF
+ END
+
+CDECK ID>, PHO_DATINI
+ SUBROUTINE PHO_DATINI
+C*********************************************************************
+C
+C initialization of variables and switches
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+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 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 some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+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)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+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 interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+
+C initialize /POCONS/
+ PI = ATAN(1.D0)*4.D0
+ PI2 = 2.D0*PI
+ PI4 = 2.D0*PI2
+C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
+ GEV2MB = 0.389365D0
+C precalculate quark charges
+ do i=1,6
+ Q_ch(i) = dble(2-3*mod(i,2))/3.D0
+ Q_ch(-i) = -Q_ch(i)
+
+ Q_ch2(i) = Q_ch(i)**2
+ Q_ch2(-i) = Q_ch2(i)
+
+ Q_ch4(i) = Q_ch2(i)**2
+ Q_ch4(-i) = Q_ch4(i)
+ enddo
+ Q_ch(0) = 0.D0
+ Q_ch2(0) = 0.D0
+ Q_ch4(0) = 0.D0
+
+C initialize /GLOCMS/
+ ECM = 50.D0
+ PMASS(1) = 0.D0
+ PVIRT(1) = 0.D0
+ PMASS(2) = 0.D0
+ PVIRT(2) = 0.D0
+ IFPAP(1) = 22
+ IFPAP(2) = 22
+C initialize /HADVAL/
+ IHFLD(1,1) = 0
+ IHFLD(1,2) = 0
+ IHFLD(2,1) = 0
+ IHFLD(2,2) = 0
+ IHFLS(1) = 1
+ IHFLS(2) = 1
+C initialize /MODELS/
+ ISWMDL(1) = 3
+ MDLNA(1) = 'AMPL MOD'
+ ISWMDL(2) = 1
+ MDLNA(2) = 'MIN-BIAS'
+ ISWMDL(3) = 1
+ MDLNA(3) = 'PTS DISH'
+ ISWMDL(4) = 1
+ MDLNA(4) = 'PTS DISP'
+ ISWMDL(5) = 2
+ MDLNA(5) = 'PTS ASSI'
+ ISWMDL(6) = 3
+ MDLNA(6) = 'HADRONIZ'
+ ISWMDL(7) = 2
+ MDLNA(7) = 'MASS COR'
+ ISWMDL(8) = 3
+ MDLNA(8) = 'PAR SHOW'
+ ISWMDL(9) = 0
+ MDLNA(9) = 'GLU SPLI'
+ ISWMDL(10) = 2
+ MDLNA(10) = 'VIRT PHO'
+ ISWMDL(11) = 0
+ MDLNA(11) = 'LARGE NC'
+ ISWMDL(12) = 0
+ MDLNA(12) = 'LIPA POM'
+ ISWMDL(13) = 1
+ MDLNA(13) = 'QELAS VM'
+ ISWMDL(14) = 2
+ MDLNA(14) = 'ENHA GRA'
+ ISWMDL(15) = 4
+ MDLNA(15) = 'MULT SCA'
+ ISWMDL(16) = 4
+ MDLNA(16) = 'MULT DIF'
+ ISWMDL(17) = 4
+ MDLNA(17) = 'MULT CDF'
+ ISWMDL(18) = 0
+ MDLNA(18) = 'BALAN PT'
+ ISWMDL(19) = 1
+ MDLNA(19) = 'POMV FLA'
+ ISWMDL(20) = 0
+ MDLNA(20) = 'SEA FLA'
+ ISWMDL(21) = 2
+ MDLNA(21) = 'SPIN DEC'
+ ISWMDL(22) = 1
+ MDLNA(22) = 'DIF.MASS'
+ ISWMDL(23) = 1
+ MDLNA(23) = 'DIFF RES'
+ ISWMDL(24) = 0
+ MDLNA(24) = 'PTS HPOM'
+ ISWMDL(25) = 0
+ MDLNA(25) = 'POM CORR'
+ ISWMDL(26) = 1
+ MDLNA(26) = 'OVERLAP '
+ ISWMDL(27) = 0
+ MDLNA(27) = 'MUL R/AN'
+ ISWMDL(28) = 1
+ MDLNA(28) = 'SUR PROB'
+ ISWMDL(29) = 1
+ MDLNA(29) = 'PRIMO KT'
+ ISWMDL(30) = 0
+ MDLNA(30) = 'DIFF. CS'
+ ISWMDL(31) = -9999
+C mass-independent sea flavour ratios (for low-mass strings)
+ PARMDL(1) = 0.425D0
+ PARMDL(2) = 0.425D0
+ PARMDL(3) = 0.15D0
+ PARMDL(4) = 0.D0
+ PARMDL(5) = 0.D0
+ PARMDL(6) = 0.D0
+C suppression by energy momentum conservation
+ PARMDL(8) = 9.D0
+ PARMDL(9) = 7.D0
+C VDM factors
+ PARMDL(10) = 0.866D0
+ PARMDL(11) = 0.288D0
+ PARMDL(12) = 0.288D0
+ PARMDL(13) = 0.288D0
+ PARMDL(14) = 0.866D0
+ PARMDL(15) = 0.288D0
+ PARMDL(16) = 0.288D0
+ PARMDL(17) = 0.288D0
+ PARMDL(18) = 0.D0
+C lower energy limit for initialization
+ PARMDL(19) = 5.D0
+C soft pt for hard scattering remnants
+ PARMDL(20) = 5.D0
+C low energy beta of soft pt distribution 1
+ PARMDL(21) = 4.5D0
+C high energy beta of soft pt distribution 1
+ PARMDL(22) = 3.0D0
+C low energy beta of soft pt distribution 0
+ PARMDL(23) = 2.5D0
+C high energy beta of soft pt distribution 0
+ PARMDL(24) = 0.4D0
+C effective quark mass in photon wave function
+ PARMDL(25) = 0.2D0
+C normalization of unevolved Pomeron PDFs
+ PARMDL(26) = 0.3D0
+C effective VDM parameters for Q**2 dependence of cross section
+ PARMDL(27) = 0.65D0
+ PARMDL(28) = 0.08D0
+ PARMDL(29) = 0.05D0
+ PARMDL(30) = 0.22D0
+ PARMDL(31) = 0.589824D0
+ PARMDL(32) = 0.609961D0
+ PARMDL(33) = 1.038361D0
+ PARMDL(34) = 1.96D0
+C Q**2 suppression of multiple interactions
+ PARMDL(35) = 0.59D0
+C pt cutoff defaults
+ PARMDL(36) = 2.5D0
+ PARMDL(37) = 2.5D0
+ PARMDL(38) = 2.5D0
+ PARMDL(39) = 2.5D0
+C enhancement factor for diffractive cross sections
+ PARMDL(40) = 1.D0
+ PARMDL(41) = 1.D0
+ PARMDL(42) = 1.D0
+C mass in soft pt distribution
+ PARMDL(43) = 0.D0
+C maximum of x allowed for leading particle
+ PARMDL(44) = 0.9D0
+C max. mass sampled in diffraction
+ PARMDL(45) = sqrt(0.4D0)
+C mass threshold in diffraction (2pi mass)
+ PARMDL(46) = 0.3D0
+C regularization of slope parameter in diffraction
+ PARMDL(47) = 4.D0
+C renormalized intercept for enhanced graphs
+ PARMDL(48) = 1.08D0
+C coherence constraint for diff. cross sections
+ PARMDL(49) = sqrt(0.05D0)
+C exponents of x distributions
+C baryon
+ PARMDL(50) = 1.5D0
+ PARMDL(51) = -0.5D0
+ PARMDL(52) = -0.99D0
+ PARMDL(53) = -0.99D0
+C meson (non-strangeness part)
+ PARMDL(54) = -0.5D0
+ PARMDL(55) = -0.5D0
+ PARMDL(56) = -0.99D0
+ PARMDL(57) = -0.99D0
+C meson (strangeness part)
+ PARMDL(58) = -0.2D0
+ PARMDL(59) = -0.2D0
+ PARMDL(60) = -0.99D0
+ PARMDL(61) = -0.99D0
+C particle remnant (no valence quarks)
+ PARMDL(62) = -0.5D0
+ PARMDL(63) = -0.5D0
+ PARMDL(64) = -0.99D0
+ PARMDL(65) = -0.99D0
+C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
+ PARMDL(66) = 10.D0
+C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
+ PARMDL(67) = 10.D0
+C min. abs(t) in diffraction
+ PARMDL(68) = 0.D0
+C max. abs(t) in diffraction
+ PARMDL(69) = 10.D0
+C min. mass for elastic pomerons in central diffraction
+ PARMDL(70) = 2.D0
+C min. mass of diffractive blob in central diffraction
+ PARMDL(71) = 2.D0
+C min. Feynman x cut in central diffraction
+ PARMDL(72) = 0.D0
+C direct pomeron coupling
+ PARMDL(74) = 0.D0
+C relative deviation allowed for energy-momentum conservation
+C energy-momentum relative deviation
+ PARMDL(75) = 0.01D0
+C transverse momentum deviation
+ PARMDL(76) = 0.01D0
+C couplings for unitarization in diffraction
+C non-unitarized pomeron coupling (sqrt(mb))
+ PARMDL(77) = 3.D0
+C rescaling factor for pomeron PDF
+ PARMDL(78) = 3.D0
+C coupling probabilities
+ PARMDL(79) = 1.D0
+ PARMDL(80) = 0.D0
+C scales to calculate alpha-s of matrix element
+ PARMDL(81) = 1.D0
+ PARMDL(82) = 1.D0
+ PARMDL(83) = 1.D0
+C scales to calculate alpha-s of initial state radiation
+ PARMDL(84) = 1.D0
+ PARMDL(85) = 1.D0
+ PARMDL(86) = 1.D0
+C scales to calculate alpha-s of final state radiation
+ PARMDL(87) = 1.D0
+ PARMDL(88) = 1.D0
+ PARMDL(89) = 1.D0
+C scales to calculate PDFs
+ PARMDL(90) = 1.D0
+ PARMDL(91) = 1.D0
+ PARMDL(92) = 1.D0
+C scale for ISR starting virtuality
+ PARMDL(93) = 1.D0
+C min. virtuality to generate time-like showers in ISR
+ PARMDL(94) = 2.D0
+C factor to scale the max. allowed time-like parton shower virtuality
+ PARMDL(95) = 4.D0
+C max. transverse momentum for primordial kt
+ PARMDL(100) = 2.D0
+C weight factors for pt-distribution
+ PARMDL(101) = 2.D0
+ PARMDL(102) = 2.D0
+ PARMDL(103) = 4.D0
+ PARMDL(104) = 2.D0
+ PARMDL(105) = 6.D0
+ PARMDL(106) = 4.D0
+C
+* PARMDL(110-125) reserved for hard scattering
+C currently chosen scales for hard scattering
+ DO 10 I=1,16
+ PARMDL(109+I) = 0.D0
+ 10 CONTINUE
+C virtuality cutoff in initial state evolution
+ PARMDL(126) = PARMDL(36)**2
+ PARMDL(127) = PARMDL(37)**2
+ PARMDL(128) = PARMDL(38)**2
+ PARMDL(129) = PARMDL(39)**2
+C virtuality cutoff for direct contribution to photon PDF
+ PARMDL(130) = 1.D30
+ PARMDL(131) = 1.D30
+ PARMDL(132) = 1.D30
+ PARMDL(133) = 1.D30
+C fraction of events without popcorn
+ PARMDL(134) = -1.D0
+C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
+ PARMDL(135) = 0.5D0
+C soft color re-connection (fraction)
+C g g final state
+ PARMDL(140) = 1.D0/64.D0
+C g q final state
+ PARMDL(141) = 1.D0/24.D0
+C q q final state
+ PARMDL(142) = 1.D0/9.D0
+C effective scale in Drees-Godbole like suppresion in photon PDF
+ PARMDL(144) = 0.766D0**2
+C QCD scales (if PDF scales are not used, 4 active flavours)
+ PARMDL(145) = 0.2D0**2
+ PARMDL(146) = 0.2D0**2
+ PARMDL(147) = 0.2D0**2
+C threshold scales for variable flavour calculation (GeV**2)
+ PARMDL(148) = 1.5D0**2
+ PARMDL(149) = 4.5D0**2
+ PARMDL(150) = 175.D0**2
+C constituent quark masses
+ PARMDL(151) = 0.3D0
+ PARMDL(152) = 0.3D0
+ PARMDL(153) = 0.5D0
+ PARMDL(154) = 1.6D0
+ PARMDL(155) = 5.D0
+ PARMDL(156) = 174.D0
+C min. masses of valence quark
+ PARMDL(157) = 0.3D0
+C min. masses of valence diquark
+ PARMDL(158) = 0.8D0
+C min. mass of sea quark
+ PARMDL(159) = 0.D0
+C suppression of strange quarks as photon valences
+ PARMDL(160) = 0.2D0
+C min. masses for strings (used in PHO_SOFTXX)
+ PARMDL(161) = 1.D0
+ PARMDL(162) = 1.D0
+ PARMDL(163) = 1.D0
+ PARMDL(164) = 1.D0
+C min. momentum fraction for soft processes
+ PARMDL(165) = 0.3D0
+C min. phase space for x-sampling
+ PARMDL(166) = 0.135D0
+C Ross-Stodolsky exponent
+ PARMDL(170) = 4.2D0
+C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
+ PARMDL(175) = 2.D0
+
+**sr
+* extra factor multiplying difference between Goulianos and PHOJET-
+* diff. cross sections
+ PARMDL(200) = 0.6D0
+**
+
+C complex amplitudes, eikonal functions
+ IPAMDL(1) = 0
+C allow for Reggeon cuts
+ IPAMDL(2) = 1
+C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
+ IPAMDL(3) = 0
+C polarization of photon resonances (0 none, 1 trans, 2 long)
+ IPAMDL(4) = 1
+C pt of valence partons
+ IPAMDL(5) = 1
+C pt of hard scattering remnant
+ IPAMDL(6) = 2
+C running cutoff for hard scattering
+ IPAMDL(7) = 1
+C intercept used for the calculation of enhanced graphs
+ IPAMDL(8) = 1
+C effective slope of hard scattering amplitde
+ IPAMDL(9) = 1
+C mass dependence of slope parameters
+ IPAMDL(10) = 0
+C lepton-photon vertex 1
+ IPAMDL(11) = 0
+C lepton-photon vertex 2
+ IPAMDL(12) = 0
+C call by DPMJET
+ IPAMDL(13) = 0
+C method to sample x distributions
+ IPAMDL(14) = 3
+C energy-momentum check
+ IPAMDL(15) = 1
+C phase space correction for DPMJET interface
+ IPAMDL(16) = 1
+C fragment strings from projectile/target/central diff. separately
+ IPAMDL(17) = 1
+C method to construct strings for hard interactions
+ IPAMDL(18) = 1
+C method to construct strings for soft sea (pomeron cuts)
+ IPAMDL(19) = 0
+C method to construct strings in pomeron interactions
+ IPAMDL(20) = 0
+C soft color re-connection
+ IPAMDL(21) = 0
+C resummation of triple- and loop-Pomeron
+ IPAMDL(24) = 1
+C resummation of X iterated triple-Pomeron
+ IPAMDL(25) = 1
+C dimension of interpolation table for weights in hard scattering
+ IPAMDL(30) = Max_tab_E
+C dimension of interpolation table for pomeron cut distribution
+ IPAMDL(31) = IEETA1
+C number of cut soft pomerons (restriction by field dimension)
+ IPAMDL(32) = IIMAX
+C number of cut hard pomerons (restriction by field dimension)
+ IPAMDL(33) = KKMAX
+C tau pair production in direct photon-photon collisions
+ IPAMDL(64) = 0
+C currently chosen scales for hard scattering
+C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
+ DO 15 I=1,16
+ IPAMDL(64+I) = -99999
+ 15 CONTINUE
+C scales to calculate alpha-s of matrix element
+ IPAMDL(81) = 1
+ IPAMDL(82) = 1
+ IPAMDL(83) = 1
+C scales to calculate alpha-s of initial state radiation
+ IPAMDL(84) = 1
+ IPAMDL(85) = 1
+ IPAMDL(86) = 1
+C scales to calculate alpha-s of final state radiation
+ IPAMDL(87) = 1
+ IPAMDL(88) = 1
+ IPAMDL(89) = 1
+C scales to calculate PDFs
+ IPAMDL(90) = 1
+ IPAMDL(91) = 1
+ IPAMDL(92) = 1
+C where to get the parameter sets from
+ IPAMDL(99) = 1
+C program PHO_ABORT for fatal errors (simulation of division by zero)
+ IPAMDL(100) = 0
+C initial state parton showers for all / hardest interaction(s)
+ IPAMDL(101) = 1
+C final state parton showers for all / hardest interaction(s)
+ IPAMDL(102) = 1
+C initial virtuality for ISR generation
+ IPAMDL(109) = 1
+C qqbar-gamma coupling in initial state showers
+ IPAMDL(110) = 1
+C generation of time-like showers during ISR
+ IPAMDL(111) = 1
+C reweighting of multiple soft contributions for virtual photons
+ IPAMDL(114) = 1
+C reweighting / use photon virtuality in photon PDF calculations
+ IPAMDL(115) = 0
+C use full QPM model incl. interference terms (direct part in gam-gam)
+ IPAMDL(116) = 0
+C matching sigma_tot to F2 as given by parton density at high Q2
+ IPAMDL(117) = 1
+C use virtuality of target in F2 calculations (two-gamma only)
+ IPAMDL(118) = 1
+C calculation of alpha_em
+ IPAMDL(120) = 1
+C strict pt cutoff for gamma-gamma events
+ IPAMDL(121) = 0
+C photon virtuality sampled in photon flux approximations
+ IPAMDL(174) = 1
+C photon-pomeron: 0,1,2: both,left,right photon emission
+ IPAMDL(175) = 0
+C keep full history information in PHOJET-JETSET interface
+ IPAMDL(178) = 1
+C max. number of conservation law violations allowed in one run
+ IPAMDL(179) = 20
+C selection of soft X values
+C max. iteration number in PHO_SELSXS
+ IPAMDL(180) = 50
+C max. iteration number in PHO_SELSXR
+ IPAMDL(181) = 200
+C max. iteration number in PHO_SELSX2
+ IPAMDL(182) = 100
+C max. iteration number in PHO_SELSXI
+ IPAMDL(183) = 50
+
+C initialize /PROBAB/
+ IEEMAX = IEETA1
+ IMAX = IIMAX
+ KMAX = KKMAX
+
+ DO 20 I=1,30
+ PARMDL(300+I) = -100000.D0
+ 20 CONTINUE
+C initialize /POHDRN/
+ QMASS(1) = PARMDL(151)
+ QMASS(2) = PARMDL(152)
+ QMASS(3) = PARMDL(153)
+ QMASS(4) = PARMDL(154)
+ QMASS(5) = PARMDL(155)
+ QMASS(6) = PARMDL(156)
+ BET = 8.D0
+ PCOUDI = 0.D0
+ VALPRG(1) = 1.D0
+ VALPRG(2) = 1.D0
+C number of light flavours (quarks treated as massless)
+ NFS = 4
+C initialize /POCUT1/
+ PTCUT(1) = PARMDL(36)
+ PTCUT(2) = PARMDL(37)
+ PTCUT(3) = PARMDL(38)
+ PTCUT(4) = PARMDL(39)
+ PSOMIN = 0.D0
+ XSOMIN = 0.D0
+C initialize /POHAPA/
+ NFbeta = 4
+ NF = 4
+ BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
+ BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
+ BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
+ BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
+C initialize /POGAUP/
+ NGAUP1 = 12
+ NGAUP2 = 12
+ NGAUET = 16
+ NGAUIN = 12
+ NGAUSO = 96
+C initialize //
+ DO 30 I=1,100
+ IDEB(I) = 0
+ 30 CONTINUE
+C initialize /PROCES/
+ DO 35 I=1,11
+ IPRON(I,1) = 1
+ 35 CONTINUE
+
+C DPMJET default: no elastic scattering
+ IPRON(2,1) = 0
+
+ DO 36 K=2,4
+ DO 37 I=2,11
+ IPRON(I,K) = 0
+ 37 CONTINUE
+ IPRON(1,K) = 1
+ IPRON(8,K) = 1
+ 36 CONTINUE
+C initialize /POSVDM/
+ TWOPIM = 0.28D0
+ RMIN(1) = 0.285D0
+ RMIN(2) = 0.45D0
+ RMIN(3) = 1.D0
+ RMIN(4) = TWOPIM
+ VMAS(1) = 0.770D0
+ VMAS(2) = 0.787D0
+ VMAS(3) = 1.02D0
+ VMAS(4) = TWOPIM
+ GAMM(1) = 0.155D0
+ GAMM(2) = 0.01D0
+ GAMM(3) = 0.0045D0
+ GAMM(4) = 1.D0
+ RMAX(1) = VMAS(1)+TWOPIM
+ RMAX(2) = VMAS(2)+TWOPIM
+ RMAX(3) = VMAS(3)+TWOPIM
+ RMAX(4) = VMAS(1)+TWOPIM
+ VMSL(1) = 11.D0
+ VMSL(2) = 10.D0
+ VMSL(3) = 6.D0
+ VMSL(4) = 4.D0
+ VMFA(1) = 0.0033D0
+ VMFA(2) = 0.00036D0
+ VMFA(3) = 0.0002D0
+ VMFA(4) = 0.0002D0
+C initialize /PODGL1/
+ Q2MISR(1) = PARMDL(36)**2
+ Q2MISR(2) = PARMDL(36)**2
+ PMISR(1) = 1.D0
+ PMISR(2) = 1.D0
+ ZMISR(1) = 0.001D0
+ ZMISR(2) = 0.001D0
+ AL2ISR(1) = 0.046D0
+ AL2ISR(2) = 0.046D0
+ NFSISR = 4
+C initialize /POPISR/
+ DO 40 I=1,50
+ IPOISR(1,2,I) = 0
+ IPOISR(2,2,I) = 0
+ 40 CONTINUE
+C initialize /POHPRO/
+ PROC(0) = 'sum over processes'
+ PROC(1) = 'G +G --> G +G '
+ PROC(2) = 'Q +QB --> G +G '
+ PROC(3) = 'G +Q --> G +Q '
+ PROC(4) = 'G +G --> Q +QB '
+ PROC(5) = 'Q +QB --> Q +QB '
+ PROC(6) = 'Q +QB --> QP +QBP'
+ PROC(7) = 'Q +Q --> Q +Q '
+ PROC(8) = 'Q +QP --> Q +QP '
+ PROC(9) = 'resolved processes'
+ PROC(10) = 'gam+Q --> G +Q '
+ PROC(11) = 'gam+G --> Q +QB '
+ PROC(12) = 'Q +gam--> G +Q '
+ PROC(13) = 'G +gam--> Q +QB '
+ PROC(14) = 'gam+gam--> Q +QB '
+ PROC(15) = 'direct processes '
+ PROC(16) = 'gam+gam--> l+ +l- '
+
+C initialize /POHRCS/
+ do M=1,Max_pro_2
+ HWgx(M) = 0.D0
+ HSig(M) = 0.D0
+ Hdpt(M) = 0.D0
+ enddo
+ DO I=0,4
+ DO M=-1,Max_pro_2
+C switch all hard subprocesses on
+ MH_pro_on(M,I) = 1
+C reset all counters
+ MH_tried(M,I) = 0
+ MH_acc_1(M,I) = 0
+ MH_acc_2(M,I) = 0
+ ENDDO
+ MH_pro_on(16,I) = 0
+ ENDDO
+
+C initialize /POHTAB/
+ do I=0,4
+ IH_Ecm_up(I) = 0
+ IH_Q2a_up(I) = 0
+ IH_Q2b_up(I) = 0
+ HEcm_tab(1,I) = 0.D0
+ enddo
+ HEcm_last = 0.D0
+ IHa_last = 0.D0
+ IHb_last = 0.D0
+
+C initialize /POFSRC/
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+C initialize /LEPCUT/
+ ECMIN = 5.D0
+ ECMAX = 1.D+30
+ EEMIN1 = 1.D0
+ EEMIN2 = 1.D0
+ YMAX1 = -1.D0
+ YMAX2 = -1.D0
+ THMIN1 = 0.D0
+ THMAX1 = PI
+ THMIN2 = 0.D0
+ THMAX2 = PI
+ ITAG1 = 1
+ ITAG2 = 1
+C initialize /POWGHT/
+ DO 70 I=1,20
+ HSWCUT(I) = 0.D0
+ ISWCUT(I) = 0
+ 70 CONTINUE
+ EVWGHT(1) = 1.D0
+ IVWGHT(1) = 0
+ SIGGEN(1) = 0.D0
+ SIGGEN(2) = 0.D0
+ SIGGEN(3) = 0.D0
+ SIGGEN(4) = 0.D0
+
+ END
+
+CDECK ID>, PHO_PARDAT
+ SUBROUTINE PHO_PARDAT
+C***********************************************************************
+C
+C particle data (based on 1996 PDG naming scheme and data tables)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+C external functions
+
+ integer ipho_pdg2id
+ double precision pho_pmass
+
+C local variables for storing data tables
+
+ integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
+ & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
+
+ dimension number(300),ich3(300),iba3(300),iq_linear(900),
+ & idec_linear(900),isec_linear(900),id_psm_linear(36),
+ & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
+
+ double precision xmass,gamma,wg_chan
+ dimension xmass(300),gamma(300),wg_chan(300)
+
+ character*12 name
+ dimension name(300)
+
+ integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
+ double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
+
+ integer itmp
+
+ DATA i_tab_max /260/
+
+ DATA (number(K),K= 1, 171) /
+ & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
+ & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
+ & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
+ & 110, 990, 21, 22, 24, 23, 11, 13, 15,
+ & 12, 14, 16, 211, 111, 221, 113, 213, 223,
+ & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
+ & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
+ & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
+ & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
+ & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
+ & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
+ & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
+ & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
+ & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
+ & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
+ & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
+ & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
+ & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
+ & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
+ DATA (number(K),K= 172, 260) /
+ & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
+ & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
+ & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
+ & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
+ & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
+ & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
+ & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
+ & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
+ & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
+ & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
+ DATA (name(K),K= 1, 76) /
+ &'d ','u ','s ','c ',
+ &'b ','t ','(dd)_1 ','(ud)_0 ',
+ &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
+ &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
+ &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
+ &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
+ &'string ','mod. string ','coll. string','reggeon ',
+ &'pomeron ','gluon ','gamma ','W ',
+ &'Z ','e ','mu ','tau ',
+ &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
+ &'pi ','eta ','rho(770) ','rho(770) ',
+ &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
+ &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
+ &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
+ &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
+ &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
+ &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
+ &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
+ &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
+ DATA (name(K),K= 77, 152) /
+ &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
+ &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
+ &'K ','K(S) ','K(L) ','K*(892) ',
+ &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
+ &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
+ &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
+ &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
+ &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
+ &'K(4)*(2045) ','D ','D ','D*(2007) ',
+ &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
+ &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
+ &'B ','B* ','B* ','B(s) ',
+ &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
+ &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
+ &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
+ &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
+ &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
+ &'Ups(10860) ','Ups(11020) ','p ','n ',
+ &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
+ DATA (name(K),K= 153, 228) /
+ &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
+ &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
+ &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
+ &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
+ &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
+ &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
+ &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
+ &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
+ &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
+ &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
+ &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
+ &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
+ &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
+ &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
+ &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
+ &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
+ &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
+ &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
+ &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
+ DATA (name(K),K= 229, 260) /
+ &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
+ &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
+ &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
+ &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
+ &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
+ &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
+ &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
+ &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
+ DATA (ich3(K),K= 1, 260) /
+ &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
+ & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
+ & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
+ & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
+ &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
+ & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
+ & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
+ & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
+ DATA (iba3(K),K= 1, 260) /
+ &1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
+ &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
+ &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
+ &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
+ DATA (iq_linear(K),K= 1, 418) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
+ & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
+ & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
+ & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
+ &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
+ & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
+ & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
+ &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
+ & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
+ & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
+ &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
+ & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
+ & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
+ &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
+ & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
+ & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
+ DATA (iq_linear(K),K= 419, 780) /
+ &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
+ & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
+ & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
+ & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
+ & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
+ & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
+ & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
+ & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
+ & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
+ & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
+ & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
+ & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
+ & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
+ & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
+ & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
+ & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
+ & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
+ DATA (xmass(K),K= 1, 114) /
+ &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
+ &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
+ &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
+ &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
+ &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
+ &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
+ &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
+ &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
+ &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
+ &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
+ &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
+ &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
+ &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
+ &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
+ &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
+ &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
+ DATA (xmass(K),K= 115, 228) /
+ &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
+ &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
+ &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
+ &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
+ &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
+ &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
+ &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
+ &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
+ &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
+ &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
+ &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
+ &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
+ &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
+ &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
+ &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
+ &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
+ &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
+ &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
+ &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
+ DATA (xmass(K),K= 229, 260) /
+ &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
+ &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
+ &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
+ &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
+ &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
+ &2.7040E+00,5.6240E+00/
+ DATA (gamma(K),K= 1, 114) /
+ &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
+ &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
+ &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
+ &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
+ &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
+ &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
+ &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
+ &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
+ &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
+ &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
+ &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
+ &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
+ &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
+ &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
+ &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
+ &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
+ DATA (gamma(K),K= 115, 228) /
+ &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
+ &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
+ &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
+ &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
+ &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
+ &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
+ &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
+ &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
+ &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
+ &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
+ &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
+ &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
+ &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
+ &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
+ &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
+ &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
+ &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
+ DATA (gamma(K),K= 229, 260) /
+ &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
+ &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
+ &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
+ &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
+ &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
+ &1.0200E-11,5.3100E-13/
+ DATA (idec_linear(K),K= 1, 304) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
+ & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 25, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 30, 32,
+ & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
+ & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
+ & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
+ & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (idec_linear(K),K= 305, 608) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 2, 77, 78, 2, 79, 82, 1, 83, 84,
+ & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
+ & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 1, 99,101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
+ &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,137,144, 1,145,152, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
+ &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
+ &163,169, 1,170,176, 1,177,180, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (idec_linear(K),K= 609, 780) /
+ & 0, 0, 0, 0, 3,181,182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,183,184, 3,185,
+ &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,195,203, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 1,204,216, 0, 0, 0, 3,217,217, 3,
+ &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
+ &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
+ & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
+ DATA (isec_linear(K),K= 1, 152) /
+ & 11, 12, -12, 13, -14, 16, 11, -12,
+ & 16, -213, 16, 0, -211, 16, 0, -323,
+ & 16, 0, -13, 12, 0, 22, 22, 0,
+ & 22, -11, 11, 22, 22, 0, 111, 22,
+ & 22, 111, 111, 111, 211, -211, 111, 211,
+ & -211, 22, 211, -211, 0, 111, 111, 0,
+ & 211, 111, 0, 211, -211, 111, 211, -211,
+ & 0, 111, 22, 0, 221, 211, -211, 221,
+ & 111, 111, 211, -211, 22, 22, 22, 0,
+ & 321, -321, 0, 130, 310, 0, 113, 111,
+ & 0, 211, -211, 111, 221, 22, 0, 113,
+ & 111, 0, -213, 211, 0, 213, -211, 0,
+ & 211, -211, 0, 111, 111, 0, 113, 111,
+ & 0, -213, 211, 0, 213, -211, 0, 311,
+ & -313, 0, -311, 313, 0, 113, 211, -211,
+ & -13, 12, 0, 211, 111, 0, 211, 211,
+ & -211, 211, 111, 111, -13, 111, 12, -11,
+ & 111, 12, 211, -211, 0, 111, 111, 0,
+ & 111, 111, 111, 211, -211, 111, 211, 13/
+ DATA (isec_linear(K),K= 153, 304) /
+ & 12, 211, 11, 12, 321, 111, 0, 311,
+ & 211, 0, 311, 111, 0, 321, -211, 0,
+ & 311, 111, 0, 321, -211, 0, 321, 111,
+ & 0, 311, 211, 0, 311, 111, 0, 321,
+ & -211, 0, 313, 111, 0, 323, -211, 0,
+ & 311, 113, 0, 321, -213, 0, 311, 223,
+ & 0, 311, 221, 0, 321, 111, 0, 311,
+ & 211, 0, 323, 111, 0, 313, 211, 0,
+ & 321, 113, 0, 311, 213, 0, 321, 223,
+ & 0, 321, 221, 0, -321, 211, 211, -311,
+ & 211, 0, -321, 211, 0, -321, 211, 111,
+ & 311, 211, -211, 311, 111, 0, 421, 111,
+ & 0, 421, 22, 0, 421, 211, 0, 411,
+ & 111, 0, 411, 22, 0, 221, 211, 0,
+ & 321, -321, 321, 321, -311, 0, 431, 22,
+ & 0, 431, 22, 0, 111, 111, 0, 211,
+ & -211, 0, 22, 22, 0, -11, 11, 0,
+ & -13, 13, 0, 211, -211, 111, 443, 211,
+ & -211, 443, 111, 111, 443, 221, 0, 2212/
+ DATA (isec_linear(K),K= 305, 456) /
+ & 11, 12, 2112, 111, 0, 2212, -211, 0,
+ & 2112, 111, 111, 2112, 211, -211, 1114, 211,
+ & 0, 2114, 111, 0, 2214, -211, 0, 2112,
+ & 113, 0, 2212, -213, 0, 2112, 221, 0,
+ & 2212, 111, 0, 2112, 211, 0, 2212, 111,
+ & 111, 2212, 211, -211, 2224, -211, 0, 2214,
+ & 111, 0, 2114, 211, 0, 2212, 113, 0,
+ & 2112, 213, 0, 2212, 221, 0, 2212, -211,
+ & 0, 2112, 111, 0, 2214, -211, 0, 2114,
+ & 111, 0, 1114, 211, 0, 2212, -213, 0,
+ & 2112, 113, 0, 2212, 111, 0, 2112, 211,
+ & 0, 2224, -211, 0, 2214, 111, 0, 2114,
+ & 211, 0, 2212, 113, 0, 2112, 213, 0,
+ & 2212, -211, 0, 2112, 111, 0, 2212, -213,
+ & 0, 2112, 113, 0, 3122, 311, 0, 3212,
+ & 311, 0, 3112, 321, 0, 2112, 221, 0,
+ & 2212, 111, 0, 2112, 211, 0, 2212, 113,
+ & 0, 2112, 213, 0, 3122, 321, 0, 3222,
+ & 311, 0, 3212, 321, 0, 2212, 221, 0/
+ DATA (isec_linear(K),K= 457, 608) /
+ & 2112, -211, 0, 2212, -211, 0, 2112, 111,
+ & 0, 2212, 111, 0, 2112, 211, 0, 2212,
+ & 211, 0, 2112, -211, 0, 2114, -211, 0,
+ & 1114, 111, 0, 2112, -213, 0, 2212, -211,
+ & 0, 2112, 111, 0, 2214, -211, 0, 2114,
+ & 111, 0, 1114, 211, 0, 2212, -213, 0,
+ & 2112, 113, 0, 2212, 111, 0, 2112, 211,
+ & 0, 2224, -211, 0, 2214, 111, 0, 2114,
+ & 211, 0, 2212, 113, 0, 2112, 213, 0,
+ & 2212, 211, 0, 2224, 111, 0, 2214, 211,
+ & 0, 2212, 213, 0, 2212, -211, 0, 2112,
+ & 111, 0, 2212, 111, 0, 2112, 211, 0,
+ & 3122, 22, 0, 2112, -211, 0, 3122, 211,
+ & 0, 3212, 211, 0, 3222, 111, 0, 3122,
+ & 111, 0, 3222, -211, 0, 3112, 211, 0,
+ & 3122, -211, 0, 3212, -211, 0, 2112, -311,
+ & 0, 2212, -321, 0, 3222, -211, 0, 3212,
+ & 111, 0, 3112, 211, 0, 3122, 221, 0,
+ & 3224, -211, 0, 3114, 211, 0, 3214, 111/
+ DATA (isec_linear(K),K= 609, 760) /
+ & 0, 2112, -311, 0, 2212, -321, 0, 3122,
+ & 111, 0, 3122, 223, 0, 3122, 113, 0,
+ & 3222, -213, 0, 3112, 213, 0, 3212, 113,
+ & 0, 3122, 221, 0, 3212, 221, 0, 3222,
+ & -211, 0, 3112, 211, 0, 3212, 111, 0,
+ & 3122, 111, 0, 3122, -211, 0, 3322, 111,
+ & 0, 3312, 211, 0, 3322, -211, 0, 3312,
+ & 111, 0, 3322, -211, 0, 3312, 111, 0,
+ & 3122, -321, 0, 3222, 221, 0, 3222, 331,
+ & 0, 2212, -311, 0, 3322, 321, 0, 3224,
+ & 221, 0, 2214, 331, 0, 2224, -321, 0,
+ & 3122, 213, 0, 3212, 213, 0, 3222, 113,
+ & 0, 3222, 223, 0, 2212, -313, 0, 2214,
+ & -313, 0, 2224, -323, 0, 4122, 211, 0,
+ & 4122, 111, 0, 4122, -211, 0, 3222, -311,
+ & 0, 3322, 211, 0, 3222, -313, 0, 3322,
+ & 213, 0, 3212, -313, 0, 3222, -323, 0,
+ & 3322, 223, 0, 3312, 213, 0, 3214, -313,
+ & 0, 3322, -311, 0, 3322, 313, 0, 3334/
+ DATA (isec_linear(K),K= 761, 765) /
+ & 213, 0, 3334, 211, 0/
+ DATA (wg_chan(K),K= 1, 114) /
+ &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
+ &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
+ &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
+ &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
+ &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
+ &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
+ &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
+ &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
+ &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
+ &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
+ &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
+ &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
+ &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
+ &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
+ &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
+ &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
+ &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
+ &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
+ &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
+ DATA (wg_chan(K),K= 115, 228) /
+ &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
+ &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
+ &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
+ &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
+ &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
+ &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
+ &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
+ &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
+ &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
+ &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
+ &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
+ &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
+ &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
+ &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
+ &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
+ &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
+ &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
+ &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
+ &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
+ DATA (wg_chan(K),K= 229, 255) /
+ &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
+ &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
+ &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
+ &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
+ &2.0000E-01,3.6000E-01,7.0000E-02/
+ DATA (id_psm_linear(K),K= 1, 36) /
+ & 111, 211, -311, 411, 0, 0, -211, 111,
+ & -321, 421, 0, 0, 311, 321, 221, 431,
+ & 0, 0, -411, -421, -431, 441, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0/
+ DATA (id_vem_linear(K),K= 1, 36) /
+ & 113, 213, -313, 413, 0, 0, -213, 113,
+ & -323, 423, 0, 0, 313, 323, 333, 433,
+ & 0, 0, -413, -423, -433, 20443, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0/
+ DATA (id_b8_linear(K),K= 1, 171) /
+ & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
+ & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
+ & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
+ & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
+ & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
+ & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
+ & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
+ & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
+ & 4412, 4422, 4432, 4444, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b8_linear(K),K= 172, 216) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b10_linear(K),K= 1, 171) /
+ & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
+ & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
+ & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
+ & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
+ & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
+ & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
+ & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
+ & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
+ & 4414, 4424, 4434, 4444, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (id_b10_linear(K),K= 172, 216) /
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 0, 0, 0, 0, 0, 0, 0, 0, 0/
+
+ ID_pdg_max = i_tab_max
+
+C copy from local to global variables
+ do i=1,i_tab_max
+ ID_pdg_list(i) = number(i)
+ name_list(i) = name(i)
+ xm_list(i) = xmass(i)
+ gam_list(i) = gamma(i)
+ ich3_list(i) = ich3(i)
+ iba3_list(i) = iba3(i)
+ do j=1,3
+ iq_list(j,i) = iq_linear(3*(i-1)+j)
+ idec_list(j,i) = idec_linear(3*(i-1)+j)
+ enddo
+ enddo
+
+C initialize hash table
+ call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
+
+ itmp = IDEB(71)
+ IDEB(71) = -1
+
+C quark index table for mesons
+ do i=1,6
+ do j=1,6
+ id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
+ id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
+ enddo
+ enddo
+
+C quark index table for baryons
+ do i=1,6
+ do j=1,6
+ do k=1,6
+ id_b8_list(i,j,k) =
+ & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
+ id_b10_list(i,j,k) =
+ & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
+ enddo
+ enddo
+ enddo
+
+ IDEB(71) = itmp
+
+C copy secondary particles
+C (translate PDG-ID to CPC and sort according to CPC)
+ ichan = 0
+ do i=1,i_tab_max
+ if(idec_list(1,i).ne.0) then
+ do j=idec_list(2,i),idec_list(3,i)
+ ichan = ichan+1
+ wg_sec_list(ichan) = wg_chan(j)
+ do k=1,3
+ if(isec_linear(3*(j-1)+k).ne.0) then
+ isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
+ else
+ isec_list(k,ichan) = 0
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+C add two-pion background (low-mass photon dissociation)
+ i = ipho_pdg2id(92)
+ ichan = ichan+1
+ idec_list(1,i) = 1
+ idec_list(2,i) = ichan
+ idec_list(3,i) = ichan
+ wg_sec_list(ichan) = 1.D0
+ isec_list(1,ichan) = ipho_pdg2id(211)
+ isec_list(2,ichan) = ipho_pdg2id(-211)
+ isec_list(3,ichan) = 0
+
+C min. mass limits for strings: q-qbar
+ do i=1,6
+ do j=1,6
+ AM2P = 1000.D0
+ AM2V = 1000.D0
+ do k=1,3
+C pseudo-scalar mesons
+ i1 = iabs(id_psm_list(i,k))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+ i2 = iabs(id_psm_list(k,j))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(k,3)+pho_pmass(j,3)
+ endif
+ AM2P = MIN(AM2P,AM1+AM2)
+C vector mesons
+ i1 = iabs(id_vem_list(i,k))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+ i2 = iabs(id_vem_list(k,j))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(k,3)+pho_pmass(j,3)
+ endif
+ AM2V = MIN(AM2V,AM1+AM2)
+ enddo
+ xm_psm2_list(i,j) = AM2P
+ xm_vem2_list(i,j) = AM2V
+ enddo
+ enddo
+
+C min. mass limits for strings: qq-q
+ do i=1,6
+ do j=1,6
+ do k=1,6
+ AM82 = 1000.D0
+ AM102 = 1000.D0
+ do l=1,3
+C pseudo-scalar meson
+ i1 = iabs(id_psm_list(k,l))
+ if(i1.ne.0) then
+ AM1 = xm_list(i1)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+C vector meson
+ i2 = iabs(id_vem_list(k,l))
+ if(i2.ne.0) then
+ AM2 = xm_list(i2)
+ else
+ AM2 = pho_pmass(i,3)+pho_pmass(k,3)
+ endif
+C octet baryon
+ AMM = min(AM1,AM2)
+ K8 = id_b8_list(i,j,l)
+ if(K8.ne.0) then
+ AM1 = xm_list(K8)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ AM82 = MIN(AM82, AM1 + AMM)
+C decuplet baryon
+ K10 = id_b10_list(i,j,l)
+ if(K10.ne.0) then
+ AM2 = xm_list(K10)
+ else
+ AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ AM102 = MIN(AM102, AM2 + AMM)
+ enddo
+ xm_b82_list(i,j,k) = AM82
+ xm_b102_list(i,j,k) = AM102
+ enddo
+ enddo
+ enddo
+
+C min. mass limits for strings: qq-qbarqbar
+ do i=1,6
+ do j=1,6
+ do ii=1,6
+ do jj=1,6
+ AM82 = 1000.D0
+ AM102 = 1000.D0
+ do l=1,3
+C octet baryons
+ K8 = id_b8_list(i,j,l)
+ if(K8.ne.0) then
+ AM1 = xm_list(K8)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ L8 = id_b8_list(ii,jj,l)
+ if(L8.ne.0) then
+ AM2 = xm_list(L8)
+ else
+ AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
+ endif
+ AM82 = MIN(AM82, AM1+AM2)
+C decuplet baryons
+ K10 = id_b10_list(i,j,l)
+ if(K10.ne.0) then
+ AM1 = xm_list(K10)
+ else
+ AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
+ endif
+ L10 = id_b10_list(ii,jj,l)
+ if(L10.ne.0) then
+ AM2 = xm_list(L10)
+ else
+ AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
+ endif
+ AM102 = MIN(AM102, AM1+AM2)
+ enddo
+ xm_bb82_list(i,j,ii,jj) = AM82
+ xm_bb102_list(i,j,ii,jj) = AM102
+ enddo
+ enddo
+ enddo
+ enddo
+
+ END
+
+CDECK ID>, PHO_PRESEL
+ SUBROUTINE PHO_PRESEL(MODE,IREJ)
+C**********************************************************************
+C
+C user specific function to pre-select events during generation
+C
+C input: MODE 5 electron and photon kinematics
+C 10 process and number of cut Pomerons
+C 15 partons without construction of strings
+C 20 partons assigned to strings
+C 25 after fragmentation, complete final state
+C
+C output: IREJ 0 event accepted
+C 50 event rejected
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 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 gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ IREJ = 0
+
+* XBJ = GQ2(2)/(GGECM**2+GQ2(2))
+* IF(XBJ.LT.0.002D0) IREJ = 1
+
+ END
+
+CDECK ID>, PHO_FIXCOL
+ SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
+C**********************************************************************
+C
+C interface to call PHOJET (fixed energy run) with
+C collider kinematics
+C
+C equivalen photon approximation to get photon flux
+C
+C input: NEV number of events to generate
+C THETA azimuthal angle (micro radians)
+C PHI beam crossing angle
+C (with respect to x, in degrees)
+C E1 energy of particle 1 (+z direction, GeV)
+C E2 energy of particle 2 (-z direction, GeV)
+C
+C note: particle types have to be specified before
+C with PHO_SETPAR
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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)
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+C remnant initialization (only needed for DPMJET)
+ ISAVP1 = IFPAP(1)
+ ISAVB1 = IFPAB(1)
+ IF(IFPAP(1).EQ.81) THEN
+ IFPAP(1) = IDEQP(1)
+ IFPAB(1) = IDEQB(1)
+ ENDIF
+ ISAVP2 = IFPAP(2)
+ ISAVB2 = IFPAB(2)
+ IF(IFPAP(2).EQ.82) THEN
+ IFPAP(2) = IDEQP(2)
+ IFPAB(2) = IDEQB(2)
+ ENDIF
+ PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
+ PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
+ PP1 = SQRT(E1**2-PMASS1**2)
+ PP2 = SQRT(E2**2-PMASS2**2)
+C beam crossing angle
+ TH = 1.D-6*THETA/2.D0
+ PH = PHI*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
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ IFPAP(1) = ISAVP1
+ IFPAB(1) = ISAVB1
+ IFPAP(2) = ISAVP2
+ IFPAB(2) = ISAVB2
+ ITRY = 0
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C test of DPMJET interface (default is IPAMDL(13)=0)
+ if(IPAMDL(13).gt.0) then
+ MODE = IPAMDL(13)
+ IPAMDL(13) = 0
+ else
+ MODE = 1
+ endif
+C main generation loop
+ DO 50 I=1,NEV
+ 55 CONTINUE
+ ITRY = ITRY+1
+ CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 55
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 50 CONTINUE
+
+ IF(NEV.GT.0) THEN
+ SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',SIGMAX,' mb *****',
+ & '========================================================='
+ CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
+ CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_LHIST(-2,SIGMAX)
+ ELSE
+ WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_FIXLAB
+ SUBROUTINE PHO_FIXLAB(PLAB,NEV)
+C**********************************************************************
+C
+C interface to call PHOJET (fixed energy run) with
+C LAB kinematics (second particle as target)
+C
+C equivalent photon approximation to get photon flux
+C
+C input: NEV number of events to generate
+C PLAB LAB momentum of particle 1
+C
+C note: particle types have to be specified before
+C with PHO_SETPAR
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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)
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+C remnant initialization (only needed for DPMJET)
+ SPCM = PLAB
+ ISAVP1 = IFPAP(1)
+ ISAVB1 = IFPAB(1)
+ IF(IFPAP(1).EQ.81) THEN
+ IFPAP(1) = IDEQP(1)
+ IFPAB(1) = IDEQB(1)
+ ENDIF
+ ISAVP2 = IFPAP(2)
+ ISAVB2 = IFPAB(2)
+ IF(IFPAP(2).EQ.82) THEN
+ IFPAP(2) = IDEQP(2)
+ IFPAB(2) = IDEQB(2)
+ ENDIF
+C get momenta in LAB system
+ PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
+ PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
+ IF(PMASS2.LT.0.1D0) THEN
+ WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
+ & 'no LAB system possible',IFPAB(1),IFPAB(2)
+ ELSE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = PLAB
+ P1(4) = SQRT(PMASS1+PLAB**2)
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = 0.D0
+ P2(4) = SQRT(PMASS2)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ IFPAP(1) = ISAVP1
+ IFPAB(1) = ISAVB1
+ IFPAP(2) = ISAVP2
+ IFPAB(2) = ISAVB2
+ ITRY = 0
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C event generation loop
+ DO 40 I=1,NEV
+ 45 CONTINUE
+ ITRY = ITRY+1
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 45
+ CALL PHO_LHIST(1,HSWGHT(0))
+
+ CALL PHO_PHIST(10,HSWGHT(0))
+
+ 40 CONTINUE
+ IF(NEV.GT.0) THEN
+ SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',SIGMAX,' mb *****',
+ & '========================================================='
+ CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
+ CALL PHO_PHIST(-2,SIGMAX)
+ CALL PHO_LHIST(-2,SIGMAX)
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_FIXLAB: no events simulated',NEV
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GPHERA
+ SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) with
+C HERA kinematics, photon as particle 2
+C
+C equivalent photon approximation to get photon flux
+C
+C input: NEVENT number of events to generate
+C EE1 proton energy (LAB system)
+C EE2 electron energy (LAB system)
+C from /POFCUT/:
+C YMIN2 lower limit of Y
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y
+C Q2MIN2 lower limit of photon virtuality
+C Q2MAX2 upper limit of photon virtuality
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
+C assign particle momenta according to HERA kinematics
+C proton data
+ PROM = PHO_PMASS(2212,1)
+ PROM2 = PROM**2
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+C electron data
+ ELEM = 0.512D-03
+ ELEM2 = ELEM**2
+ AMSRC(2) = ELEM
+ IDPSRC(2) = 11
+ IDBSRC(2) = ipho_pdg2id(11)
+C
+ Q2MIN = Q2MIN2
+ Q2MAX = Q2MAX2
+C
+ XIMAX = LOG(YMAX2)
+ XIMIN = LOG(YMIN2)
+ XIDEL = XIMAX-XIMIN
+C
+ IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
+ & WRITE(LO,'(/1X,A,1P2E11.4)')
+ & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
+ & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
+C
+ Max_tab = 50
+ DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
+ FLUXT = 0.D0
+ FLUXL = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
+ DO 100 I=1,Max_tab
+ Y = EXP(XIMIN+DELLY*DBLE(I-1))
+ Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
+ FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+ & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
+ FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
+ FLUXT = FLUXT + Y*FFT
+ FLUXL = FLUXL + Y*FFL
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
+ 100 CONTINUE
+ FLUXT = FLUXT*DELLY
+ FLUXL = FLUXL*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
+ & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
+C
+ AY = 0.D0
+ AY2 = 0.D0
+ YY = YMIN2
+ Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
+ WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
+ & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
+ IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
+C
+C initialization of PHOJET at upper energy limit
+C proton momentum
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EE1**2-PROM2+DEPS)
+ P1(4) = EE1
+C photon momentum
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+C sum of both photon polarizations
+ IGHEL(2) = -1
+C
+ CALL PHO_SETPAR(1,2212,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ ECMIN2 = ECMIN**2
+ ECMAX2 = ECMAX**2
+ AY = 0.D0
+ AY2 = 0.D0
+ Q22MIN = 1.D30
+ Q22AVE = 0.D0
+ Q22AV2 = 0.D0
+ Q22MAX = 0.D0
+ AN2MIN = 1.D30
+ AN2MAX = 0.D0
+ YY2MIN = 1.D30
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+C sample y
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
+ IF(ISWMDL(10).GE.2) THEN
+ YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
+ ELSE
+ YEFF = 1.D0+(1.D0-YY)**2
+ ENDIF
+ Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
+ Q2LOG = LOG(Q2MAX/Q2LOW)
+ WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ 185 CONTINUE
+ Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
+ WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
+ ELSE
+ Q2 = Q2LOW
+ ENDIF
+C
+
+C incoming electron
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron
+ YQ2 = SQRT((1.D0-YY)*Q2)
+ Q2E = Q2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-YY)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C set /POFSRC/
+ GYY(2) = YY
+ GQ2(2) = Q2
+C polar angle
+ PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
+C electron tagger
+ IF(PFIN(4,2).GT.EEMIN2) THEN
+ IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
+ ENDIF
+C azimuthal angle
+ PFPHI(2) = ATAN2(COF,SIF)
+C photon momentum
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C proton momentum
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EE1**2-PROM2)
+ P1(4) = EE1
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
+ GGECM = SQRT(GGECM)
+C
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2)
+C photon helicity
+ IF(ISWMDL(10).GE.2) THEN
+ WGH = YEFF-2.D0*ELEM2*YY**2/Q2
+ WGHL = 2.D0*(1-YY)
+ IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
+ IGHEL(2) = 1
+ ELSE
+ IGHEL(2) = 0
+ ENDIF
+ ELSE
+ IGHEL(2) = -1
+ ENDIF
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY = AY+YY
+ AY2 = AY2+YY*YY
+ YY2MIN = MIN(YY2MIN,YY)
+ YY2MAX = MAX(YY2MAX,YY)
+ Q22MIN = MIN(Q22MIN,Q2)
+ Q22MAX = MAX(Q22MAX,Q2)
+ Q22AVE = Q22AVE+Q2
+ Q22AV2 = Q22AV2+Q2*Q2
+ AN2MIN = MIN(AN2MIN,PFTHE(2))
+ AN2MAX = MAX(AN2MAX,PFTHE(2))
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
+ WGY = WGY*LOG(YMAX2/YMIN2)
+ AY = AY/DBLE(NITER)
+ AY2 = AY2/DBLE(NITER)
+ DAY = SQRT((AY2-AY**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
+ & Q22MIN,Q22MAX
+ WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
+ & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGEPEM
+ SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions on e+e- collider
+C
+C fully differential equivalent (improved) photon approximation
+C to get photon flux
+C
+C input: EE1 LAB system energy of electron/positron 1
+C EE2 LAB system energy of electron/positron 2
+C NEVENT >0 number of events to generate
+C -1 initialization
+C -2 final call (cross section calculation)
+C from /LEPCUT/:
+C YMIN1 lower limit of Y1
+C (energy fraction taken by photon from electron)
+C YMAX1 upper limit of Y1
+C Q2MIN1 lower limit of photon virtuality
+C Q2MAX1 upper limit of photon virtuality
+C THMIN1 lower limit of scattered electron
+C THMAX1 upper limit of scattered electron
+C YMIN2 lower limit of Y2
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y2
+C Q2MIN2 lower limit of photon virtuality
+C Q2MAX2 upper limit of photon virtuality
+C THMIN2 lower limit of scattered electron
+C THMAX2 upper limit of scattered electron
+C
+C output: after final call with NEVENT=-2
+C EE1 e+ e- cross section (mb)
+C EE2 gamma-gamma cross section (mb)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION EE1,EE2
+ INTEGER NEVENT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+C external functions
+ DOUBLE PRECISION DT_RNDM
+
+C local variables
+ DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
+ & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
+ & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
+ & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
+ & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
+ & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
+ & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
+ & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
+ & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
+
+ INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
+ & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
+
+ DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
+ integer ipho_pdg2id
+
+C initialization of event generation
+
+ if(NEVENT.eq.-1) then
+
+ DO 10 I=1,4
+ IHETRY(I) = 0
+ IHEAC1(I) = 0
+ IHEAC2(I) = 0
+ 10 CONTINUE
+
+ WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
+
+C electron data
+ ELEM = 0.512D-03
+ ELEM2 = ELEM**2
+ AMSRC(1) = ELEM
+ AMSRC(2) = ELEM
+C lepton numbers
+ IDPSRC(1) = 11
+ IDPSRC(2) = -11
+ IDBSRC(1) = ipho_pdg2id(11)
+ IDBSRC(2) = ipho_pdg2id(-11)
+
+C check/update kinematic limitations
+
+ Ymi = min(Ymax1,1.D0-ELEM/EE1)
+ if(Ymi.lt.Ymax1) then
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
+ Ymax1 = YMI
+ endif
+ Ymi = min(Ymax2,1.D0-ELEM/EE2)
+ if(Ymi.lt.Ymax2) then
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
+ Ymax2 = YMI
+ endif
+
+ YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+
+C store COS of angular tagging range
+ THMIC1 = COS(MAX(0.D0,THMIN1))
+ THMAC1 = COS(MIN(THMAX1,PI))
+ THMIC2 = COS(MAX(0.D0,THMIN2))
+ THMAC2 = COS(MIN(THMAX2,PI))
+
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+
+C debug: integrated photon flux
+
+ if(IDEB(30).ge.1) then
+ Max_tab = 50
+ FLUXT = 0.D0
+ FLUXL = 0.D0
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
+ & 'table of photon flux (trans/long side 1)',Max_tab
+ do I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ if((1.D0-Y1).gt.1.D-8) then
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
+ else
+ Q2low1 = 2.D0*Q2max1
+ endif
+ if(Q2low1.lt.Q2max1) then
+ FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
+ FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
+ else
+ FFT = 0.D0
+ FFL = 0.D0
+ endif
+ FLUXT = FLUXT + Y1*FFL
+ FLUXL = FLUXL + Y1*FFT
+ IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
+ enddo
+ FLUXT = FLUXT*DELLY
+ FLUXL = FLUXL*DELLY
+ WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
+ & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
+ endif
+
+C maximum weight
+
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ IF(ISWMDL(10).GE.2) THEN
+C long. and transversely polarized photons
+ WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ ELSE
+C transversely polarized photons only
+ WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ ENDIF
+
+C initialize gamma-gamma event generator
+
+C photon 1
+ EGAM = YMAX1*EE1
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EGAM**2-Q2LOW1)
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EGAM**2-Q2LOW2)
+ P2(4) = EGAM
+C sum of helicities
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+
+C set min. energy for interpolation tables
+ parmdl(19) = min(parmdl(19),ecmin)
+
+C initialize event gneration
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events, flux calculation
+
+ ECMIN2 = ECMIN**2
+ ECMAX2 = ECMAX**2
+ ECFRAC = ECMIN2/(4.D0*EE1*EE2)
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ AN1MIN = 1.D30
+ AN2MIN = 1.D30
+ AN1MAX = 0.D0
+ AN2MAX = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = 0
+ ITRY_low = 0
+ ITRY_high = 0
+ ITRW_low = 0
+ ITRW_high = 0
+
+C generate NEVENT events (might be just 1 per call)
+
+ else if(NEVENT.gt.0) then
+
+ NITER = NITER+NEVENT
+
+ DO 200 I=1,NEVENT
+
+C sample y1, y2
+ 150 CONTINUE
+ ITRY_low = ITRY_low+1
+ if(ITRY_low.eq.1000000) then
+ ITRY_low = 0
+ ITRY_high = ITRY_high+1
+ endif
+
+ 175 CONTINUE
+ ITRW_low = ITRW_low+1
+ if(ITRW_low.eq.1000000) then
+ ITRW_low = 0
+ ITRW_high = ITRW_high+1
+ endif
+
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ IF(Y1*Y2.LT.ECFRAC) GOTO 175
+ IF(ISWMDL(10).GE.2) THEN
+ YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
+ YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
+ ELSE
+ YEFF1 = 1.D0+(1.D0-Y1)**2
+ YEFF2 = 1.D0+(1.D0-Y2)**2
+ ENDIF
+
+ Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
+ Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (YEFF1*Q2LOG1
+ & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *(YEFF2*Q2LOG2
+ & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,4E12.5)')
+ & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
+
+C limit on Ecm_gg (app. cut, precise cut applied later)
+ GGECM2 = 4.D0*Y1*Y2*EE1*EE2
+ if(GGECM2.lt.ECMIN2) goto 175
+
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+
+ IF(IPAMDL(174).EQ.1) THEN
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
+ PINI(4,1) = EE1
+ PINI(5,1) = ELEM
+C photon 1
+ PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
+ PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
+ & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
+ IF(PT2.LT.0.D0) GOTO 175
+ PT = SQRT(PT2)
+ CALL PHO_SFECFE(SIF1,COF1)
+ P1(1) = COF1*PT
+ P1(2) = SIF1*PT
+ P1(3) = PP
+ P1(4) = EE1*Y1
+C outgoing electron 1
+ PFIN(1,1) = -P1(1)
+ PFIN(2,1) = -P1(2)
+ PFIN(3,1) = PINI(3,1)-P1(3)
+ PFIN(4,1) = PINI(4,1)-P1(4)
+ PFIN(5,1) = ELEM
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C photon 2
+ PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
+ PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
+ & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
+ IF(PT2.LT.0.D0) GOTO 175
+ PT = SQRT(PT2)
+ CALL PHO_SFECFE(SIF2,COF2)
+ P2(1) = COF2*PT
+ P2(2) = SIF2*PT
+ P2(3) = PP
+ P2(4) = EE2*Y2
+C outgoing electron 2
+ PFIN(1,2) = -P2(1)
+ PFIN(2,2) = -P2(2)
+ PFIN(3,2) = PINI(3,2)-P2(3)
+ PFIN(4,2) = PINI(4,2)-P2(4)
+ PFIN(5,2) = ELEM
+
+C precise ECMS cut
+
+ GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
+ GGECM = SQRT(GGECM2)
+
+C beam lepton detector acceptance
+
+C lepton tagger 1
+ CPFTHE = PFIN(3,1)/PFIN(4,1)
+ ITG1 = 0
+ IF(PFIN(4,1).GE.EEMIN1) THEN
+ IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
+ ENDIF
+
+C lepton tagger 2
+ CPFTHE = PFIN(3,2)/PFIN(4,2)
+ ITG2 = 0
+ IF(PFIN(4,2).GE.EEMIN2) THEN
+ IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
+ ENDIF
+
+C beam lepton taggers
+
+C anti-tag
+ IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
+ IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
+C tag
+ IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
+ IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
+C single-tag inclusive
+ IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
+ & GOTO 175
+C single-tag/anti-tag
+ IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
+ & GOTO 175
+
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+
+C photon helicities
+ IF(ISWMDL(10).GE.2) THEN
+ WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
+ WGHL = 2.D0*(1-Y1)
+ IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
+ IGHEL(1) = 1
+ ELSE
+ IGHEL(1) = 0
+ ENDIF
+ WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
+ WGHL = 2.D0*(1-Y2)
+ IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
+ IGHEL(2) = 1
+ ELSE
+ IGHEL(2) = 0
+ ENDIF
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHETRY(K) = IHETRY(K)+1
+ ELSE
+ IGHEL(1) = -1
+ IGHEL(2) = -1
+ ENDIF
+
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+
+ WGFX = 1.D0
+C reweight according to LO photon emission diagrams (Budnev et al.)
+ IF(IPAMDL(116).GE.1) THEN
+ CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
+ WGFX = FLXQPM/FLXAPP
+ if(WGFX.gt.1.D0) then
+ WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
+ & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
+ & Y1,Y2,Q2P1,Q2P2,GGECM
+ endif
+ ENDIF
+
+C event generation
+* IVWGHT(1) = 1
+* EVWGHT(1) = MAX(WGFX,1.D0)
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+ IF(ISWMDL(10).GE.2) THEN
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHEAC1(K) = IHEAC1(K)+1
+ ENDIF
+
+C reweight according to QPM model (e+e- collider only)
+ IF((KHDIR.GT.0).AND.
+ & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
+ CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
+ WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
+ IF(DT_RNDM(WG).GT.WG) GOTO 150
+ ELSE IF(IPAMDL(116).GE.1) THEN
+ IF(DT_RNDM(WG).GT.WGFX) GOTO 150
+ ENDIF
+
+C polar angle
+ PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
+ PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
+C azimuthal angle
+ PFPHI(1) = ATAN2(COF1,SIF1)
+ PFPHI(2) = ATAN2(COF2,SIF2)
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ AN1MIN = MIN(AN1MIN,PFTHE(1))
+ AN2MIN = MIN(AN2MIN,PFTHE(2))
+ AN1MAX = MAX(AN1MAX,PFTHE(1))
+ AN2MAX = MAX(AN2MAX,PFTHE(2))
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+ Q21AVE = Q21AVE+Q2P1
+ Q22AVE = Q22AVE+Q2P2
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ IF(ISWMDL(10).GE.2) THEN
+ K = 2*IGHEL(1)+IGHEL(2)+1
+ IHEAC2(K) = IHEAC2(K)+1
+ ENDIF
+
+C external histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+
+C final cross section calculation and event generation summary
+
+ else if(NEVENT.eq.-2) then
+
+* EVWGHT(1) = 1.D0
+* IVWGHT(1) = 0
+ DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
+ DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
+ WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
+ WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ Q21AVE = Q21AVE/DBLE(NITER)
+ Q21AV2 = Q21AV2/DBLE(NITER)
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
+ EE1 = WEIGHT
+ EE2 = SIGMAX*DBLE(NITER)/DITRY
+
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ & '=========================================================',
+ & ' ***** simulated cross section: ',WEIGHT,' mb *****',
+ & '========================================================='
+ WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
+ & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
+ & Q22MIN,Q22MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
+ & AN1MIN,AN1MAX
+ WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
+ & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
+
+ IF(ISWMDL(10).GE.2) THEN
+ WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
+ & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
+ & 'tried: ',IHETRY,
+ & 'accepted (1): ',IHEAC1,
+ & 'accepted (2): ',IHEAC2
+ ENDIF
+
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_GGEPEM: no output of histograms',NITER
+ ENDIF
+
+ endif
+
+ END
+
+CDECK ID>, PHO_WGEPEM
+ SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
+C**********************************************************************
+C
+C calculate cross section weights for
+C fully differential equivalent (improved) photon approximation
+C and/or
+C fully differential QPM model with exact one-photon exchange graphs
+C
+C (unpolarized lepton beams)
+C
+C input: IMODE 0 flux calculation only
+C 1 flux folded with QPM cross section
+C /POFSRC/ photon and electron momenta
+C /POPRCS/ process type
+C /POCKIN/ kinematics of hard scattering
+C
+C output: WGHAPP weight of event according to approximation
+C WGHQPM weight of event according to one-photon exchange
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION WGHAPP,WGHQPM
+ INTEGER IMODE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+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)
+
+ DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
+ & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
+ & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
+ & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
+ & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
+ & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+
+ INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
+
+ DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
+ DIMENSION HELFLX(6),SIGQPM(6)
+
+ WGHAPP = 1.D0
+ WGHQPM = 0.D0
+
+C strict pt cutoff after putting partons on mass shell,
+C calculated in gamma-gamma CMS
+ if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
+ if(PTfin.lt.PTwant) then
+ if(ipamdl(121).gt.1) return
+ if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
+ endif
+ endif
+
+C cross section of sampled event (approximate treatment)
+
+C photon flux
+ DO 50 K=1,2
+ XM2(K) = AMSRC(K)**2
+ IF(abs(IGHEL(K)).EQ.1) THEN
+ WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
+ & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
+ ELSE
+ WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
+ ENDIF
+ 50 CONTINUE
+
+ W2 = GGECM*GGECM
+ IDIR = 0
+ WGHQQ = 1.D0
+
+C direct or single-resolved gam-gam interaction
+ IF((IMODE.GE.1).AND.
+ & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
+ IDIR = 1
+ WGHQQ = 0.D0
+C determine final state partons
+ DO 100 I=3,NHEP
+ IF(ISTHEP(I).EQ.25) GOTO 110
+ 100 CONTINUE
+ WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
+ & 'inconsistent process information (MSPR)',MSPR
+ CALL PHO_ABORT
+ 110 CONTINUE
+ IPOS = I
+C final state flavors
+ IPFL1 = ABS(IDHEP(IPOS+3))
+ IPFL2 = ABS(IDHEP(IPOS+4))
+ SH = X1*X2*W2
+C calculate alpha-em
+ ALPHA1 = pho_alphae(QQAL)
+C calculate alpha-s
+ IF(MSPR.LT.14) THEN
+ ALPHA2 = PHO_ALPHAS(QQAL,3)
+ ENDIF
+C LO matrix element (8 pi s dsig/dt)
+* QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
+ QC2 = Q_ch2(IPFL2)
+ IF(IPFL2.EQ.0) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
+ & 'invalid hard process - flavor combination',
+ & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
+ ENDIF
+ IF(MSPR.EQ.10) THEN
+ WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.11) THEN
+ WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.12) THEN
+ WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.13) THEN
+ WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ELSE IF(MSPR.EQ.14) THEN
+ WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
+ & *8.D0*PI*SH
+ ENDIF
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+ WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
+
+C full leading-order QPM prediction (Budnev et al.)
+
+C full two-gamma flux
+
+ P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
+ & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
+ P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
+ & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
+ Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
+ & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
+ P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
+ & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
+ DO 120 I=1,4
+ P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
+ P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
+ 120 CONTINUE
+ XTM1 = 2.D0*P1Q2-Q1Q2
+ XTM2 = 2.D0*P2Q1-Q1Q2
+ XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
+ XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
+ YCAP = P1P2**2-XM2(1)*XM2(2)
+ CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
+
+ RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
+ RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
+ RHO100 = XTM1**2/XCAP-1.D0
+ RHO200 = XTM2**2/XCAP-1.D0
+ RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
+ RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
+ SS = 2.D0*P1P2+XM2(1)+XM2(2)
+
+ HELFLX(1) = 4.D0*RHO1PP*RHO2PP
+ HELFLX(2) = RHOPM2
+ HELFLX(3) = 2.D0*RHO1PP*RHO200
+ HELFLX(4) = 2.D0*RHO100*RHO2PP
+ HELFLX(5) = RHO100*RHO200
+ HELFLX(6) = -RHOP08
+
+C only flux calculation
+
+ IF(IDIR.EQ.0) THEN
+ IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
+ WEIGHT = HELFLX(1)
+ ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
+ WEIGHT = HELFLX(3)
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
+ WEIGHT = HELFLX(4)
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
+ WEIGHT = HELFLX(5)
+ ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
+ WEIGHT = HELFLX(1)
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
+ WEIGHT = 0.D0
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+ WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
+ & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
+
+ ELSE
+
+C flux folded with cross section
+C polarized, leading order gam gam --> q qbar cross sections
+
+ DO 125 I=1,6
+ SIGQPM(I) = 0.D0
+ 125 CONTINUE
+C momenta of produced parton pair
+ I1 = IPOS+3
+ I2 = IPOS+4
+ DO 150 K=1,4
+ XK1(K) = PHEP(K,I1)
+ XK2(K) = PHEP(K,I2)
+ 150 CONTINUE
+ XQ2 = PHEP(5,I2)**2
+
+ IF(MSPR.EQ.14) THEN
+C direct photon-photon interaction
+ XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
+ & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
+ & +(PGAM(3,1)-XK1(3))**2
+ XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
+ & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
+ & +(PGAM(3,1)-XK2(3))**2
+ CC = Q1Q2
+ AA = XKAP*XKAM-GQ2(1)*GQ2(2)
+ BB = CC**2-XKAP*XKAM
+ DD = CC**2-GQ2(1)*GQ2(2)
+ RR = -XQ2+W2*AA/(4.D0*DD)
+ Q1KK = Q1Q2-GQ2(1)
+ Q2KK = Q1Q2-GQ2(2)
+ FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
+
+ ELSE
+C single-resolved photon-hadron interactions
+C Mandelstam variables
+ IF(MSPR.LE.11) THEN
+ TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
+ & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
+ UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
+ & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
+ ELSE
+ TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
+ & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
+ UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
+ & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
+ ENDIF
+ V = TH/SH
+ U = UH/SH
+ ENDIF
+
+ WEIGHT = 0.D0
+ IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
+ IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
+ IF(MSPR.EQ.10) THEN
+ Q2 = -GQ2(1)
+ SP = SH-XQ2
+ TP = UH-XQ2
+ ELSE
+ Q2 = -GQ2(2)
+ SP = SH-XQ2
+ TP = TH-XQ2
+ ENDIF
+ SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
+ & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
+ & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
+ & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
+ & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
+ & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
+ & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
+ ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
+ IF(MSPR.EQ.11) THEN
+ Q2 = -GQ2(1)
+ ELSE
+ Q2 = -GQ2(2)
+ ENDIF
+ SP = SH
+ TP = UH
+ SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
+ & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
+ & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
+ & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
+ & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
+ & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
+ & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
+ & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
+ & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
+ & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
+ & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
+ & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
+ & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
+ & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
+ & (Q2-SP-TP+XQ2)**2)
+ WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
+ SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
+ SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
+ & -2.D0*XKAP*XKAM*AA
+ SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
+ SIGQPM(2) = SWPPMM*FAC
+ WEIGHT = HELFLX(1)*SIGQPM(1)
+ & +HELFLX(2)*SIGQPM(2)
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
+ IF(MSPR.EQ.12) THEN
+ Q2 = -GQ2(2)
+ SP = SH-XQ2
+ TP = TH-XQ2
+ SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
+ & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
+ & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
+ & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
+ & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
+ & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
+ & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.13) THEN
+ Q2 = -GQ2(2)
+ SP = SH
+ TP = TH
+ SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
+ & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
+ & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
+ WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
+ & -XKAP*XKAM*Q1KK**2)/DD
+ SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
+ SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
+ & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
+ SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SIGQPM(3) = SWP0P0*FAC
+ SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
+ WEIGHT = HELFLX(3)*SIGQPM(3)
+ & +HELFLX(6)*SIGQPM(6)/2.D0
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
+ IF(MSPR.EQ.10) THEN
+ Q2 = -GQ2(1)
+ SP = SH-XQ2
+ TP = UH-XQ2
+ SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
+ & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
+ & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
+ & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
+ & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
+ & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
+ & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
+ & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
+ WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
+ ELSE IF(MSPR.EQ.11) THEN
+ Q2 = -GQ2(1)
+ SP = SH
+ TP = TH
+ SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
+ & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
+ & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
+ WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
+ ELSE IF(MSPR.EQ.14) THEN
+ SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
+ & -XKAP*XKAM*Q2KK**2)/DD
+ SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
+ SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
+ & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
+ SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
+ & *SQRT(GQ2(1)*GQ2(2))/DD
+ SIGQPM(4) = SW0P0P*FAC
+ SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
+ WEIGHT = HELFLX(4)*SIGQPM(4)
+ & +HELFLX(6)*SIGQPM(6)/2.D0
+ ENDIF
+ ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
+ IF(MSPR.EQ.14) THEN
+ SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
+ SIGQPM(5) = SW0000*FAC
+ WEIGHT = HELFLX(5)*SIGQPM(5)
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
+ WEIGHT = 0.D0
+ ENDIF
+
+C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
+
+ WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
+ & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGBLSR
+ SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
+ & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
+C***********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via laser backscattering
+C
+C input: EE1 lab. system energy of electron/positron 1
+C EE2 lab. system energy of electron/positron 2
+C NEVENT number of events to generate
+C Pl_lam_1/2 product of electron and photon pol.
+C X_1/2 standard X parameter
+C rho ratio of distance to conversion point and
+C transverse beam size
+C A ellipticity of electon beam
+C
+C (see Ginzburg & Kotkin hep-ph/9905462)
+C
+C from /LEPCUT/:
+C YMIN1 lower limit of Y1
+C (energy fraction taken by photon from electron)
+C YMAX1 upper limit of Y1
+C YMIN2 lower limit of Y2
+C (energy fraction taken by photon from electron)
+C YMAX2 upper limit of Y2
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ parameter (N_dim=100)
+ dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
+ & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
+ & Xgrid(96),Wgrid(96)
+
+ DIMENSION P1(4),P2(4)
+
+ Pi2 = 2.D0*Pi
+
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
+
+ YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
+ YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
+ IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
+ WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
+ & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
+ RETURN
+ ENDIF
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+
+C initialize sampling
+
+ Max_tab = 50
+ DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
+ DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
+
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GGBLSR: table of photon flux ',Max_tab
+
+ DO 100 I=1,Max_tab
+
+ y1 = YMIN1+DELY1*DBLE(I-1)
+ r1 = y1/(X_1*(1.D0-y1))
+ X_inp_1(i) = y1
+ F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
+ & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
+
+ y2 = YMIN2+DELY2*DBLE(I-1)
+ r2 = y2/(X_2*(1.D0-y2))
+ X_inp_2(i) = y2
+ F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
+ & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
+
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
+ & y1,F_inp_1(i),y2,F_inp_2(i)
+
+ 100 CONTINUE
+
+ call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
+ call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
+
+C initialize event generator
+
+C photon 1
+ EGAM = YMAX1*EE1
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE2
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+
+ call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
+ call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
+
+ g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
+ g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
+ if(abs(1.D0-A).lt.1.D-3) then
+ v = rho**2/4.D0*g_1*g_2
+ Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
+ else
+ Nint = 16
+ call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
+ A2 = A**2
+ fac = rho**2/(4.D0*(1.D0+A2))
+ Wght = 0.D0
+ do i1=1,Nint
+ phi_1 = Xgrid(i1)
+ do i2=1,Nint
+ phi_2 = Xgrid(i2)
+ Wght = Wght
+ & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
+ & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
+ & *Wgrid(i1)*Wgrid(i2)
+ enddo
+ enddo
+ Wght = Wght/Pi2**2
+ endif
+
+ IF(Wght.GT.1.D0) THEN
+ WRITE(LO,'(1X,A,5E11.4)')
+ & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
+ ENDIF
+ IF(DT_RNDM(dum).GT.Wght) GOTO 175
+
+ Y1 = X_out_1
+ Y2 = X_out_2
+
+ Q2P1 = 0.D0
+ Q2P2 = 0.D0
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1
+ PINI(4,1) = EE1
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P2)
+ Q2E = Q2P1/(4.D0*EE1)
+ E1Y = EE1*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+
+ WGY = DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
+
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, pho_samp1d
+ SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
+C***********************************************************************
+C
+C Monte Carlo sampling from arbitrary 1d distribution
+C (linear interpolation to improve reproduction of initial function)
+C
+C input: Imode -1 initialization
+C 1 sampling (after initialization)
+C X_inp(N_dim) array with x values
+C F_inp(N_dim) array with function values
+C F_int(N_dim) array with integral
+C
+C output: X_out sampled value (Imode=1)
+C
+C (R.E. 10/99)
+C
+C***********************************************************************
+ implicit none
+ save
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer Imode,N_dim
+ double precision X_inp,F_inp,F_int,X_out
+ dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
+
+C local variables
+ integer i
+ double precision dum,xi,a,b
+
+C external functions
+ double precision DT_RNDM
+ external DT_RNDM
+
+ if(Imode.eq.-1) then
+
+C initialization
+
+ F_int(1) = 0.D0
+ do i=2,N_dim
+ F_int(i) = F_int(i-1)
+ & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
+ enddo
+
+ else if(Imode.eq.1) then
+
+C sample from previously calculated integral
+
+ xi = DT_RNDM(dum)*F_int(N_dim)
+
+ do i=2,N_dim
+ if(xi.lt.F_int(i)) then
+ a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
+ b = F_inp(i)-a*X_inp(i)
+ xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
+ X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
+ return
+ endif
+ enddo
+ X_out = X_inp(N_dim)
+
+ else
+
+C invalid option Imode
+
+ WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
+ X_out = 0.D0
+
+ endif
+
+ END
+
+CDECK ID>, pho_ExpBessI0
+ DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
+C**********************************************************************
+C
+C Bessel Function I0 times exponential function from neg. arg.
+C (defined for pos. arguments only)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ pho_ExpBessI0 =
+ & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
+ & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
+ ELSE
+ Y = 3.75D0/AX
+ pho_ExpBessI0 =
+ & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
+ & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
+ & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
+ & +Y*0.392377D-2))))))))
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGBEAM
+ SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via beamstrahlung
+C
+C input: EE LAB system energy of electron/positron
+C YPSI beamstrahlung parameter
+C SIGX,Y transverse bunch dimensions
+C SIGZ longitudinal bunch dimension
+C AEB number of electrons/positrons in a bunch
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1 lower limit of Y
+C (energy fraction taken by photon from electron)
+C YMAX1 upper cutoff for Y, necessary to avoid
+C underflows
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ PARAMETER (Max_tab=100)
+ DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
+
+C
+ WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
+C electron data
+ RE = 2.818D-12
+ ELEM = 0.512D-03
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+C table of flux function, log interpolation
+ IF(YPSI.LE.0.D0) THEN
+ YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
+ ENDIF
+ WRITE(LO,'(/1X,A,E12.4)')
+ & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
+ TT = 2.D0/3.D0
+ OT = 1.D0/3.D0
+C GAOT = DGAMMA(OT)
+ GAOT = 2.6789385347D0
+ AKAP = TT/YPSI
+ WW = 1.D0/(6.D0*SQRT(AKAP))
+ ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
+ & *YPSI/SQRT(1.D0+YPSI**TT)
+
+ YMIN = YMIN1
+ YMAX = MIN(YMAX1,0.9D0)
+ TABCU(0) = 0.D0
+ TABYL(0) = LOG(YMIN)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_GGBEAM: table of photon flux',Max_tab
+ DO 100 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
+ FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
+ & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
+ & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
+ TABCU(I) = TABCU(I-1)+FF*Y
+ TABYL(I) = LOG(Y)
+ FLUX = FLUX+Y*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
+ 100 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGBEAM: integrated flux (one side):',FLUX
+
+ EE1 = EE
+ EE2 = EE
+C photon 1
+ EGAM = YMAX*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ XI = DT_RNDM(AY1)*TABCU(Max_tab)
+ DO 110 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y1 = EXP(Y1)
+ GOTO 120
+ ENDIF
+ 110 CONTINUE
+ Y1 = YMAX
+ 120 CONTINUE
+ XI = DT_RNDM(AY2)*TABCU(Max_tab)
+ DO 130 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y2 = EXP(Y2)
+ GOTO 140
+ ENDIF
+ 130 CONTINUE
+ Y2 = YMAX
+ 140 CONTINUE
+
+ Q2P1 = 0.D0
+ Q2P2 = 0.D0
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE1
+ PINI(4,1) = EE1
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P2)
+ Q2E = Q2P1/(4.D0*EE1)
+ E1Y = EE1*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE2
+ PINI(4,2) = EE2
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE2)
+ E1Y = EE2*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+ GGECML = LOG(GGECM)
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,2I10)')
+ & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
+ WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGHIOF
+ SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via heavy ions (form factor approach)
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX1,2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C currently implemented approximation similar to:
+C E.Papageorgiu PhysLettB250(1990)155
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4),BIMP(2,2)
+
+C
+ WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
+ & '--------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+C correct Q2MAX1,2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(1) = HIMASS
+C kinematic limitations
+ YMI = (ECMIN/(2.D0*EE))**2
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
+ & Q2MAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
+ CALL PHO_ABORT
+ ENDIF
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX1
+ YMIN = YMIN1
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 100 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
+ YMAX1 = MIN(Y1,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX2
+ IF(YMI.GT.YMIN1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
+ YMIN1 = YMI
+ ENDIF
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX1
+ IF(YMI.GT.YMIN2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
+ YMIN2 = YMI
+ ENDIF
+C
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y1*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGHIOF: integrated flux (one side):',FLUX
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+C
+C photon 1
+ EGAM = YMAX1*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX2*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ ECFRAC = ECMIN**2/(4.D0*EE*EE)
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+C sample y1, y2
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ IF(Y1*Y2.LT.ECFRAC) GOTO 175
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) GOTO 175
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
+ & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
+ IF(WGMAX.LT.WGH) THEN
+ WRITE(LO,'(1X,A,4E12.5)')
+ & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
+ ENDIF
+ IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y1)**2
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(1) = 1.D0/SQRT(Q2P1)
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF21 = 1.D0
+ IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
+ FF22 = 1.D0
+ IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
+ IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
+C do the hadrons overlap?
+ IF(ISWMDL(26).GT.0) THEN
+ DO 190 K=1,2
+ CALL PHO_SFECFE(SIF,COF)
+ BIMP(1,K) = SIF*GAIMP(K)
+ BIMP(2,K) = COF*GAIMP(K)
+ 190 CONTINUE
+ BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
+ & +(BIMP(2,1)-BIMP(2,2))**2)
+ IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
+ ENDIF
+C photon data
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+C
+
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE
+ PINI(4,1) = EE
+ PINI(5,1) = 0.D0
+C outgoing hadron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P1)
+ Q2E = Q2P1/(4.D0*EE)
+ E1Y = EE*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+ PFPHI(1) = ATAN2(COF,SIF)
+ PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE
+ PINI(4,2) = EE
+ PINI(5,2) = 0.D0
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+ Q21AVE = Q21AVE+Q2P1
+ Q22AVE = Q22AVE+Q2P2
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
+ WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ Q21AVE = Q21AVE/DBLE(NITER)
+ Q21AV2 = Q21AV2/DBLE(NITER)
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
+ Q22AVE = Q22AVE/DBLE(NITER)
+ Q22AV2 = Q22AV2/DBLE(NITER)
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I10)')
+ & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGHIOG
+ SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-gamma collisions via heavy ions (geometrical approach)
+C
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C
+C currently implemented approximation similar to:
+C
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20,
+ & PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ PARAMETER (Max_tab=100)
+ DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
+
+C
+ WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
+ & '---------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(1) = HIMASS
+C kinematic limitations
+ YMI = (ECMIN/(2.D0*EE))**2
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDBSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(2) = 0
+C table of flux function, log interpolation
+ YMIN = YMIN1
+ YMAX = YMAX1
+ YMAX = MIN(YMAX,0.9999999D0)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABYL(0) = LOG(YMIN)
+ FFMAX = 0.D0
+ DO 100 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ IF(FF.LT.1.D-10*FFMAX) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
+ YMAX1 = MIN(Y,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMIN = YMIN2
+ YMAX = YMAX2
+ YMAX = MIN(YMAX,0.9999999D0)
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABYL(0) = LOG(YMIN)
+ FFMAX = 0.D0
+ DO 102 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ IF(FF.LT.1.D-10*FFMAX) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
+ YMAX2 = MIN(Y,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX2
+ IF(YMI.GT.YMIN1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
+ YMIN1 = YMI
+ ENDIF
+ YMAX1 = MIN(YMAX,YMAX1)
+ YMI = (ECMIN/(2.D0*EE))**2/YMAX1
+ IF(YMI.GT.YMIN2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
+ YMIN2 = YMI
+ ENDIF
+C
+ YMIN = YMIN1
+ YMAX = YMAX1
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ TABCU(0) = 0.D0
+ TABYL(0) = LOG(YMIN)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
+ WG = EE*Y
+ XI = WG*HIRADI/GAMMA
+ FF = ALPHA*PHO_GGFLCL(XI)/Y
+ FFMAX = MAX(FF,FFMAX)
+ TABCU(I) = TABCU(I-1)+FF*Y
+ TABYL(I) = LOG(Y)
+ FLUX = FLUX+Y*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GGHIOG: integrated flux (one side):',FLUX
+C
+C initialization
+C photon 1
+ EGAM = YMAX*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C photon 2
+ EGAM = YMAX*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+ ITRW = ITRW+1
+ XI = DT_RNDM(AY1)*TABCU(Max_tab)
+ DO 110 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y1 = EXP(Y1)
+ GOTO 120
+ ENDIF
+ 110 CONTINUE
+ Y1 = YMAX1
+ 120 CONTINUE
+ XI = DT_RNDM(AY2)*TABCU(Max_tab)
+ DO 130 K=1,Max_tab
+ IF(TABCU(K).GE.XI) THEN
+ Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
+ Y2 = EXP(Y2)
+ GOTO 140
+ ENDIF
+ 130 CONTINUE
+ Y2 = YMAX2
+ 140 CONTINUE
+C setup kinematics
+
+ GYY(1) = Y1
+ GQ2(1) = 0.D0
+ GYY(2) = Y2
+ GQ2(2) = 0.D0
+C incoming electron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = EE
+ PINI(4,1) = EE
+ PINI(5,1) = 0.D0
+C outgoing electron 1
+ E1Y = EE*(1.D0-Y1)
+ PFIN(1,1) = 0.D0
+ PFIN(2,1) = 0.D0
+ PFIN(3,1) = E1Y
+ PFIN(4,1) = E1Y
+ PFIN(5,1) = 0.D0
+C photon 1
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C incoming electron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -EE
+ PINI(4,2) = EE
+ PINI(5,2) = 0.D0
+C outgoing electron 2
+ E1Y = EE*(1.D0-Y2)
+ PFIN(1,2) = 0.D0
+ PFIN(2,2) = 0.D0
+ PFIN(3,2) = -E1Y
+ PFIN(4,2) = E1Y
+ PFIN(5,2) = 0.D0
+C photon 2
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = 0.D0
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = 0.D0
+C impact parameter constraints
+ XI1 = P1(4)*HIRADI/GAMMA
+ XI2 = P2(4)*HIRADI/GAMMA
+ FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
+ FCORR = PHO_GGFLCR(HIRADI)
+ WGX = (FLX-FCORR)/FLX
+ IF(DT_RNDM(Y2).GT.WGX) GOTO 175
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C cut given by user
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+
+C statistics
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY1MAX = MAX(YY1MAX,Y1)
+ YY2MAX = MAX(YY2MAX,Y2)
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
+ AY1 = AY1/DBLE(NITER)
+ AYS1 = AYS1/DBLE(NITER)
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
+ AY2 = AY2/DBLE(NITER)
+ AYS2 = AYS2/DBLE(NITER)
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,3I12)')
+ & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GGFLCL
+ DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
+C*********************************************************************
+C
+C semi-classical photon flux (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
+ & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
+
+ END
+
+CDECK ID>, PHO_GGFLCR
+ DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
+C*********************************************************************
+C
+C semi-classical photon flux correction due to
+C overlap in impact parameter space (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+
+ DIMENSION XGAUSS(126),WGAUSS(126)
+
+ DATA XGAUSS(1)/ .57735026918962576D0/
+ DATA XGAUSS(2)/-.57735026918962576D0/
+ DATA WGAUSS(1)/ 1.00000000000000000D0/
+ DATA WGAUSS(2)/ 1.00000000000000000D0/
+
+ DATA XGAUSS(3)/ .33998104358485627D0/
+ DATA XGAUSS(4)/ .86113631159405258D0/
+ DATA XGAUSS(5)/-.33998104358485627D0/
+ DATA XGAUSS(6)/-.86113631159405258D0/
+ DATA WGAUSS(3)/ .65214515486254613D0/
+ DATA WGAUSS(4)/ .34785484513745385D0/
+ DATA WGAUSS(5)/ .65214515486254613D0/
+ DATA WGAUSS(6)/ .34785484513745385D0/
+
+ DATA XGAUSS(7)/ .18343464249564981D0/
+ DATA XGAUSS(8)/ .52553240991632899D0/
+ DATA XGAUSS(9)/ .79666647741362674D0/
+ DATA XGAUSS(10)/ .96028985649753623D0/
+ DATA XGAUSS(11)/-.18343464249564981D0/
+ DATA XGAUSS(12)/-.52553240991632899D0/
+ DATA XGAUSS(13)/-.79666647741362674D0/
+ DATA XGAUSS(14)/-.96028985649753623D0/
+ DATA WGAUSS(7)/ .36268378337836198D0/
+ DATA WGAUSS(8)/ .31370664587788727D0/
+ DATA WGAUSS(9)/ .22238103445337448D0/
+ DATA WGAUSS(10)/ .10122853629037627D0/
+ DATA WGAUSS(11)/ .36268378337836198D0/
+ DATA WGAUSS(12)/ .31370664587788727D0/
+ DATA WGAUSS(13)/ .22238103445337448D0/
+ DATA WGAUSS(14)/ .10122853629037627D0/
+
+ DATA XGAUSS(15)/ .0950125098376374402D0/
+ DATA XGAUSS(16)/ .281603550779258913D0/
+ DATA XGAUSS(17)/ .458016777657227386D0/
+ DATA XGAUSS(18)/ .617876244402643748D0/
+ DATA XGAUSS(19)/ .755404408355003034D0/
+ DATA XGAUSS(20)/ .865631202387831744D0/
+ DATA XGAUSS(21)/ .944575023073232576D0/
+ DATA XGAUSS(22)/ .989400934991649933D0/
+ DATA XGAUSS(23)/-.0950125098376374402D0/
+ DATA XGAUSS(24)/-.281603550779258913D0/
+ DATA XGAUSS(25)/-.458016777657227386D0/
+ DATA XGAUSS(26)/-.617876244402643748D0/
+ DATA XGAUSS(27)/-.755404408355003034D0/
+ DATA XGAUSS(28)/-.865631202387831744D0/
+ DATA XGAUSS(29)/-.944575023073232576D0/
+ DATA XGAUSS(30)/-.989400934991649933D0/
+ DATA WGAUSS(15)/ .189450610455068496D0/
+ DATA WGAUSS(16)/ .182603415044923589D0/
+ DATA WGAUSS(17)/ .169156519395002538D0/
+ DATA WGAUSS(18)/ .149595988816576732D0/
+ DATA WGAUSS(19)/ .124628971255533872D0/
+ DATA WGAUSS(20)/ .0951585116824927848D0/
+ DATA WGAUSS(21)/ .0622535239386478929D0/
+ DATA WGAUSS(22)/ .0271524594117540949D0/
+ DATA WGAUSS(23)/ .189450610455068496D0/
+ DATA WGAUSS(24)/ .182603415044923589D0/
+ DATA WGAUSS(25)/ .169156519395002538D0/
+ DATA WGAUSS(26)/ .149595988816576732D0/
+ DATA WGAUSS(27)/ .124628971255533872D0/
+ DATA WGAUSS(28)/ .0951585116824927848D0/
+ DATA WGAUSS(29)/ .0622535239386478929D0/
+ DATA WGAUSS(30)/ .0271524594117540949D0/
+
+ DATA XGAUSS(31)/ .0483076656877383162D0/
+ DATA XGAUSS(32)/ .144471961582796493D0/
+ DATA XGAUSS(33)/ .239287362252137075D0/
+ DATA XGAUSS(34)/ .331868602282127650D0/
+ DATA XGAUSS(35)/ .421351276130635345D0/
+ DATA XGAUSS(36)/ .506899908932229390D0/
+ DATA XGAUSS(37)/ .587715757240762329D0/
+ DATA XGAUSS(38)/ .663044266930215201D0/
+ DATA XGAUSS(39)/ .732182118740289680D0/
+ DATA XGAUSS(40)/ .794483795967942407D0/
+ DATA XGAUSS(41)/ .849367613732569970D0/
+ DATA XGAUSS(42)/ .896321155766052124D0/
+ DATA XGAUSS(43)/ .934906075937739689D0/
+ DATA XGAUSS(44)/ .964762255587506430D0/
+ DATA XGAUSS(45)/ .985611511545268335D0/
+ DATA XGAUSS(46)/ .997263861849481564D0/
+ DATA XGAUSS(47)/-.0483076656877383162D0/
+ DATA XGAUSS(48)/-.144471961582796493D0/
+ DATA XGAUSS(49)/-.239287362252137075D0/
+ DATA XGAUSS(50)/-.331868602282127650D0/
+ DATA XGAUSS(51)/-.421351276130635345D0/
+ DATA XGAUSS(52)/-.506899908932229390D0/
+ DATA XGAUSS(53)/-.587715757240762329D0/
+ DATA XGAUSS(54)/-.663044266930215201D0/
+ DATA XGAUSS(55)/-.732182118740289680D0/
+ DATA XGAUSS(56)/-.794483795967942407D0/
+ DATA XGAUSS(57)/-.849367613732569970D0/
+ DATA XGAUSS(58)/-.896321155766052124D0/
+ DATA XGAUSS(59)/-.934906075937739689D0/
+ DATA XGAUSS(60)/-.964762255587506430D0/
+ DATA XGAUSS(61)/-.985611511545268335D0/
+ DATA XGAUSS(62)/-.997263861849481564D0/
+ DATA WGAUSS(31)/ .0965400885147278006D0/
+ DATA WGAUSS(32)/ .0956387200792748594D0/
+ DATA WGAUSS(33)/ .0938443990808045654D0/
+ DATA WGAUSS(34)/ .0911738786957638847D0/
+ DATA WGAUSS(35)/ .0876520930044038111D0/
+ DATA WGAUSS(36)/ .0833119242269467552D0/
+ DATA WGAUSS(37)/ .0781938957870703065D0/
+ DATA WGAUSS(38)/ .0723457941088485062D0/
+ DATA WGAUSS(39)/ .0658222227763618468D0/
+ DATA WGAUSS(40)/ .0586840934785355471D0/
+ DATA WGAUSS(41)/ .0509980592623761762D0/
+ DATA WGAUSS(42)/ .0428358980222266807D0/
+ DATA WGAUSS(43)/ .0342738629130214331D0/
+ DATA WGAUSS(44)/ .0253920653092620595D0/
+ DATA WGAUSS(45)/ .0162743947309056706D0/
+ DATA WGAUSS(46)/ .00701861000947009660D0/
+ DATA WGAUSS(47)/ .0965400885147278006D0/
+ DATA WGAUSS(48)/ .0956387200792748594D0/
+ DATA WGAUSS(49)/ .0938443990808045654D0/
+ DATA WGAUSS(50)/ .0911738786957638847D0/
+ DATA WGAUSS(51)/ .0876520930044038111D0/
+ DATA WGAUSS(52)/ .0833119242269467552D0/
+ DATA WGAUSS(53)/ .0781938957870703065D0/
+ DATA WGAUSS(54)/ .0723457941088485062D0/
+ DATA WGAUSS(55)/ .0658222227763618468D0/
+ DATA WGAUSS(56)/ .0586840934785355471D0/
+ DATA WGAUSS(57)/ .0509980592623761762D0/
+ DATA WGAUSS(58)/ .0428358980222266807D0/
+ DATA WGAUSS(59)/ .0342738629130214331D0/
+ DATA WGAUSS(60)/ .0253920653092620595D0/
+ DATA WGAUSS(61)/ .0162743947309056706D0/
+ DATA WGAUSS(62)/ .00701861000947009660D0/
+
+ DATA XGAUSS(63)/ .02435029266342443250D0/
+ DATA XGAUSS(64)/ .0729931217877990394D0/
+ DATA XGAUSS(65)/ .121462819296120554D0/
+ DATA XGAUSS(66)/ .169644420423992818D0/
+ DATA XGAUSS(67)/ .217423643740007084D0/
+ DATA XGAUSS(68)/ .264687162208767416D0/
+ DATA XGAUSS(69)/ .311322871990210956D0/
+ DATA XGAUSS(70)/ .357220158337668116D0/
+ DATA XGAUSS(71)/ .402270157963991604D0/
+ DATA XGAUSS(72)/ .446366017253464088D0/
+ DATA XGAUSS(73)/ .489403145707052957D0/
+ DATA XGAUSS(74)/ .531279464019894546D0/
+ DATA XGAUSS(75)/ .571895646202634034D0/
+ DATA XGAUSS(76)/ .611155355172393250D0/
+ DATA XGAUSS(77)/ .648965471254657340D0/
+ DATA XGAUSS(78)/ .685236313054233243D0/
+ DATA XGAUSS(79)/ .719881850171610827D0/
+ DATA XGAUSS(80)/ .752819907260531897D0/
+ DATA XGAUSS(81)/ .783972358943341408D0/
+ DATA XGAUSS(82)/ .813265315122797560D0/
+ DATA XGAUSS(83)/ .840629296252580363D0/
+ DATA XGAUSS(84)/ .865999398154092820D0/
+ DATA XGAUSS(85)/ .889315445995114106D0/
+ DATA XGAUSS(86)/ .910522137078502806D0/
+ DATA XGAUSS(87)/ .929569172131939576D0/
+ DATA XGAUSS(88)/ .946411374858402816D0/
+ DATA XGAUSS(89)/ .961008799652053719D0/
+ DATA XGAUSS(90)/ .973326827789910964D0/
+ DATA XGAUSS(91)/ .983336253884625957D0/
+ DATA XGAUSS(92)/ .991013371476744321D0/
+ DATA XGAUSS(93)/ .996340116771955279D0/
+ DATA XGAUSS(94)/ .999305041735772139D0/
+ DATA XGAUSS(95)/-.02435029266342443250D0/
+ DATA XGAUSS(96)/-.0729931217877990394D0/
+ DATA XGAUSS(97)/-.121462819296120554D0/
+ DATA XGAUSS(98)/-.169644420423992818D0/
+ DATA XGAUSS(99)/-.217423643740007084D0/
+ DATA XGAUSS(100)/-.264687162208767416D0/
+ DATA XGAUSS(101)/-.311322871990210956D0/
+ DATA XGAUSS(102)/-.357220158337668116D0/
+ DATA XGAUSS(103)/-.402270157963991604D0/
+ DATA XGAUSS(104)/-.446366017253464088D0/
+ DATA XGAUSS(105)/-.489403145707052957D0/
+ DATA XGAUSS(106)/-.531279464019894546D0/
+ DATA XGAUSS(107)/-.571895646202634034D0/
+ DATA XGAUSS(108)/-.611155355172393250D0/
+ DATA XGAUSS(109)/-.648965471254657340D0/
+ DATA XGAUSS(110)/-.685236313054233243D0/
+ DATA XGAUSS(111)/-.719881850171610827D0/
+ DATA XGAUSS(112)/-.752819907260531897D0/
+ DATA XGAUSS(113)/-.783972358943341408D0/
+ DATA XGAUSS(114)/-.813265315122797560D0/
+ DATA XGAUSS(115)/-.840629296252580363D0/
+ DATA XGAUSS(116)/-.865999398154092820D0/
+ DATA XGAUSS(117)/-.889315445995114106D0/
+ DATA XGAUSS(118)/-.910522137078502806D0/
+ DATA XGAUSS(119)/-.929569172131939576D0/
+ DATA XGAUSS(120)/-.946411374858402816D0/
+ DATA XGAUSS(121)/-.961008799652053719D0/
+ DATA XGAUSS(122)/-.973326827789910964D0/
+ DATA XGAUSS(123)/-.983336253884625957D0/
+ DATA XGAUSS(124)/-.991013371476744321D0/
+ DATA XGAUSS(125)/-.996340116771955279D0/
+ DATA XGAUSS(126)/-.999305041735772139D0/
+ DATA WGAUSS(63)/ .0486909570091397204D0/
+ DATA WGAUSS(64)/ .0485754674415034269D0/
+ DATA WGAUSS(65)/ .0483447622348029572D0/
+ DATA WGAUSS(66)/ .0479993885964583077D0/
+ DATA WGAUSS(67)/ .0475401657148303087D0/
+ DATA WGAUSS(68)/ .0469681828162100173D0/
+ DATA WGAUSS(69)/ .0462847965813144172D0/
+ DATA WGAUSS(70)/ .0454916279274181445D0/
+ DATA WGAUSS(71)/ .0445905581637565631D0/
+ DATA WGAUSS(72)/ .0435837245293234534D0/
+ DATA WGAUSS(73)/ .0424735151236535890D0/
+ DATA WGAUSS(74)/ .0412625632426235286D0/
+ DATA WGAUSS(75)/ .0399537411327203414D0/
+ DATA WGAUSS(76)/ .0385501531786156291D0/
+ DATA WGAUSS(77)/ .0370551285402400460D0/
+ DATA WGAUSS(78)/ .0354722132568823838D0/
+ DATA WGAUSS(79)/ .0338051618371416094D0/
+ DATA WGAUSS(80)/ .0320579283548515535D0/
+ DATA WGAUSS(81)/ .0302346570724024789D0/
+ DATA WGAUSS(82)/ .0283396726142594832D0/
+ DATA WGAUSS(83)/ .0263774697150546587D0/
+ DATA WGAUSS(84)/ .0243527025687108733D0/
+ DATA WGAUSS(85)/ .0222701738083832542D0/
+ DATA WGAUSS(86)/ .0201348231535302094D0/
+ DATA WGAUSS(87)/ .0179517157756973431D0/
+ DATA WGAUSS(88)/ .0157260304760247193D0/
+ DATA WGAUSS(89)/ .0134630478967186426D0/
+ DATA WGAUSS(90)/ .0111681394601311288D0/
+ DATA WGAUSS(91)/ .00884675982636394772D0/
+ DATA WGAUSS(92)/ .00650445796897836286D0/
+ DATA WGAUSS(93)/ .00414703326056246764D0/
+ DATA WGAUSS(94)/ .00178328072169643295D0/
+ DATA WGAUSS(95)/ .0486909570091397204D0/
+ DATA WGAUSS(96)/ .0485754674415034269D0/
+ DATA WGAUSS(97)/ .0483447622348029572D0/
+ DATA WGAUSS(98)/ .0479993885964583077D0/
+ DATA WGAUSS(99)/ .0475401657148303087D0/
+ DATA WGAUSS(100)/ .0469681828162100173D0/
+ DATA WGAUSS(101)/ .0462847965813144172D0/
+ DATA WGAUSS(102)/ .0454916279274181445D0/
+ DATA WGAUSS(103)/ .0445905581637565631D0/
+ DATA WGAUSS(104)/ .0435837245293234534D0/
+ DATA WGAUSS(105)/ .0424735151236535890D0/
+ DATA WGAUSS(106)/ .0412625632426235286D0/
+ DATA WGAUSS(107)/ .0399537411327203414D0/
+ DATA WGAUSS(108)/ .0385501531786156291D0/
+ DATA WGAUSS(109)/ .0370551285402400460D0/
+ DATA WGAUSS(110)/ .0354722132568823838D0/
+ DATA WGAUSS(111)/ .0338051618371416094D0/
+ DATA WGAUSS(112)/ .0320579283548515535D0/
+ DATA WGAUSS(113)/ .0302346570724024789D0/
+ DATA WGAUSS(114)/ .0283396726142594832D0/
+ DATA WGAUSS(115)/ .0263774697150546587D0/
+ DATA WGAUSS(116)/ .0243527025687108733D0/
+ DATA WGAUSS(117)/ .0222701738083832542D0/
+ DATA WGAUSS(118)/ .0201348231535302094D0/
+ DATA WGAUSS(119)/ .0179517157756973431D0/
+ DATA WGAUSS(120)/ .0157260304760247193D0/
+ DATA WGAUSS(121)/ .0134630478967186426D0/
+ DATA WGAUSS(122)/ .0111681394601311288D0/
+ DATA WGAUSS(123)/ .00884675982636394772D0/
+ DATA WGAUSS(124)/ .00650445796897836286D0/
+ DATA WGAUSS(125)/ .00414703326056246764D0/
+ DATA WGAUSS(126)/ .00178328072169643295D0/
+
+C integrate first over b1
+C
+C Loop incrementing the boundary
+C
+ tmin = 0.D0
+ tmax = 0.25D0
+ Sum = 0.D0
+
+ 50 CONTINUE
+
+C
+C Loop for the Gauss integration
+C
+ XINT=0.D0
+ DO 100 N=1,6
+ XINT2 = XINT
+ XINT=0.D0
+ DO 200 I=2**N-1,2**(N+1)-2
+ t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
+ b1 = RADSRC(1) * EXP (t)
+ XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
+ 200 CONTINUE
+ XINT = (tmax-tmin)/2.D0*XINT
+ IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
+ 100 CONTINUE
+ WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
+ 300 CONTINUE
+
+ Sum = Sum + XINT
+ IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
+ tmin = tmax
+ tmax = tmax + 0.5D0
+ GOTO 50
+ ENDIF
+
+ PHO_GGFLCR = 4.D0*Pi * Sum
+
+ END
+
+CDECK ID>, PHO_GGFAUX
+ DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
+C*********************************************************************
+C
+C auxiliary function for integration over b2,
+C semi-classical photon flux correction due to
+C overlap in impact parameter space (geometrical model)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+
+ DIMENSION XGAUSS(126),WGAUSS(126)
+
+ DATA XGAUSS(1)/ .57735026918962576D0/
+ DATA XGAUSS(2)/-.57735026918962576D0/
+ DATA WGAUSS(1)/ 1.00000000000000000D0/
+ DATA WGAUSS(2)/ 1.00000000000000000D0/
+
+ DATA XGAUSS(3)/ .33998104358485627D0/
+ DATA XGAUSS(4)/ .86113631159405258D0/
+ DATA XGAUSS(5)/-.33998104358485627D0/
+ DATA XGAUSS(6)/-.86113631159405258D0/
+ DATA WGAUSS(3)/ .65214515486254613D0/
+ DATA WGAUSS(4)/ .34785484513745385D0/
+ DATA WGAUSS(5)/ .65214515486254613D0/
+ DATA WGAUSS(6)/ .34785484513745385D0/
+
+ DATA XGAUSS(7)/ .18343464249564981D0/
+ DATA XGAUSS(8)/ .52553240991632899D0/
+ DATA XGAUSS(9)/ .79666647741362674D0/
+ DATA XGAUSS(10)/ .96028985649753623D0/
+ DATA XGAUSS(11)/-.18343464249564981D0/
+ DATA XGAUSS(12)/-.52553240991632899D0/
+ DATA XGAUSS(13)/-.79666647741362674D0/
+ DATA XGAUSS(14)/-.96028985649753623D0/
+ DATA WGAUSS(7)/ .36268378337836198D0/
+ DATA WGAUSS(8)/ .31370664587788727D0/
+ DATA WGAUSS(9)/ .22238103445337448D0/
+ DATA WGAUSS(10)/ .10122853629037627D0/
+ DATA WGAUSS(11)/ .36268378337836198D0/
+ DATA WGAUSS(12)/ .31370664587788727D0/
+ DATA WGAUSS(13)/ .22238103445337448D0/
+ DATA WGAUSS(14)/ .10122853629037627D0/
+
+ DATA XGAUSS(15)/ .0950125098376374402D0/
+ DATA XGAUSS(16)/ .281603550779258913D0/
+ DATA XGAUSS(17)/ .458016777657227386D0/
+ DATA XGAUSS(18)/ .617876244402643748D0/
+ DATA XGAUSS(19)/ .755404408355003034D0/
+ DATA XGAUSS(20)/ .865631202387831744D0/
+ DATA XGAUSS(21)/ .944575023073232576D0/
+ DATA XGAUSS(22)/ .989400934991649933D0/
+ DATA XGAUSS(23)/-.0950125098376374402D0/
+ DATA XGAUSS(24)/-.281603550779258913D0/
+ DATA XGAUSS(25)/-.458016777657227386D0/
+ DATA XGAUSS(26)/-.617876244402643748D0/
+ DATA XGAUSS(27)/-.755404408355003034D0/
+ DATA XGAUSS(28)/-.865631202387831744D0/
+ DATA XGAUSS(29)/-.944575023073232576D0/
+ DATA XGAUSS(30)/-.989400934991649933D0/
+ DATA WGAUSS(15)/ .189450610455068496D0/
+ DATA WGAUSS(16)/ .182603415044923589D0/
+ DATA WGAUSS(17)/ .169156519395002538D0/
+ DATA WGAUSS(18)/ .149595988816576732D0/
+ DATA WGAUSS(19)/ .124628971255533872D0/
+ DATA WGAUSS(20)/ .0951585116824927848D0/
+ DATA WGAUSS(21)/ .0622535239386478929D0/
+ DATA WGAUSS(22)/ .0271524594117540949D0/
+ DATA WGAUSS(23)/ .189450610455068496D0/
+ DATA WGAUSS(24)/ .182603415044923589D0/
+ DATA WGAUSS(25)/ .169156519395002538D0/
+ DATA WGAUSS(26)/ .149595988816576732D0/
+ DATA WGAUSS(27)/ .124628971255533872D0/
+ DATA WGAUSS(28)/ .0951585116824927848D0/
+ DATA WGAUSS(29)/ .0622535239386478929D0/
+ DATA WGAUSS(30)/ .0271524594117540949D0/
+
+ DATA XGAUSS(31)/ .0483076656877383162D0/
+ DATA XGAUSS(32)/ .144471961582796493D0/
+ DATA XGAUSS(33)/ .239287362252137075D0/
+ DATA XGAUSS(34)/ .331868602282127650D0/
+ DATA XGAUSS(35)/ .421351276130635345D0/
+ DATA XGAUSS(36)/ .506899908932229390D0/
+ DATA XGAUSS(37)/ .587715757240762329D0/
+ DATA XGAUSS(38)/ .663044266930215201D0/
+ DATA XGAUSS(39)/ .732182118740289680D0/
+ DATA XGAUSS(40)/ .794483795967942407D0/
+ DATA XGAUSS(41)/ .849367613732569970D0/
+ DATA XGAUSS(42)/ .896321155766052124D0/
+ DATA XGAUSS(43)/ .934906075937739689D0/
+ DATA XGAUSS(44)/ .964762255587506430D0/
+ DATA XGAUSS(45)/ .985611511545268335D0/
+ DATA XGAUSS(46)/ .997263861849481564D0/
+ DATA XGAUSS(47)/-.0483076656877383162D0/
+ DATA XGAUSS(48)/-.144471961582796493D0/
+ DATA XGAUSS(49)/-.239287362252137075D0/
+ DATA XGAUSS(50)/-.331868602282127650D0/
+ DATA XGAUSS(51)/-.421351276130635345D0/
+ DATA XGAUSS(52)/-.506899908932229390D0/
+ DATA XGAUSS(53)/-.587715757240762329D0/
+ DATA XGAUSS(54)/-.663044266930215201D0/
+ DATA XGAUSS(55)/-.732182118740289680D0/
+ DATA XGAUSS(56)/-.794483795967942407D0/
+ DATA XGAUSS(57)/-.849367613732569970D0/
+ DATA XGAUSS(58)/-.896321155766052124D0/
+ DATA XGAUSS(59)/-.934906075937739689D0/
+ DATA XGAUSS(60)/-.964762255587506430D0/
+ DATA XGAUSS(61)/-.985611511545268335D0/
+ DATA XGAUSS(62)/-.997263861849481564D0/
+ DATA WGAUSS(31)/ .0965400885147278006D0/
+ DATA WGAUSS(32)/ .0956387200792748594D0/
+ DATA WGAUSS(33)/ .0938443990808045654D0/
+ DATA WGAUSS(34)/ .0911738786957638847D0/
+ DATA WGAUSS(35)/ .0876520930044038111D0/
+ DATA WGAUSS(36)/ .0833119242269467552D0/
+ DATA WGAUSS(37)/ .0781938957870703065D0/
+ DATA WGAUSS(38)/ .0723457941088485062D0/
+ DATA WGAUSS(39)/ .0658222227763618468D0/
+ DATA WGAUSS(40)/ .0586840934785355471D0/
+ DATA WGAUSS(41)/ .0509980592623761762D0/
+ DATA WGAUSS(42)/ .0428358980222266807D0/
+ DATA WGAUSS(43)/ .0342738629130214331D0/
+ DATA WGAUSS(44)/ .0253920653092620595D0/
+ DATA WGAUSS(45)/ .0162743947309056706D0/
+ DATA WGAUSS(46)/ .00701861000947009660D0/
+ DATA WGAUSS(47)/ .0965400885147278006D0/
+ DATA WGAUSS(48)/ .0956387200792748594D0/
+ DATA WGAUSS(49)/ .0938443990808045654D0/
+ DATA WGAUSS(50)/ .0911738786957638847D0/
+ DATA WGAUSS(51)/ .0876520930044038111D0/
+ DATA WGAUSS(52)/ .0833119242269467552D0/
+ DATA WGAUSS(53)/ .0781938957870703065D0/
+ DATA WGAUSS(54)/ .0723457941088485062D0/
+ DATA WGAUSS(55)/ .0658222227763618468D0/
+ DATA WGAUSS(56)/ .0586840934785355471D0/
+ DATA WGAUSS(57)/ .0509980592623761762D0/
+ DATA WGAUSS(58)/ .0428358980222266807D0/
+ DATA WGAUSS(59)/ .0342738629130214331D0/
+ DATA WGAUSS(60)/ .0253920653092620595D0/
+ DATA WGAUSS(61)/ .0162743947309056706D0/
+ DATA WGAUSS(62)/ .00701861000947009660D0/
+
+ DATA XGAUSS(63)/ .02435029266342443250D0/
+ DATA XGAUSS(64)/ .0729931217877990394D0/
+ DATA XGAUSS(65)/ .121462819296120554D0/
+ DATA XGAUSS(66)/ .169644420423992818D0/
+ DATA XGAUSS(67)/ .217423643740007084D0/
+ DATA XGAUSS(68)/ .264687162208767416D0/
+ DATA XGAUSS(69)/ .311322871990210956D0/
+ DATA XGAUSS(70)/ .357220158337668116D0/
+ DATA XGAUSS(71)/ .402270157963991604D0/
+ DATA XGAUSS(72)/ .446366017253464088D0/
+ DATA XGAUSS(73)/ .489403145707052957D0/
+ DATA XGAUSS(74)/ .531279464019894546D0/
+ DATA XGAUSS(75)/ .571895646202634034D0/
+ DATA XGAUSS(76)/ .611155355172393250D0/
+ DATA XGAUSS(77)/ .648965471254657340D0/
+ DATA XGAUSS(78)/ .685236313054233243D0/
+ DATA XGAUSS(79)/ .719881850171610827D0/
+ DATA XGAUSS(80)/ .752819907260531897D0/
+ DATA XGAUSS(81)/ .783972358943341408D0/
+ DATA XGAUSS(82)/ .813265315122797560D0/
+ DATA XGAUSS(83)/ .840629296252580363D0/
+ DATA XGAUSS(84)/ .865999398154092820D0/
+ DATA XGAUSS(85)/ .889315445995114106D0/
+ DATA XGAUSS(86)/ .910522137078502806D0/
+ DATA XGAUSS(87)/ .929569172131939576D0/
+ DATA XGAUSS(88)/ .946411374858402816D0/
+ DATA XGAUSS(89)/ .961008799652053719D0/
+ DATA XGAUSS(90)/ .973326827789910964D0/
+ DATA XGAUSS(91)/ .983336253884625957D0/
+ DATA XGAUSS(92)/ .991013371476744321D0/
+ DATA XGAUSS(93)/ .996340116771955279D0/
+ DATA XGAUSS(94)/ .999305041735772139D0/
+ DATA XGAUSS(95)/-.02435029266342443250D0/
+ DATA XGAUSS(96)/-.0729931217877990394D0/
+ DATA XGAUSS(97)/-.121462819296120554D0/
+ DATA XGAUSS(98)/-.169644420423992818D0/
+ DATA XGAUSS(99)/-.217423643740007084D0/
+ DATA XGAUSS(100)/-.264687162208767416D0/
+ DATA XGAUSS(101)/-.311322871990210956D0/
+ DATA XGAUSS(102)/-.357220158337668116D0/
+ DATA XGAUSS(103)/-.402270157963991604D0/
+ DATA XGAUSS(104)/-.446366017253464088D0/
+ DATA XGAUSS(105)/-.489403145707052957D0/
+ DATA XGAUSS(106)/-.531279464019894546D0/
+ DATA XGAUSS(107)/-.571895646202634034D0/
+ DATA XGAUSS(108)/-.611155355172393250D0/
+ DATA XGAUSS(109)/-.648965471254657340D0/
+ DATA XGAUSS(110)/-.685236313054233243D0/
+ DATA XGAUSS(111)/-.719881850171610827D0/
+ DATA XGAUSS(112)/-.752819907260531897D0/
+ DATA XGAUSS(113)/-.783972358943341408D0/
+ DATA XGAUSS(114)/-.813265315122797560D0/
+ DATA XGAUSS(115)/-.840629296252580363D0/
+ DATA XGAUSS(116)/-.865999398154092820D0/
+ DATA XGAUSS(117)/-.889315445995114106D0/
+ DATA XGAUSS(118)/-.910522137078502806D0/
+ DATA XGAUSS(119)/-.929569172131939576D0/
+ DATA XGAUSS(120)/-.946411374858402816D0/
+ DATA XGAUSS(121)/-.961008799652053719D0/
+ DATA XGAUSS(122)/-.973326827789910964D0/
+ DATA XGAUSS(123)/-.983336253884625957D0/
+ DATA XGAUSS(124)/-.991013371476744321D0/
+ DATA XGAUSS(125)/-.996340116771955279D0/
+ DATA XGAUSS(126)/-.999305041735772139D0/
+ DATA WGAUSS(63)/ .0486909570091397204D0/
+ DATA WGAUSS(64)/ .0485754674415034269D0/
+ DATA WGAUSS(65)/ .0483447622348029572D0/
+ DATA WGAUSS(66)/ .0479993885964583077D0/
+ DATA WGAUSS(67)/ .0475401657148303087D0/
+ DATA WGAUSS(68)/ .0469681828162100173D0/
+ DATA WGAUSS(69)/ .0462847965813144172D0/
+ DATA WGAUSS(70)/ .0454916279274181445D0/
+ DATA WGAUSS(71)/ .0445905581637565631D0/
+ DATA WGAUSS(72)/ .0435837245293234534D0/
+ DATA WGAUSS(73)/ .0424735151236535890D0/
+ DATA WGAUSS(74)/ .0412625632426235286D0/
+ DATA WGAUSS(75)/ .0399537411327203414D0/
+ DATA WGAUSS(76)/ .0385501531786156291D0/
+ DATA WGAUSS(77)/ .0370551285402400460D0/
+ DATA WGAUSS(78)/ .0354722132568823838D0/
+ DATA WGAUSS(79)/ .0338051618371416094D0/
+ DATA WGAUSS(80)/ .0320579283548515535D0/
+ DATA WGAUSS(81)/ .0302346570724024789D0/
+ DATA WGAUSS(82)/ .0283396726142594832D0/
+ DATA WGAUSS(83)/ .0263774697150546587D0/
+ DATA WGAUSS(84)/ .0243527025687108733D0/
+ DATA WGAUSS(85)/ .0222701738083832542D0/
+ DATA WGAUSS(86)/ .0201348231535302094D0/
+ DATA WGAUSS(87)/ .0179517157756973431D0/
+ DATA WGAUSS(88)/ .0157260304760247193D0/
+ DATA WGAUSS(89)/ .0134630478967186426D0/
+ DATA WGAUSS(90)/ .0111681394601311288D0/
+ DATA WGAUSS(91)/ .00884675982636394772D0/
+ DATA WGAUSS(92)/ .00650445796897836286D0/
+ DATA WGAUSS(93)/ .00414703326056246764D0/
+ DATA WGAUSS(94)/ .00178328072169643295D0/
+ DATA WGAUSS(95)/ .0486909570091397204D0/
+ DATA WGAUSS(96)/ .0485754674415034269D0/
+ DATA WGAUSS(97)/ .0483447622348029572D0/
+ DATA WGAUSS(98)/ .0479993885964583077D0/
+ DATA WGAUSS(99)/ .0475401657148303087D0/
+ DATA WGAUSS(100)/ .0469681828162100173D0/
+ DATA WGAUSS(101)/ .0462847965813144172D0/
+ DATA WGAUSS(102)/ .0454916279274181445D0/
+ DATA WGAUSS(103)/ .0445905581637565631D0/
+ DATA WGAUSS(104)/ .0435837245293234534D0/
+ DATA WGAUSS(105)/ .0424735151236535890D0/
+ DATA WGAUSS(106)/ .0412625632426235286D0/
+ DATA WGAUSS(107)/ .0399537411327203414D0/
+ DATA WGAUSS(108)/ .0385501531786156291D0/
+ DATA WGAUSS(109)/ .0370551285402400460D0/
+ DATA WGAUSS(110)/ .0354722132568823838D0/
+ DATA WGAUSS(111)/ .0338051618371416094D0/
+ DATA WGAUSS(112)/ .0320579283548515535D0/
+ DATA WGAUSS(113)/ .0302346570724024789D0/
+ DATA WGAUSS(114)/ .0283396726142594832D0/
+ DATA WGAUSS(115)/ .0263774697150546587D0/
+ DATA WGAUSS(116)/ .0243527025687108733D0/
+ DATA WGAUSS(117)/ .0222701738083832542D0/
+ DATA WGAUSS(118)/ .0201348231535302094D0/
+ DATA WGAUSS(119)/ .0179517157756973431D0/
+ DATA WGAUSS(120)/ .0157260304760247193D0/
+ DATA WGAUSS(121)/ .0134630478967186426D0/
+ DATA WGAUSS(122)/ .0111681394601311288D0/
+ DATA WGAUSS(123)/ .00884675982636394772D0/
+ DATA WGAUSS(124)/ .00650445796897836286D0/
+ DATA WGAUSS(125)/ .00414703326056246764D0/
+ DATA WGAUSS(126)/ .00178328072169643295D0/
+C
+ W1 = PGAM(4,1)
+ W2 = PGAM(4,2)
+ bmin = b1 - 2.D0*RADSRC(1)
+ IF (RADSRC(1) .GT. bmin) THEN
+ bmin = RADSRC(1)
+ ENDIF
+ bmax = b1 + 2.D0 * RADSRC(1)
+
+ XINT = 0.D0
+ DO 100 N=1,6
+ XINT2 = XINT
+ XINT = 0.D0
+ DO 200 I=2**N-1,2**(N+1)-2
+ b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
+ XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
+ & * PHO_GGFNUC(W2,b2,GAMSRC(2))
+ & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
+ XINT = XINT +WGAUSS(I) * b2 * XINT3
+ 200 CONTINUE
+ XINT = (bmax-bmin)/2.D0*XINT
+ IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
+ 100 CONTINUE
+ WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
+ 300 CONTINUE
+
+ PHO_GGFAUX = XINT
+
+ END
+
+CDECK ID>, PHO_GGFNUC
+ DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
+C**********************************************************************
+C
+C differential photonnumber for a nucleus (geometrical model)
+C (without form factor)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (PI = 3.14159265359D0)
+
+ WGamma = W/Gamma
+ Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
+
+ PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
+
+ END
+
+CDECK ID>, PHO_GHHIOF
+ SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-hadron collisions in heavy ion collisions
+C (form factor approach)
+C
+C input: EEN LAB system energy per nucleon
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN1,2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX1,2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX1,2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+ DIMENSION NITERS(2),ITRW(2)
+
+ WRITE(LO,'(2(/1X,A))')
+ & 'PHO_GHHIOF: gamma-hadron event generation',
+ & '-----------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+ AMP = 0.938D0
+ AMP2 = AMP**2
+C correct Q2MAX1,2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(1) = GAMMA
+ GAMSRC(2) = GAMMA
+ RADSRC(1) = HIRADI
+ RADSRC(2) = HIRADI
+ AMSRC(1) = HIMASS
+ AMSRC(2) = HIMASS
+C check cuts on photon-hadron mass
+ IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
+ YMI = ECMIN
+ ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
+ ENDIF
+C check kinematic limitations
+ YMI = ECMIN**2/(4.D0*EE*EEN)
+ IF(YMIN1.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
+ YMIN1 = YMI
+ ELSE IF(YMIN1.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
+ & ' INSTEAD OF',YMIN1
+ ENDIF
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
+ & Q2MAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
+ & YMAX1
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*EEN,2.D0*EE
+ WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
+ & ECMAX
+ WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
+ & PARMDL(175)
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
+ CALL PHO_ABORT
+ ENDIF
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX1
+ YMIN = YMIN1
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 100 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
+ YMAX1 = MIN(Y1,YMAX1)
+ GOTO 101
+ ENDIF
+ 100 CONTINUE
+ 101 CONTINUE
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+C
+ X1MAX = LOG(YMAX1)
+ X1MIN = LOG(YMIN1)
+ X1DEL = X1MAX-X1MIN
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
+ DO 105 I=1,Max_tab
+ Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
+ FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y1*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GHHIOF: integrated flux (one side):',FLUX
+C
+C photon
+ EGAM = MAX(YMAX1,YMAX2)*EE
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = EGAM
+ P1(4) = EGAM
+C hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+ CALL PHO_SETPAR(1,22,0,0.D0)
+ CALL PHO_SETPAR(2,2212,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+C
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y1 = YMIN1
+ Y2 = YMIN2
+ WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
+ WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+C
+ IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
+ IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
+C
+ FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
+ & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
+C
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q21MIN = 1.D30
+ Q22MIN = 1.D30
+ Q21MAX = 0.D0
+ Q22MAX = 0.D0
+ Q21AVE = 0.D0
+ Q22AVE = 0.D0
+ Q21AV2 = 0.D0
+ Q22AV2 = 0.D0
+ YY1MIN = 1.D30
+ YY2MIN = 1.D30
+ YY1MAX = 0.D0
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ NITERS(1) = 0
+ NITERS(2) = 0
+ ITRY = 0
+ ITRW(1) = 0
+ ITRW(2) = 0
+ DO 200 I=1,NITER
+C sample y1, y2
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+C
+C select side of photon emission
+ IF(DT_RNDM(AY1).LT.FAC12) THEN
+ ITRW(1) = ITRW(1)+1
+C select Y1
+ Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
+ Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
+ IF(Q2LOW1.GE.Q2MAX1) GOTO 175
+ Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
+ WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
+ & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
+ IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
+ IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y1)**2
+ 185 CONTINUE
+ Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
+ ELSE
+ Q2P1 = Q2LOW1
+ ENDIF
+C impact parameter
+ GAIMP(1) = 1.D0/SQRT(Q2P1)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
+C photon data
+ GYY(1) = Y1
+ GQ2(1) = Q2P1
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EE**2-AMP2)
+ PINI(4,1) = EE
+ PINI(5,1) = AMP
+C outgoing hadron 1
+ YQ2 = SQRT((1.D0-Y1)*Q2P1)
+ Q2E = Q2P1/(4.D0*EE)
+ E1Y = EE*(1.D0-Y1)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,1) = YQ2*COF
+ PFIN(2,1) = YQ2*SIF
+ PFIN(3,1) = E1Y-Q2E
+ PFIN(4,1) = E1Y+Q2E
+ PFIN(5,1) = 0.D0
+ PFPHI(1) = ATAN2(COF,SIF)
+ PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C scattering photon
+ P1(1) = -PFIN(1,1)
+ P1(2) = -PFIN(2,1)
+ P1(3) = PINI(3,1)-PFIN(3,1)
+ P1(4) = PINI(4,1)-PFIN(4,1)
+C scattering hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+ ISIDE = 1
+C
+ ELSE
+C
+ ITRW(2) = ITRW(2)+1
+C select Y2
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+ IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
+ IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
+C photon data
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EE**2-AMP2)
+ PINI(4,1) = EE
+ PINI(5,1) = AMP
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C scattering hadron
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = SQRT(EEN**2-AMP2)
+ P2(4) = EEN
+C scattering photon
+ P1(1) = -PFIN(1,2)
+ P1(2) = -PFIN(2,2)
+ P1(3) = PINI(3,2)-PFIN(3,2)
+ P1(4) = PINI(4,2)-PFIN(4,2)
+ ISIDE = 2
+ ENDIF
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = -SQRT(Q2P1)
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+ CALL PHO_PRESEL(5,IREJ)
+C photon helicities
+ IGHEL(1) = 1
+ IGHEL(2) = 1
+C user cuts
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+C cut on diffractive mass
+ DO 250 K=1,NHEP
+ IF(ISTHEP(K).EQ.30) THEN
+ GHDIFF = PHEP(1,K)
+ IF(GHDIFF.GE.PARMDL(175)) THEN
+ GOTO 251
+ ELSE
+ GOTO 150
+ ENDIF
+ ENDIF
+ 250 CONTINUE
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_GHHIOF: no diffractive entry found'
+ CALL PHO_PREVNT(-1)
+ GOTO 150
+ 251 CONTINUE
+C remove quasi-elastically scattered hadron
+ DO 260 K=1,NHEP
+ IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
+ XF = ABS(PHEP(3,K)/EEN)
+ IF(XF.LT.PARMDL(72)) GOTO 150
+* ISTHEP(K) = 2
+ GOTO 261
+ ENDIF
+ 260 CONTINUE
+ 261 CONTINUE
+C
+C statistics
+
+ NITERS(ISIDE) = NITERS(ISIDE)+1
+ IF(ISIDE.EQ.1) THEN
+
+ AY1 = AY1+Y1
+ AYS1 = AYS1+Y1*Y1
+ Q21AVE = Q21AVE+Q2P1
+ Q21AV2 = Q21AV2+Q2P1*Q2P1
+ Q21MIN = MIN(Q21MIN,Q2P1)
+ Q21MAX = MAX(Q21MAX,Q2P1)
+ YY1MIN = MIN(YY1MIN,Y1)
+ YY1MAX = MAX(YY1MAX,Y1)
+ ELSE
+
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q22AVE = Q22AVE+Q2P2
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY2MAX = MAX(YY2MAX,Y2)
+ ENDIF
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
+ WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
+ WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
+ AY1 = AY1/DBLE(MAX(NITERS(1),1))
+ AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
+ DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
+ AY2 = AY2/DBLE(MAX(NITERS(2),1))
+ AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
+ Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
+ Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
+ Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
+ Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
+ Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
+ WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,/3X,6I12)')
+ & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
+ & NITER,NITERS,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
+ & AY1,DAY1
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
+ & YY1MIN,YY1MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
+ & Q21AVE,Q21AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
+ & Q21MIN,Q21MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GHHIAS
+ SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
+C**********************************************************************
+C
+C interface to call PHOJET (variable energy run) for
+C gamma-hadron collisions in heavy ion - hadron
+C collisions (form factor approach)
+C
+C input: EEP LAB system energy of proton (GeV)
+C EEN LAB system energy per nucleon (GeV)
+C NA atomic number of ion/hadron
+C NZ charge number of ion/hadron
+C NEVENT number of events to generate
+C from /LEPCUT/:
+C YMIN2 lower limit of Y
+C (energy fraction taken by photon from hadron)
+C YMAX2 upper cutoff for Y, necessary to avoid
+C underflows
+C Q2MIN2 minimum Q**2 of photons (should be set to 0)
+C Q2MAX2 maximum Q**2 of photons (if necessary,
+C corrected according size of hadron)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI = 3.14159265359D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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
+C photon flux kinematics and cuts
+ DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2
+ INTEGER ITAG1,ITAG2
+ COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
+ & YMIN1,YMAX1,YMIN2,YMAX2,
+ & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
+ & THMIN1,THMAX1,THMIN2,THMAX2,
+ & ITAG1,ITAG2
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION P1(4),P2(4)
+
+ WRITE(LO,'(2(/1X,A))')
+ & 'PHO_GHHIAS: hadron-gamma event generation',
+ & '-----------------------------------------'
+C hadron size and mass
+ FM2GEV = 5.07D0
+ HIMASS = DBLE(NA)*0.938D0
+ HIMA2 = HIMASS**2
+ HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
+ ALPHA = DBLE(NZ**2)/137.D0
+ AMP = 0.938D0
+ AMP2 = AMP**2
+C correct Q2MAX2 according to hadron size
+ Q2MAXH = 2.D0/HIRADI**2
+ Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
+ IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
+C total hadron / heavy ion energy
+ EE = EEN*DBLE(NA)
+ GAMMA = EE/HIMASS
+C setup /POFSRC/
+ GAMSRC(2) = GAMMA
+ RADSRC(2) = HIRADI
+ AMSRC(2) = HIMASS
+C check kinematic limitations
+ YMI = ECMIN**2/(4.D0*EE*EEP)
+ IF(YMIN2.LT.YMI) THEN
+ WRITE(LO,'(/1X,A,2E12.5)')
+ & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
+ YMIN2 = YMI
+ ELSE IF(YMIN2.GT.YMI) THEN
+ WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
+ & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
+ & ' INSTEAD OF',YMIN2
+ ENDIF
+C kinematic limitation
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+C debug output
+ WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
+ WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
+ WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
+ WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
+ & Q2MAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
+ & YMAX2
+ WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
+ & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
+ WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
+ & ECMAX
+ WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
+ CALL PHO_ABORT
+ ENDIF
+C hadron numbers set to 0
+ IDPSRC(1) = 0
+ IDPSRC(2) = 0
+ IDBSRC(1) = 0
+ IDBSRC(2) = 0
+C
+ Max_tab = 100
+ YMAX = YMAX2
+ YMIN = YMIN2
+ XMAX = LOG(YMAX)
+ XMIN = LOG(YMIN)
+ XDEL = XMAX-XMIN
+ DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
+ DO 102 I=1,Max_tab
+ Y1 = EXP(XMIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
+ IF(Q2LOW2.GE.Q2MAX2) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
+ YMAX2 = MIN(Y1,YMAX2)
+ GOTO 103
+ ENDIF
+ 102 CONTINUE
+ 103 CONTINUE
+C
+ X2MAX = LOG(YMAX2)
+ X2MIN = LOG(YMIN2)
+ X2DEL = X2MAX-X2MIN
+ DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
+ FLUX = 0.D0
+ IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
+ DO 105 I=1,Max_tab
+ Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
+ FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
+ FLUX = FLUX+Y2*FF
+ IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
+ 105 CONTINUE
+ FLUX = FLUX*DELLY
+ IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_GHHIAS: integrated flux:',FLUX
+C
+C hadron
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = -SQRT(EEP**2-AMP2)
+ P1(4) = EEP
+C photon
+ EGAM = YMAX2*EE
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = EGAM
+ P2(4) = EGAM
+ CALL PHO_SETPAR(1,2212,0,0.D0)
+ CALL PHO_SETPAR(2,22,0,0.D0)
+ CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
+C
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
+ Y2 = YMIN2
+ WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+C
+ CALL PHO_PHIST(-1,SIGMAX)
+ CALL PHO_LHIST(-1,SIGMAX)
+C
+C generation of events, flux calculation
+
+ AY1 = 0.D0
+ AY2 = 0.D0
+ AYS1 = 0.D0
+ AYS2 = 0.D0
+ Q22MIN = 1.D30
+ Q22MAX = 0.D0
+ Q22AVE = 0.D0
+ Q22AV2 = 0.D0
+ YY2MIN = 1.D30
+ YY2MAX = 0.D0
+ NITER = NEVENT
+ NITERS = 0
+ ITRY = 0
+ ITRW = 0
+ DO 200 I=1,NITER
+C sample photon flux
+ 150 CONTINUE
+ ITRY = ITRY+1
+ 175 CONTINUE
+C
+ ITRW = ITRW+1
+C select Y2
+ Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
+ Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
+ IF(Q2LOW2.GE.Q2MAX2) GOTO 175
+ Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
+ WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
+ & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
+ IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
+ & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
+ IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
+C sample Q2
+ IF(IPAMDL(174).EQ.1) THEN
+ YEFF = 1.D0+(1.D0-Y2)**2
+ 186 CONTINUE
+ Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
+ WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
+ IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
+ ELSE
+ Q2P2 = Q2LOW2
+ ENDIF
+C impact parameter
+ GAIMP(2) = 1.D0/SQRT(Q2P2)
+C form factor (squared)
+ FF2 = 1.D0
+ IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
+ IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
+C photon data
+ GYY(2) = Y2
+ GQ2(2) = Q2P2
+
+C
+C incoming hadron 1
+ PINI(1,1) = 0.D0
+ PINI(2,1) = 0.D0
+ PINI(3,1) = SQRT(EEP**2-AMP2)
+ PINI(4,1) = EEP
+ PINI(5,1) = AMP
+C incoming hadron 2
+ PINI(1,2) = 0.D0
+ PINI(2,2) = 0.D0
+ PINI(3,2) = -SQRT(EE**2-AMP2)
+ PINI(4,2) = EE
+ PINI(5,2) = AMP
+C outgoing hadron 2
+ YQ2 = SQRT((1.D0-Y2)*Q2P2)
+ Q2E = Q2P2/(4.D0*EE)
+ E1Y = EE*(1.D0-Y2)
+ CALL PHO_SFECFE(SIF,COF)
+ PFIN(1,2) = YQ2*COF
+ PFIN(2,2) = YQ2*SIF
+ PFIN(3,2) = -E1Y+Q2E
+ PFIN(4,2) = E1Y+Q2E
+ PFIN(5,2) = 0.D0
+ PFPHI(2) = ATAN2(COF,SIF)
+ PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
+C scattering hadron
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = SQRT(EEP**2-AMP2)
+ P1(4) = EEP
+ Q2P1 = AMP2
+C scattering photon
+ P2(1) = -PFIN(1,2)
+ P2(2) = -PFIN(2,2)
+ P2(3) = PINI(3,2)-PFIN(3,2)
+ P2(4) = PINI(4,2)-PFIN(4,2)
+ ISIDE = 2
+C
+C ECMS cut
+ GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
+ IF(GGECM.LT.0.1D0) GOTO 175
+ GGECM = SQRT(GGECM)
+ IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
+C
+ PGAM(1,1) = P1(1)
+ PGAM(2,1) = P1(2)
+ PGAM(3,1) = P1(3)
+ PGAM(4,1) = P1(4)
+ PGAM(5,1) = AMP
+ PGAM(1,2) = P2(1)
+ PGAM(2,2) = P2(2)
+ PGAM(3,2) = P2(3)
+ PGAM(4,2) = P2(4)
+ PGAM(5,2) = -SQRT(Q2P2)
+C photon helicities
+ IGHEL(2) = 1
+C user cuts
+ CALL PHO_PRESEL(5,IREJ)
+ IF(IREJ.NE.0) GOTO 175
+C event generation
+ CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
+ IF(IREJ.NE.0) GOTO 150
+C cut on diffractive mass
+ DO 250 K=1,NHEP
+ IF(ISTHEP(K).EQ.30) THEN
+ GHDIFF = PHEP(1,K)
+ IF(GHDIFF.GE.PARMDL(175)) THEN
+ GOTO 251
+ ELSE
+ GOTO 150
+ ENDIF
+ ENDIF
+ 250 CONTINUE
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_GHHIOF: no diffractive entry found'
+ CALL PHO_PREVNT(-1)
+ GOTO 150
+ 251 CONTINUE
+C remove quasi-elastically scattered hadron
+ DO 260 K=1,NHEP
+ IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
+ XF = ABS(PHEP(3,K)/EEN)
+ IF(XF.LT.PARMDL(72)) GOTO 150
+* ISTHEP(K) = 2
+ GOTO 261
+ ENDIF
+ 260 CONTINUE
+ 261 CONTINUE
+C
+C statistics
+
+ NITERS = NITERS+1
+
+ AY2 = AY2+Y2
+ AYS2 = AYS2+Y2*Y2
+ Q22AVE = Q22AVE+Q2P2
+ Q22AV2 = Q22AV2+Q2P2*Q2P2
+ Q22MIN = MIN(Q22MIN,Q2P2)
+ Q22MAX = MAX(Q22MAX,Q2P2)
+ YY2MIN = MIN(YY2MIN,Y2)
+ YY2MAX = MAX(YY2MAX,Y2)
+C histograms
+ CALL PHO_PHIST(1,HSWGHT(0))
+ CALL PHO_LHIST(1,HSWGHT(0))
+ 200 CONTINUE
+C
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
+ WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
+ AY2 = AY2/DBLE(MAX(NITERS,1))
+ AYS2 = AYS2/DBLE(MAX(NITERS,1))
+ DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
+ Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
+ Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
+ Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
+ WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
+ WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
+ WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
+C output of statistics, histograms
+ WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
+ &'=========================================================',
+ &' ***** simulated cross section: ',WEIGHT,' mb *****',
+ &'========================================================='
+ WRITE(LO,'(//1X,A,/3X,4I12)')
+ & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
+ & NITER,NITERS,ITRY,ITRW
+ WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
+ & WGY,WEIGHT
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
+ & AY2,DAY2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
+ & YY2MIN,YY2MAX
+ WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
+ & Q22AVE,Q22AV2
+ WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
+ & Q22MIN,Q22MAX
+C
+ CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
+ IF(NITER.GT.1) THEN
+ CALL PHO_PHIST(-2,WEIGHT)
+ CALL PHO_LHIST(-2,WEIGHT)
+ ELSE
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_GHHIOF: no output of histograms',NITER
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_FITPAR
+ SUBROUTINE PHO_FITPAR(IOUTP)
+C**********************************************************************
+C
+C read input parameters according to PDFs
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEFA=-99999.D0,
+ & DEFB=-100000.D0,
+ & THOUS=1.D3)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+
+ DIMENSION INUM(3),IFPAS(2)
+ CHARACTER*8 CNAME8,PDFNA1,PDFNA2
+ CHARACTER*10 CNAM10
+
+ PARAMETER ( Max_tab = 22 )
+ DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
+ REAL XDPtab
+ INTEGER IDPtab
+
+C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 1),k=1,8) /
+ & 2212, 5, 6, 0, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 1),k=1,27) /
+ &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
+ &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
+ &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
+ &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
+ DATA (IDPtab(k, 2),k=1,8) /
+ & 2212, 5, 6, 0, -2212, 5, 6, 0 /
+ DATA (XDPtab(k, 2),k=1,27) /
+ &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
+ &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
+ &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
+ &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 3),k=1,8) /
+ & 22, 5, 3, 0, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 3),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
+ DATA (IDPtab(k, 4),k=1,8) /
+ & 22, 5, 3, 0, 22, 5, 3, 0 /
+ DATA (XDPtab(k, 4),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 5),k=1,8) /
+ & 22, 5, 4, 4, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 5),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
+ DATA (IDPtab(k, 6),k=1,8) /
+ & 22, 5, 4, 4, 22, 5, 4, 4 /
+ DATA (XDPtab(k, 6),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
+ &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
+ DATA (IDPtab(k, 7),k=1,8) /
+ & 22, 1, 1, 4, 22, 1, 1, 4 /
+ DATA (XDPtab(k, 7),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
+ &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
+ DATA (IDPtab(k, 8),k=1,8) /
+ & 22, 1, 2, 4, 22, 1, 2, 4 /
+ DATA (XDPtab(k, 8),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
+ &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
+ DATA (IDPtab(k, 9),k=1,8) /
+ & 22, 1, 3, 4, 22, 1, 3, 4 /
+ DATA (XDPtab(k, 9),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
+ &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
+ DATA (IDPtab(k, 10),k=1,8) /
+ & 22, 1, 4, 4, 22, 1, 4, 4 /
+ DATA (XDPtab(k, 10),k=1,27) /
+ &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
+ &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 11),k=1,8) /
+ & 22, 3, 1, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 11),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 12),k=1,8) /
+ & 22, 3, 1, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 12),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 13),k=1,8) /
+ & 22, 3, 1, 3, 22, 3, 1, 3 /
+ DATA (XDPtab(k, 13),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
+ &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 14),k=1,8) /
+ & 22, 3, 1, 2, 22, 3, 1, 2 /
+ DATA (XDPtab(k, 14),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
+ &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 15),k=1,8) /
+ & 22, 3, 2, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 15),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 16),k=1,8) /
+ & 22, 3, 2, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 16),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 17),k=1,8) /
+ & 22, 3, 2, 3, 22, 3, 2, 3 /
+ DATA (XDPtab(k, 17),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 18),k=1,8) /
+ & 22, 3, 2, 2, 22, 3, 2, 2 /
+ DATA (XDPtab(k, 18),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
+ &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 19),k=1,8) /
+ & 22, 3, 3, 3, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 19),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
+ DATA (IDPtab(k, 20),k=1,8) /
+ & 22, 3, 3, 2, 2212, 5, 6, 0 /
+ DATA (XDPtab(k, 20),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
+ &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
+
+C parameter set for 22 (LAC ) 22 (LAC )
+ DATA (IDPtab(k, 21),k=1,8) /
+ & 22, 3, 3, 3, 22, 3, 3, 3 /
+ DATA (XDPtab(k, 21),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
+ DATA (IDPtab(k, 22),k=1,8) /
+ & 22, 3, 3, 2, 22, 3, 3, 2 /
+ DATA (XDPtab(k, 22),k=1,27) /
+ &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
+ &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
+ &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
+ &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
+ &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
+
+ DATA CNAME8 /' '/
+ DATA CNAM10 /' '/
+ DATA INIT / 0 /
+ DATA IFPAS / 0, 0 /
+
+ IF((INIT.EQ.1).AND.
+ & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
+
+ INIT=1
+ IFPAS(1) = IFPAP(1)
+ IFPAS(2) = IFPAP(2)
+
+C parton distribution functions
+ CALL PHO_ACTPDF(IFPAP(1),1)
+ CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
+ CALL PHO_ACTPDF(IFPAP(2),2)
+ CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+
+ IF(IDEB(54).GE.0) THEN
+ WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
+ & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
+ WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
+ & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
+ ENDIF
+
+ IFOUND = 0
+
+C load parameter set from internal tables
+ I1 = 1
+ I2 = 2
+ 110 CONTINUE
+
+ DO I=1,Max_tab
+ IF((IFPAP(I1).EQ.IDPtab(1,I))
+ & .AND.(IGRP(I1).EQ.IDPtab(2,I))
+ & .AND.(ISET(I1).EQ.IDPtab(3,I))
+ & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
+ IF((IFPAP(I2).EQ.IDPtab(5,I))
+ & .AND.(IGRP(I2).EQ.IDPtab(6,I))
+ & .AND.(ISET(I2).EQ.IDPtab(7,I))
+ & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A)')
+C & 'PHO_FITPAR: parameter set found in internal table'
+ ALPOM = XDPtab(1,I)
+ ALPOMP = XDPtab(2,I)
+ GP(I1) = XDPtab(3,I)
+ GP(I2) = XDPtab(4,I)
+ B0POM(I1) = XDPtab(5,I)
+ B0POM(I2) = XDPtab(6,I)
+ ALREG = XDPtab(7,I)
+ ALREGP = XDPtab(8,I)
+ GR(I1) = XDPtab(9,I)
+ GR(I2) = XDPtab(10,I)
+ B0REG(I1) = XDPtab(11,I)
+ B0REG(I2) = XDPtab(12,I)
+ GPPP = XDPtab(13,I)
+ B0PPP = XDPtab(14,I)
+ GPPR = XDPtab(15,I)
+ B0PPR = XDPtab(16,I)
+ VDMFAC(2*I1-1) = XDPtab(17,I)
+ VDMFAC(2*I1) = XDPtab(18,I)
+ VDMFAC(2*I2-1) = XDPtab(19,I)
+ VDMFAC(2*I2) = XDPtab(20,I)
+ B0HAR = XDPtab(21,I)
+ AKFAC = XDPtab(22,I)
+ PHISUP(I1) = XDPtab(23,I)
+ PHISUP(I2) = XDPtab(24,I)
+ RMASS(I1) = XDPtab(25,I)
+ RMASS(I2) = XDPtab(26,I)
+ VAR = XDPtab(27,I)
+ IFOUND = 1
+ GOTO 1200
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF(I1.EQ.1) THEN
+ I1 = 2
+ I2 = 1
+ GOTO 110
+ ELSE
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A)')
+C & 'PHO_FITPAR: parameter set not found in internal table'
+ ENDIF
+
+ 1200 CONTINUE
+
+C get parameters of soft cross sections from fitpar.dat
+ IF(IPAMDL(99).GT.IFOUND) THEN
+
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
+ OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
+
+ 100 CONTINUE
+ READ(12,'(A8)',ERR=1020,END=1010) CNAME8
+ IF(CNAME8.EQ.'STOP') GOTO 1010
+ IF(CNAME8.EQ.'NEXTDATA') THEN
+ READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
+ & IDPA1,CNAME8,INUM
+ IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
+ & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
+ READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
+ & IDPA2,CNAME8,INUM
+ IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
+ & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
+ READ(12,*) ALPOM,ALPOMP,GP,B0POM
+ READ(12,*) ALREG,ALREGP,GR,B0REG
+ READ(12,*) GPPP,B0PPP,GPPR,B0PPR
+ READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
+ READ(12,*) B0HAR
+ READ(12,*) AKFAC
+ READ(12,*) PHISUP
+ READ(12,*) RMASS,VAR
+ IFOUND = 1
+ GOTO 1100
+ ENDIF
+ ENDIF
+ ENDIF
+ GOTO 100
+
+ 1020 CONTINUE
+ WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
+ WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
+ 1010 CONTINUE
+ WRITE(LO,'(/A)')
+ & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
+
+ 1100 CONTINUE
+ CLOSE(12)
+
+ ENDIF
+
+C nothing found
+ IF(IFOUND.EQ.0) THEN
+ WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
+ WRITE(LO,'(3(10X,A,/))')
+ & '(copy fitpar.dat into the working directory and/or',
+ & ' request the missing parameter set via e-mail from',
+ & ' eng@lepton.bartol.udel.edu)'
+ STOP
+ ENDIF
+
+ 1300 CONTINUE
+
+C overwrite parameters with user settings
+ IF(PARMDL(301).GT.DEFA) THEN
+ ALPOM = PARMDL(301)
+ PARMDL(301) = DEFB
+ ENDIF
+ IF(PARMDL(302).GT.DEFA) THEN
+ ALPOMP = PARMDL(302)
+ PARMDL(302) = DEFB
+ ENDIF
+ IF(PARMDL(303).GT.DEFA) THEN
+ GP(1) = PARMDL(303)
+ PARMDL(303) = DEFB
+ ENDIF
+ IF(PARMDL(304).GT.DEFA) THEN
+ GP(2) = PARMDL(304)
+ PARMDL(304) = DEFB
+ ENDIF
+ IF(PARMDL(305).GT.DEFA) THEN
+ B0POM(1) = PARMDL(305)
+ PARMDL(305) = DEFB
+ ENDIF
+ IF(PARMDL(306).GT.DEFA) THEN
+ B0POM(2) = PARMDL(306)
+ PARMDL(306) = DEFB
+ ENDIF
+ IF(PARMDL(307).GT.DEFA) THEN
+ ALREG = PARMDL(307)
+ PARMDL(307) = DEFB
+ ENDIF
+ IF(PARMDL(308).GT.DEFA) THEN
+ ALREGP = PARMDL(308)
+ PARMDL(308) = DEFB
+ ENDIF
+ IF(PARMDL(309).GT.DEFA) THEN
+ GR(1) = PARMDL(309)
+ PARMDL(309) = DEFB
+ ENDIF
+ IF(PARMDL(310).GT.DEFA) THEN
+ GR(2) = PARMDL(310)
+ PARMDL(310) = DEFB
+ ENDIF
+ IF(PARMDL(311).GT.DEFA) THEN
+ B0REG(1) = PARMDL(311)
+ PARMDL(311) = DEFB
+ ENDIF
+ IF(PARMDL(312).GT.DEFA) THEN
+ B0REG(2) = PARMDL(312)
+ PARMDL(312) = DEFB
+ ENDIF
+ IF(PARMDL(313).GT.DEFA) THEN
+ GPPP = PARMDL(313)
+ PARMDL(313) = DEFB
+ ENDIF
+ IF(PARMDL(314).GT.DEFA) THEN
+ B0PPP = PARMDL(314)
+ PARMDL(314)= DEFB
+ ENDIF
+ IF(PARMDL(315).GT.DEFA) THEN
+ VDMFAC(1) = PARMDL(315)
+ PARMDL(315)= DEFB
+ ENDIF
+ IF(PARMDL(316).GT.DEFA) THEN
+ VDMFAC(2) = PARMDL(316)
+ PARMDL(316)= DEFB
+ ENDIF
+ IF(PARMDL(317).GT.DEFA) THEN
+ VDMFAC(3) = PARMDL(317)
+ PARMDL(317)= DEFB
+ ENDIF
+ IF(PARMDL(318).GT.DEFA) THEN
+ VDMFAC(4) = PARMDL(318)
+ PARMDL(318)= DEFB
+ ENDIF
+ IF(PARMDL(319).GT.DEFA) THEN
+ B0HAR = PARMDL(319)
+ PARMDL(319)= DEFB
+ ENDIF
+ IF(PARMDL(320).GT.DEFA) THEN
+ AKFAC = PARMDL(320)
+ PARMDL(320)= DEFB
+ ENDIF
+ IF(PARMDL(321).GT.DEFA) THEN
+ PHISUP(1) = PARMDL(321)
+ PARMDL(321)= DEFB
+ ENDIF
+ IF(PARMDL(322).GT.DEFA) THEN
+ PHISUP(2) = PARMDL(322)
+ PARMDL(322)= DEFB
+ ENDIF
+ IF(PARMDL(323).GT.DEFA) THEN
+ RMASS(1) = PARMDL(323)
+ PARMDL(323)= DEFB
+ ENDIF
+ IF(PARMDL(324).GT.DEFA) THEN
+ RMASS(2) = PARMDL(324)
+ PARMDL(324)= DEFB
+ ENDIF
+ IF(PARMDL(325).GT.DEFA) THEN
+ VAR = PARMDL(325)
+ PARMDL(325)= DEFB
+ ENDIF
+ IF(PARMDL(327).GT.DEFA) THEN
+ GPPR = PARMDL(327)
+ PARMDL(327)= DEFB
+ ENDIF
+ IF(PARMDL(328).GT.DEFA) THEN
+ B0PPR = PARMDL(328)
+ PARMDL(328)= DEFB
+ ENDIF
+
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = VDMFAC(3)
+ VDMQ2F(4) = VDMFAC(4)
+
+C output of parameter set
+C *** Commented by Chiara
+C IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
+C WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
+C & ' -------------------------'
+C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
+C & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
+C & B0POM
+C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
+C & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
+C & B0REG
+C WRITE(LO,'(4(A,F7.3))')
+C & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
+C WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
+C WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
+C WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
+C WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
+C WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
+C WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
+C ENDIF
+
+ CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
+
+ END
+
+CDECK ID>, PHO_BORNCS
+ SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
+C*********************************************************************
+C
+C calculation of Born graph cross sections and slopes
+C
+C input: IP particle combination
+C IFHARD -1 calculate hard Born graph cross section
+C 0 take hard Born graph cross section
+C from interpolation table if available
+C 1 assume that correct hard cross
+C sections are already stored in /POSBRN/
+C XM1,XM2,XM3,XM4 masses of external lines
+C /GLOCMS/ energy and PT cut-off
+C /POPREG/ soft and hard parameters
+C /POSBRN/ input cross sections
+C /POZBRN/ scaled input values
+C IFHARD 0 calculate hard input cross sections
+C 1 assume hard input cross sections exist
+C
+C output: ZPOM scaled pomeron cross section
+C ZIGR scaled reggeon cross section
+C ZIGHR scaled hard resolved cross section
+C ZIGHD scaled hard direct cross section
+C ZIGT1 scaled triple-Pomeron cross section
+C ZIGT2 scaled triple-Pomeron cross section
+C ZIGL scaled loop-Pomeron cross section
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & IFOUR=4,
+ & IFIVE=5,
+ & FIVE=5.D0,
+ & THOUS=1.D3,
+ & EPS=0.01D0,
+ & DEPS=1.D-30)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+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 interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C scaled cross sections and slopes
+ COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
+ & ZIGD1,ZIGD2,
+ & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
+ COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
+ & ZIGDP(4),ZIGD1(2),ZIGD2(2),
+ & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
+ & BD1(2),BD2(2)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
+ & BPOM1,BPOM2,BREG1,BREG2,B0HARD
+ DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
+ DIMENSION BT14(2),BT24(2),BD4(4)
+ DIMENSION DSPT(0:Max_pro_2)
+
+ DATA XMPOM / 0.766D0 /
+ DATA CZERO /(0.D0,0.D0)/
+
+ CDABS(SS) = ABS(SS)
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+C debug output
+ IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
+ & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
+C scales
+ CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
+C
+C calculate hard input cross sections (output in mb)
+ IF(IFHARD.NE.1) THEN
+ IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
+C double-log interpolation
+ CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
+ DO 60 M=0,Max_pro_2
+ DSIGH(M) = HSig(M)
+ DSPT(M) = Hdpt(M)
+ 60 CONTINUE
+ ELSE
+C new calculation
+ CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
+ CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
+ ENDIF
+C
+C save values to calculate soft pt distribution
+ IF(IP.EQ.1) THEN
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = VDMFAC(3)
+ VDMQ2F(4) = VDMFAC(4)
+ ELSE IF(IP.EQ.2) THEN
+ VDMQ2F(1) = VDMFAC(1)
+ VDMQ2F(2) = VDMFAC(2)
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ELSE IF(IP.EQ.3) THEN
+ VDMQ2F(1) = VDMFAC(3)
+ VDMQ2F(2) = VDMFAC(4)
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ELSE
+ VDMQ2F(1) = 1.D0
+ VDMQ2F(2) = 0.D0
+ VDMQ2F(3) = 1.D0
+ VDMQ2F(4) = 0.D0
+ ENDIF
+C VDM factors
+ AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
+ AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
+ AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
+ AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
+ ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
+ & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
+ ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
+ ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
+ ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
+ VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
+ & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
+ DSIGHP = DSPT(9)/VFAC
+ SIGH = DSIGH(9)/VFAC
+C extract real part
+ IF(IPAMDL(1).EQ.0) THEN
+ DO 50 I=0,Max_pro_2
+ DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
+ 50 CONTINUE
+ ENDIF
+C write out results
+ IF(IDEB(48).GE.15) THEN
+ WRITE(LO,'(/1X,A,1P,2E11.3)')
+ & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
+ DO 200 I=0,Max_pro_2
+ WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
+ 200 CONTINUE
+ ENDIF
+ ENDIF
+
+C DPMJET interface: subtract anomalous part
+ IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
+ & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
+
+ SCALE = CDABS(DSIGH(15))
+ IF(SCALE.LT.DEPS) THEN
+ SIGHD=CZERO
+ ELSE
+ SIGHD=DSIGH(15)
+ ENDIF
+ SCALE = CDABS(DSIGH(9))
+ IF(SCALE.LT.DEPS) THEN
+ SIGHR=CZERO
+ ELSE
+ SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
+ ENDIF
+
+C calculate soft input cross sections (output in mb)
+ SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
+ IF(IPAMDL(1).EQ.1) THEN
+C pomeron signature
+ SP=SS*DCMPLX(0.D0,-1.D0)
+C reggeon signature
+ SR=SS*DCMPLX(0.D0,1.D0)
+ ELSE
+ SP=SS
+ SR=SS
+ ENDIF
+C coupling constants (mb**1/2)
+C particle dependent slopes (GeV**-2)
+ IF(IP.EQ.1) THEN
+ GP1 = GP(1)
+ GP2 = GP(2)
+ GR1 = GR(1)
+ GR2 = GR(2)
+ B0POM1 = B0POM(1)
+ B0POM2 = B0POM(2)
+ B0REG1 = B0REG(1)
+ B0REG2 = B0REG(2)
+ B0HARD = B0HAR
+ RMASS1 = RMASS(1)
+ RMASS2 = RMASS(2)
+ ELSE IF(IP.EQ.2) THEN
+ GP1 = GP(1)
+ GP2 = PARMDL(77)
+ GR1 = GR(1)
+ GR2 = PARMDL(77)*GPPR/GPPP
+ B0POM1 = B0POM(1)
+ B0POM2 = B0PPP
+ B0REG1 = B0REG(1)
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = RMASS(1)
+ RMASS2 = XMPOM
+ ELSE IF(IP.EQ.3) THEN
+ GP1 = GP(2)
+ GP2 = PARMDL(77)
+ GR1 = GR(2)
+ GR2 = PARMDL(77)*GPPR/GPPP
+ B0POM1 = B0POM(2)
+ B0POM2 = B0PPP
+ B0REG1 = B0REG(2)
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = RMASS(2)
+ RMASS2 = XMPOM
+ ELSE IF(IP.EQ.4) THEN
+ GP1 = PARMDL(77)
+ GP2 = GP1
+ GR1 = PARMDL(77)*GPPR/GPPP
+ GR2 = GR1
+ B0POM1 = B0PPP
+ B0POM2 = B0PPP
+ B0REG1 = B0PPR
+ B0REG2 = B0PPR
+ B0HARD = B0POM1+B0POM2
+ RMASS1 = XMPOM
+ RMASS2 = XMPOM
+ ELSE
+ WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
+ CALL PHO_ABORT
+ ENDIF
+ GP1 = GP1*SCALE1
+ GP2 = GP2*SCALE2
+ GR1 = GR1*SCALE1
+ GR2 = GR2*SCALE2
+C input slope parameters (GeV**-2)
+ BPOM1 = B0POM1*SCALB1
+ BPOM2 = B0POM2*SCALB2
+ BREG1 = B0REG1*SCALB1
+ BREG2 = B0REG2*SCALB2
+C effective slopes
+ XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
+ SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
+ BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
+ BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
+ IF(IPAMDL(9).EQ.0) THEN
+ BHAR = B0HARD
+ BHAD = B0HARD
+ ELSE IF(IPAMDL(9).EQ.1) THEN
+ BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
+ BHAD = BHAR
+ ELSE IF(IPAMDL(9).EQ.2) THEN
+ BHAR = BPOM1+BPOM2
+ BHAD = BHAR
+ ELSE
+ BHAR = BPOM
+ BHAD = BPOM
+ ENDIF
+C input cross section pomeron
+ SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
+ SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
+C save value to calculate soft pt distribution
+ SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
+
+C higher order graphs
+ VIRT1 = PVIRTP(1)
+ VIRT2 = PVIRTP(2)
+C bare/renormalized intercept for enhanced graphs
+ IF(IPAMDL(8).EQ.0) THEN
+ DELTAP = ALPOM-1.D0
+ ELSE
+ DELTAP = PARMDL(48)-1.D0
+ ENDIF
+ SD = ECMP**2
+ BP1 = 2.D0*BPOM1
+ BP2 = 2.D0*BPOM2
+C input cross section high-mass double diffraction
+ CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
+ SIGL = DCMPLX(SIGTR,0.D0)
+ BLOO = DCMPLX(BTR,0.D0)
+C
+C input cross section high mass diffraction particle 1
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
+ SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
+ BTR1(1) = DCMPLX(BTR,0.D0)
+C second possibility: high-low mass double diffraction
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
+ SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
+ BTR1(2) = DCMPLX(BTR,0.D0)
+C
+C input cross section high mass diffraction particle 2
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
+ SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
+ BTR2(1) = DCMPLX(BTR,0.D0)
+C second possibility: high-low mass double diffraction
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ SCALB1 = (SCB1(1)+SCB1(2))/2.D0
+ SCALB2 = (SCB2(1)+SCB2(2))/2.D0
+ BP1 = 2.D0*BPOM1*SCALB1
+ BP2 = 2.D0*BPOM2*SCALB2
+C input cross section high mass diffraction
+ CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
+ & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
+ SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
+ BTR2(2) = DCMPLX(BTR,0.D0)
+C
+C input cross section for loop-pomeron
+C first possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(1) = DCMPLX(BTX,0.D0)
+C second possibility
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(2) = DCMPLX(BTX,0.D0)
+C third possibility
+ CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(3) = DCMPLX(BTX,0.D0)
+C fourth possibility
+ CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
+ & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
+ CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
+ & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
+ CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
+ & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
+ CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
+ & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
+ SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
+ SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
+ BP1 = BPOM1*SCALB1
+ BP2 = BPOM2*SCALB2
+ CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
+ & SIGTX,BTX)
+ SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
+ BDP(4) = DCMPLX(BTX,0.D0)
+C
+C input cross section for YY-iterated triple-pomeron
+C .....
+C
+C write out input cross sections
+ IF(IDEB(48).GE.5) THEN
+ WRITE(LO,'(2(/1X,A))')
+ & 'Born graph input cross sections and slopes',
+ & '------------------------------------------'
+ WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
+ WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
+ & XM1,XM2,XM3,XM4
+ WRITE(LO,'(A)') ' input cross sections (millibarn):'
+ WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
+ WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
+ WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
+ WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
+ WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
+ WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
+ WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
+ WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
+ WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
+ WRITE(LO,'(A)') ' input slopes (GeV**-2)'
+ WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
+ WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
+ WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
+ WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
+ WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
+ WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
+ WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
+ WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
+ WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
+ WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
+ WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
+ WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
+ WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
+ WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
+ ENDIF
+C
+ BPOM = BPOM*GEV2MB
+ BREG = BREG*GEV2MB
+ BHAR = BHAR*GEV2MB
+ BHAD = BHAD*GEV2MB
+ BTR1(1) = BTR1(1)*GEV2MB
+ BTR1(2) = BTR1(2)*GEV2MB
+ BTR2(1) = BTR2(1)*GEV2MB
+ BTR2(2) = BTR2(2)*GEV2MB
+ BLOO = BLOO*GEV2MB
+C
+ BP4 =BPOM*4.D0
+ BR4 =BREG*4.D0
+ BHR4=BHAR*4.D0
+ BHD4=BHAD*4.D0
+ BT14(1)=BTR1(1)*4.D0
+ BT14(2)=BTR1(2)*4.D0
+ BT24(1)=BTR2(1)*4.D0
+ BT24(2)=BTR2(2)*4.D0
+ BL4 =BLOO*4.D0
+C
+ ZIGP = SIGP/(PI2*BP4)
+ ZIGR = SIGR/(PI2*BR4)
+ ZIGHR = SIGHR/(PI2*BHR4)
+ ZIGHD = SIGHD/(PI2*BHD4)
+ ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
+ ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
+ ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
+ ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
+ ZIGL = SIGL/(PI2*BL4)
+ DO 20 I=1,4
+ BDP(I) = BDP(I)*GEV2MB
+ BD4(I) = BDP(I)*4.D0
+ ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
+ 20 CONTINUE
+C
+ IF(IDEB(48).GE.10) THEN
+ WRITE(LO,'(A)') ' normalized input values:'
+ WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
+ WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
+ WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
+ WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
+ WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
+ WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
+ WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
+ WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
+ WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
+ WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
+ WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
+ WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
+ WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
+ ENDIF
+ END
+
+CDECK ID>, PHO_SCALES
+ SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
+C**********************************************************************
+C
+C calculation of scale factors
+C (mass dependent couplings and slopes)
+C
+C input: XM1..XM4 external masses
+C
+C output: SCG1,SCG2 scales of coupling constants
+C SCB1,SCB2 scales of coupling slope parameter
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-3 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+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 scale factors for couplings
+ ECMMIN = 2.D0
+* ECMTP = 6.D0
+ ECMTP = 1.D0
+ IF(ABS(XM1-XM3).GT.EPS) THEN
+ IF(ECMP.LT.ECMTP) THEN
+ SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
+ ELSE
+ SCG1 = PHISUP(1)
+ ENDIF
+ ELSE
+ SCG1 = 1.D0
+ ENDIF
+ IF(ABS(XM2-XM4).GT.EPS) THEN
+ IF(ECMP.LT.ECMTP) THEN
+ SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
+ ELSE
+ SCG2 = PHISUP(2)
+ ENDIF
+ ELSE
+ SCG2 = 1.D0
+ ENDIF
+C
+C scale factors for slope parameters
+ IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
+ SCB1 = 1.D0
+ SCB2 = 1.D0
+ ELSE IF(ISWMDL(1).EQ.2) THEN
+C rational
+ SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
+ SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
+ ELSE IF(ISWMDL(1).GE.3) THEN
+C symmetric gaussian
+ SCB1 = VAR*(XM1-XM3)**2
+ IF(SCB1.LT.25.D0) THEN
+ SCB1 = EXP(-SCB1)
+ ELSE
+ SCB1 = 0.D0
+ ENDIF
+ SCB2 = VAR*(XM2-XM4)**2
+ IF(SCB2.LT.25.D0) THEN
+ SCB2 = EXP(-SCB2)
+ ELSE
+ SCB2 = 0.D0
+ ENDIF
+ ELSE
+ WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
+ & ISWMDL(1)
+ CALL PHO_ABORT
+ ENDIF
+C debug output
+ IF(IDEB(65).GE.10) THEN
+ WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
+ & XM1,XM2,XM3,XM4
+ WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
+ & SCB1,SCB2,SCG1,SCG2
+ ENDIF
+ END
+
+CDECK ID>, PHO_EIKON
+ SUBROUTINE PHO_EIKON(IP,IFHARD,B)
+C*********************************************************************
+C
+C calculation of unitarized amplitudes
+C
+C input: IP particle combination
+C IFHARD -1 ignore previously calculated Born
+C cross sections
+C 0 calculate hard Born cross sections or
+C take them from interpolation table
+C (if available)
+C 1 take hard cross sections from /POSBRN/
+C B impact parameter (mb**(1/2))
+C /POSBRN/ input cross sections
+C /GLOCMS/ cm energy
+C /POPREG/ soft and hard parameters
+C
+C output: /POINT4/
+C AMPEL purely elastic amplitude
+C AMPVM quasi-elastically vectormeson prod.
+C AMLMSD(2) amplitudes of low mass sing. diffr.
+C AMHMSD(2) amplitudes of high mass sing. diffr.
+C AMLMDD amplitude of low mass double diffr.
+C AMHMDD amplitude of high mass double diffr.
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & IFOUR=4,
+ & IFIVE=5,
+ & ISIX=6,
+ & FIVE=5.D0,
+ & THOUS=1.D3,
+ & EXPMAX=70.D0,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C scaled cross sections and slopes
+ COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
+ & ZIGD1,ZIGD2,
+ & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
+ COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
+ & ZIGDP(4),ZIGD1(2),ZIGD2(2),
+ & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
+ & BD1(2),BD2(2)
+C Born graph cross sections after applying diffraction model
+ DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
+ & SBOLPO,SBODPO
+ COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
+ & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
+ & SBODPO(0:4,4)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+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 unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+
+ COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
+ & AUXL,AMPR,AMPO,AMPP,AMPQ
+
+ DIMENSION PVOLD(2)
+
+ DATA ELAST / 0.D0 /
+ DATA IPOLD / -1 /
+ DATA PVOLD / -1.D0, -1.D0 /
+ DATA XMPOM / 0.766D0 /
+ DATA XMVDM / 0.766D0 /
+
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+C calculation of scaled cross sections and slopes
+
+C test for redundant calculation
+ IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
+ & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
+C effective particle masses, VDM assumption
+ XMASS1 = PMASS(1)
+ XMASS2 = PMASS(2)
+ RMASS1 = RMASS(1)
+ RMASS2 = RMASS(2)
+ IF(IFPAP(1).EQ.22) THEN
+ XMASS1 = XMVDM
+ ELSE IF(IFPAP(1).EQ.990) THEN
+ XMASS1 = XMPOM
+ ENDIF
+ IF(IFPAP(2).EQ.22) THEN
+ XMASS2 = XMVDM
+ ELSE IF(IFPAP(2).EQ.990) THEN
+ XMASS2 = XMPOM
+ ENDIF
+C different particle combinations
+ IF(IP.EQ.3) THEN
+ XMASS1 = XMASS2
+ RMASS1 = RMASS2
+ ELSE IF(IP.EQ.4) THEN
+ XMASS1 = XMPOM
+ RMASS1 = XMASS1
+ ENDIF
+ IF(IP.GT.1) THEN
+ XMASS2 = XMPOM
+ RMASS2 = XMASS2
+ ENDIF
+C update pomeron CM system
+ PMASSP(1) = XMASS1
+ PMASSP(2) = XMASS2
+ ECMP = ECM
+
+ CZERO = DCMPLX(0.D0,0.D0)
+ CONE = DCMPLX(1.D0,0.D0)
+ ELAST = ECM
+ PVOLD(1) = PVIRT(1)
+ PVOLD(2) = PVIRT(2)
+ IPOLD = IP
+
+C purely elastic scattering
+ CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
+ ZXP(1,1) = ZIGP
+ BXP(1,1) = BPOM
+ ZXR(1,1) = ZIGR
+ BXR(1,1) = BREG
+ ZXH(1,1) = ZIGHR
+ BXH(1,1) = BHAR
+ ZXD(1,1) = ZIGHD
+ BXD(1,1) = BHAD
+ ZXT1A(1,1) = ZIGT1(1)
+ BXT1A(1,1) = BTR1(1)
+ ZXT1B(1,1) = ZIGT1(2)
+ BXT1B(1,1) = BTR1(2)
+ ZXT2A(1,1) = ZIGT2(1)
+ BXT2A(1,1) = BTR2(1)
+ ZXT2B(1,1) = ZIGT2(2)
+ BXT2B(1,1) = BTR2(2)
+ ZXL(1,1) = ZIGL
+ BXL(1,1) = BLOO
+ ZXDPE(1,1) = ZIGDP(1)
+ BXDPE(1,1) = BDP(1)
+ ZXDPA(1,1) = ZIGDP(2)
+ BXDPA(1,1) = BDP(2)
+ ZXDPB(1,1) = ZIGDP(3)
+ BXDPB(1,1) = BDP(3)
+ ZXDPD(1,1) = ZIGDP(4)
+ BXDPD(1,1) = BDP(4)
+ SBOPOM(1) = SIGP
+ SBOREG(1) = SIGR
+ SBOHAR(1) = SIGHR
+ SBOHAD(1) = SIGHD
+ SBOTR1(1,1) = SIGT1(1)
+ SBOTR1(1,2) = SIGT1(2)
+ SBOTR2(1,1) = SIGT2(1)
+ SBOTR2(1,2) = SIGT2(2)
+ SBOLPO(1) = SIGL
+ SBODPO(1,1) = SIGDP(1)
+ SBODPO(1,2) = SIGDP(2)
+ SBODPO(1,3) = SIGDP(3)
+ SBODPO(1,4) = SIGDP(4)
+
+C low mass single diffractive scattering 1
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
+ ZXP(1,2) = ZIGP
+ BXP(1,2) = BPOM
+ ZXR(1,2) = ZIGR
+ BXR(1,2) = BREG
+ ZXH(1,2) = ZIGHR
+ BXH(1,2) = BHAR
+ ZXD(1,2) = ZIGHD
+ BXD(1,2) = BHAD
+ ZXT1A(1,2) = ZIGT1(1)
+ BXT1A(1,2) = BTR1(1)
+ ZXT1B(1,2) = ZIGT1(2)
+ BXT1B(1,2) = BTR1(2)
+ ZXT2A(1,2) = ZIGT2(1)
+ BXT2A(1,2) = BTR2(1)
+ ZXT2B(1,2) = ZIGT2(2)
+ BXT2B(1,2) = BTR2(2)
+ ZXL(1,2) = ZIGL
+ BXL(1,2) = BLOO
+ ZXDPE(1,2) = ZIGDP(1)
+ BXDPE(1,2) = BDP(1)
+ ZXDPA(1,2) = ZIGDP(2)
+ BXDPA(1,2) = BDP(2)
+ ZXDPB(1,2) = ZIGDP(3)
+ BXDPB(1,2) = BDP(3)
+ ZXDPD(1,2) = ZIGDP(4)
+ BXDPD(1,2) = BDP(4)
+ SBOPOM(2) = SIGP
+ SBOREG(2) = SIGR
+ SBOHAR(2) = SIGHR
+ SBOHAD(2) = 0.D0
+ SBOTR1(2,1) = SIGT1(1)
+ SBOTR1(2,2) = SIGT1(2)
+ SBOTR2(2,1) = SIGT2(1)
+ SBOTR2(2,2) = SIGT2(2)
+ SBOLPO(2) = SIGL
+ SBODPO(2,1) = SIGDP(1)
+ SBODPO(2,2) = SIGDP(2)
+ SBODPO(2,3) = SIGDP(3)
+ SBODPO(2,4) = SIGDP(4)
+
+C low mass single diffractive scattering 2
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
+ ZXP(1,3) = ZIGP
+ BXP(1,3) = BPOM
+ ZXR(1,3) = ZIGR
+ BXR(1,3) = BREG
+ ZXH(1,3) = ZIGHR
+ BXH(1,3) = BHAR
+ ZXD(1,3) = ZIGHD
+ BXD(1,3) = BHAD
+ ZXT1A(1,3) = ZIGT1(1)
+ BXT1A(1,3) = BTR1(1)
+ ZXT1B(1,3) = ZIGT1(2)
+ BXT1B(1,3) = BTR1(2)
+ ZXT2A(1,3) = ZIGT2(1)
+ BXT2A(1,3) = BTR2(1)
+ ZXT2B(1,3) = ZIGT2(2)
+ BXT2B(1,3) = BTR2(2)
+ ZXL(1,3) = ZIGL
+ BXL(1,3) = BLOO
+ ZXDPE(1,3) = ZIGDP(1)
+ BXDPE(1,3) = BDP(1)
+ ZXDPA(1,3) = ZIGDP(2)
+ BXDPA(1,3) = BDP(2)
+ ZXDPB(1,3) = ZIGDP(3)
+ BXDPB(1,3) = BDP(3)
+ ZXDPD(1,3) = ZIGDP(4)
+ BXDPD(1,3) = BDP(4)
+ SBOPOM(3) = SIGP
+ SBOREG(3) = SIGR
+ SBOHAR(3) = SIGHR
+ SBOHAD(3) = 0.D0
+ SBOTR1(3,1) = SIGT1(1)
+ SBOTR1(3,2) = SIGT1(2)
+ SBOTR2(3,1) = SIGT2(1)
+ SBOTR2(3,2) = SIGT2(2)
+ SBOLPO(3) = SIGL
+ SBODPO(3,1) = SIGDP(1)
+ SBODPO(3,2) = SIGDP(2)
+ SBODPO(3,3) = SIGDP(3)
+ SBODPO(3,4) = SIGDP(4)
+
+C low mass double diffractive scattering
+ CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
+ ZXP(1,4) = ZIGP
+ BXP(1,4) = BPOM
+ ZXR(1,4) = ZIGR
+ BXR(1,4) = BREG
+ ZXH(1,4) = ZIGHR
+ BXH(1,4) = BHAR
+ ZXD(1,4) = ZIGHD
+ BXD(1,4) = BHAD
+ ZXT1A(1,4) = ZIGT1(1)
+ BXT1A(1,4) = BTR1(1)
+ ZXT1B(1,4) = ZIGT1(2)
+ BXT1B(1,4) = BTR1(2)
+ ZXT2A(1,4) = ZIGT2(1)
+ BXT2A(1,4) = BTR2(1)
+ ZXT2B(1,4) = ZIGT2(2)
+ BXT2B(1,4) = BTR2(2)
+ ZXL(1,4) = ZIGL
+ BXL(1,4) = BLOO
+ ZXDPE(1,4) = ZIGDP(1)
+ BXDPE(1,4) = BDP(1)
+ ZXDPA(1,4) = ZIGDP(2)
+ BXDPA(1,4) = BDP(2)
+ ZXDPB(1,4) = ZIGDP(3)
+ BXDPB(1,4) = BDP(3)
+ ZXDPD(1,4) = ZIGDP(4)
+ BXDPD(1,4) = BDP(4)
+ SBOPOM(4) = SIGP
+ SBOREG(4) = SIGR
+ SBOHAR(4) = SIGHR
+ SBOHAD(4) = 0.D0
+ SBOTR1(4,1) = SIGT1(1)
+ SBOTR1(4,2) = SIGT1(2)
+ SBOTR2(4,1) = SIGT2(1)
+ SBOTR2(4,2) = SIGT2(2)
+ SBOLPO(4) = SIGL
+ SBODPO(4,1) = SIGDP(1)
+ SBODPO(4,2) = SIGDP(2)
+ SBODPO(4,3) = SIGDP(3)
+ SBODPO(4,4) = SIGDP(4)
+
+C calculate Born graph cross sections
+ SBOPOM(0) = 0.D0
+ SBOREG(0) = 0.D0
+ SBOHAR(0) = 0.D0
+ SBOHAD(0) = 0.D0
+ SBOTR1(0,1) = 0.D0
+ SBOTR1(0,2) = 0.D0
+ SBOTR2(0,1) = 0.D0
+ SBOTR2(0,2) = 0.D0
+ SBOLPO(0) = 0.D0
+ SBODPO(0,1) = 0.D0
+ SBODPO(0,2) = 0.D0
+ SBODPO(0,3) = 0.D0
+ SBODPO(0,4) = 0.D0
+ DO 150 I=1,4
+ SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
+ SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
+ SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
+ SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
+ SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
+ SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
+ SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
+ SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
+ SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
+ SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
+ SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
+ SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
+ SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
+ 150 CONTINUE
+
+ SIGPOM = SBOPOM(0)
+ SIGREG = SBOREG(0)
+ SIGTR1(1) = SBOTR1(0,1)
+ SIGTR1(2) = SBOTR1(0,2)
+ SIGTR2(1) = SBOTR2(0,1)
+ SIGTR2(2) = SBOTR2(0,2)
+ SIGLOO = SBOLPO(0)
+ SIGDPO(1) = SBODPO(0,1)
+ SIGDPO(2) = SBODPO(0,2)
+ SIGDPO(3) = SBODPO(0,3)
+ SIGDPO(4) = SBODPO(0,4)
+ SIGHAR = SBOHAR(0)
+ SIGDIR = SBOHAD(0)
+ ENDIF
+
+ B24=DCMPLX(B**2,0.D0)/4.D0
+
+ AMPEL = CZERO
+ AMPR = CZERO
+ AMPO = CZERO
+ AMPP = CZERO
+ AMPQ = CZERO
+ AMLMSD(1) = CZERO
+ AMLMSD(2) = CZERO
+ AMHMSD(1) = CZERO
+ AMHMSD(2) = CZERO
+ AMLMDD = CZERO
+ AMHMDD = CZERO
+
+C different models
+
+ IF(ISWMDL(1).LT.3) THEN
+C pomeron
+ AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
+C reggeon
+ AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
+C hard resolved processes
+ AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
+C hard direct processes
+ AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
+C triple-Pomeron: baryon high mass diffraction
+ AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
+ & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
+C triple-Pomeron: photon/meson high mass diffraction
+ AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
+ & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
+C loop-Pomeron
+ AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
+ ENDIF
+
+ IF(ISWMDL(1).EQ.0) THEN
+ AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
+ & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
+ & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
+ & )
+ AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+ AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
+ & +AUXT1+AUXT2+AUXL))
+
+ ELSE IF(ISWMDL(1).EQ.1) THEN
+ AMPR = 0.5D0*SQRT(VDMQ2F(1))*
+ & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
+ AMPO = 0.5D0*SQRT(VDMQ2F(2))*
+ & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
+ AMPP = 0.5D0*SQRT(VDMQ2F(3))*
+ & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
+ AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
+ & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
+ AMPEL = SQRT(VDMQ2F(1))*AMPR
+ & + SQRT(VDMQ2F(2))*AMPO
+ & + SQRT(VDMQ2F(3))*AMPP
+ & + SQRT(VDMQ2F(4))*AMPQ
+ & + AUXD/2.D0
+
+C simple analytic two channel model (version A)
+ ELSE IF(ISWMDL(1).EQ.3) THEN
+ CALL PHO_CHAN2A(B)
+
+ ELSE
+ WRITE(LO,'(1X,A,I2)')
+ & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
+ STOP
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DSIGDT
+ SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
+C*********************************************************************
+C
+C calculation of unitarized amplitude
+C and differential cross section
+C
+C input: EE cm energy (GeV)
+C XTA(1,*) t values (GeV**2)
+C NFILL entries in t table
+C
+C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
+C XTA(3,*) DSIG/DT g p --> rho0 h/V
+C XTA(4,*) DSIG/DT g p --> omega0 h/V
+C XTA(5,*) DSIG/DT g p --> phi h/V
+C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ITWO=2,
+ & ITHREE=3,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+ DIMENSION XTA(6,NFILL)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+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 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 complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ COMPLEX*16 XT,AMP,CZERO
+ DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
+ CHARACTER*12 FNA
+
+ CDABS(AMPEL) = ABS(AMPEL)
+ DCMPLX(X,Y) = CMPLX(X,Y)
+
+ CZERO=DCMPLX(0.D0,0.D0)
+
+ ETMP = ECM
+ ECM = EE
+
+ IF(NFILL.GT.100) THEN
+ WRITE(LO,'(1X,A,I4)')
+ & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
+ STOP
+ ENDIF
+C
+ DO 100 K=1,NFILL
+ DO 150 L=1,5
+ XT(L,K)=CZERO
+ 150 CONTINUE
+ 100 CONTINUE
+C
+C impact parameter integration
+C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
+ BMAX=10.D0
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+ IAMP = 5
+ IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
+ I1 = 1
+ I2 = 0
+ ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
+ I1 = 0
+ I2 = 1
+ ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE
+ I1 = 0
+ I2 = 0
+ IAMP = 1
+ ENDIF
+ J1 = I1*2
+ K1 = I1*3
+ L1 = I1*4
+ J2 = I2*2
+ K2 = I2*3
+ L2 = I2*4
+C
+ DO 200 I=1,NGAUSO
+ WG=WGHT(I)*XPNT(I)
+C calculate amplitudes
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(1,-1,XPNT(I))
+ ELSE
+ CALL PHO_EIKON(1,1,XPNT(I))
+ ENDIF
+ AMP(1) = AMPEL
+ AMP(2) = AMPVM(I1,I2)
+ AMP(3) = AMPVM(J1,J2)
+ AMP(4) = AMPVM(K1,K2)
+ AMP(5) = AMPVM(L1,L2)
+C
+ DO 400 J=1,NFILL
+ XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
+ FAC = PHO_BESSJ0(XX)*WG
+ DO 500 K=1,IAMP
+ XT(1,J)=XT(1,J)+AMP(K)*FAC
+ 500 CONTINUE
+ 400 CONTINUE
+ 200 CONTINUE
+C
+C change units to mb/GeV**2
+ FAC = 4.D0*PI/GEV2MB
+ FNA = '(mb/GeV**2) '
+ IF(I1+I2.EQ.1) THEN
+ FAC = FAC*THOUS
+ FNA = '(mub/GeV**2)'
+ ELSE IF(I1+I2.EQ.2) THEN
+ FAC = FAC*THOUS*THOUS
+ FNA = '(nb/GeV**2) '
+ ENDIF
+ IF(IDEB(56).GE.5) THEN
+ WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
+ & FNA,'------------------------------------------'
+ ENDIF
+ DO 600 J=1,NFILL
+ DO 700 K=1,IAMP
+ XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
+ 700 CONTINUE
+ IF(IDEB(56).GE.5) THEN
+ WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
+ ENDIF
+ 600 CONTINUE
+
+ ECM = ETMP
+ END
+
+CDECK ID>, PHO_XSECT
+ SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
+C*********************************************************************
+C
+C calculation of physical cross sections
+C
+C input: IP particle combination
+C IFHARD -1 reset Born graph cross section tables
+C 0 calculate hard cross sections or take them
+C from interpolation table (if available)
+C 1 assume that hard cross sections are already
+C calculated and stored in /POSBRN/
+C EE cms energy (GeV)
+C
+C output: /POSBRN/ input cross sections
+C /POZBRN/ scaled input cross values
+C /POCSEC/ physical cross sections and slopes
+C
+C slopes in GeV**-2, cross sections in mb
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ONEM=-1.D0,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+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 Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+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)
+
+ CHARACTER*15 PHO_PNAME
+
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
+ CHARACTER*8 VMESA(0:4),VMESB(0:4)
+ DATA VMESA / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+ DATA VMESB / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+
+ CDABS(AMPEL) = ABS(AMPEL)
+
+ ETMP = ECM
+ IF(EE.LT.0.D0) GOTO 500
+ ECM = EE
+
+C impact parameter integration
+C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
+ BMAX=10.D0
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+ SIGTOT = 0.D0
+ SIGINE = 0.D0
+ SIGELA = 0.D0
+ SIGNDF = 0.D0
+ SIGLSD(1) = 0.D0
+ SIGLSD(2) = 0.D0
+ SIGLDD = 0.D0
+ SIGHSD(1) = 0.D0
+ SIGHSD(2) = 0.D0
+ SIGHDD = 0.D0
+ SIGCDF(0) = 0.D0
+ SIG1SO = 0.D0
+ SIG1HA = 0.D0
+ SLEL1 = 0.D0
+ SLEL2 = 0.D0
+ DO 50 I=1,4
+ SIGCDF(I) = 0.D0
+ DO 55 K=1,4
+ SIGVM(I,K) = 0.D0
+ SLVM1(I,K) = 0.D0
+ SLVM2(I,K) = 0.D0
+ 55 CONTINUE
+ 50 CONTINUE
+
+ DO 100 I=1,NGAUSO
+ B2 = XPNT(I)**2
+ WG = WGHT(I)*XPNT(I)
+ WGB = B2*WG
+
+C calculate impact parameter amplitude, results in /POINT4/
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(IP,IFHARD,XPNT(I))
+ ELSE
+ CALL PHO_EIKON(IP,1,XPNT(I))
+ ENDIF
+
+ SIGTOT = SIGTOT + DREAL(AMPEL)*WG
+ SIGELA = SIGELA + CDABS(AMPEL)**2*WG
+ SLEL1 = SLEL1 + AMPEL*WGB
+ SLEL2 = SLEL2 + AMPEL*WG
+
+ DO 110 J=1,4
+ DO 120 K=1,4
+ SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
+ SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
+ SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
+ 120 CONTINUE
+ SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
+ 110 CONTINUE
+
+ SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
+ SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
+ SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
+ SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
+ SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
+ SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
+ SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
+ SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
+
+ 100 CONTINUE
+
+ SIGDIR = DREAL(SIGHD)
+ FAC = 4.D0*PI2
+ SIGTOT = SIGTOT*FAC
+ SIGELA = SIGELA*FAC
+ FACSL = 0.5D0/GEV2MB
+ SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
+
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
+ DO 130 I=1,4
+ DO 140 J=1,4
+ SIGVM(I,J) = SIGVM(I,J)*FAC
+ SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
+ 140 CONTINUE
+ 130 CONTINUE
+ SIGVM(0,0) = 0.D0
+ DO 150 I=1,4
+ SIGVM(0,I) = 0.D0
+ SIGVM(I,0) = 0.D0
+ DO 160 J=1,4
+ SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
+ SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
+ 160 CONTINUE
+ SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
+ 150 CONTINUE
+ ENDIF
+
+C diffractive cross sections
+
+ SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
+ SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
+ SIGLDD = SIGLDD *FAC*PARMDL(42)
+ SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
+ SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
+ SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
+ & *FAC*PARMDL(42)
+
+C double pomeron scattering
+
+ SIGCDF(0) = 0.D0
+ DO 170 I=1,4
+ SIGCDF(I) = SIGCDF(I)*FAC
+ SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
+ 170 CONTINUE
+
+ SIG1SO = SIG1SO *FAC
+ SIG1HA = SIG1HA *FAC
+
+ SIGINE = SIGTOT - SIGELA
+
+C user-forced change of diffractive cross section
+
+ IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
+
+C use optional explicit parametrization for single-diffraction
+
+ SIGSD1 = SIGLSD(1)+SIGHSD(1)
+ SIGSD2 = SIGLSD(2)+SIGHSD(2)
+ SS = EE*EE
+ XI_MIN = 1.5D0/SS
+ XI_MAX = PARMDL(45)**2
+ CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
+ & SIG_SD1,SIG_SD2,SIG_DD)
+ SIG_SD1 = SIG_SD1*PARMDL(40)
+ SIG_SD2 = SIG_SD2*PARMDL(41)
+
+**sr
+C DEL_SD1 = SIG_SD1-SIGSD1
+ DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
+**
+
+ FAC = SIGLSD(1)/SIGSD1
+ SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
+ SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
+
+C DEL_SD2 = SIG_SD2-SIGSD2
+ DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
+
+ FAC = SIGLSD(2)/SIGSD2
+ SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
+ SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
+
+ IF(ISWMDL(30).GE.2) THEN
+
+C use explicit parametrization also for double diffraction diss.
+ SIGDD = SIGLDD+SIGHDD
+ SIG_DD = SIG_DD*PARMDL(42)
+ DEL_DD = SIG_DD-SIGDD
+ FAC = SIGLDD/SIGDD
+ SIGLDD = SIGLDD+FAC*DEL_DD
+ SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
+ SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
+
+ ELSE
+
+C rescale double diffraction cross sections
+ SIGLDD = SIGLDD *PARMDL(42)
+ SIGHDD = SIGHDD *PARMDL(42)
+ SIGCOR = DEL_SD1 + DEL_SD2
+ & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
+
+ ENDIF
+
+ ELSE
+
+C rescale unitarized cross sections for diffraction dissociation
+
+ SIGLSD(1) = SIGLSD(1)*PARMDL(40)
+ SIGHSD(1) = SIGHSD(1)*PARMDL(40)
+ SIGLSD(2) = SIGLSD(2)*PARMDL(41)
+ SIGHSD(2) = SIGHSD(2)*PARMDL(41)
+ SIGLDD = SIGLDD *PARMDL(42)
+ SIGHDD = SIGHDD *PARMDL(42)
+ SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
+ & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
+ & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
+
+ ENDIF
+
+C non-diffractive inelastic cross section
+
+ SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD
+
+C specify elastic scattering channel
+
+ 500 CONTINUE
+ IF(IFPAP(1).NE.22) THEN
+ VMESA(1) = PHO_PNAME(IFPAB(1),0)
+ ELSE
+ VMESA(1) = 'rho '
+ ENDIF
+ IF(IFPAP(2).NE.22) THEN
+ VMESB(1) = PHO_PNAME(IFPAB(2),0)
+ ELSE
+ VMESB(1) = 'rho '
+ ENDIF
+
+C write out physical cross sections
+
+ IF(IDEB(57).GE.5) THEN
+ WRITE(LO,'(/1X,A,I3,/1X,A)')
+ & 'PHO_XSECT: cross sections (mb) for combination',IP,
+ & '----------------------------------------------'
+ WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
+ WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
+ WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
+ WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
+ WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
+ & SIGLSD(1)+SIGHSD(1)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
+ & SIGLSD(2)+SIGHSD(2)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
+ WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
+ WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
+ ENDIF
+ WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
+ DO 200 I=1,4
+ DO 210 J=1,4
+ IF(SIGVM(I,J).GT.DEPS) THEN
+ WRITE(LO,'(1X,3A)') 'q-elastic production of ',
+ & VMESA(I),VMESB(J)
+ WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
+ IF((I.NE.0).AND.(J.NE.0))
+ & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
+ ENDIF
+ 210 CONTINUE
+ 200 CONTINUE
+ IF(IDEB(57).GE.7) THEN
+ WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
+ WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
+ WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
+ WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
+ WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
+ WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
+ WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
+ & DREAL(DSIGH(15))
+ ENDIF
+ ENDIF
+
+ ECM = ETMP
+
+ END
+
+CDECK ID>, PHO_IMPAMP
+ SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
+C*********************************************************************
+C
+C calculation of physical impact parameter amplitude
+C
+C input: EE cm energy (GeV)
+C BMIN lower bound in B
+C BMAX upper bound in B
+C NSTEP number of values (linear)
+C
+C output: values written to output unit
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(ONEM=-1.D0,
+ & THOUS=1.D3,
+ & DEPS=1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+
+ ECM=EE
+ BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
+C
+ WRITE(LO,'(3(/,1X,A))')
+ & 'impact parameter amplitudes:',
+ & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
+ & '-------------------------------------------------------------'
+C
+ BB = BMIN
+ DO 100 I=1,NSTEP
+C calculate impact parameter amplitudes
+ IF(I.EQ.1) THEN
+ CALL PHO_EIKON(1,-1,BMIN)
+ ELSE
+ CALL PHO_EIKON(1,1,BB)
+ ENDIF
+ WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
+ & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
+ & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
+ BB = BB+BSTEP
+ 100 CONTINUE
+
+ END
+
+CDECK ID>, PHO_PRBDIS
+ SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
+C*********************************************************************
+C
+C calculation of multi interactions probabilities
+C
+C input: IP particle combination to scatter
+C ECM CMS energy
+C IE index for weight storing
+C /PROBAB/
+C IMAX max. number of soft pomeron interactions
+C KMAX max. number of hard pomeron interactions
+C
+C output: /PROBAB/
+C PROB field of probabilities
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS=1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C Born graph cross sections and slopes
+ INTEGER Max_pro_3
+ PARAMETER ( Max_pro_3 = 16 )
+ COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
+ & SIGD1,SIGD2,DSIGH
+ COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
+ & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C Born graph cross sections after applying diffraction model
+ DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
+ & SBOLPO,SBODPO
+ COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
+ & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
+ & SBODPO(0:4,4)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+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 unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+
+C local variables
+ DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
+ PARAMETER (ICHMAX=40)
+ DIMENSION CHIFAC(4,4),AMPCOF(4)
+ DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
+ DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
+
+C combinatorical factors
+ DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
+ & 1.D0,-1.D0, 1.D0,-1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0 /
+
+ DATA FACLOG / .000000000000000D+00,
+ & .000000000000000D+00, .693147180559945D+00,
+ & .109861228866811D+01, .138629436111989D+01,
+ & .160943791243410D+01, .179175946922805D+01,
+ & .194591014905531D+01, .207944154167984D+01,
+ & .219722457733622D+01, .230258509299405D+01,
+ & .239789527279837D+01, .248490664978800D+01,
+ & .256494935746154D+01, .263905732961526D+01,
+ & .270805020110221D+01, .277258872223978D+01,
+ & .283321334405622D+01, .289037175789616D+01,
+ & .294443897916644D+01, .299573227355399D+01,
+ & .304452243772342D+01, .309104245335832D+01,
+ & .313549421592915D+01, .317805383034795D+01,
+ & .321887582486820D+01, .325809653802148D+01,
+ & .329583686600433D+01, .333220451017520D+01,
+ & .336729582998647D+01, .340119738166216D+01 /
+
+ DATA ELAST / 0.D0 /
+ DATA IPLAST / 0 /
+
+C test for redundant calculation: skip cs calculation
+ IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
+ ELAST = ECM
+ IPLAST = IP
+ CALL PHO_XSECT(IP,0,ELAST)
+ ISIMAX = IE
+ SIGECM(IP,IE) = ECM
+ SIGTAB(IP,1,IE) = SIGTOT
+ SIGTAB(IP,2,IE) = SIGELA
+ J = 2
+ DO 5 I=0,4
+ DO 6 K=0,4
+ J = J+1
+ SIGTAB(IP,J,IE) = SIGVM(I,K)
+ 6 CONTINUE
+ 5 CONTINUE
+ SIGTAB(IP,28,IE) = SIGINE
+ SIGTAB(IP,29,IE) = SIGDIR
+ SIGTAB(IP,30,IE) = SIGLSD(1)
+ SIGTAB(IP,31,IE) = SIGLSD(2)
+ SIGTAB(IP,32,IE) = SIGHSD(1)
+ SIGTAB(IP,33,IE) = SIGHSD(2)
+ SIGTAB(IP,34,IE) = SIGLDD
+ SIGTAB(IP,35,IE) = SIGHDD
+ SIGTAB(IP,36,IE) = SIGCDF(0)
+ SIGTAB(IP,37,IE) = SIG1SO
+ SIGTAB(IP,38,IE) = SIG1HA
+ SIGTAB(IP,39,IE) = SLOEL
+ J = 39
+ DO 7 I=1,4
+ DO 8 K=1,4
+ J = J+1
+ SIGTAB(IP,J,IE) = SLOVM(I,K)
+ 8 CONTINUE
+ 7 CONTINUE
+ SIGTAB(IP,56,IE) = SIGPOM
+ SIGTAB(IP,57,IE) = SIGREG
+ SIGTAB(IP,58,IE) = SIGHAR
+ SIGTAB(IP,59,IE) = SIGDIR
+ SIGTAB(IP,60,IE) = SIGTR1(1)
+ SIGTAB(IP,61,IE) = SIGTR1(2)
+ SIGTAB(IP,62,IE) = SIGTR2(1)
+ SIGTAB(IP,63,IE) = SIGTR2(2)
+ SIGTAB(IP,64,IE) = SIGLOO
+ SIGTAB(IP,65,IE) = SIGDPO(1)
+ SIGTAB(IP,66,IE) = SIGDPO(2)
+ SIGTAB(IP,67,IE) = SIGDPO(3)
+ SIGTAB(IP,68,IE) = SIGDPO(4)
+
+C consistency check
+ SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD
+
+ IF(SIGNDF.LE.0.D0) THEN
+ WRITE(LO,'(//1X,A,/)')
+ & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
+ WRITE(LO,'(4X,A,/1P,8E10.3)')
+ &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
+ & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
+ & SIGLSD(2),SIGLDD
+ STOP
+ ENDIF
+
+ IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
+ print LO,'------------------------------------------------'
+ print LO,'IP,ECM:',IP,ECM
+ print LO,'SIGTOT:',SIGTOT
+ print LO,'SIGELA:',SIGELA
+ print LO,'SIGVM :',SIGVM(0,0)
+ print LO,'SIGCDF:',SIGCDF(0)
+ print LO,'SIGDIR:',SIGDIR
+ print LO,'SIGLSD:',SIGLSD
+ print LO,'SIGHSD:',SIGHSD
+ print LO,'SIGLDD:',SIGLDD
+ print LO,'SIGHDD:',SIGHDD
+ print LO,'SIGNDF:',SIGNDF
+
+ print LO,'SIGPOM:',SIGPOM
+ print LO,'SIGREG:',SIGREG
+ print LO,'SIGHAR:',SIGHAR
+ print LO,'SIGDIR:',SIGDIR
+ print LO,'SIGTR1:',SIGTR1
+ print LO,'SIGTR2:',SIGTR2
+ print LO,'SIGLOO:',SIGLOO
+ print LO,'SIGDPO:',SIGDPO
+ print LO,'SIG1SO:',SIG1SO
+ print LO,'SIG1HA:',SIG1HA
+ ENDIF
+
+ SIGTAB(IP,77,IE) = PTCUT(IP)
+ SIGTAB(IP,78,IE) = SIGNDF
+
+ AUXFAC = PI2/SIGNDF
+ IF(ISWMDL(1).EQ.3) THEN
+ DO 133 I=1,4
+ AMPCOF(I) = 0.D0
+ DO 135 K=1,4
+ AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
+ 135 CONTINUE
+ AMPCOF(I) = AMPCOF(I)*AUXFAC
+ 133 CONTINUE
+ ENDIF
+C
+* BMAX=5.D0*SQRT(DBLE(BPOM))
+ BMAX=10.D0
+ EPTAB(IP,IE) = ECM
+ CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
+C
+ ENDIF
+C
+ DO 160 K=0,KMAX
+ DO 170 I=0,IMAX
+ PROB(IP,IE,I,K) = 0.D0
+ 170 CONTINUE
+ 160 CONTINUE
+ DO 120 I=1,ICHMAX
+ PCHAIN(1,I) = 0.D0
+ PCHAIN(2,I) = 0.D0
+ 120 CONTINUE
+C
+C main cross section loop
+C**********************************************************
+ DO 5000 IB=1,NGAUSO
+ B24=XPNT(IB)**2/4.D0
+ FAC = XPNT(IB)*WGHT(IB)
+C
+ IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
+C
+C amplitude construction
+ DO 525 I=1,4
+ AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
+ & +ZXR(1,I)*EXP(-B24/BXR(1,I))
+ AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
+ AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
+ & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
+ & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
+ & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
+ & -ZXL(1,I)*EXP(-B24/BXL(1,I))
+ AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
+ & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
+ & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
+ & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
+ AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
+ AB(2,I) = AB(2,I)
+ AB(3,I) = 0.D0
+ AB(4,I) = 0.D0
+*
+ 525 CONTINUE
+C
+ DO 460 I=1,4
+ DO 500 K=1,4
+ ABSUM2(I,K) = 0.D0
+ DO 550 L=1,4
+ ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
+ 550 CONTINUE
+ ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
+ 500 CONTINUE
+ 460 CONTINUE
+ DO 600 I=1,4
+ CHI2(I) = 0.D0
+ DO 650 K=1,4
+ CHI2(I) = CHI2(I) + ABSUM2(K,I)
+ 650 CONTINUE
+ 600 CONTINUE
+C sums instead of products
+ DO 660 I=1,4
+ DO 670 KD=1,4
+ DTMP = ABS(ABSUM2(I,KD))
+ IF(DTMP.LT.1.D-30) THEN
+ ABSUM2(I,KD) = -50.D0
+ ELSE
+ ABSUM2(I,KD) = LOG(DTMP)
+ ENDIF
+ 670 CONTINUE
+ 660 CONTINUE
+
+ IF(MAX(IMAX,KMAX).GT.30) THEN
+ WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
+ & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
+ CALL PHO_ABORT
+ ENDIF
+
+ DO 700 KD=1,4
+ DO 750 I=1,4
+ ABSTMP(I) = ABSUM2(I,KD)
+ 750 CONTINUE
+C recursive sum
+ CHITMP(1) = -ABSUM2(1,KD)
+ DO 800 I=0,IMAX
+ CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
+ CHITMP(2) = -ABSTMP(2)
+ DO 810 K=0,KMAX
+ CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
+C calculation of elastic part
+ DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
+ IF(DTMP.LT.-30.D0) THEN
+ DTMP = 0.D0
+ ELSE
+ DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
+ ENDIF
+ PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
+ 810 CONTINUE
+ 800 CONTINUE
+ 700 CONTINUE
+ PROB(IP,IE,0,0) = 0.D0
+C
+C**********************************************************
+ ELSE
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
+ STOP
+ ENDIF
+ 5000 CONTINUE
+
+C debug output
+ IF(IDEB(55).GE.15) THEN
+ WRITE(LO,'(/,1X,A,I3,E11.4)')
+ & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
+ & IP,ECM
+ DO 905 I=0,MIN(IMAX,5)
+ DO 915 K=0,MIN(KMAX,5)
+ IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
+ & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
+ 915 CONTINUE
+ 905 CONTINUE
+ ENDIF
+C string probability (uncorrected)
+ IF(IDEB(55).GE.5) THEN
+ DO 955 I=0,IMAX
+ DO 965 K=0,KMAX
+ INDX = 2*I+2*K
+ IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
+ PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
+ ENDIF
+ 965 CONTINUE
+ 955 CONTINUE
+ WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
+ & 'list of selected probabilities (uncorr,ECM)',ECM
+ WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
+ DO 183 I=0,IIMAX
+ IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
+ & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
+ & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
+ 183 CONTINUE
+ ENDIF
+C substract high-mass single and double diffraction
+ PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
+ & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
+ PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
+C
+C probability check
+ CHKSUM = 0.D0
+ PRONEG = 0.D0
+ AVERI = 0.D0
+ AVERK = 0.D0
+ AVERL = 0.D0
+ AVERM = 0.D0
+ AVERN = 0.D0
+ SIGMI = 0.D0
+ SIGMK = 0.D0
+ SIGML = 0.D0
+ SIGMM = 0.D0
+ DO 1001 I=0,IMAX
+ PSOFT(I) = 0.D0
+ 1001 CONTINUE
+ DO 1002 K=0,KMAX
+ PHARD(K) = 0.D0
+ 1002 CONTINUE
+ DO 1000 K=0,KMAX
+ DO 1010 I=0,IMAX
+ TMP = PROB(IP,IE,I,K)
+ IF(TMP.LT.0.D0) THEN
+ IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
+ WRITE(LO,'(1X,A,4I4,E14.4)')
+ & 'PHO_PRBDIS: neg.probability:',
+ & IP,IE,I,K,PROB(IP,IE,I,K)
+ ENDIF
+ PRONEG = PRONEG+TMP
+ TMP = 0.D0
+ ENDIF
+ CHKSUM = CHKSUM+TMP
+ AVERI = AVERI+DBLE(I)*TMP
+ AVERK = AVERK+DBLE(K)*TMP
+ SIGMI = SIGMI+DBLE(I**2)*TMP
+ SIGMK = SIGMK+DBLE(K**2)*TMP
+ PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
+ PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
+ PROB(IP,IE,I,K) = CHKSUM
+ 1010 CONTINUE
+ 1000 CONTINUE
+C
+ IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
+ & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
+C cut probabilites output
+ IF(IDEB(55).GE.5) THEN
+ WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
+ DO 185 I=1,ICHMAX
+ IF(ABS(PCHAIN(1,I)).GT.1.D-10)
+ & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
+ 185 CONTINUE
+ ENDIF
+C rescaling necessary
+ IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
+ FAC = 1.D0/CHKSUM
+ IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
+ & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
+ DO 40 K=0,KMAX
+ DO 50 I=0,IMAX
+ PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
+ 50 CONTINUE
+ 40 CONTINUE
+ AVERI = AVERI*FAC
+ AVERK = AVERK*FAC
+ AVERL = AVERL*FAC
+ AVERM = AVERM*FAC
+ SIGMI = SIGMI*FAC**2
+ SIGMK = SIGMK*FAC**2
+ SIGML = SIGML*FAC**2
+ SIGMM = SIGMM*FAC**2
+ ENDIF
+C
+C probability to find Reggeon/Pomeron
+ PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
+ AVERJ = -PROB(IP,IE,0,0)*AVERI
+ AVERII = AVERI-AVERJ
+C
+ SIGTAB(IP,74,IE) = AVERII
+ SIGTAB(IP,75,IE) = AVERK
+ SIGTAB(IP,76,IE) = AVERJ
+C
+ SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
+ SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
+C
+ IF(IDEB(55).GE.1) THEN
+
+C average interaction probabilities
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_PRBDIS: expected interaction statistics',
+ & '-------------------------------------------'
+ WRITE(LO,'(1X,A,E12.4,2I3)')
+ & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
+ WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
+ & IMAX,KMAX
+ WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
+ & 'averaged number of cuts per event (eff. cs):',SIGNDF,
+ & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
+ & AVERII,AVERK,AVERJ,AVERL,AVERM,
+ & AVERI+AVERK+AVERL+AVERM
+ WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
+ & 'standard deviation ( sqrt(sigma) ):',
+ & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
+ & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
+ & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
+ WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
+ DO I=0,MIN(IMAX,KMAX)
+ WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
+ & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
+ ENDDO
+
+C cross check of probability distribution and inclusive cross section
+ PSsum_1 = 0.D0
+ PSsum_2 = 0.D0
+ PHsum_1 = 0.D0
+ PHsum_2 = 0.D0
+ do i=1,IMAX
+ PSsum_1 = PSsum_1+PSOFT(i)*FAC
+ PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
+ enddo
+ do k=1,KMAX
+ PHsum_1 = PHsum_1+PHARD(k)
+ PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
+ enddo
+ WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
+ & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SAMPRO
+ SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
+C***********************************************************************
+C
+C routine to sample kind of process
+C
+C input: IP particle combination
+C IFP1/2 PDG number of particle 1/2
+C ECM c.m. energy (GeV)
+C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
+C SPROB suppression factor for processes 1-7
+C due to rapidity gap survival probability
+C IPROC mode
+C -2 output of statistics
+C -1 initialization
+C 0 sampling of process
+C
+C output: IPROC kind of interaction process:
+C 1 non-diffractive resolved process
+C 2 elastic scattering
+C 3 quasi-elastic rho/omega/phi production
+C 4 central diffraction
+C 5 single diffraction according to IDIFF1
+C 6 single diffraction according to IDIFF2
+C 7 double diffraction
+C 8 single-resolved / direct processes
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER IP,IFP1,IFP2,IPROC
+ DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+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)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
+ DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
+ DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
+
+ INTEGER I,K,KMAX
+ DOUBLE PRECISION DT_RNDM
+ DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
+
+ IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
+ & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
+ & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
+
+ IF(IPROC.GE.0) THEN
+
+C interpolate cross sections
+ CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
+
+C cross check
+ IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
+ WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
+ & 'PHO_SAMPRO: inconsistent gap survival probability',
+ & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
+ & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
+ ENDIF
+
+C calculate cumulative probabilities
+ IF(ISWMDL(1).EQ.3) THEN
+ IF(ISWMDL(2).GE.1) THEN
+ SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
+ SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
+ SIGDDI = SIGLDD+SIGHDD
+ SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
+ & - SIGSDI(1)-SIGSDI(2)-SIGDDI
+ XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
+ XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
+ XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
+ XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
+ XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
+ XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
+ XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
+ XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
+ ELSE
+ SIGHR = 0.D0
+ IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
+ SIGHD = 0.D0
+ IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
+ XPROB(1) = SIGHR/(SIGHR+SIGHD)
+ XPROB(2) = XPROB(1)
+ XPROB(3) = XPROB(1)
+ XPROB(4) = XPROB(1)
+ XPROB(5) = XPROB(1)
+ XPROB(6) = XPROB(1)
+ XPROB(7) = XPROB(1)
+ XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
+ ENDIF
+
+ IF(IDEB(11).GE.15) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_SAMPRO: partial cross sections for IP',IP
+ WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
+ DO 240 I=2,8
+ WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
+ 240 CONTINUE
+ ENDIF
+
+ ELSE
+ WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
+ & ISWMDL(1)
+ CALL PHO_ABORT
+ ENDIF
+
+ IF(XPROB(8).LT.1.D-20) THEN
+ IF(IDEB(11).GE.2)
+ & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
+ & 'activated processes have vanishing cross section sum',
+ & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
+ IPROC = 0
+ RETURN
+ ENDIF
+
+C sample process
+ XI = DT_RNDM(XI)*XPROB(8)
+ DO 100 I=1,8
+ IF(XI.LE.XPROB(I)) GOTO 110
+ 100 CONTINUE
+ 110 CONTINUE
+ IPROC = MIN(I,8)
+
+ CALLS(IP) = CALLS(IP)+1.D0
+ PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
+ ECMSUM(IP) = ECMSUM(IP)+ECM
+ IF(ISWMDL(2).GE.1) THEN
+ SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
+ ELSE
+ SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
+ ENDIF
+
+C debug output
+ IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
+ & 'PHO_SAMPRO: IP,CALL,PROC-ID',
+ & IP,INT(CALLS(IP)+0.1D0),IPROC
+
+C statistics initialization
+ ELSE IF(IPROC.EQ.-1) THEN
+ DO 260 K=1,4
+ DO 250 I=1,8
+ PRO(I,K) = 0.D0
+ 250 CONTINUE
+ CALLS(K) = 0.D0
+ SIGSUM(K) = 0.D0
+ ECMSUM(K) = 0.D0
+ 260 CONTINUE
+
+C write out statistics
+ ELSE IF(IPROC.EQ.-2) THEN
+ KMAX = 4
+ IF(ISWMDL(2).EQ.0) KMAX=1
+ DO 270 K=1,KMAX
+ IF(CALLS(K).GT.0.5D0) THEN
+ SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
+ ECMSUM(K) = ECMSUM(K)/CALLS(K)
+ IF(IDEB(11).GE.0) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
+C & 'PHO_SAMPRO: internal process statistics ',
+C & '(IP,<Ecm>)',K,ECMSUM(K),
+C & '---------------------------------------'
+C WRITE(LO,'(8X,A)')
+C & ' process sampled cross section'
+C IF(ISWMDL(2).GE.1) THEN
+C WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
+C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
+C & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
+C & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
+C & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
+C & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
+C & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
+C & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
+C & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
+C & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
+C ELSE
+C WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
+C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
+C & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
+C & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
+C ENDIF
+ ENDIF
+ ENDIF
+ 270 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SAMPRB
+ SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
+C********************************************************************
+C
+C routine to sample number of cut graphs of different kind
+C
+C input: IP scattering particle combination
+C ECMI CMS energy
+C IP -1 initialization
+C -2 output of statistics
+C others sampling of cuts
+C
+C output: ISAM number of soft Pomerons cut
+C JSAM number of soft Reggeons cut
+C KSAM number of hard Pomerons cut
+C
+C PHO_PRBDIS has to be called before
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+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 cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
+
+C sample number of interactions
+ IF(IP.GE.0) THEN
+ ITER = 0
+ ECMX = ECMI
+ ECMC = ECMI
+ KLIM = 1
+ IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
+ IF(IPAMDL(16).EQ.0) ECMC = SECM
+ KLIM = 0
+ ENDIF
+
+C sample up to kinematic limits only
+ IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
+ IF(IMAX1.LT.1) THEN
+ IF(IPAMDL(2).EQ.1) THEN
+C reggeon allowed
+ ISAM = 0
+ JSAM = 1
+ KSAM = 0
+ AVERB(3,IP) = AVERB(3,IP)+1.D0
+ ELSE
+C only pomeron even at very low energies
+ ISAM = 1
+ JSAM = 0
+ KSAM = 0
+ AVERB(1,IP) = AVERB(1,IP)+1.D0
+ ENDIF
+ AVERB(0,IP) = AVERB(0,IP)+1.D0
+ GOTO 150
+ ENDIF
+C find interpolation factors
+ IF(ECMX.LE.EPTAB(IP,1)) THEN
+ I1 = 1
+ I2 = 1
+ ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
+ DO 50 I=2,IEEMAX
+ IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = IEEMAX
+ I2 = IEEMAX
+ ENDIF
+ FAC2 = 0.D0
+ IF(I1.NE.I2)
+ & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
+ FAC1=1.D0-FAC2
+C reggeon probability
+ PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
+C calculate soft suppression factor
+ IF(IP.EQ.1) FSUPP = PARMDL(35)**2
+ & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
+C
+ 10 CONTINUE
+ ITER = ITER+1
+ XI = DT_RNDM(FAC2)
+ DO 260 KSAM=0,KMAX
+ DO 270 ISAM=0,IMAX
+ PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
+ & +PROB(IP,I2,ISAM,KSAM)*FAC2
+ IF(PRO.GT.XI) GOTO 100
+ 270 CONTINUE
+ 260 CONTINUE
+ ISAM = MIN(IMAX,ISAM)
+ KSAM = MIN(KMAX,KSAM)
+
+ 100 CONTINUE
+
+ IF(ITER.GT.100) THEN
+
+ ISAM = 0
+ JSAM = 1
+ KSAM = 0
+ IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
+ & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
+
+ ELSE
+
+C reggeon contribution
+ JSAM = 0
+ IF(IPAMDL(2).EQ.1) THEN
+ DO 90 I=1,ISAM
+ IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
+ 90 CONTINUE
+ ISAM = ISAM-JSAM
+ ENDIF
+C statistics of bare cuts
+ IF(ITER.EQ.1) THEN
+ AVERB(0,IP) = AVERB(0,IP)+1.D0
+ AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
+ AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
+ AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
+ ENDIF
+C limitation given by field dimensions
+ IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
+
+ IF(IP.EQ.1) THEN
+
+C reweight according to virtualities and PDF treatment
+ IF(IPAMDL(115).GE.1) THEN
+ IF(KSAM.EQ.0) THEN
+ IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
+ ENDIF
+ ENDIF
+
+C reduce number of cuts according to photon virtualities
+ IF(IPAMDL(114).GE.1) THEN
+ 110 CONTINUE
+ I = ISAM+JSAM
+ WGX = FSUPP**I
+ IF(DT_RNDM(WGX).GT.WGX) THEN
+ IF(ISAM+JSAM+KSAM.GT.1) THEN
+ IF(JSAM.GT.0) THEN
+ JSAM = JSAM-1
+ GOTO 110
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ GOTO 110
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+C phase space limitation
+ 120 CONTINUE
+ XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
+ & +DBLE(2*KSAM)*PTCUT(IP)
+ PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
+ IF(DT_RNDM(XM).GT.PACC) THEN
+ IF(ISAM+JSAM+KSAM.GT.1) THEN
+ IF(JSAM.GT.0) THEN
+ JSAM = JSAM-1
+ GOTO 120
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ GOTO 120
+ ELSE IF(KSAM.GT.KLIM) THEN
+ KSAM = KSAM-1
+ GOTO 120
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ISAM = ISAM+JSAM/2
+ JSAM = MOD(JSAM,2)
+C collect statistics
+ 150 CONTINUE
+ ECMS1(IP) = ECMS1(IP)+ECMX
+ ECMS2(IP) = ECMS2(IP)+ECMC
+
+ AVERC(0,IP) = AVERC(0,IP)+1.D0
+ AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
+ AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
+ AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
+C
+ IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
+ & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
+C
+C initialize statistics
+ ELSE IF(IP.EQ.-1) THEN
+ DO 60 I=1,4
+ ECMS1(I) = 0.D0
+ ECMS2(I) = 0.D0
+ DO 65 K=0,3
+ AVERB(K,I) = 0.D0
+ AVERC(K,I) = 0.D0
+ 65 CONTINUE
+
+ 60 CONTINUE
+ RETURN
+C
+C write out statistics
+ ELSE IF(IP.EQ.-2) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
+C & '----------------------------------'
+ DO 70 I=1,4
+ IF(AVERB(0,I).LT.2.D0) GOTO 75
+C WRITE(LO,'(1X,A,I3,1P,2E13.3)')
+C & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
+C & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
+C WRITE(LO,'(5X,A)')
+C & 'average number of s-pom,h-pom,reg cuts (bare)'
+C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
+C & (AVERB(K,I)/AVERB(0,I),K=1,3)
+C WRITE(LO,'(5X,A)')
+C & 'average (with energy/virtuality corrections)'
+C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
+C & (AVERC(K,I)/AVERC(0,I),K=1,3)
+
+ 75 CONTINUE
+ 70 CONTINUE
+ RETURN
+ ENDIF
+ END
+
+CDECK ID>, PHO_TRIREG
+ SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
+ & SIGTR,BTR)
+C**********************************************************************
+C
+C calculation of triple-Pomeron total cross section
+C according to Gribov's Regge theory
+C
+C input: S squared cms energy
+C GA coupling constant to diffractive line
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C GPPP triple-Pomeron coupling
+C BPPP slope related to B0PPP (GeV**-2)
+C VIR2A virtuality of particle a (GeV**2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGTR total triple-Pomeron cross section
+C BTR effective triple-Pomeron slope
+C (differs from diffractive slope!)
+C
+C uses E_i (Exponential-Integral function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
+ SIGU = 2.5
+C integration cut-off Sigma_L (min. squared mass of diff. blob)
+ SIGL = 5.+VIR2A
+C debug output
+ IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(S.LT.5.D0) THEN
+ SIGTR = 0.D0
+ BTR = BPPP+BB
+ RETURN
+ ENDIF
+C change units of ALPHAP to mb
+ ALSCA = ALPHAP*GEV2MB
+C
+C cross section
+ PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
+ & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
+ PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
+ PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
+C
+ SIGTR=PART1*(PART2-PART3)
+C
+C slope
+ PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
+ & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
+ PART2 = LOG(PART1)
+ PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
+ BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
+ BTR = BTR-PART1
+C
+ IF(SIGTR.LT.EPS) SIGTR = 0.D0
+ IF(BTR.LT.BB) BTR = BB
+C
+ IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
+ END
+
+CDECK ID>, PHO_LOOREG
+ SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
+ & VIR2A,VIR2B,SIGLO,BLO)
+C**********************************************************************
+C
+C calculation of loop-Pomeron total cross section
+C according to Gribov's Regge theory
+C
+C input: S squared cms energy
+C GA coupling constant to diffractive line
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C GPPP triple-Pomeron coupling
+C BPPP slope related to B0PPP (GeV**-2)
+C VIR2A virtuality of particle a (GeV**2)
+C VIR2B virtuality of particle b (GeV**2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGLO total loop-Pomeron cross section
+C BLO effective loop-Pomeron slope
+C (differs from double diffractive slope!)
+C
+C uses E_i (Exponential-Integral function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
+ SIGU = 2.5
+C integration cut-off Sigma_L (min. squared mass of diff. blob)
+ SIGL = 5.+VIR2A+VIR2B
+C debug output
+ IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(S.LT.5.D0) THEN
+ SIGLO = 0.D0
+ BLO = 2.D0*BPPP
+ RETURN
+ ENDIF
+
+C
+C change units of ALPHAP to mb
+ ALSCA = ALPHAP*GEV2MB
+C
+C cross section
+ PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
+ & EXP(-DELTA*BPPP/ALPHAP)
+ PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
+ PARTB=BPPP/ALPHAP+LOG(SIGU)
+ SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
+ & -PHO_EXPINT(PARTB*DELTA))
+ & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
+ & )
+C
+C slope
+ PART1 = LOG(ABS(PARTA/PARTB))
+ & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
+ PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
+ BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
+ BLO = BLO-PART1
+C
+ IF(SIGLO.LT.EPS) SIGLO = 0.D0
+ IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
+C
+ IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
+ END
+
+CDECK ID>, PHO_TRXPOM
+ SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
+ & GPPP,BPPP,SIGDP,BDP)
+C**********************************************************************
+C
+C calculation of total cross section of two tripe-Pomeron
+C graphs in X configuration according to Gribov's Reggeon field
+C theory
+C
+C input: S squared cms energy
+C GA coupling constant to elastic line 1
+C AA slope related to GA (GeV**-2)
+C GB coupling constant to elastic line 2
+C BB slope related to GB (GeV**-2)
+C DELTA effective pomeron delta (intercept-1)
+C ALPHAP slope of pomeron trajectory (GeV**-2)
+C BPPP triple-Pomeron coupling
+C BTR slope related to B0PPP (GeV**-2)
+C note: units of all coupling constants are mb**1/2
+C
+C output: SIGDP total cross section for double-Pomeron
+C scattering
+C BDP effective double-Pomeron slope
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS =0.0001D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION XWGH1(96),XPOS1(96)
+
+C lower integration cut-off Sigma_L
+ SIGL = PARMDL(71)**2
+C upper integration cut-off Sigma_U
+ C = 1.D0-1.D0/PARMDL(70)**2
+ C = MAX(PARMDL(72),C)
+ SIGU = (1.D0-C)**2*S
+C integration precision
+ NGAUS1=16
+C
+C debug output
+ IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
+ & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
+ & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
+C
+ IF(SIGU.LE.SIGL) THEN
+ SIGDP = 0.D0
+ BDP = AA+BB
+ RETURN
+ ENDIF
+C
+C cross section
+C
+ XIL = LOG(SIGL)
+ XIU = LOG(SIGU)
+ XI = LOG(S)
+ FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
+ ALPHA2 = 2.D0*ALPHAP
+ ALOC = LOG(1.D0/(1.D0-C))
+ CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
+ XSUM = 0.D0
+ DO 100 I1=1,NGAUS1
+ AMXSQ = EXP(XPOS1(I1))
+ ALOSMX = LOG(S/AMXSQ)
+ ALCSMX = LOG((1.D0-C)*S/AMXSQ)
+ W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
+ W = MAX(0.D0,W)
+ WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
+C supercritical part
+ WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
+ XSUM = XSUM + W*XWGH1(I1)/WN*WSC
+ 100 CONTINUE
+ SIGDP = XSUM*FAC
+C
+C slope
+ BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
+C
+ IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
+ & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
+ END
+
+CDECK ID>, PHO_CHAN2A
+ SUBROUTINE PHO_CHAN2A(BB)
+C***********************************************************************
+C
+C simple two channel model to realize low mass diffraction
+C (version A, iteration of triple- and loop-Pomeron)
+C
+C input: BB impact parameter (mb**1/2)
+C
+C output: /POINT4/
+C AMPEL elastic amplitude
+C AMPVM(4,4) q-elastic VM production
+C AMLMSD(2) low mass single diffraction amplitude
+C AMHMSD(2) high mass single diffraction amplitude
+C AMLMDD low mass double diffraction amplitude
+C AMHMDD high mass double diffraction amplitude
+C AMPDP(4) central diffraction amplitude
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-5,
+ & EIGHT = 8.D0)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C complex Born graph amplitudes used for unitarization
+ COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
+ & AMHMDD,AMPDP
+ COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
+ & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
+C unitarized amplitudes for different diffraction channels
+ DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
+ & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
+ & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
+ & ZXL,BXL
+ COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
+ & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
+ & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
+ & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
+ & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
+ & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
+ & ZXL(4,4),BXL(4,4)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+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 local variables
+ DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
+ & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
+ & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
+ DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
+
+C combinatorical factors
+ DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
+ & 1.D0,-1.D0, 1.D0,-1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0 /
+ DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
+ & 1.D0,-1.D0,-1.D0, 1.D0,
+ & -1.D0, 1.D0,-1.D0, 1.D0,
+ & -1.D0,-1.D0, 1.D0, 1.D0 /
+ DATA IELTAB / 1, 2, 3, 4,
+ & 2, 1, 4, 3,
+ & 3, 4, 1, 2,
+ & 4, 3, 2, 1 /
+
+ IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_CHAN2A: impact parameter B',BB
+
+ B24 = BB**2/4.D0
+ DO 25 I=1,4
+ AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
+ & +ZXR(1,I)*EXP(-B24/BXR(1,I))
+ AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
+ AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
+ AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
+ AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
+ & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
+ & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
+ AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
+ AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
+ AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
+ AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
+ 25 CONTINUE
+
+ DO 50 I=1,4
+ ABSUM(I) = 0.D0
+ DO 75 II=9,1,-1
+ ABSUM(I) = ABSUM(I) + AB(II,I)
+ 75 CONTINUE
+ 50 CONTINUE
+ IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
+ & 'PHO_CHAN2A: ABSUM',ABSUM
+
+ DO 100 I=1,4
+ CHI(I) = 0.D0
+ CHDS(I) = 0.D0
+ CHDH(I) = 0.D0
+ CHDA(I) = 0.D0
+ CHDB(I) = 0.D0
+ CHDD(I) = 0.D0
+ CHDPE(I) = 0.D0
+ CHDPA(I) = 0.D0
+ CHDPB(I) = 0.D0
+ CHDPD(I) = 0.D0
+ AMPELA(I,0) = 0.D0
+ AMPELA(I,9) = 0.D0
+ DO 200 K=1,4
+ AMPELA(I,K) = 0.D0
+ AMPELA(I,K+4) = 0.D0
+ AMPVM(I,K) = 0.D0
+ CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
+ CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
+ CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
+ CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
+ CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
+ CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
+ CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
+ CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
+ CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
+ CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
+ 200 CONTINUE
+ IF(CHI(I).LT.-DEPS) THEN
+ IF(IDEB(86).GE.0) THEN
+ WRITE(LO,'(1X,A,I3,2E12.3)')
+ & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
+ WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
+ ENDIF
+ ENDIF
+ IF(ABS(CHI(I)).GT.200.D0) THEN
+ EX1CHI(I) = 0.D0
+ EX2CHI(I) = 0.D0
+ ELSE
+ TMP = EXP(-CHI(I))
+ EX1CHI(I) = TMP
+ EX2CHI(I) = TMP*TMP
+ ENDIF
+ 100 CONTINUE
+ IF(IDEB(86).GE.20) THEN
+ WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
+ ENDIF
+
+ AMPELA(1,0) = 4.D0
+ DO 300 K=1,4
+ DO 400 J=1,4
+ CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
+ AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
+ AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
+ AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
+ AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
+ AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
+ AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
+ AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
+ AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
+ AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
+ AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
+ 400 CONTINUE
+ 300 CONTINUE
+
+ IF(IDEB(86).GE.25) THEN
+ DO 305 I=1,9
+ WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
+ & (AMPELA(K,1),K=1,4)
+ 305 CONTINUE
+ ENDIF
+
+C VDM factors --> amplitudes
+C low mass excitations
+ DO 500 I=1,4
+ AMPCHA(I) = 0.D0
+ DO 600 K=1,4
+ AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
+ 600 CONTINUE
+ 500 CONTINUE
+ AMPVME = AMPCHA(1)/EIGHT
+ AMLMSD(1) = AMPCHA(2)/EIGHT
+ AMLMSD(2) = AMPCHA(3)/EIGHT
+ AMLMDD = AMPCHA(4)/EIGHT
+C elastic part, high mass diffraction
+ AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
+ AMPSOF = 0.D0
+ AMPHAR = 0.D0
+ AMHMSD(1) = 0.D0
+ AMHMSD(2) = 0.D0
+ AMHMDD = 0.D0
+ AMPDP(1) = 0.D0
+ AMPDP(2) = 0.D0
+ AMPDP(3) = 0.D0
+ AMPDP(4) = 0.D0
+ DO 450 I=1,4
+ AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
+ AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
+ AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
+ AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
+ AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
+ AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
+ AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
+ AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
+ AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
+ AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
+ 450 CONTINUE
+ AMPSOF = AMPSOF/16.D0
+ AMPHAR = AMPHAR/16.D0
+ AMHMSD(1) = AMHMSD(1)/16.D0
+ AMHMSD(2) = AMHMSD(2)/16.D0
+ AMHMDD = AMHMDD/16.D0
+ AMPDP(1) = AMPDP(1)/16.D0
+ AMPDP(2) = AMPDP(2)/16.D0
+ AMPDP(3) = AMPDP(3)/16.D0
+ AMPDP(4) = AMPDP(4)/16.D0
+ IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
+ IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
+ IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
+ IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
+ IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
+ IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
+ IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
+
+C vector-meson production, weight factors
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
+ IF(IFPAP(1).EQ.22) THEN
+ IF(IFPAP(2).EQ.22) THEN
+ DO 10 I=1,4
+ DO 15 J=1,4
+ AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
+ 15 CONTINUE
+ 10 CONTINUE
+ ELSE
+ AMPVM(1,1) = PARMDL(10)*AMPVME
+ AMPVM(2,1) = PARMDL(11)*AMPVME
+ AMPVM(3,1) = PARMDL(12)*AMPVME
+ AMPVM(4,1) = PARMDL(13)*AMPVME
+ ENDIF
+ ELSE IF(IFPAP(2).EQ.22) THEN
+ AMPVM(1,1) = PARMDL(10)*AMPVME
+ AMPVM(1,2) = PARMDL(11)*AMPVME
+ AMPVM(1,3) = PARMDL(12)*AMPVME
+ AMPVM(1,4) = PARMDL(13)*AMPVME
+ ENDIF
+ ENDIF
+C debug output
+ IF(IDEB(86).GE.5) THEN
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_CHAN2A: impact parameter amplitudes'
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
+ WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
+ WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
+ WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_EVENT
+ SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
+C********************************************************************
+C
+C main subroutine to manage simulation processes
+C
+C input: NEV -1 initialization
+C 1 generation of events
+C 2 generation of events without rejection
+C due to energy dependent cross section
+C 3 generation of events without rejection
+C using initialization energy
+C -2 output of event generation statistics
+C P1(4) momentum of particle 1 (internal TARGET)
+C P2(4) momentum of particle 2 (internal PROJECTILE)
+C FAC used for initialization:
+C contains cross section the events corresponds to
+C during generation: current cross section
+C
+C output: IREJ 0: event accepted
+C 1: event rejected
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY = 1.D-10 )
+
+ DIMENSION P1(4),P2(4)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+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 table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
+
+ IREJ = 0
+
+C initializations
+ IF(NEV.EQ.-1) THEN
+ WRITE(LO,'(/3(/1X,A))')
+ & '=======================================================',
+ & ' ------- initialization of event generation --------',
+ & '======================================================='
+ CALL PHO_SETMDL(0,0,-2)
+C amplitude parameters
+ CALL PHO_FITPAR(1)
+
+ CALL PHO_REJSTA(-1)
+C initialize MC package
+ CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
+ CALL PHO_MCINI
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 0.D0,-1)
+ CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
+
+C cross section
+ FAC = SIGGEN(4)
+ DO 20 I=1,10
+ IPRSAM(I) = 0
+ IPRACC(I) = 0
+ IENACC(I) = 0
+ 20 CONTINUE
+ ISPS = 0
+ ISPA = 0
+ ISRS = 0
+ ISRA = 0
+ IHPS = 0
+ IHPA = 0
+ ISTS = 0
+ ISTA = 0
+ ISLS = 0
+ ISLA = 0
+ IDIS = 0
+ IDIA = 0
+ IDPS = 0
+ IDPA = 0
+ IDNS(1) = 0
+ IDNS(2) = 0
+ IDNS(3) = 0
+ IDNS(4) = 0
+ IDNA(1) = 0
+ IDNA(2) = 0
+ IDNA(3) = 0
+ IDNA(4) = 0
+ KACCEP = 0
+ KEVENT = 0
+ KEVGEN = 0
+ ECMSUM = 0.D0
+ ELSE IF(NEV.GT.0) THEN
+C
+C -------------- begin event generation ---------------
+C
+ IPAMDL(13) = 0
+ IF(NEV.EQ.3) IPAMDL(13) = 1
+ KEVENT = KEVENT+1
+C enable debugging
+ CALL PHO_TRACE(0,0,0)
+ IF(IDEB(68).GE.2) THEN
+ IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
+ & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
+ ENDIF
+ CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
+C cross section calculation
+ FAC = SIGGEN(3)
+ IF(NEV.EQ.1) THEN
+ IF(IVWGHT(1).EQ.1) THEN
+ WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
+ ELSE
+ WG = SIGGEN(3)/SIGGEN(4)
+ ENDIF
+ IF(DT_RNDM(FAC).GT.WG) THEN
+ IREJ = 1
+ IF(IDEB(68).GE.6) THEN
+ WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
+ & 'PHO_EVENT: rejection due to cross section',
+ & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
+ & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ KEVGEN = KEVGEN+1
+ SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
+ HSWGHT(0) = MAX(1.D0,WG)
+
+ ITRY1 = 0
+ 50 CONTINUE
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+
+C sample process
+ IPROCE = 0
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 1.D0,IPROCE)
+ IF(IPROCE.EQ.0) THEN
+ IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
+ & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
+ IREJ = 50
+ RETURN
+ ENDIF
+C sampling statistics
+ IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
+
+ ITRY2 = 0
+ 60 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+C sample number of cut graphs according to IPROCE and
+C generate parton configurations+strings
+ CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
+C collect statistics
+ ISPS = ISPS+KSPOM
+ IHPS = IHPS+KHPOM
+ ISRS = ISRS+KSREG
+ ISTS = ISTS+KSTRG+KHTRG
+ ISLS = ISLS+KSLOO+KHLOO
+ IDIS = IDIS+MIN(KHDIR,1)
+ IDPS = IDPS+KHDPO+KSDPO
+ IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
+ & IDNS(KHDIR) = IDNS(KHDIR)+1
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(68).GE.4) THEN
+ WRITE(LO,'(/1X,A,2I5)')
+ & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
+ RETURN
+ ENDIF
+ IFAIL(1) = IFAIL(1)+1
+ IF(ITRY1.GT.5) RETURN
+ IF(IREJ.GE.5) THEN
+ IF(ISWMDL(2).EQ.0) RETURN
+ GOTO 50
+ ENDIF
+ IF(ITRY2.LT.5) GOTO 60
+ GOTO 50
+ ENDIF
+C fragmentation of strings
+
+C FSR and string fragmentation is done separately by DPMJET routines
+C CALL PHO_STRFRA(IREJ)
+
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IFAIL(23) = IFAIL(23)+1
+ IF(IDEB(68).GE.4) THEN
+ WRITE(LO,'(/1X,A,2I5)')
+ & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ GOTO 50
+ ENDIF
+C check of conservation of quantum numbers
+ IF(IDEB(68).GE.-5) THEN
+ CALL PHO_CHECK(-1,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ ENDIF
+C event now completely processed and accepted
+C acceptance statistics
+ IPRACC(IPROCE) = IPRACC(IPROCE)+1
+ ISPA = ISPA+KSPOM
+ IHPA = IHPA+KHPOM
+ ISRA = ISRA+KSREG
+ ISTA = ISTA+(KSTRG+KHTRG)
+ ISLA = ISLA+(KSLOO+KHLOO)
+ IDIA = IDIA+MIN(KHDIR,1)
+ IDPA = IDPA+KHDPO+KSDPO
+ IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
+ & IDNA(KHDIR) = IDNA(KHDIR)+1
+ DO 55 I=1,IPOIX2
+ IENACC(IPORES(I)) = IENACC(IPORES(I))+1
+ 55 CONTINUE
+ KACCEP = KACCEP+1
+
+C debug output (partial / full event listing)
+ if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
+ & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
+ IF(IDEB(67).GE.10) THEN
+ IF(IDEB(67).LE.15) THEN
+ CALL PHO_PREVNT(-1)
+ ELSE IF(IDEB(67).LE.20) THEN
+ CALL PHO_PREVNT(0)
+ ELSE IF(IDEB(67).LE.25) THEN
+ CALL PHO_PREVNT(1)
+ ELSE
+ CALL PHO_PREVNT(2)
+ ENDIF
+ ENDIF
+C
+C effective weight
+ DO 65 I=1,10
+ IF(IPOWGC(I).GT.0) THEN
+ HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
+ ENDIF
+ 65 CONTINUE
+ IF(IVWGHT(1).EQ.1) THEN
+ WG = HSWGHT(0)
+ IF(WG.GT.1.01D0) THEN
+ IF(EVWGHT(1).LT.1.01D0) THEN
+ WRITE(LO,'(1X,A,2I12,1PE12.3)')
+ & 'PHO_EVENT: cross section weight > 1',
+ & KEVENT,KACCEP,WG
+ WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
+ & SIGGEN(3),SIGGEN(4),EVWGHT(1)
+ ENDIF
+ EVWGHT(1) = HSWGHT(0)
+ HSWGHT(0) = 1.D0
+ ELSE
+ EVWGHT(1) = 1.D0
+ ENDIF
+ ENDIF
+
+C effective cross section
+ SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
+ ECMSUM = ECMSUM+ECM
+ SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
+ ELSE IF(NEV.EQ.-2) THEN
+
+C ---------------- end of event generation ----------------------
+
+* --- Commented by Chiara
+* WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
+* & '====================================================',
+* & ' --------- summary of event generation ----------',
+* & '====================================================',
+* & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
+* & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
+
+C write out statistics
+ IF(KACCEP.GT.0) THEN
+
+ FAC1 = SIGGEN(4)/DBLE(KEVENT)
+ FAC2 = FAC/DBLE(KACCEP)
+* WRITE(LO,'(/1X,A,/1X,A)')
+* & 'PHO_EVENT: generated and accepted events',
+* & '----------------------------------------'
+* WRITE(LO,'(3X,A)')
+* & 'process, sampled, accepted, cross section (internal/external)'
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
+* & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
+* & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
+* & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
+* & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
+* & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
+* & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
+* & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
+* & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
+* & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
+* & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
+* & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
+* & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
+* & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
+* & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
+* & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
+* & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
+* WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
+* & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
+C *** commented by Chiara
+C IF(ISWMDL(14).GT.0) THEN
+C WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
+C & ISWMDL(14)
+C WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
+C WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
+C WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
+C WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
+C WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
+C ENDIF
+* WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
+* & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
+
+ CALL PHO_REJSTA(-2)
+ CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
+ & 0.D0,-2)
+ CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
+C statistics of hard scattering processes
+* WRITE(LO,'(2(/1X,A))')
+* & 'PHO_EVENT: statistics of hard scattering processes',
+* & '--------------------------------------------------'
+* DO 43 K=1,4
+* IF(MH_tried(0,K).GT.0) THEN
+* WRITE(LO,'(/5X,A,I3)')
+* & 'process (accepted,x-section internal/external) for IP:',K
+* DO 47 M=0,Max_pro_2
+* WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
+* & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
+* & DBLE(MH_acc_2(M,K))*FAC2
+* 47 CONTINUE
+* ENDIF
+* 43 CONTINUE
+
+ ELSE
+ WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
+ ENDIF
+* WRITE(LO,'(/3(/1X,A)/)')
+* & '======================================================',
+* & ' ------- end of event generation summary --------',
+* & '======================================================'
+ ELSE
+ WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_PARTON
+ SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
+C********************************************************************
+C
+C calculation of complete parton configuration
+C
+C input: IPROC process ID 1 nondiffractive
+C 2 elastic
+C 3 quasi-ela. rho,omega,phi prod.
+C 4 double Pomeron
+C 5 single diff 1
+C 6 single diff 2
+C 7 double diff diss.
+C 8 single-resolved / direct photon
+C JM1,2 index of mother particles in /POEVT1/
+C
+C
+C output: complete parton configuration in /POEVT1/
+C IREJ 1 failure
+C 0 success
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4)
+
+ PARAMETER ( TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+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 cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+C clear event statistics
+ KSPOM = 0
+ KHPOM = 0
+ KSREG = 0
+ KHDIR = 0
+ KSTRG = 0
+ KHTRG = 0
+ KSLOO = 0
+ KHLOO = 0
+ KHARD = 0
+ KSOFT = 0
+ KSDPO = 0
+ KHDPO = 0
+
+C-------------------------------------------------------------------
+C nondiffractive resolved processes
+
+ IF(IPROC.EQ.1) THEN
+C sample number of interactions
+ 555 CONTINUE
+ IINT = 0
+ IP = 1
+C generate only hard events
+ IF(ISWMDL(2).EQ.0) THEN
+ MHPOM = 1
+ MSPOM = 0
+ MSREG = 0
+ MHDIR = 0
+ HSWGHT(1) = 1.D0
+ ELSE
+C minimum bias events
+ IPOWGC(1) = 0
+ 10 CONTINUE
+ CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
+ IPOWGC(1) = IPOWGC(1)+1
+ MINT = 0
+ MHDIR = 0
+ MSTRG = 0
+ MSLOO = 0
+C
+C resolved soft processes: pomeron and reggeon
+ MSPOM = IINT
+ MSREG = JINT
+C resolved hard process: hard pomeron
+ MHPOM = KINT
+C resolved absorptive corrections
+ MPTRI = 0
+ MPLOO = 0
+C restrictions given by user
+ IF(MSPOM.LT.ISWCUT(1)) GOTO 10
+ IF(MSREG.LT.ISWCUT(2)) GOTO 10
+ IF(MHPOM.LT.ISWCUT(3)) GOTO 10
+ HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
+C ----------------------------
+ IF(ISWMDL(15).EQ.0) THEN
+ MHPOM = 0
+ IF(MSREG.GT.0) THEN
+ MSPOM = 0
+ MSREG = 1
+ ELSE
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ ELSE IF(ISWMDL(15).EQ.1) THEN
+ IF(MHPOM.GT.0) THEN
+ MHPOM = 1
+ MSPOM = 0
+ MSREG = 0
+ ELSE IF(MSPOM.GT.0) THEN
+ MSPOM = 1
+ MSREG = 0
+ ELSE
+ MSREG = 1
+ ENDIF
+ ELSE IF(ISWMDL(15).EQ.2) THEN
+ MHPOM = MIN(1,MHPOM)
+ ELSE IF(ISWMDL(15).EQ.3) THEN
+ MSPOM = MIN(1,MSPOM)
+ ENDIF
+ ENDIF
+C ----------------------------
+
+C statistics
+ ISPS = ISPS+MSPOM
+ IHPS = IHPS+MHPOM
+ ISRS = ISRS+MSREG
+ ISTS = ISTS+MSTRG
+ ISLS = ISLS+MSLOO
+
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
+ & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
+ & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
+
+ ITRY2 = 0
+ 50 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+ KHDIR = MHDIR
+ KSTRG = MPTRI
+ KSLOO = MPLOO
+
+ CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ IF(MHPOM.GT.0) THEN
+ IDNODF = 3
+ ELSE IF(MSPOM.GT.0) THEN
+ IDNODF = 2
+ ELSE
+ IDNODF = 1
+ ENDIF
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.20) GOTO 50
+ IF(IDEB(3).GE.1) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C statistics
+ ISPA = ISPA+KSPOM
+ IHPA = IHPA+KHPOM
+ ISRA = ISRA+KSREG
+ ISTA = ISTA+KSTRG
+ ISLA = ISLA+KSLOO
+
+C-------------------------------------------------------------------
+C elastic scattering / quasi-elastic rho/omega/phi production
+
+ ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
+ & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
+
+C DPMJET call with special projectile / target: transform into CMS
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(1,JM1,JM2)
+
+ CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
+
+ IF(IREJ.NE.0) THEN
+C DPMJET call with special projectile / target: clean up
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(-2,JM1,JM2)
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C DPMJET call with special projectile / target: transform back
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(2,JM1,JM2)
+
+C prepare possible decays
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ RETURN
+ ENDIF
+
+C---------------------------------------------------------------------
+C double Pomeron scattering
+
+ ELSE IF(IPROC.EQ.4) THEN
+ MSOFT = 0
+ MHARD = 0
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
+ & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
+ IDPS = IDPS+1
+ ITRY2 = 0
+ 60 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+C
+ CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 60
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 60
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IDPA = IDPA+1
+
+C-----------------------------------------------------------------------
+C single / double diffraction dissociation
+
+ ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
+ MSOFT = 0
+ MHARD = 0
+ IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
+ & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
+ IF(IPROC.EQ.5) ID1S = ID1S+1
+ IF(IPROC.EQ.6) ID2S = ID2S+1
+ IF(IPROC.EQ.7) ID3S = ID3S+1
+ ITRY2 = 0
+ 70 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ IPAR1 = 1
+ IPAR2 = 1
+ IF(IPROC.EQ.5) IPAR2 = 0
+ IF(IPROC.EQ.6) IPAR1 = 0
+C calculate rapidity gap survival probability
+ SPROB = 1.D0
+ IF(ECM.GT.10.D0) THEN
+ IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
+ IF(SIGTR1(1).LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
+ ENDIF
+ ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
+ IF(SIGTR2(1).LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
+ ENDIF
+ ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
+ IF(SIGLOO.LT.1.D-10) THEN
+ SPROB = 1.D0
+ ELSE
+ SPROB = SIGHDD/SIGLOO
+ ENDIF
+ ENDIF
+ ENDIF
+
+**sr
+* temporary patch, r.e. 8.6.99
+ SPROB = 1.D0
+**
+
+C DPMJET call with special projectile / target: transform into CMS
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(1,JM1,JM2)
+
+ CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
+
+ IF(IREJ.NE.0) THEN
+C DPMJET call with special projectile / target: clean up
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(-2,JM1,JM2)
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C DPMJET call with special projectile / target: transform back
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
+ & CALL PHO_DFWRAP(2,JM1,JM2)
+
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 70
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 70
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IF(IPROC.EQ.5) ID1A = ID1A+1
+ IF(IPROC.EQ.6) ID2A = ID2A+1
+ IF(IPROC.EQ.7) ID3A = ID3A+1
+
+C-----------------------------------------------------------------------
+C single / double direct processes
+
+ ELSE IF(IPROC.EQ.8) THEN
+ MSREG = 0
+ MSPOM = 0
+ MHPOM = 0
+ MHDIR = 1
+ IF(IDEB(3).GE.5) THEN
+ WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
+ ENDIF
+ IDIS = IDIS+MHDIR
+ ITRY2 = 0
+ 80 CONTINUE
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+ KHDIR = 4
+
+ CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ IDNODF = 4
+C check of quantum numbers of parton configurations
+ IF(IDEB(3).GE.0) THEN
+ CALL PHO_CHECK(1,IREJ)
+ IF(IREJ.NE.0) GOTO 80
+ ENDIF
+C sample strings to prepare fragmentation
+ CALL PHO_STRING(1,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IREJ.EQ.50) RETURN
+ IFAIL(30) = IFAIL(30)+1
+ IF(IDEB(3).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ IF(ITRY2.LT.10) GOTO 80
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
+ CALL PHO_PREVNT(-1)
+ RETURN
+ ENDIF
+ IF(IPROC.EQ.5) ID1A = ID1A+1
+ IF(IPROC.EQ.6) ID2A = ID2A+1
+ IF(IPROC.EQ.7) ID3A = ID3A+1
+ IDIA = IDIA+MHDIR
+
+C-----------------------------------------------------------------------
+C initialize control statistics
+
+ ELSE IF(IPROC.EQ.-1) THEN
+ CALL PHO_SAMPRB(ECM,-1,0,0,0)
+ CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
+ CALL PHO_SEAFLA(-1,0,0,DUM)
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
+ & CALL PHO_QELAST(-1,1,2,0)
+ ISPS = 0
+ ISPA = 0
+ ISRS = 0
+ ISRA = 0
+ IHPS = 0
+ IHPA = 0
+ ISTS = 0
+ ISTA = 0
+ ISLS = 0
+ ISLA = 0
+ ID1S = 0
+ ID1A = 0
+ ID2S = 0
+ ID2A = 0
+ ID3S = 0
+ ID3A = 0
+ IDPS = 0
+ IDPA = 0
+ IDIS = 0
+ IDIA = 0
+ CALL PHO_STRING(-1,IREJ)
+ CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
+ RETURN
+
+C-----------------------------------------------------------------------
+C produce statistics summary
+
+ ELSE IF(IPROC.EQ.-2) THEN
+ IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
+C IF(IDEB(3).GE.0) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A,/1X,A)')
+C & 'PHO_PARTON: internal statistics on parton configurations',
+C & '--------------------------------------------------------'
+C WRITE(LO,'(5X,A)') 'process sampled accepted'
+C WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
+C WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
+C WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
+C WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
+C WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
+C WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
+C WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
+C WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
+C WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
+C WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
+C ENDIF
+ CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
+ IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
+ & CALL PHO_QELAST(-2,1,2,0)
+ CALL PHO_STRING(-2,IREJ)
+ CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
+ CALL PHO_SEAFLA(-2,0,0,DUM)
+ RETURN
+ ELSE
+ WRITE(LO,'(1X,A,I2)')
+ & 'PARTON:ERROR: unknown process ID ',IPROC
+ STOP
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_MCINI
+ SUBROUTINE PHO_MCINI
+C********************************************************************
+C
+C initialization of MC event generation
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PIMASS = 0.13D0,
+ & TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+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 interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C cut probability distribution
+ INTEGER IEETA1,IIMAX,KKMAX
+ PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
+ INTEGER IEEMAX,IMAX,KMAX
+ REAL PROB
+ DOUBLE PRECISION EPTAB
+ COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
+ & IEEMAX,IMAX,KMAX
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ CHARACTER*15 PHO_PNAME
+ DIMENSION ECMF(4)
+
+ DATA XMPOM / 0.766D0 /
+
+C initialize fragmentation
+ CALL PHO_FRAINI(ISWMDL(6))
+
+C reset interpolation tables
+ DO 50 I=1,4
+ DO 60 J=1,10
+ DO 70 K=1,70
+ SIGTAB(I,K,J) = 0.D0
+ 70 CONTINUE
+ SIGECM(I,J) = 0.D0
+ 60 CONTINUE
+ 50 CONTINUE
+
+C max. number of allowed colors (large N expansion)
+ IC1 = 0
+ IC2 = 10000
+ CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
+
+C lower energy limit of initialization
+ ETABLO = PARMDL(19)
+ IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
+
+C *** Commented by Chiara
+C WRITE(LO,'(/,1X,A,2F12.1)')
+C & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
+C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
+C & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
+C & PMASS(1),PVIRT(1)
+C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
+C & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
+C & PMASS(2),PVIRT(2)
+
+C cuts on probabilities of multiple interactions
+ IMAX = MIN(IPAMDL(32),IIMAX)
+ KMAX = MIN(IPAMDL(33),KKMAX)
+ AH = 2.D0*PTCUT(1)/ECM
+ IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
+ KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
+
+C hard interpolation table
+ ECMF(1) = ECM
+ ECMF(2) = 0.9D0*ECMF(1)
+ ECMF(3) = ECMF(2)
+ ECMF(4) = ECMF(2)
+ do k=1,4
+ IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
+ IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
+ IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
+ IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
+ enddo
+
+C initialization of hard scattering for all channels and cutoffs
+ IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
+ I0 = 4
+ IF(ISWMDL(2).EQ.0) I0 = 1
+ DO 110 I=I0,1,-1
+ CALL PHO_HARMCI(I,ECMF(I))
+ 110 CONTINUE
+
+C dimension of interpolation table of cut probabilities
+ IEEMAX = MIN(IPAMDL(31),IEETA1)
+ IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
+ IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
+ IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
+ ISIMAX = IEEMAX
+
+C calculate probability distribution
+ I0 = 4
+ IFT1 = IFPAP(1)
+ IFT2 = IFPAP(2)
+ XMT1 = PMASS(1)
+ XMT2 = PMASS(2)
+ XVT1 = PVIRT(1)
+ XVT2 = PVIRT(2)
+ IF(ISWMDL(2).EQ.0) I0 = 1
+ DO 150 IP=I0,1,-1
+ ECMPRO = ECMF(IP)*1.001D0
+ IF(IP.EQ.4) THEN
+ IFPAP(1) = 990
+ IFPAP(2) = 990
+ PMASS(1) = XMPOM
+ PMASS(2) = XMPOM
+ PVIRT(1) = 0.D0
+ PVIRT(2) = 0.D0
+ ELSE IF(IP.EQ.3) THEN
+ IFPAP(1) = IFT2
+ IFPAP(2) = 990
+ PMASS(1) = XMT2
+ PMASS(2) = XMPOM
+ PVIRT(1) = XVT2
+ PVIRT(2) = 0.D0
+ ELSE IF(IP.EQ.2) THEN
+ IFPAP(1) = IFT1
+ IFPAP(2) = 990
+ PMASS(1) = XMT1
+ PMASS(2) = XMPOM
+ PVIRT(1) = XVT1
+ PVIRT(2) = 0.D0
+ ELSE
+ IFPAP(1) = IFT1
+ IFPAP(2) = IFT2
+ PMASS(1) = XMT1
+ PMASS(2) = XMT2
+ PVIRT(1) = XVT1
+ PVIRT(2) = XVT2
+ ENDIF
+ IF(IEEMAX.GT.1) THEN
+ IF(IP.EQ.1) THEN
+ ELMIN = LOG(ETABLO)
+ ELSE
+ ELMIN = LOG(2.5D0)
+ ENDIF
+ EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
+ DO 100 I=1,IEEMAX
+ ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
+ CALL PHO_PRBDIS(IP,ECMPRO,I)
+ 100 CONTINUE
+ ELSE
+ CALL PHO_PRBDIS(IP,ECMPRO,1)
+ ENDIF
+
+C debug output of cross section tables
+ IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
+ IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
+* --- Commented by Chiara
+* WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+* &'Table of total cross sections (mb) for particle combination',IP,
+* &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
+* &'-------------------------------------------------------------'
+* DO 200 I=1,IEEMAX
+* WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
+* & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
+* & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
+* & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
+* & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
+* 200 CONTINUE
+ 201 CONTINUE
+ IF(IDEB(62).GE.2) THEN
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of partial x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
+ &'--------------------------------------------------------------'
+ DO 205 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
+ & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
+ & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
+ 205 CONTINUE
+ ENDIF
+ IF(IDEB(62).GE.2) THEN
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of born graph x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
+ &'-------------------------------------------------------------'
+ DO 210 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
+ & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
+ & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
+ & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
+ & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
+ & +SIGTAB(IP,68,I)
+ 210 CONTINUE
+ WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
+ &'Table of unitarized x-sections (mb) for particle combination',IP,
+ &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
+ &'-------------------------------------------------------------'
+ DO 215 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
+ & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
+ & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
+ 215 CONTINUE
+ ENDIF
+ IF(IDEB(62).GE.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
+ &'Table of expected average number of cuts in non-diff events:',
+ &' for max. number of cuts soft/hard:',IMAX,KMAX,
+ &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
+ &'---------------------------------------------'
+ DO 220 I=1,IEEMAX
+ WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
+ & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
+ & SIGTAB(IP,76,I)
+ 220 CONTINUE
+ IF(IP.EQ.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
+ & 'Table of rapidity gap survival probability (high-mass diff.):',
+ & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
+ & '---------------------------------------------------'
+ DO 230 I=1,IEEMAX
+ IF(SIGECM(IP,I).GT.10.D0) THEN
+ SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
+ & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
+ SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
+ & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
+ SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
+ & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
+ & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
+ SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
+ & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
+ WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
+ & SPRSD1,SPRSD2,SPRDD,SPRCDF
+ ENDIF
+ 230 CONTINUE
+ ENDIF
+ ENDIF
+ ENDIF
+ 150 CONTINUE
+
+C simulate only hard scatterings
+ IF(ISWMDL(2).EQ.0) THEN
+ WRITE(LO,'(2(/1X,A))')
+ & 'WARNING: generation of hard scatterings only!',
+ & '============================================='
+ DO 151 I=2,7
+ IPRON(I,1) = 0
+ 151 CONTINUE
+ DO 152 K=2,4
+ DO 153 I=1,15
+ IPRON(I,K) = 0
+ 153 CONTINUE
+ 152 CONTINUE
+ SIGGEN(4) = 0.D0
+ DO 160 I=1,IEEMAX
+ SIGMAX = 0.D0
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
+ IF(SIGMAX.GT.SIGGEN(4)) THEN
+ ISIGM = I
+ SIGGEN(4) = SIGMAX
+ ENDIF
+ 160 CONTINUE
+ ELSE
+* --- Commented by Chiara
+* WRITE(LO,'(2(/1X,A))')
+* & 'activated processes, cross section',
+* & '----------------------------------'
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' elastic scattering',(IPRON(2,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' double pomeron processes',(IPRON(4,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' double diffract. processes',(IPRON(7,K),K=1,4)
+* WRITE(LO,'(5X,A,I3,2X,3I3)')
+* & ' direct photon processes',(IPRON(8,K),K=1,4)
+
+C calculate effective cross section
+ SIGGEN(4) = 0.D0
+ DO 165 I=1,IEEMAX
+ CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
+ & PVIRT(1),PVIRT(2))
+ SIGMAX = 0.D0
+ if(iswmdl(2).ge.1) then
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
+ & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
+ & -SIGLDD-SIGHDD-SIGDIR
+ IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
+ IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
+ IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
+ IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
+ IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
+ IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
+ else
+ IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
+ IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
+ endif
+ IF(SIGMAX.GT.SIGGEN(4)) THEN
+ ISIGM = I
+ SIGGEN(4) = SIGMAX
+ ENDIF
+ 165 CONTINUE
+ ENDIF
+
+C debug output
+ IF(SIGGEN(4).LT.1.D-20) THEN
+ WRITE(LO,'(//1X,A)')
+ & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
+ STOP
+ ENDIF
+ WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
+ & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
+ WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
+
+ END
+
+CDECK ID>, PHO_REJSTA
+ SUBROUTINE PHO_REJSTA(IMODE)
+C********************************************************************
+C
+C MC rejection counting
+C
+C input IMODE -1 initialization
+C -2 output of statistics
+C
+C********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ INTEGER IMODE
+
+ INTEGER I
+
+C initialization
+ IF(IMODE.EQ.-1) THEN
+ DO 100 I=1,NMXJ
+ IFAIL(I) = 0
+ 100 CONTINUE
+C
+ REJTIT(1) = 'PARTON ALL'
+ REJTIT(2) = 'STDPAR ALL'
+ REJTIT(3) = 'STDPAR DPO'
+ REJTIT(4) = 'POMSCA ALL'
+ REJTIT(5) = 'POMSCA INT'
+ REJTIT(6) = 'POMSCA KIN'
+ REJTIT(7) = 'DIFDIS ALL'
+ REJTIT(8) = 'POSPOM ALL'
+ REJTIT(9) = 'HRES.DIF.1'
+ REJTIT(10) = 'HDIR.DIF.1'
+ REJTIT(11) = 'HRES.DIF.2'
+ REJTIT(12) = 'HDIR.DIF.2'
+ REJTIT(13) = 'DIFDIS INT'
+ REJTIT(14) = 'HADRON SP2'
+ REJTIT(15) = 'HADRON SP3'
+ REJTIT(16) = 'HARDIR ALL'
+ REJTIT(17) = 'HARDIR INT'
+ REJTIT(18) = 'HARDIR KIN'
+ REJTIT(19) = 'MCHECK BAR'
+ REJTIT(20) = 'MCHECK MES'
+ REJTIT(21) = 'DIF.DISS.1'
+ REJTIT(22) = 'DIF.DISS.2'
+ REJTIT(23) = 'STRFRA ALL'
+ REJTIT(24) = 'MSHELL CHA'
+ REJTIT(25) = 'PARTPT SOF'
+ REJTIT(26) = 'PARTPT HAR'
+ REJTIT(27) = 'INTRINS KT'
+ REJTIT(28) = 'HACHEK DIR'
+ REJTIT(29) = 'HACHEK RES'
+ REJTIT(30) = 'STRING ALL'
+ REJTIT(31) = 'POMSCA INT'
+ REJTIT(32) = 'DIFF SLOPE'
+ REJTIT(33) = 'GLU2QU ALL'
+ REJTIT(34) = 'MASCOR ALL'
+ REJTIT(35) = 'PARCOR ALL'
+ REJTIT(36) = 'MSHELL PAR'
+ REJTIT(37) = 'MSHELL ALL'
+ REJTIT(38) = 'POMCOR ALL'
+ REJTIT(39) = 'DB-POM KIN'
+ REJTIT(40) = 'DB-POM ALL'
+ REJTIT(41) = 'SOFTXX ALL'
+ REJTIT(42) = 'SOFTXX PSP'
+
+C write output
+* --- Commented by Chiara
+* ELSE IF(IMODE.EQ.-2) THEN
+* WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
+* & '--------------------------------'
+* DO 300 I=1,NMXJ
+* IF(IFAIL(I).GT.0)
+* & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
+* 300 CONTINUE
+* ELSE
+* WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_POSPOM
+ SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
+C***********************************************************************
+C
+C registration of one cut pomeron (soft/semihard)
+C
+C input: IP particle combination the pomeron belongs to
+C IND1,2 position of X values in /POSOFT/
+C 1 corresponds to a valence-pomeron
+C IGEN production process of mother particles
+C IPOM pomeron number
+C KCUT total number of cut pomerons and reggeons
+C
+C output: ISWAP exchange of x values
+C IND1,2 increased by the number of partons belonging
+C to the generated pomeron cut
+C IREJ success/failure
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+
+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 table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+ DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
+
+ IREJ = 0
+ ISWAP = 0
+ JM1 = NPOSP(1)
+ JM2 = NPOSP(2)
+ INDX1 = IND1
+ INDX2 = IND2
+ EA1 = XS1(IND1)*ECMP/2.D0
+ EA2 = XS1(IND1+1)*ECMP/2.D0
+ EB1 = XS2(IND2)*ECMP/2.D0
+ EB2 = XS2(IND2+1)*ECMP/2.D0
+ CMASS1 = MIN(EA1,EA2)
+ CMASS2 = MIN(EB1,EB2)
+
+C debug output
+ IF(IDEB(9).GE.20) THEN
+ WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
+ & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
+ WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
+ & CMASS1,CMASS2
+ ENDIF
+
+C flavours
+ IF(IND1.EQ.1) THEN
+ CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
+ ELSE
+ CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
+ ENDIF
+ IF(IND2.EQ.1) THEN
+ CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
+ ELSE
+ CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
+ ENDIF
+ DO 75 I=1,4
+ P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
+ P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
+ 75 CONTINUE
+
+C pomeron resolved?
+ IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
+C find energy for cross section calculation
+ IF(IPAMDL(16).EQ.2) THEN
+ ESUB = ECMP
+ ELSE IF(IPAMDL(16).EQ.3) THEN
+ IF(IPROCE.EQ.1) THEN
+ ESUB = ECM
+ ELSE
+ ESUB = ECMP
+ ENDIF
+ ELSE
+ ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
+ & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
+ ENDIF
+C load cross sections from interpolation table
+ IF(ESUB.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 2
+ ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = ISIMAX-1
+ I2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1=1.D0-FAC2
+C calculate weights
+* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
+* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
+* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
+* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
+* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
+* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
+
+ WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
+ & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
+ WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
+ WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
+ WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
+ & +SIGTAB(IP,64,I2))
+ & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
+ & +SIGTAB(IP,64,I1))
+ WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
+ & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
+ & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
+ & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
+
+C one-pomeron cut
+ WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
+C central diff. cut
+ WGX(2) = WGXCDF
+C diff. diss. of particle 1
+ WGX(3) = WGXHSD(1)
+C diff. diss. of particle 2
+ WGX(4) = WGXHSD(2)
+C double diff. dissociation
+ WGX(5) = WGXHDD
+C two-pomeron cut
+ WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
+
+* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
+* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
+* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
+* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
+* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
+* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
+* ENDIF
+
+ SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
+
+C selection loop
+ 205 CONTINUE
+ XI = DT_RNDM(SUM)*SUM
+ I = 0
+ SUM = 0.D0
+ 210 CONTINUE
+ I = I+1
+ SUM = SUM+WGX(I)
+ IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
+C phase space correction
+ IF(I.NE.1) THEN
+ ISAM = 4
+ IF(I.EQ.6) ISAM = 8
+ PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
+* IF(DT_RNDM(SUM).GT.PACC) I=1
+ IF(DT_RNDM(SUM).GT.PACC) GOTO 205
+ ENDIF
+
+C do not generate diffraction for events with only one cut pomeron
+ IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
+
+C do not generate recursive calls for remants with
+C diquark-anti-diquark flavour contents
+ if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
+ if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
+
+C debug output
+ IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
+ & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
+
+ IF(I.GT.1) THEN
+C second scattering needed
+ CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
+ CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
+ IDPD1 = IPHO_ID2PDG(IDHA1)
+ IDPD2 = IPHO_ID2PDG(IDHA2)
+
+ if(INDX1.eq.1) then
+ if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
+ & IGEN_had = IGEN
+ else
+ IGEN_had = -IGEN
+ endif
+ CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
+ & IPOM,IGEN_had,0,0,IPOS1,1)
+
+ if(INDX2.eq.1) then
+ if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
+ & IGEN_had = IGEN
+ else
+ IGEN_had = -IGEN
+ endif
+ CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
+ & IPOM,IGEN_had,0,0,IPOS1,1)
+
+ IND1 = IND1+2
+ IND2 = IND2+2
+C update index
+ IPOIX2 = IPOIX2+1
+
+ IF(IPOIX2.GT.MAXIPX) THEN
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
+ & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IPORES(IPOIX2) = I+2
+ IPOPOS(1,IPOIX2) = IPOS1-1
+ IPOPOS(2,IPOIX2) = IPOS1
+ RETURN
+ ENDIF
+ ENDIF
+
+ 100 CONTINUE
+ IF(ISWMDL(12).EQ.0) THEN
+C sample colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
+
+C purely gluonic pomeron or sea strings formed by gluons
+
+ IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
+ & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
+ IFLA1 = 21
+ IFLA2 = 21
+ ENDIF
+ IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
+ & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
+ IFLB1 = 21
+ IFLB2 = 21
+ ENDIF
+
+C color connection
+ IF(IFLA1.NE.21) THEN
+ IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
+ & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
+ & CALL PHO_SWAPI(ICA1,ICD1)
+ ENDIF
+ IF(IFLB1.NE.21) THEN
+ IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
+ & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
+ & CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ISWAP = 0
+ IF(ICA1*ICB1.GT.0) THEN
+ IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
+ IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ELSE IF(IND1.NE.1) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE IF(IND2.NE.1) THEN
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
+ IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ENDIF
+ ELSE IF(IFLA1.EQ.-IFLA2) THEN
+ CALL PHO_SWAPI(IFLA1,IFLA2)
+ CALL PHO_SWAPI(ICA1,ICD1)
+ ELSE IF(IFLB1.EQ.-IFLB2) THEN
+ CALL PHO_SWAPI(IFLB1,IFLB2)
+ CALL PHO_SWAPI(ICB1,ICC1)
+ ELSE
+ ISWAP = 1
+ IF(IDEB(9).GE.5) THEN
+ WRITE(LO,'(1X,A,I12)')
+ & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
+ WRITE(LO,'(5X,A,4I7)')
+ & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
+ WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
+ ENDIF
+ ENDIF
+ ENDIF
+
+C registration
+
+C purely gluonic pomeron or sea strings formed by gluons
+ IF(IFLA1.EQ.21) THEN
+ CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
+ & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
+ IND1 = IND1+2
+
+C strings formed by quarks
+ ELSE
+C valence quark labels
+ IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
+ & .and.(IDHEP(JM1).NE.990)) THEN
+ ICA2 = 1
+ ICD2 = 1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
+ & ICA2,IPOS1,1)
+ IND1 = IND1+1
+ CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
+ & ICD2,IPOS,1)
+ IND1 = IND1+1
+
+ ENDIF
+
+C purely gluonic pomeron or sea strings formed by gluons
+ IF(IFLB1.EQ.21) THEN
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
+ & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
+ IND2 = IND2+2
+
+C strings formed by quarks
+ ELSE
+C valence quark labels
+ IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
+ & .and.(IDHEP(JM2).NE.990)) THEN
+ ICB2 = 1
+ ICC2 = 1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
+ & ICB2,IPOS,1)
+ IND2 = IND2+1
+ CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
+ & ICC2,IPOS2,1)
+ IND2 = IND2+1
+
+ ENDIF
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25)+1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+* CALL PHO_BFKL(P1,P2,IPART,IREJ)
+* IF(IREJ.NE.0) RETURN
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HADSP2
+ SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
+C***********************************************************************
+C
+C split hadron momentum XMAX into two partons using
+C lower cut-off: AS
+C
+C input: IFLB compressed particle code of particle to split
+C XS1 sum of x values already selected
+C XMAX maximal x possible
+C
+C output: XS1 new sum of x values (without first one)
+C XSOFT1 field of selected x values
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+ DIMENSION XSOFT1(50)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+C model exponents
+ DATA PVMES1 /-0.5D0/
+ DATA PVMES2 /-0.5D0/
+ DATA PVBAR1 / 1.5D0/
+ DATA PVBAR2 /-0.5D0/
+C
+ IREJ = 0
+ ITMAX = 100
+C
+C mesonic particle
+ IF(ipho_bar3(IFLB,0).EQ.0) THEN
+ XPOT1 = PVMES1+1.D0
+ XPOT2 = PVMES2+1.D0
+C baryonic particle
+ ELSE
+ XPOT1 = PVBAR1+1.D0
+ XPOT2 = PVBAR2+1.D0
+ ENDIF
+ ITER = 0
+ XREST= 1.D0-XS1
+C selection loop
+ 100 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.ITMAX) THEN
+ IF(IDEB(39).GE.3) THEN
+ WRITE(LO,'(1X,A,I8)')
+ & 'PHO_HADSP2: REJECTION (ITER)',ITER
+ WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
+ ENDIF
+ IFAIL(14) = IFAIL(14)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
+ IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
+ XSS1 = XS1 + ZZ
+ IF((1.D0-XSS1).LT.AS) GOTO 100
+C
+ XS1 = XSS1
+ XSOFT1(1) = 1.D0-XSS1
+ XSOFT1(2) = ZZ
+C debug output
+ IF(IDEB(39).GE.10) THEN
+ WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
+ WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
+ & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
+ ENDIF
+ END
+
+CDECK ID>, PHO_HADSP3
+ SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
+C***********************************************************************
+C
+C split hadron momentum XMAX into diquark & quark pair
+C using lower cut-off: AS
+C
+C input: IFLB compressed particle code of particle to split
+C XS1 sum of x values already selected
+C XMAX maximal x possible
+C
+C output: XS1 new sum of x values
+C XSOFT1 field of selected x values
+C
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER ( DEPS = 1.D-8 )
+
+ DIMENSION XSOFT1(50),XSOFT2(50)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+ DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
+
+C model exponents
+ DATA PVMES1 /-0.5D0/
+ DATA PVMES2 /-0.5D0/
+ DATA PSMES /-0.99D0/
+ DATA PVBAR1 / 1.5D0/
+ DATA PVBAR2 /-0.5D0/
+ DATA PSBAR /-0.99D0/
+C
+ IREJ = 0
+C
+C determine exponents
+C particle 1
+C
+ XMMIN = 0.3D0/ECMP
+ XBMIN = 1.6D0/ECMP
+C mesonic particle
+ IF(ipho_bar3(IFLB,0).EQ.0) THEN
+ XPOT1(1) = PVMES1
+ XMIN(1,1) = XMMIN
+ XPOT1(2) = PVMES2
+ XMIN(1,2) = XMMIN
+ XPOT1(3) = PSMES
+ XMIN(1,3) = XMMIN
+C baryonic particle
+ ELSE
+ XPOT1(1) = PVBAR1
+ XMIN(1,1) = XBMIN
+ XPOT1(2) = PVBAR2
+ XMIN(1,2) = XMMIN
+ XPOT1(3) = PSBAR
+ XMIN(1,3) = XMMIN
+ ENDIF
+C particle 2
+C mesonic particle
+ XPOT2(1) = PVMES1
+ XMIN(2,1) = XMMIN
+ XPOT2(2) = PVMES2
+ XMIN(2,2) = XMMIN
+ XPOT2(3) = PSMES
+ XMIN(2,3) = XMMIN
+C
+ XDUM1 = 0.01D0
+ XDUM2 = 0.99D0
+ CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
+ & XSOFT1,XSOFT2,IREJ)
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
+ & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
+ IFAIL(15) = IFAIL(15)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+C debug output
+ IF(IDEB(74).GE.10) THEN
+ WRITE(LO,'(1X,A,I6,2E12.4)')
+ & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
+ DO 100 I=1,3
+ WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
+ 100 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SOFTXX
+ SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
+ & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
+C***********************************************************************
+C
+C select soft x values
+C
+C input: JM1,JM2 mother particle index in POEVT1
+C (0 flavour not known before)
+C MSPAR1,2 number of x values to select
+C IVAL1,2 number valence quarks involved in hard
+C scattering (0,1,2)
+C MSM1,2 minimum number of soft x to get sampled
+C XSUM1,2 sum of all x values samples up this call
+C XMAX1,2 max. x value
+C
+C output XSUM1,2 new sum of x-values sampled
+C XS1,2 field containing sampled x values
+C
+C x values of valence partons are first given
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+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 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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ DIMENSION XS1(*),XS2(*)
+
+ INTEGER MAXPOT
+ PARAMETER ( MAXPOT = 50 )
+ DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
+
+ IREJ = 0
+
+ MSMAX = MAX(MSPAR1,MSPAR2)
+ MSMIN = MAX(MSM1,MSM2)
+
+ IF(MSMAX.GT.MAXPOT) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
+ & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
+ IREJ = 1
+ RETURN
+ ENDIF
+
+C determine exponents
+ IBAR1 = ipho_bar3(JM1,2)
+ IBAR2 = ipho_bar3(JM2,2)
+ ISWAP = 0
+ IF((IBAR1*IBAR2).LT.0) ISWAP = 1
+C meson-baryon scattering (asymmetric sea)
+ IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
+ PSBAR = PARMDL(53)
+ PSMES = PARMDL(57)
+ ELSE
+ PSBAR = PARMDL(52)
+ PSMES = PARMDL(56)
+ ENDIF
+
+C lower limits for x sampling
+ XMMINA = 2.D0*PARMDL(157)/ECMP
+ XBMINA = 2.D0*PARMDL(158)/ECMP
+ XSMINA = 2.D0*PARMDL(159)/ECMP
+ XMIN1 = MAX(XSOMIN,AS/XMAX2)
+ XMIN2 = MAX(XSOMIN,AS/XMAX1)
+ XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
+ XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
+ XMIN1 = MAX(AS/XMAX2,XMIN1)
+ XMIN2 = MAX(AS/XMAX1,XMIN2)
+
+C particle 1
+ XMMIN1 = MAX(XMIN1,XMMINA)
+ XBMIN1 = MAX(XMIN1,XBMINA)
+ XSMIN1 = MAX(XMIN1,XSMINA)
+C mesonic particle
+ IF(IBAR1.EQ.0) THEN
+ IF(IHFLS(1).EQ.0) THEN
+ XPOT1(1) = PARMDL(62)
+ XMIN(1,1) = XSMIN1
+ XPOT1(2) = PARMDL(63)
+ XMIN(1,2) = XSMIN1
+ ELSE
+ XPOT1(1) = PARMDL(54)
+ XMIN(1,1) = XMMIN1
+ XPOT1(2) = PARMDL(55)
+ XMIN(1,2) = XMMIN1
+ ENDIF
+ DO 100 I=3-IVAL1,MSMAX
+ XPOT1(I) = PSMES
+ XMIN(1,I) = XSMIN1
+ 100 CONTINUE
+C baryonic particle
+ ELSE
+ IF(IHFLS(1).EQ.0) THEN
+ XPOT1(1) = PARMDL(62)
+ XMIN(1,1) = XSMIN1
+ XPOT1(2) = PARMDL(63)
+ XMIN(1,2) = XSMIN1
+ ELSE
+ XPOT1(1) = PARMDL(50)
+ XMIN(1,1) = XBMIN1
+ XPOT1(2) = PARMDL(51)
+ XMIN(1,2) = XMMIN1
+ ENDIF
+ DO 200 I=3-IVAL1,MSMAX
+ XPOT1(I) = PSBAR
+ XMIN(1,I) = XSMIN1
+ 200 CONTINUE
+ ENDIF
+
+C particle 2
+ XMMIN2 = MAX(XMIN2,XMMINA)
+ XBMIN2 = MAX(XMIN2,XBMINA)
+ XSMIN2 = MAX(XMIN2,XSMINA)
+C mesonic particle
+ IF(IBAR2.EQ.0) THEN
+ IF(IHFLS(2).EQ.0) THEN
+ XPOT2(1) = PARMDL(62)
+ XMIN(2,1) = XSMIN2
+ XPOT2(2) = PARMDL(63)
+ XMIN(2,2) = XSMIN2
+ ELSE
+ XPOT2(1) = PARMDL(54)
+ XMIN(2,1) = XMMIN2
+ XPOT2(2) = PARMDL(55)
+ XMIN(2,2) = XMMIN2
+ ENDIF
+ DO 300 I=3-IVAL2,MSMAX
+ XPOT2(I) = PSMES
+ XMIN(2,I) = XSMIN2
+ 300 CONTINUE
+C baryonic particle
+ ELSE
+ IF(IHFLS(2).EQ.0) THEN
+ XPOT2(1) = PARMDL(62)
+ XMIN(2,1) = XSMIN2
+ XPOT2(2) = PARMDL(63)
+ XMIN(2,2) = XSMIN2
+ ELSE
+ XPOT2(1) = PARMDL(50)
+ XMIN(2,1) = XBMIN2
+ XPOT2(2) = PARMDL(51)
+ XMIN(2,2) = XMMIN2
+ ENDIF
+ DO 400 I=3-IVAL2,MSMAX
+ XPOT2(I) = PSBAR
+ XMIN(2,I) = XSMIN2
+ 400 CONTINUE
+ ENDIF
+
+ XSS1 = XSUM1
+ XSS2 = XSUM2
+ MSOFT = MSMAX
+
+C check limits (important for valences)
+ IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
+ IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
+
+ XMINS1 = XSS1
+ IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
+ XMINS2 = XSS2
+ IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
+ DO 10 I=1,MSOFT
+ XMINS1 = XMINS1+XMIN(1,I)
+ XMINS2 = XMINS2+XMIN(2,I)
+ 10 CONTINUE
+ IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
+
+C try to sample x values
+ IF(IPAMDL(14).EQ.0) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE IF(MSOFT.LT.5) THEN
+ CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE IF(IPAMDL(14).EQ.1) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE IF(IPAMDL(14).EQ.2) THEN
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE IF(IPAMDL(14).EQ.3) THEN
+ IF(MSOFT.EQ.2) THEN
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
+ & XS1,XS2,IREJ)
+ ELSE IF(IVAL1+IVAL2.EQ.0) THEN
+ CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ELSE
+ CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
+ & XMAXP1,XMAXP2,XS1,XS2,IREJ)
+ ENDIF
+ ELSE
+ WRITE(LO,'(/,1X,A,I3)')
+ & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
+ STOP
+ ENDIF
+ IF(IREJ.NE.0) THEN
+ IFAIL(41) = IFAIL(41)+1
+ IF(IDEB(60).GE.2) THEN
+ WRITE(LO,'(1X,A,I12,4I3)')
+ & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
+ & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
+ WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
+ & XSUM1,XSUM2,XMAX1,XMAX2
+ ENDIF
+ RETURN
+ ENDIF
+ IF(MSOFT.NE.MSMAX) THEN
+ MSDIFF = MSMAX-MSOFT
+ MSPAR1 = MSPAR1-MSDIFF
+ MSPAR2 = MSPAR2-MSDIFF
+ ENDIF
+
+C correct for different MSPAR numbers
+ IF(MSOFT.NE.MSPAR1) THEN
+ IF(MSPAR1.GT.1) THEN
+ XDEL = 0.D0
+ DO 500 I=MSPAR1+1,MSOFT
+ XDEL = XDEL+XS1(I)
+ 500 CONTINUE
+ XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
+ DO 550 I=2,MSPAR1
+ XS1(I) = XS1(I)*XFAC
+ 550 CONTINUE
+ XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
+ ELSE
+ XSS1 = XSUM1
+ ENDIF
+ ENDIF
+ IF(MSOFT.NE.MSPAR2) THEN
+ IF(MSPAR2.GT.1) THEN
+ XDEL = 0.D0
+ DO 600 I=MSPAR2+1,MSOFT
+ XDEL = XDEL+XS2(I)
+ 600 CONTINUE
+ XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
+ DO 650 I=2,MSPAR2
+ XS2(I) = XS2(I)*XFAC
+ 650 CONTINUE
+ XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
+ ELSE
+ XSS2 = XSUM2
+ ENDIF
+ ENDIF
+
+C first x entry
+ XS1(1) = 1.D0 - XSS1
+ XS2(1) = 1.D0 - XSS2
+ XSUM1 = XSS1
+ XSUM2 = XSS2
+
+C debug output
+ IF(IDEB(60).GE.10) THEN
+ WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
+ & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
+ & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
+ WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
+ DO 30 I=1,MSOFT
+ WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
+ & XMIN(1,I),XMIN(2,I)
+ 30 CONTINUE
+ ENDIF
+
+ RETURN
+
+C not enough phase space
+ 1000 CONTINUE
+
+ IFAIL(42) = IFAIL(42)+1
+ IREJ = 1
+
+C warning message
+ IF(IDEB(60).GE.1) THEN
+ WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
+ & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
+ & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
+ & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
+ WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
+ WRITE(LO,'(1X,A)')
+ & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
+ DO 27 I=1,MSOFT
+ WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
+ 27 CONTINUE
+ WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
+ & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
+ & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
+ WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
+ DO 25 I=1,MSOFT
+ WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
+ & XMIN(1,I),XMIN(2,I)
+ 25 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SELSXR
+ SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (rejection method)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IF(IDEB(13).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
+ WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
+ & MSOFT,XS1,XS2,XMAX1,XMAX2
+ DO 40 I=1,MSOFT
+ WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
+ 40 CONTINUE
+ ENDIF
+C
+ IREJ = 0
+C
+ XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
+ XMIN1 = MAX(AS/XMAX1,XMINK)
+ XMIN2 = MAX(AS/XMAX2,XMINK)
+C
+ IF(MSOFT.EQ.1) THEN
+ XSOFT1(2) = 0.D0
+ XSOFT2(2) = 0.D0
+ RETURN
+ ENDIF
+ XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
+ & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
+C
+ 10 CONTINUE
+C
+ DO 50 I=2,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+C
+ ITRY0 = 0
+ 5 CONTINUE
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(181)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XREST1 = 1.D0-XS1
+ XREST2 = 1.D0-XS2
+ DO 100 I=2,MSOFT
+ ITRY1 = 0
+
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+
+ XREST1 = XREST1-XSOFT1(I)
+ IF(XREST1.LT.XMIN1) GOTO 5
+ IF(XREST1.LT.XMIN(1,1)) GOTO 5
+ XREST2 = XREST2-XSOFT2(I)
+ IF(XREST2.LT.XMIN2) GOTO 5
+ IF(XREST2.LT.XMIN(2,1)) GOTO 5
+ IF(XREST1*XREST2.LT.AS) GOTO 5
+
+ 100 CONTINUE
+ XSOFT1(1) = XREST1
+ XSOFT2(1) = XREST2
+ IREJ=0
+* XX = 1.D0
+* DO 200 I=2,MSOFT
+* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
+*200 CONTINUE
+ XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
+ IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
+
+ XS1 = 1.D0-XREST1
+ XS2 = 1.D0-XREST2
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(13).GE.2) THEN
+ WRITE(LO,'(1X,A,2I4)')
+ & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
+ WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SELSX2
+ SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
+ & XS1,XS2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends using PHO_RNDBET
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ IREJ = 0
+
+ IF(IDEB(32).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
+ WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
+ & AS,XSUM1,XSUM2,XMAX1,XMAX2
+ DO 30 I=1,2
+ WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
+ 30 CONTINUE
+ ENDIF
+
+ FAC1 = 1.D0-XSUM1
+ FAC2 = 1.D0-XSUM2
+ FAC = FAC1*FAC2
+ GAM1 = XPOT1(1)+1.D0
+ GAM2 = XPOT2(1)+1.D0
+ BET1 = XPOT1(2)+1.D0
+ BET2 = XPOT2(2)+1.D0
+
+ ITRY0 = 0
+ DO 100 I=1,IPAMDL(182)
+
+ ITRY1 = 0
+ 10 CONTINUE
+ X1 = PHO_RNDBET(GAM1,BET1)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
+
+ ITRY2 = 0
+ 11 CONTINUE
+ X2 = PHO_RNDBET(GAM2,BET2)
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GE.50) GOTO 1000
+ IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
+
+ X3 = 1.D0 - X1
+ X4 = 1.D0 - X2
+ IF(X1*X2*FAC.GT.AS) THEN
+ IF(X3*X4*FAC.GT.AS) THEN
+ XS1(1) = X1*FAC1
+ XS1(2) = X3*FAC1
+ XS2(1) = X2*FAC2
+ XS2(2) = X4*FAC2
+ IF(XS1(1).GT.XMIN(1,1)) THEN
+ IF(XS2(1).GT.XMIN(2,1)) THEN
+ IF(XS1(2).GT.XMIN(1,2)) THEN
+ IF(XS2(2).GT.XMIN(2,2)) THEN
+ XSUM1 = XSUM1+XS1(2)
+ XSUM2 = XSUM2+XS2(2)
+ GOTO 300
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ITRY0 = ITRY0+1
+
+ 100 CONTINUE
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(32).GE.2) THEN
+ WRITE(LO,'(1X,A,3I4)')
+ & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
+ WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
+ ENDIF
+ RETURN
+ 300 CONTINUE
+
+ END
+
+CDECK ID>, PHO_SELSXS
+ SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (rescaling method)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IREJ = 0
+
+ 10 CONTINUE
+
+ IF(MSOFT.EQ.1) THEN
+ XSOFT1(1) = 1.D0-XS1
+ XSOFT1(2) = 0.D0
+ XSOFT2(1) = 1.D0-XS2
+ XSOFT2(2) = 0.D0
+ RETURN
+ ENDIF
+
+ DO 50 I=1,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+
+ ITRY0 = 0
+ 5 CONTINUE
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(180)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT= MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XSUM1 = 0.D0
+ XSUM2 = 0.D0
+ DO 100 I=1,MSOFT
+ ITRY1 = 0
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+ XSUM1 = XSUM1+XSOFT1(I)
+ XSUM2 = XSUM2+XSOFT2(I)
+ 100 CONTINUE
+ FAC1 = (1.D0-XS1)/XSUM1
+ FAC2 = (1.D0-XS2)/XSUM2
+ DO 200 I=1,MSOFT
+ XSOFT1(I) = XSOFT1(I)*FAC1
+ XSOFT2(I) = XSOFT2(I)*FAC2
+ IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
+ IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
+ IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
+ 200 CONTINUE
+
+ XS1 = 1.D0-XSOFT1(1)
+ XS2 = 1.D0-XSOFT2(1)
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(14).GE.2) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
+ & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
+ DO 300 I=1,MSOFT
+ WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
+ 300 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SELSXI
+ SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
+ & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
+C***********************************************************************
+C
+C select x values of soft string ends (sea independent from valence)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+
+ DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
+
+ IREJ = 0
+
+ 10 CONTINUE
+
+ DO 50 I=1,MSOFT
+ POT(1,I) = XPOT1(I)+1.D0
+ POT(2,I) = XPOT2(I)+1.D0
+ REVP(1,I) = 1.D0/POT(1,I)
+ REVP(2,I) = 1.D0/POT(2,I)
+ XLMIN(1,I) = XMIN(1,I)**POT(1,I)
+ XLMAX = XMAX1**POT(1,I)
+ XLDIF(1,I) = XLMAX-XLMIN(1,I)
+ XLMIN(2,I) = XMIN(2,I)**POT(2,I)
+ XLMAX = XMAX2**POT(2,I)
+ XLDIF(2,I) = XLMAX-XLMIN(2,I)
+ 50 CONTINUE
+
+C selection of sea
+ ITRY0 = 0
+ 5 CONTINUE
+
+ ITRY0 = ITRY0 + 1
+ IF(ITRY0.GE.IPAMDL(183)) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ GOTO 1000
+ ENDIF
+ XSUM1 = XS1
+ XSUM2 = XS2
+ DO 100 I=3,MSOFT
+ ITRY1 = 0
+ 20 CONTINUE
+ Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
+ Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
+ XSOFT1(I) = Z1**REVP(1,I)
+ XSOFT2(I) = Z2**REVP(2,I)
+ ITRY1 = ITRY1+1
+ IF(ITRY1.GE.50) GOTO 1000
+ IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
+ XSUM1 = XSUM1+XSOFT1(I)
+ XSUM2 = XSUM2+XSOFT2(I)
+ 100 CONTINUE
+
+ IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
+ IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
+
+C selection of valence
+ CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
+ & XSOFT1,XSOFT2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(MSOFT-MSMIN.GE.2) THEN
+ MSOFT = MSMIN
+ GOTO 10
+ ENDIF
+ IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
+ & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
+ & XSUM1,XSUM2,XMAX1,XMAX2
+ RETURN
+ ENDIF
+
+ XS1 = 1.D0-XSOFT1(1)
+ XS2 = 1.D0-XSOFT2(1)
+ RETURN
+
+ 1000 CONTINUE
+ IREJ = 1
+ IF(IDEB(14).GE.2) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
+ & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
+ DO 300 I=1,MSOFT
+ WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
+ 300 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SELCOL
+ SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
+C********************************************************************
+C
+C color combinatorics
+C
+C input: ICO1,2 colors of incoming particle
+C IMODE -2 output of initialization status
+C -1 initialization
+C ICINP(1) selection mode
+C 0 QCD
+C 1 large N_c expansion
+C ICINP(2) max. allowed color
+C 0 clear internal color counter
+C 1 hadron into two colored objects
+C 2 quark into quark gluon
+C 3 gluon into gluon gluon
+C 4 gluon into quark antiquark
+C
+C output: ICOA1,2 colors of first outgoing particle
+C ICOB1,2 colors of second outgoing particle
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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
+
+ DATA METHOD /0/, II /0/
+
+ ICI1 = ICO1
+ ICI2 = ICO2
+ IF(METHOD.EQ.0) THEN
+
+ IF(IMODE.EQ.1) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ ICOA1 = II
+ ICOA2 = 0
+ ICOB1 = -II
+ ICOB2 = 0
+ ELSE IF(IMODE.EQ.2) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ ICOA2 = 0
+ IF(ICI1.GT.0) THEN
+ ICOA1 = II
+ ICOB1 = ICI1
+ ICOB2 = -II
+ ELSE
+ ICOA1 = -II
+ ICOB1 = II
+ ICOB2 = ICI1
+ ENDIF
+ ELSE IF(IMODE.EQ.3) THEN
+ II = II+1
+ IF(II.GT.MAXCOL)
+ & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
+ IF(DT_RNDM(DUM).GT.0.5D0) THEN
+ ICOA1 = ICI1
+ ICOA2 = -II
+ ICOB1 = II
+ ICOB2 = ICI2
+ ELSE
+ ICOB1 = ICI1
+ ICOB2 = -II
+ ICOA1 = II
+ ICOA2 = ICI2
+ ENDIF
+ ELSE IF(IMODE.EQ.4) THEN
+ ICOA1 = ICI1
+ ICOA2 = 0
+ ICOB1 = ICI2
+ ICOB2 = 0
+ ELSE IF(IMODE.EQ.0) THEN
+ II = 0
+ ELSE IF(IMODE.EQ.-1) THEN
+ METHOD = ICI1
+ MAXCOL = ICI2
+ ELSE IF(IMODE.EQ.-2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
+ & METHOD,MAXCOL
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ ELSE
+ WRITE(LO,'(1X,A,I5)')
+ & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
+ CALL PHO_ABORT
+ ENDIF
+
+ II = ABS(II)
+ IF(IDEB(75).GE.10) THEN
+ WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
+ & IMODE,MAXCOL,II
+ WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
+ WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
+ ENDIF
+
+ END
+
+CDECK ID>, ipho_diqu
+ INTEGER FUNCTION ipho_diqu(iq1,iq2)
+C***********************************************************************
+C
+C selection of diquark number (PDG convention)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer iq1,iq2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+C external functions
+ double precision DT_RNDM
+
+C local variables
+ integer i0,i1,i2
+ double precision dum
+
+ i1 = abs(iq1)
+ i2 = abs(iq2)
+
+ if(i1.eq.i2) then
+ i0 = i1*1100+3
+ else
+ i0 = max(i1,i2)*1000+min(i1,i2)*100
+ if(DT_RNDM(dum).gt.PARMDL(135)) then
+ i0 = i0+1
+ else
+ i0 = i0+3
+ endif
+ endif
+
+ ipho_diqu = sign(i0,iq1)
+
+ END
+
+CDECK ID>, PHO_PARREM
+ SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
+C**********************************************************************
+C
+C selection of particle remnant flavour(s) (quark or diquark)
+C
+C input: INDX index of particle in /POEVT1/
+C IOUT parton which was taken out
+C
+C output: IREM remnant according to valence flavours
+C IREJ 0 flavour combination possible
+C 1 flavour combination impossible
+C
+C all particle ID are given according to PDG conventions
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer INDX,IOUT,IREM,IREJ
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_diqu
+
+C local variables
+ integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
+ dimension IQUA(3),IDQ(2)
+
+ ID1 = IDHEP(INDX)
+ ID2 = IMPART(INDX)
+ IREJ = 0
+
+ IF(ID2.EQ.0) THEN
+ WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
+ CALL PHO_ABORT
+ ENDIF
+
+C particle with flavour mixing
+ if(ID1.eq.22) then
+C photon
+ IREM = -IOUT
+ GOTO 100
+ else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
+C pi0, rho0, and omega
+ IF(ABS(IOUT).LE.2) THEN
+ IREM = -IOUT
+ GOTO 100
+ ELSE
+ GOTO 150
+ ENDIF
+ else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
+C neutral kaons (K0,K0-bar)
+ if(abs(IOUT).eq.1) then
+ IREM = sign(3,-IOUT)
+ goto 100
+ else if(abs(IOUT).eq.3) then
+ IREM = sign(1,-IOUT)
+ goto 100
+ else
+ goto 150
+ endif
+ else if((ID1.eq.990).or.(ID1.eq.110)) then
+C pomeron and reggeon
+ IREM = -IOUT
+ GOTO 100
+ endif
+
+C ordinary hadron
+ ID = abs(ID2)
+ IS = sign(1,ID2)
+ IQUA(1) = iq_list(1,ID)*IS
+ IQUA(2) = iq_list(2,ID)*IS
+ IQUA(3) = iq_list(3,ID)*IS
+
+C compare to flavour content
+ IF(ABS(IOUT).LT.1000) THEN
+C single quark requested
+ IF(IQUA(1).EQ.IOUT) THEN
+ K1 = 2
+ K2 = 3
+ ELSE IF(IQUA(2).EQ.IOUT) THEN
+ K1 = 1
+ K2 = 3
+ ELSE IF(IQUA(3).EQ.IOUT) THEN
+ K1 = 1
+ K2 = 2
+ ELSE
+ GOTO 150
+ ENDIF
+ IF(IQUA(3).EQ.0) THEN
+ IREM = IQUA(K1)
+ ELSE
+ IREM = ipho_diqu(IQUA(K1),IQUA(K2))
+ ENDIF
+ ELSE IF(IQUA(3).NE.0) THEN
+C diquark requested from baryon
+ IDQ(1) = IOUT/1000
+ IDQ(2) = (IOUT-IDQ(1)*1000)/100
+ do i=1,2
+ do k=1,3
+ if(IDQ(i).eq.IQUA(k)) then
+ IQUA(k) = 0
+ goto 110
+ endif
+ enddo
+ goto 150
+ 110 continue
+ enddo
+ IREM = IQUA(1)+IQUA(2)+IQUA(3)
+ ENDIF
+
+ 100 CONTINUE
+C debug output
+ IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
+ & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
+ & INDX,ID1,ID2,IOUT,IREM
+ RETURN
+
+C rejection
+ 150 CONTINUE
+ IREJ = 1
+ IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
+ & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
+
+ END
+
+CDECK ID>, PHO_VALFLA
+ SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
+C***********************************************************************
+C
+C selection of valence flavour decomposition of particle IPAR
+C
+C input: IPAR particle index in /POEVT1/
+C -1 initialization
+C -2 output of statistics
+C XMASS mass of particle
+C (important for pomeron:
+C mass dependent flavour sampling)
+C
+C output: IFL1,IFL2
+C baryon: IFL1 diquark flavour
+C (valence flavours according to PDG conventions)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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 general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ data ITMX / 5 /
+
+ IF(IPAR.GT.0) THEN
+ K = IPAR
+C select particle code
+ ID1 = IDHEP(K)
+ ID = abs(IMPART(K))
+ IBAR = IPHO_BAR3(K,2)
+ ITER = 0
+
+ 10 CONTINUE
+
+ ifl1 = 0
+ ifl2 = 0
+ ITER = ITER+1
+ if(ITER.GT.ITMX) then
+ WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
+ & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
+ return
+ endif
+
+C not baryon
+ IF(IBAR.EQ.0) THEN
+
+C photon
+ IF(ID1.EQ.22) THEN
+C charge dependent flavour sampling
+ 15 CONTINUE
+ K = INT(DT_RNDM(E1)*6.D0)+1
+ IF(K.LE.4) THEN
+ IFL1 = 2
+ IFL2 = -2
+ ELSE IF(K.EQ.5) THEN
+ IFL1 = 1
+ IFL2 = -1
+ ELSE
+ IFL1 = 3
+ IFL2 = -3
+ ENDIF
+C optional strangeness suppression
+ IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
+ IF(DT_RNDM(DUM).LT.0.5D0) THEN
+ K = IFL1
+ IFL1 = IFL2
+ IFL2 = K
+ ENDIF
+
+C pomeron, reggeon
+ ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
+ IF(ISWMDL(19).EQ.0) THEN
+C SU(3) symmetric valences
+ K = INT(DT_RNDM(E1)*3.D0)+1
+ IF(DT_RNDM(DUM).LT.0.5D0) THEN
+ IFL1 = K
+ ELSE
+ IFL1 = -K
+ ENDIF
+ IFL2 = -IFL1
+ ELSE IF(ISWMDL(19).EQ.1) THEN
+C mass dependent flavour sampling
+ EMIN = MIN(E1,E2)
+ CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
+ ELSE
+ WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
+ & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
+ CALL PHO_ABORT
+ ENDIF
+
+C meson with flavour mixing
+ ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
+ K = INT(2.D0*DT_RNDM(E1))+1
+ IFL1 = K
+ IFL2 = -K
+C meson (standard)
+ ELSE
+ K = INT(2.D0*DT_RNDM(E1))+1
+ IFL1 = iq_list(K,ID)
+ K = MOD(K,2) + 1
+ IFL2 = iq_list(K,ID)
+ if(IFL1.EQ.0) then
+ EMIN = MIN(E1,E2)
+ CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
+ endif
+ ENDIF
+
+C baryon
+ ELSE
+ K = INT(2.999999D0*DT_RNDM(E2))+1
+ K1 = MOD(K,3)+1
+ K2 = MOD(K1,3)+1
+ IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
+ IFL2 = iq_list(K,ID)
+ ENDIF
+
+C change sign for antiparticles
+ if(ID1.lt.0) then
+ IFL1 = -IFL1
+ IFL2 = -IFL2
+ endif
+
+************************************************************************
+C check kinematic constraints
+* IF((PHO_PMASS(IFL1,3).GT.E1)
+* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
+************************************************************************
+
+C debug output
+ IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
+ & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
+
+ ELSE IF(IPAR.EQ.-1) THEN
+C initialization
+
+ ELSE IF(IPAR.EQ.-2) THEN
+C output of final statistics
+
+ ELSE
+ WRITE(LO,'(1X,A,I10)')
+ & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_REGFLA
+ SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
+C**********************************************************************
+C
+C selection of reggeon flavours
+C
+C input: JM1,JM2 position index of mother hadrons
+C
+C output: IFLR1,IFLR2 valence flavours according to
+C PDG conventions and JM1,JM2
+C IREJ 0 reggeon possible
+C 1 reggeon impossible
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 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)
+
+ IF(JM1.GT.0) THEN
+ IREJ = 0
+ ITER = 0
+C available energy
+ E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
+ & -(PHEP(1,JM1)+PHEP(1,JM2))**2
+ & -(PHEP(2,JM1)+PHEP(2,JM2))**2
+ & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GT.50) THEN
+ IREJ = 1
+C debug output
+ IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
+ & 'PHO_REGFLA: rejection, no reggeon found for',
+ & IDHEP(JM1),IDHEP(JM2),E1
+ RETURN
+ ENDIF
+
+ CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
+ CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
+ IF(IFLA1.EQ.-IFLB1) THEN
+ IFLR1 = IFLA2
+ IFLR2 = IFLB2
+ ELSE IF(IFLA1.EQ.-IFLB2) THEN
+ IFLR1 = IFLA2
+ IFLR2 = IFLB1
+ ELSE IF(IFLA2.EQ.-IFLB1) THEN
+ IFLR1 = IFLA1
+ IFLR2 = IFLB2
+ ELSE IF(IFLA2.EQ.-IFLB2) THEN
+ IFLR1 = IFLA1
+ IFLR2 = IFLB1
+ ELSE
+C debug output
+ IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
+ & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
+ GOTO 50
+ ENDIF
+C debug output
+ IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
+ & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
+ & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
+ ELSE IF(JM1.EQ.-1) THEN
+C initialization
+ ELSE IF(JM1.EQ.-2) THEN
+C output of statistics
+ ELSE
+ WRITE(LO,'(1X,A,I10)')
+ & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SEAFLA
+ SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
+C**********************************************************************
+C
+C selection of sea flavour content of particle IPAR
+C
+C input: IPAR particle index in /POEVT1/
+C CHMASS available invariant string mass
+C positive mass --> use BAMJET method
+C negative mass --> SU(3) symmetric sea according
+C to values given in PARMDL(1-6)
+C IPAR -1 initialization
+C -2 output of statistics
+C
+C output: sea flavours according to PDG conventions
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 0.1D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ IF(IPAR.GT.0) THEN
+ IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
+C constant weights for sea
+ 15 CONTINUE
+ SUM = 0.D0
+ DO 40 K=1,NFSEA
+ SUM = SUM + PARMDL(K)
+ 40 CONTINUE
+ XI = DT_RNDM(SUM)*SUM
+ SUM = 0.D0
+ DO 50 K=1,NFSEA
+ SUM = SUM + PARMDL(K)
+ IF(XI.LE.SUM) GOTO 55
+ 50 CONTINUE
+ 55 CONTINUE
+ IF(K.GT.NFSEA) GOTO 15
+ ELSE
+C mass dependent flavour sampling
+ 10 CONTINUE
+ CALL PHO_FLAUX(CHMASS,K)
+ IF(K.GT.NFSEA) GOTO 10
+ ENDIF
+ IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
+ IFL1 = K
+ IFL2 = -K
+ IF(IDEB(46).GE.10) THEN
+ WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
+ & IPAR,IFL1,IFL2,CHMASS
+ ENDIF
+ ELSE IF(IPAR.EQ.-1) THEN
+C initialization
+ NFSEA = NFS
+ ELSE IF(IPAR.EQ.-2) THEN
+C output of statistics
+ ELSE
+ WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_FLAUX
+ SUBROUTINE PHO_FLAUX(EQUARK,K)
+C***********************************************************************
+C
+C auxiliary subroutine to select flavours
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-14 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ DIMENSION WGHT(9)
+
+C calculate weights for given energy
+ IF(EQUARK.LT.QMASS(1)) THEN
+ IF(IDEB(16).GE.5)
+ & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
+ & EQUARK
+ WGHT(1) = 0.5D0
+ WGHT(2) = 0.5D0
+ WGHT(3) = 0.D0
+ WGHT(4) = 0.D0
+ SUM = 1.D0
+ ELSE
+ SUM = 0.D0
+ DO 305 K=1,NFS
+ IF(EQUARK.GT.QMASS(K)) THEN
+ WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
+ ELSE
+ WGHT(K) = 0.D0
+ ENDIF
+ SUM = SUM + WGHT(K)
+ 305 CONTINUE
+ ENDIF
+C sample flavours
+ XI = SUM*(DT_RNDM(SUM)-DEPS)
+ K = 0
+ SUM = 0.D0
+ 400 CONTINUE
+ K = K+1
+ SUM = SUM + WGHT(K)
+ IF(XI.GT.SUM) GOTO 400
+C debug output
+ IF(IDEB(16).GE.20) THEN
+ WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
+ ENDIF
+ END
+
+CDECK ID>, PHO_BETAF
+ DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
+C********************************************************************
+C
+C weights of different quark flavours
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX=0.D0
+ BETX1=BET*X1
+ IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
+ AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
+
+ PHO_BETAF=AX+AY
+
+ END
+
+CDECK ID>, PHO_MCHECK
+ SUBROUTINE PHO_MCHECK(J1,IREJ)
+C********************************************************************
+C
+C check parton momenta for fragmentation
+C
+C input: J1 first string number
+C /POEVT1/
+C /POSTRG/
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C in case of very small string mass:
+C NNCH mass label of string
+C 0 string
+C -1 octett baryon / pseudo scalar meson
+C 1 decuplett baryon / vector meson
+C IBHAD hadron number according to CPC,
+C string will be treated as resonance
+C (sometimes far off mass shell)
+C
+C constant WIDTH ( 0.01GeV ) determines range of acceptance
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( WIDTH = 0.01D0,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+C quark antiquark jet
+ STRM = PHEP(5,NPOS(1,J1))
+ IF(NCODE(J1).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
+ & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
+ & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
+ IF(STRM.LT.AMPS) THEN
+ IREJ = 1
+ IFAIL(20) = IFAIL(20) + 1
+ RETURN
+ ELSE IF(STRM.LT.AMPS2) THEN
+ IF(STRM.LT.(AMVE-WIDTH)) THEN
+ NNCH(J1) = -1
+ IBHAD(J1) = IPS
+ ELSE
+ NNCH(J1) = 1
+ IBHAD(J1) = IVE
+ ENDIF
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+C quark diquark or v.s. jet
+ ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
+ & AM8,AM82,AM10,AM102,I8,I10)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
+ & J1,STRM,AM8,AM82,AM10,AM102
+ IF(STRM.LT.AM8) THEN
+ IREJ = 1
+ IFAIL(19) = IFAIL(19) + 1
+ RETURN
+ ELSE IF(STRM.LT.AM82) THEN
+ IF(STRM.LT.(AM10-WIDTH)) THEN
+ NNCH(J1) = -1
+ IBHAD(J1) = I8
+ ELSE
+ NNCH(J1) = 1
+ IBHAD(J1) = I10
+ ENDIF
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+C diquark a-diquark string
+ ELSE IF(NCODE(J1).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
+ & AM82,AM102)
+ IF(IDEB(18).GE.5)
+ & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
+ & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
+ & J1,STRM,AM82,AM102
+ IF(STRM.LT.AM82) THEN
+ IREJ = 1
+ IFAIL(19) = IFAIL(19) + 1
+ RETURN
+ ELSE
+ NNCH(J1) = 0
+ IBHAD(J1) = 0
+ ENDIF
+ ELSE IF(NCODE(J1).LT.0) THEN
+ RETURN
+ ELSE
+ WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
+ & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
+ CALL PHO_ABORT
+ ENDIF
+ END
+
+CDECK ID>, PHO_POMCOR
+ SUBROUTINE PHO_POMCOR(IREJ)
+C********************************************************************
+C
+C join quarks to gluons in case of too small masses
+C
+C input: /POEVT1/
+C /POSTRG/
+C IREJ -1 initialization
+C -2 output of statistics
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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
+
+ DIMENSION PJ(4)
+
+ IF(IREJ.EQ.-1) THEN
+ ICTOT = 0
+ ICCOR = 0
+ RETURN
+ ELSE IF(IREJ.EQ.-2) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A,2I8)')
+C & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
+ RETURN
+ ENDIF
+C
+ IREJ = 0
+C
+ NITER = 100
+ ITER = 0
+ ICTOT = ICTOT+ISTR
+ IF(ISWMDL(25).LE.0) RETURN
+C debug string entries
+ IF(IDEB(83).GE.25) CALL PHO_PRSTRG
+C
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.NITER) THEN
+ IREJ = 1
+ IF(IDEB(83).GE.2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
+ IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+C
+C check mass limits
+ ISTRO = ISTR
+ DO 100 I=1,ISTRO
+ IF(NCODE(I).LT.0) GOTO 99
+ J1 = NPOS(1,I)
+ NRPOM = IPHIST(2,J1)
+ IF(NRPOM.GE.100) GOTO 99
+ CMASS0 = PHEP(5,J1)
+C get masses
+ IF(NCODE(I).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
+ & AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF(NCODE(I).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
+ & AM1,AM2)
+ AM3 = 0.D0
+ AM4 = 0.D0
+ IP1 = 0
+ IP2 = 0
+ ELSE IF(NCODE(I).EQ.7) THEN
+ GOTO 99
+ ELSE IF(NCODE(I).LT.0) THEN
+ GOTO 99
+ ELSE
+ WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
+ & J1,NCODE(I)
+ CALL PHO_ABORT
+ ENDIF
+ IF(IDEB(83).GE.5)
+ & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
+ & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
+ & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
+C select masses to correct
+ IF(CMASS0.LT.MAX(AM2,AM4)) THEN
+ DO 200 K=1,ISTRO
+ IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
+ J2 = NPOS(1,K)
+C join quarks to gluon
+ IF(NRPOM.EQ.IPHIST(2,J2)) THEN
+C flavour check
+ IFL1 = 0
+ IFL2 = 0
+ PROB1 = 0.D0
+ PROB2 = 0.D0
+ KK1 = NPOS(2,I)
+ KK2 = NPOS(2,K)
+ IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
+ CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
+ & -(PHEP(1,KK1)+PHEP(1,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ IFL1 = ABS(IDHEP(KK1))
+ IF(IFL1.GT.2) THEN
+ PROB1 = 0.1D0/MAX(CMASS,EPS)
+ ELSE
+ PROB1 = 0.9D0/MAX(CMASS,EPS)
+ ENDIF
+ ENDIF
+ KK1 = ABS(NPOS(3,I))
+ KK2 = ABS(NPOS(3,K))
+ IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
+ CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
+ & -(PHEP(1,KK1)+PHEP(1,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ & -(PHEP(2,KK1)+PHEP(2,KK2))**2
+ IFL2 = ABS(IDHEP(KK1))
+ IF(IFL2.GT.2) THEN
+ PROB2 = 0.1D0/MAX(CMASS,EPS)
+ ELSE
+ PROB2 = 0.9D0/MAX(CMASS,EPS)
+ ENDIF
+ ENDIF
+ IF(IFL1+IFL2.EQ.0) GOTO 99
+C fusion possible
+ ICCOR = ICCOR+1
+ IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
+ JJ = 2
+ JE = 3
+ ELSE
+ JJ = 3
+ JE = 2
+ ENDIF
+ KK1 = ABS(NPOS(JJ,I))
+ KK2 = ABS(NPOS(JJ,K))
+ I1 = ABS(NPOS(JE,I))
+ I2 = KK1
+ IS = SIGN(1,I2-I1)
+ I2 = I2 - IS
+ K1 = KK2
+ K2 = ABS(NPOS(JE,K))
+ KS = SIGN(1,K2-K1)
+ K1 = K1 + KS
+ IP1 = NHEP+1
+C copy mother partons of string I
+ DO 300 II=I1,I2,IS
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
+ & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
+ & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
+ 300 CONTINUE
+C register gluon
+ DO 350 II=1,4
+ PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
+ 350 CONTINUE
+ CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
+ & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
+C copy mother partons of string K
+ DO 400 II=K1,K2,KS
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
+ & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
+ & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
+ 400 CONTINUE
+C create new string entry
+ DO 450 II=1,4
+ PJ(II) = PHEP(II,J1)+PHEP(II,J2)
+ 450 CONTINUE
+ IP2 = IPOS
+ CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
+ & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
+ & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
+C delete string K in /POSTRG/
+ NCODE(K) = -999
+C update string I in /POSTRG/
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = IP1
+ NPOS(3,I) = -IP2
+C calculate new CPC string codes
+ CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
+ & IPAR2(I),IPAR3(I),IPAR4(I))
+ GOTO 99
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+ ENDIF
+ 99 CONTINUE
+ 100 CONTINUE
+ IF(IDEB(83).GE.20) THEN
+ WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
+ IF(IDEB(83).GE.22) THEN
+ CALL PHO_PRSTRG
+ CALL PHO_PREVNT(0)
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_MASCOR
+ SUBROUTINE PHO_MASCOR(IREJ)
+C********************************************************************
+C
+C check and adjust parton momenta for fragmentation
+C
+C input: /POEVT1/
+C /POSTRG/
+C IREJ -1 initialization
+C -2 output of statistics
+C
+C output: /POEVT1/
+C /POSTRG/
+C IREJ 0 successful
+C 1 failure
+C
+C in case of very small string mass:
+C - direct manipulation of /POEVT1/ and /POEVT2/
+C - string will be deleted from /POSTRG/ (label -99)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10,
+ & EMIN = 0.3D0,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 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
+
+ DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
+
+ IF(IREJ.EQ.-1) THEN
+ ICTOT = 0
+ ICCOR = 0
+ RETURN
+ ELSE IF(IREJ.EQ.-2) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A,2I8/)')
+C & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
+ RETURN
+ ENDIF
+
+ IREJ = 0
+ NITER = 100
+ ITER = 0
+ ICTOT = ICTOT+ISTR
+ IF(ISWMDL(7).EQ.-1) RETURN
+C debug /POSTRG/
+ IF(IDEB(42).GE.25) CALL PHO_PRSTRG
+
+ ITOUCH = 0
+ 50 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.NITER) THEN
+ IREJ = 1
+ IF(IDEB(42).GE.2) THEN
+ WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
+ IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+
+C check mass limits
+ IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
+ IM1 = 1
+ IM2 = ISTR
+ IST = 1
+ ELSE
+ IM1 = ISTR
+ IM2 = 1
+ IST = -1
+ ENDIF
+ DO 100 I=IM1,IM2,IST
+ J1 = NPOS(1,I)
+ CMASS0 = PHEP(5,J1)
+C get masses
+ IF(NCODE(I).EQ.3) THEN
+ CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
+ CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
+ & AM1,AM2,AM3,AM4,IP1,IP2)
+ ELSE IF(NCODE(I).EQ.5) THEN
+ CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
+ & AM1,AM2)
+ AM3 = 0.D0
+ AM4 = 0.D0
+ IP1 = 0
+ IP2 = 0
+ ELSE IF(NCODE(I).EQ.7) THEN
+ AM1 = 0.15D0
+ AM2 = 0.3D0
+ AM3 = 0.765D0
+ AM4 = 1.5D0
+*??????????????????????????????????
+ IP1 = 23
+ IP2 = 33
+*??????????????????????????????????
+ ELSE IF(NCODE(I).LT.0) THEN
+ GOTO 90
+ ELSE
+ WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
+ & J1,NCODE(I)
+ CALL PHO_ABORT
+ ENDIF
+ IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
+ & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
+ & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
+C select masses to correct
+ IBHAD(I) = 0
+ NNCH(I) = 0
+C correction needed?
+C no resonances for diquark-antidiquark and gluon-gluon strings
+ IF(NCODE(I).EQ.5) THEN
+ IF(CMASS0.LT.1.3D0*AM1) THEN
+ IF(ISWMDL(7).LE.2) THEN
+ IBHAD(I) = 90
+ NNCH(I) = -1
+ CHMASS = AM1*1.3D0
+ ELSE
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ INEED = 0
+C resonances possible
+ IF(ISWMDL(7).EQ.0) THEN
+ IF(CMASS0.LT.AM1*0.99D0) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ INEED = 1
+ ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
+ DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
+ DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
+ IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ ELSE
+ IBHAD(I) = IP2
+ NNCH(I) = 1
+ CHMASS = AM3
+ ENDIF
+ ENDIF
+ ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
+ IF(CMASS0.LT.AM1*0.99) THEN
+ IBHAD(I) = IP1
+ NNCH(I) = -1
+ CHMASS = AM1
+ INEED = 1
+ ENDIF
+ ELSE IF(ISWMDL(7).EQ.3) THEN
+ IF(CMASS0.LT.AM1) THEN
+ IREJ = 1
+ RETURN
+ ENDIF
+ ELSE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+C correction necessary?
+ IF(IBHAD(I).NE.0) THEN
+C find largest invar. mass
+ IPOS = 0
+ CMASS1 = -1.D0
+ DO 200 J2=NHEP,3,-1
+
+ IF(ABS(ISTHEP(J2)).EQ.1) THEN
+ IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
+ WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
+ & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
+ CALL PHO_PREVNT(0)
+ ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
+ CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
+ & -(PHEP(1,J1)+PHEP(1,J2))**2
+ & -(PHEP(2,J1)+PHEP(2,J2))**2
+ & -(PHEP(3,J1)+PHEP(3,J2))**2
+ IF(CMASS2.GT.CMASS1) THEN
+ IPOS=J2
+ CMASS1=CMASS2
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 200 CONTINUE
+ J2 = IPOS
+ IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
+ IF(INEED.EQ.1) THEN
+ IREJ = 1
+ RETURN
+ ELSE
+ IBHAD(I) = 0
+ NNCH(I) = 0
+ GOTO 90
+ ENDIF
+ ENDIF
+ ISTA = ISTHEP(J1)
+ ISTB = ISTHEP(J2)
+ CMASS1 = SQRT(CMASS1)
+ CMASS2 = PHEP(5,J2)
+ IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
+ IREJ = 1
+ IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
+ & CHMASS,CMASS2,PC1,PC2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(24) = IFAIL(24)+1
+ IF(IDEB(42).GE.2) THEN
+ WRITE(LO,'(1X,A,2I4)')
+ & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
+ IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+C momentum transfer
+ DO 210 II=1,4
+ PTR(II) = PHEP(II,J2)-PC2(II)
+ 210 CONTINUE
+ IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
+ & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
+C copy parents of strings
+C register partons belonging to first string
+ IF(IDHEP(J1).EQ.90) THEN
+ K1 = JMOHEP(1,J1)
+ K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
+ ESUM = 0.D0
+ DO 500 II=K1,K2
+ ESUM = ESUM+PHEP(4,II)
+ 500 CONTINUE
+ IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
+ DO 600 II=K1,K2
+ FAC = PHEP(4,II)/ESUM
+ DO 650 K=1,4
+ P1(K) = PHEP(K,II)+FAC*PTR(K)
+ 650 CONTINUE
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ 600 CONTINUE
+ K1A = IPOS+K1-K2
+ IF(JMOHEP(2,J1).GT.0) THEN
+ II = JMOHEP(2,J1)
+ FAC = PHEP(4,II)/ESUM
+ DO 675 K=1,4
+ P1(K) = PHEP(K,II)+FAC*PTR(K)
+ 675 CONTINUE
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ ENDIF
+ K2A = -IPOS
+ ELSE
+ K1A = J1
+ K2A = J2
+ ENDIF
+C register partons belonging to second string
+ IF(IDHEP(J2).EQ.90) THEN
+ CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
+ K1 = JMOHEP(1,J2)
+ K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
+ ESUM = 0.D0
+ DO 300 II=K1,K2
+ ESUM = ESUM+PHEP(4,II)
+ 300 CONTINUE
+ IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
+ DO 400 II=K1,K2
+ FAC = PHEP(4,II)/ESUM
+ IF(IREJL.EQ.0) THEN
+ CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
+ P1(4) = P1(4)+FAC*DELE
+ ELSE
+ DO 450 K=1,4
+ P1(K) = PHEP(K,II)-FAC*PTR(K)
+ 450 CONTINUE
+ ENDIF
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ 400 CONTINUE
+ K1B = IPOS+K1-K2
+ IF(JMOHEP(2,J2).GT.0) THEN
+ II = JMOHEP(2,J2)
+ FAC = PHEP(4,II)/ESUM
+ IF(IREJL.EQ.0) THEN
+ CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
+ P1(4) = P1(4)+FAC*DELE
+ ELSE
+ DO 475 K=1,4
+ P1(K) = PHEP(K,II)-FAC*PTR(K)
+ 475 CONTINUE
+ ENDIF
+ CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
+ & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
+ & ICOLOR(2,II),IPOS,1)
+ ENDIF
+ K2B = -IPOS
+ ELSE
+ K1B = J1
+ K2B = J2
+ ENDIF
+C register first string/collapsed to hadron
+ IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
+ IF(NCODE(I).NE.5) THEN
+ CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
+ & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
+C label string as collapsed to hadron/resonance
+ NCODE(I) = -99
+ IDHEP(J1) = 92
+ ELSE
+ CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
+ & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
+ IDHEP(J1) = 91
+ ENDIF
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = K1A
+ NPOS(3,I) = K2A
+ ELSE
+ CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
+ & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
+ & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
+ IF(IDHEP(J1).EQ.90) THEN
+ NPOS(1,IPHIST(1,J1)) = IPOS
+ NPOS(2,IPHIST(1,J1)) = K1A
+ NPOS(3,IPHIST(1,J1)) = K2A
+C label string as collapsed to resonance-string
+ IDHEP(J1) = 91
+ ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
+ IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
+ ENDIF
+ ENDIF
+C register second string/hadron/parton
+ CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
+ & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
+ & ICOLOR(2,J2),IPOS,1)
+ IF(IDHEP(J2).EQ.90) THEN
+ NPOS(1,IPHIST(1,J2))=IPOS
+ NPOS(2,IPHIST(1,J2))=K1B
+ NPOS(3,IPHIST(1,J2))=K2B
+C label string touched by momentum transfer
+ IDHEP(J2) = 91
+ ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
+ IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
+ ENDIF
+ ICCOR = ICCOR+1
+ ITOUCH = ITOUCH+1
+C consistency checks
+ IF(IDEB(42).GE.5) THEN
+ CALL PHO_CHECK(-1,IDEV)
+ IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
+ ENDIF
+C jump to next iteration
+ GOTO 50
+ ENDIF
+ 90 CONTINUE
+ 100 CONTINUE
+C debug output
+ IF(IDEB(42).GE.15) THEN
+ IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
+ WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
+ CALL PHO_PREVNT(1)
+ ENDIF
+ ENDIF
+ END
+
+CDECK ID>, PHO_PARCOR
+ SUBROUTINE PHO_PARCOR(MODE,IREJ)
+C********************************************************************
+C
+C conversion of string partons (using JETSET masses)
+C
+C input: MODE >0 position index of corresponding string
+C -1 initialization
+C -2 output of statistics
+C
+C output: /POSTRG/
+C IREJ 1 combination of strings impossible
+C 0 successful combination
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DELM = 0.005D0,
+ & DEPS = 1.D-15,
+ & EPS = 1.D-5)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 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
+
+ DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
+ & PL(4,100),XMP(100),XML(100)
+
+ DOUBLE PRECISION PYMASS
+
+ IREJ = 0
+ IMODE = MODE
+C
+ IF(IMODE.GT.0) THEN
+ ICH = 0
+ I1 = JMOHEP(1,IMODE)
+ I2 = ABS(JMOHEP(2,IMODE))
+C copy to local field
+ L = 0
+ DO 100 I=I1,I2
+ L = L+1
+ DO 200 K=1,4
+ PL(K,L) = PHEP(K,I)
+ 200 CONTINUE
+ XMP(L) = PHEP(5,I)
+
+ XML(L) = PYMASS(IDHEP(I))
+
+ 100 CONTINUE
+ IPAR = L
+ XMC = PHEP(5,IMODE)
+ IF(IDEB(82).GE.20) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
+ & KEVENT,IMODE,L
+ DO 150 I=1,L
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 150 CONTINUE
+ ENDIF
+C
+C two parton configurations
+C -----------------------------------------
+ IF(IPAR.EQ.2) THEN
+ XM1 = XML(1)
+ XM2 = XML(2)
+ IF((XM1+XM2).GE.XMC) THEN
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
+ & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
+ & IMODE,XM1,XM2,XMC
+ GOTO 990
+ ENDIF
+C conversion possible
+ CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
+ & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
+ & KEVENT,IMODE,XMC
+ GOTO 990
+ ENDIF
+ ICH = 1
+ DO 115 K=1,4
+ PL(K,1) = PP1(K)
+ PL(K,2) = PP2(K)
+ XMP(1) = XM1
+ XMP(2) = XM2
+ 115 CONTINUE
+C
+C multi parton configurations
+C ---------------------------------
+ ELSE
+C
+C random selection of string side to start with
+ IF(DT_RNDM(XMC).LT.0.5D0) THEN
+ K1 = 1
+ K2 = IPAR
+ KS = 1
+ ELSE
+ K1 = IPAR
+ K2 = 1
+ KS = -1
+ ENDIF
+ ITER = 0
+C
+ 300 CONTINUE
+ IF(ITER.LT.4) THEN
+ KK = K1
+ K1 = K2
+ K2 = KK
+ KS = -KS
+ ELSE
+ GOTO 990
+ ENDIF
+ ITER = ITER+1
+C select method
+ IF(ITER.GT.2) GOTO 230
+
+C conversion according to color flow method
+ IFAI = 0
+ DO 210 II=K1,K2-KS,KS
+ DO 215 IK=II+KS,K2,KS
+ XM1 = XML(II)
+ XM2 = XML(IK)
+* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
+* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
+ IF((ABS(XM1-XMP(II)).GT.DELM)
+ & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
+ CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
+ & KEVENT,IMODE,II,IK
+ IREJ = 0
+ ELSE
+ ICH = ICH+1
+ DO 220 KK=1,4
+ PL(KK,II) = PP1(KK)
+ PL(KK,IK) = PP2(KK)
+ 220 CONTINUE
+ XMP(II) = XM1
+ XMP(IK) = XM2
+ GOTO 219
+ ENDIF
+ ELSE
+ GOTO 219
+ ENDIF
+ 215 CONTINUE
+ IFAI = II
+ 219 CONTINUE
+ 210 CONTINUE
+ IF(IFAI.NE.0) GOTO 300
+ GOTO 950
+C
+ 230 CONTINUE
+C
+C conversion according to remainder method
+ DO 350 I=K1,K2,KS
+ XM1 = XML(I)
+ IF(ABS(XM1-XMP(I)).GT.DELM) THEN
+ ICH = ICH+1
+ IFAI = I
+C conversion necessary
+ DO 400 K=1,4
+ PB1(K) = PL(K,I)
+ PB2(K) = PHEP(K,IMODE)-PB1(K)
+ 400 CONTINUE
+ XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
+ IF(XM2.LT.0.D0) THEN
+ IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
+ & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
+ GOTO 300
+ ENDIF
+ XM2 = SQRT(XM2)
+ IF((XM1+XM2).GE.XMC) THEN
+ IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
+ & 'PHO_PARCOR: ',
+ & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
+ & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
+ GOTO 300
+ ENDIF
+C conversion possible
+ CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(36) = IFAIL(36)+1
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
+ & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
+ & ITER,IMODE,I
+ GOTO 300
+ ENDIF
+C calculate Lorentz transformation
+ CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
+ & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
+ & ITER,IMODE,I
+ GOTO 300
+ ENDIF
+ IFAI = 0
+C transform remaining partons
+ DO 450 L=K1,K2,KS
+ IF(L.NE.I) THEN
+ CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
+ DO 500 K=1,4
+ PL(K,L) = PP2(K)
+ 500 CONTINUE
+ ELSE
+ DO 550 K=1,4
+ PL(K,L) = PP1(K)
+ 550 CONTINUE
+ ENDIF
+ 450 CONTINUE
+ XMP(I) = XM1
+ ENDIF
+ 350 CONTINUE
+ ENDIF
+
+C register transformed partons
+ 950 CONTINUE
+ IREJ = 0
+ IF(ICH.NE.0) THEN
+ IP1 = NHEP+1
+ L = 0
+ DO 700 I=I1,I2
+ L= L+1
+ CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
+ & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
+ & ICOLOR(2,I),IPOS,1)
+ 700 CONTINUE
+ IP2 = IPOS
+C register string
+ CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
+ & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
+ & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
+C update /POSTRG/
+ I = IPHIST(1,IMODE)
+ NPOS(1,I) = IPOS
+ NPOS(2,I) = IP1
+ NPOS(3,I) = -IP2
+ ENDIF
+C debug output
+ IF(IDEB(82).GE.20) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
+ & KEVENT,IMODE,L
+ DO 850 I=1,L
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 850 CONTINUE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
+ ENDIF
+ RETURN
+C rejection
+ 990 CONTINUE
+ IREJ = 1
+ IF(IDEB(82).GE.3) THEN
+ WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
+ & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
+ & IFAI,IPAR,IMODE,XMC
+ IF(IDEB(82).GE.5) THEN
+ WRITE(LO,'(1X,A,I7,2I4)')
+ & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
+ & KEVENT,IMODE,IPAR
+ DO 155 I=1,IPAR
+ WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
+ & XMP(I),XML(I)
+ 155 CONTINUE
+ ENDIF
+ ENDIF
+ RETURN
+
+ ELSE IF(IMODE.EQ.-1) THEN
+C initialization
+ RETURN
+
+ ELSE IF(IMODE.EQ.-2) THEN
+C final output
+ RETURN
+ ENDIF
+ END
+
+CDECK ID>, PHO_STRING
+ SUBROUTINE PHO_STRING(IMODE,IREJ)
+C********************************************************************
+C
+C calculation of string combinatorics, Lorentz boosts and
+C particle codes
+C
+C - splitting of gluons
+C - strings will be built up from pairs of partons
+C according to their color labels
+C with IDHEP(..) = -1
+C - there can be other particles between to string partons
+C (these will be unchanged by string construction)
+C - string mass fine correction
+C
+C input: IMODE 1 complete string processing
+C -1 initialization
+C -2 output of statistics
+C
+C output: /POSTRG/
+C IREJ 1 combination of strings impossible
+C 0 successful combination
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 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 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 table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IREJ = 0
+ IF(IMODE.EQ.-1) THEN
+ CALL PHO_POMCOR(-1)
+ CALL PHO_MASCOR(-1)
+ CALL PHO_PARCOR(-1,IREJ)
+
+ RETURN
+ ELSE IF(IMODE.EQ.-2) THEN
+ CALL PHO_POMCOR(-2)
+ CALL PHO_MASCOR(-2)
+ CALL PHO_PARCOR(-2,IREJ)
+
+ RETURN
+ ENDIF
+
+C generate enhanced graphs
+ IF(IPOIX2.GT.0) THEN
+ 200 CONTINUE
+ I1 = MAX(1,IPOIX1)
+ I2 = IPOIX2
+ IF(ISWMDL(14).EQ.1) IPOIX1 = 0
+ KSPOMS = KSPOM-1
+ KSREGS = KSREG
+ KHPOMS = KHPOM
+ KHDIRS = KHDIR
+ IDDFS1 = IDIFR1
+ IDDFS2 = IDIFR2
+ IDDPOS = IDDPOM
+ DO 110 I=I1,I2
+ IPOIX3 = I
+ KSPOM = 0
+ KSREG = 0
+ KHPOM = 0
+ KHDIR = 0
+ IF(IPORES(I).EQ.8) THEN
+ KSPOM = 2
+ LSPOM = 2
+ LHPOM = 0
+ LSREG = 0
+ LHDIR = 0
+ IGEN = abs(IPHIST(2,IPOPOS(1,I)))
+ CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
+ & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSPOM = KSPOMS+LSPOM
+ KSREG = KSREGS+LSREG
+ KHPOM = KHPOMS+LHPOM
+ KHDIR = KHDIRS+LHDIR
+ ELSE IF(IPORES(I).EQ.4) THEN
+ ITEMP = ISWMDL(17)
+ ISWMDL(17) = 0
+ CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
+ ISWMDL(17) = ITEMP
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSDPO = KSDPO+1
+ KSPOM = KSPOMS+KSPOM
+ KSREG = KSREGS+KSREG
+ KHPOM = KHPOMS+KHPOM
+ KHDIR = KHDIRS+KHDIR
+ ELSE
+ IDIF1 = 1
+ IDIF2 = 1
+ IF(IPORES(I).EQ.5) THEN
+ IDIF2 = 0
+ KSTRG = KSTRG+1
+ ELSE IF(IPORES(I).EQ.6) THEN
+ IDIF1 = 0
+ KSTRG = KSTRG+1
+ ELSE
+ KSLOO = KSLOO+1
+ ENDIF
+ ITEMP = ISWMDL(16)
+ ISWMDL(16) = 0
+ SPROB = 1.D0
+ CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
+ & 0,MSOFT,MHARD,IREJ)
+ ISWMDL(16) = ITEMP
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(4).GE.2) THEN
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ KSPOM = KSPOMS+KSPOM
+ KSREG = KSREGS+KSREG
+ KHPOM = KHPOMS+KHPOM
+ KHDIR = KHDIRS+KHDIR
+ ENDIF
+ IDIFR1 = IDDFS1
+ IDIFR2 = IDDFS2
+ IDDPOM = IDDPOS
+ 110 CONTINUE
+ IF(IPOIX2.GT.I2) THEN
+ IPOIX1 = I2+1
+ GOTO 200
+ ENDIF
+ ENDIF
+
+C optional: split gluons to q-qbar pairs
+ IF(ISWMDL(9).GT.0) THEN
+ NHEPO = NHEP
+ DO 30 I=3,NHEPO
+ IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
+ ICG1=ICOLOR(1,I)
+ ICG2=ICOLOR(2,I)
+ IQ1 = 0
+ IQ2 = 0
+ DO 40 K=3,NHEPO
+ IF(ICOLOR(1,K).EQ.-ICG1) THEN
+ IQ1 = K
+ IF(IQ1*IQ2.NE.0) GOTO 45
+ ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
+ IQ2 = K
+ IF(IQ1*IQ2.NE.0) GOTO 45
+ ENDIF
+ 40 CONTINUE
+ WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
+ & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
+ CALL PHO_ABORT
+ 45 CONTINUE
+ CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(19).GE.5) THEN
+ WRITE(LO,'(/,1X,A)')
+ & 'PHO_STRING: no gluon splitting possible'
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ 30 CONTINUE
+ ENDIF
+
+C construct strings and write entries sorted by strings
+
+ ISTR = ISTR+1
+ NHEPO = NHEP
+ DO 50 I=3,NHEPO
+
+ IF(ISTR.GT.MSTR) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
+ & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IF(ISTHEP(I).EQ.1) THEN
+C hadrons / resonances / clusters
+ NPOS(1,ISTR) = I
+ NPOS(2,ISTR) = 0
+ NPOS(3,ISTR) = 0
+ NPOS(4,ISTR) = abs(IPHIST(2,I))
+ NCODE(ISTR) = -99
+ IPHIST(1,I) = ISTR
+ ISTR = ISTR+1
+ ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
+C quark /diquark terminated strings
+ ICOL1 = -ICOLOR(1,I)
+ P1 = PHEP(1,I)
+ P2 = PHEP(2,I)
+ P3 = PHEP(3,I)
+ P4 = PHEP(4,I)
+ ICH1 = IPHO_CHR3(I,2)
+ IBA1 = IPHO_BAR3(I,2)
+ CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
+ & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
+ & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
+ JM1 = IPOS
+
+ NRPOM = 0
+ 65 CONTINUE
+ DO 55 K=3,NHEPO
+ IF(ISTHEP(K).EQ.-1)THEN
+ IF(IDHEP(K).EQ.21) THEN
+ IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(2,K)
+ GOTO 60
+ ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(1,K)
+ GOTO 60
+ ENDIF
+ ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = 0
+ GOTO 60
+ ENDIF
+ ENDIF
+ 55 CONTINUE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
+ CALL PHO_ABORT
+ 60 CONTINUE
+ P1 = P1+PHEP(1,K)
+ P2 = P2+PHEP(2,K)
+ P3 = P3+PHEP(3,K)
+ P4 = P4+PHEP(4,K)
+ NRPOM = MAX(NRPOM,IPHIST(1,K))
+ ICH1 = ICH1+IPHO_CHR3(K,2)
+ IBA1 = IBA1+IPHO_BAR3(K,2)
+ CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
+ & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
+C further parton involved?
+ IF(ICOL1.NE.0) GOTO 65
+ JM2 = IPOS
+C register string
+ IGEN = IPHIST(2,K)
+ CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
+ & ISTR,IGEN,ICH1,IBA1,IPOS,1)
+C store additional string information
+ NPOS(1,ISTR) = IPOS
+ NPOS(2,ISTR) = JM1
+ NPOS(3,ISTR) = -JM2
+ NPOS(4,ISTR) = abs(IPHIST(2,K))
+C calculate CPC string codes
+ CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
+ & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
+ ISTR = ISTR+1
+ ENDIF
+ 50 CONTINUE
+
+ DO 150 I=3,NHEPO
+
+ IF(ISTR.GT.MSTR) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
+ & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IF(ISTHEP(I).EQ.-1) THEN
+C gluon loop-strings
+ ICOL1 = -ICOLOR(1,I)
+ P1 = PHEP(1,I)
+ P2 = PHEP(2,I)
+ P3 = PHEP(3,I)
+ P4 = PHEP(4,I)
+ IBA1 = 0
+ ICH1 = 0
+ CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
+ & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
+ & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
+ JM1 = IPOS
+C
+ NRPOM = 0
+ 165 CONTINUE
+ IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
+ DO 155 K=I,NHEPO
+ IF(ISTHEP(K).EQ.-1)THEN
+ IF(ICOLOR(1,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(2,K)
+ GOTO 160
+ ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
+ ICOL1 = -ICOLOR(1,K)
+ GOTO 160
+ ENDIF
+ ENDIF
+ 155 CONTINUE
+ WRITE(LO,'(/1X,A,I5)')
+ & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
+ CALL PHO_ABORT
+ 160 CONTINUE
+ P1 = P1+PHEP(1,K)
+ P2 = P2+PHEP(2,K)
+ P3 = P3+PHEP(3,K)
+ P4 = P4+PHEP(4,K)
+ NRPOM = MAX(NRPOM,IPHIST(1,K))
+ CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
+ & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
+C further parton involved?
+ IF(ICOL1.NE.0) GOTO 165
+ 170 CONTINUE
+ JM2 = IPOS
+C register string
+ IGEN = IPHIST(2,K)
+ CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
+ & ISTR,IGEN,ICH1,IBA1,IPOS,1)
+C store additional string information
+ NPOS(1,ISTR) = IPOS
+ NPOS(2,ISTR) = JM1
+ NPOS(3,ISTR) = -JM2
+ NPOS(4,ISTR) = abs(IPHIST(2,K))
+C calculate CPC string codes
+ CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
+ & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
+ ISTR = ISTR+1
+ ENDIF
+ 150 CONTINUE
+
+ ISTR = ISTR-1
+
+ IF(IDEB(19).GE.17) THEN
+ WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+C pomeron corrections
+ CALL PHO_POMCOR(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(38) = IFAIL(38)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C string mass corrections
+ CALL PHO_MASCOR(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(34) = IFAIL(34)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+
+C parton mass corrections
+ DO 100 I=1,ISTR
+ IF(NCODE(I).GE.0) THEN
+ CALL PHO_PARCOR(NPOS(1,I),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(35) = IFAIL(35)+1
+ IF(IDEB(19).GE.3) THEN
+ WRITE(LO,'(1X,A,I6)')
+ & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+
+C statistics of hard processes
+ DO 550 I=3,NHEP
+ IF(ISTHEP(I).EQ.25) THEN
+ K = IMPART(I)
+ II = IDHEP(I)
+ MH_acc_2(K,II) = MH_acc_2(K,II)+1
+ ENDIF
+ 550 CONTINUE
+
+C debug: write out strings
+ IF(IDEB(19).GE.5) THEN
+ IF(IDEB(19).GE.10)
+ & CALL PHO_CHECK(1,IDEV)
+ IF(IDEB(19).GE.15) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PRSTRG
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_STRFRA
+ SUBROUTINE PHO_STRFRA(IREJ)
+C********************************************************************
+C
+C do all fragmentation of strings
+C
+C output: IREJ 0 successful
+C 1 rejection
+C 50 rejection due to user cutoffs
+C
+C********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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)
+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 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 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
+
+ INTEGER IREJ
+
+ DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
+
+ INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
+ & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
+
+ integer indx(500),indx_max
+
+ DOUBLE PRECISION DT_RNDM
+ INTEGER ipho_pdg2id
+ EXTERNAL DT_RNDM,ipho_pdg2id
+
+ DOUBLE PRECISION PYP,RQLUN
+ INTEGER PYK
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+
+ DIMENSION IJOIN(100)
+
+ IREJ = 0
+ IF(ABS(ISWMDL(6)).GT.3) THEN
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
+ & 'invalid value of ISWMDL(6)',ISWMDL(6)
+ CALL PHO_ABORT
+ ENDIF
+
+C popcorn suppression
+ IF(PARMDL(134).GT.0.D0) THEN
+ IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
+ MSTJ(12) = 2
+ ELSE
+ MSTJ(12) = 1
+ ENDIF
+ ENDIF
+
+C copy partons to fragmentation code JETSET
+ IP = 0
+ IP_old = 1
+
+ DO 300 J=1,ISTR
+
+C select partons with common production process
+ IGEN = NPOS(4,J)
+ if(IGEN.lt.0) goto 299
+
+ indx_max = 0
+ DO 400 I=J,ISTR
+ if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
+
+C write final particles/resonances to JETSET
+ IF(NCODE(I).EQ.-99) THEN
+ II = NPOS(1,I)
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+
+ if(indx_max.eq.500) then
+ WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
+ & 'no space left in index vector (indx,Kevent)',
+ & indx_max,KEVENT
+ IREJ = 1
+ return
+ endif
+
+ indx_max = indx_max+1
+ indx(indx_max) = II
+C write partons to JETSET
+ ELSE IF(NCODE(I).GE.0) THEN
+ K1 = JMOHEP(1,NPOS(1,I))
+ K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
+ IJ = 0
+ DO II=K1,K2
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+ IJ = IJ+1
+ IJOIN(IJ) = IP
+ indx_max = indx_max+1
+ indx(indx_max) = II
+
+ ENDDO
+ II = JMOHEP(2,NPOS(1,I))
+ IF((II.GT.0).AND.(II.NE.K1)) THEN
+ IP = IP+1
+ P(IP,1) = PHEP(1,II)
+ P(IP,2) = PHEP(2,II)
+ P(IP,3) = PHEP(3,II)
+ P(IP,4) = PHEP(4,II)
+ P(IP,5) = PHEP(5,II)
+ K(IP,1) = 1
+ K(IP,2) = IDHEP(II)
+ K(IP,3) = 0
+ K(IP,4) = 0
+ K(IP,5) = 0
+ IPHIST(2,II) = IP
+ IJ = IJ+1
+ IJOIN(IJ) = IP
+ indx_max = indx_max+1
+ indx(indx_max) = II
+
+ ENDIF
+ N = IP
+C connect partons to strings
+
+ CALL PYJOIN(IJ,IJOIN)
+
+ ENDIF
+
+ NPOS(4,I) = -NPOS(4,I)
+ endif
+ 400 continue
+
+C set Lund counter
+ N = IP
+ if(IP.eq.0) goto 299
+
+C hard final state evolution
+ IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
+ ISH = 0
+ do 125 k1=1,indx_max
+ I = indx(k1)
+ IF(IPHIST(1,I).LE.-100) THEN
+ ISH = ISH+1
+ IJOIN(ISH) = I
+ ENDIF
+ 125 continue
+ IF(ISH.GE.2) THEN
+ DO 130 K1=1,ISH
+ IF(IJOIN(K1).EQ.0) GOTO 130
+ I = IJOIN(K1)
+ IF((IPAMDL(102).EQ.1)
+ & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
+ DO 135 K2=K1+1,ISH
+ IF(IJOIN(K2).EQ.0) GOTO 135
+ II = IJOIN(K2)
+ IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
+ PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
+ PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
+ RQLUN = MIN(PT1,PT2)
+
+ IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
+ & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
+ CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
+
+ IJOIN(K1) = 0
+ IJOIN(K2) = 0
+ GOTO 130
+ ENDIF
+ 135 CONTINUE
+ 130 CONTINUE
+ ENDIF
+ ENDIF
+
+C fragment parton / hadron configuration (hadronization & decay)
+
+ IF(ISWMDL(6).NE.0) THEN
+ II = MSTU(21)
+ MSTU(21) = 1
+
+ CALL PYEXEC
+
+ MSTU(21) = II
+C Lund warning?
+ if(MSTU(28).ne.0) then
+ IF(IDEB(22).GE.10) THEN
+ WRITE(LO,'(1X,A,I12,I3)')
+ & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
+ & KEVENT,MSTU(28)
+ CALL PHO_PREVNT(2)
+ ENDIF
+ endif
+C event accepted?
+ IF(MSTU(24).NE.0) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(1X,A,I12,I3)')
+ & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
+ & KEVENT,MSTU(24)
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ IP = N
+C change particle status in JETSET to avoid internal adjustments
+ do k1=IP_old,IP
+ K(k1,1) = K(k1,1)+1000
+ enddo
+ IP_old = IP+1
+
+ 299 continue
+ 300 CONTINUE
+
+C restore original JETSET particle status codes
+ do i=1,N
+ K(i,1) = K(i,1)-1000
+ enddo
+
+* IF(IDEB(22).GE.25) THEN
+* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
+* & 'particle/string system before fragmentation'
+* CALL PHO_PREVNT(2)
+* ENDIF
+
+C copy hadrons back to POEVT1 / POEVT2
+
+ IF(IP.GT.0) THEN
+ NHEP1 = NHEP+1
+
+ NLINES = PYK(0,1)
+
+C copy hadrons back with full history information
+ IF(IPAMDL(178).EQ.1) THEN
+ DO 155 II=1,ISTR
+ IF(NCODE(II).GE.0) THEN
+ K1 = IPHIST(2,NPOS(2,II))
+ K2 = IPHIST(2,-NPOS(3,II))
+ ELSE IF(NCODE(II).EQ.-99) THEN
+ K1 = IPHIST(2,NPOS(1,II))
+ K2 = K1
+ ELSE
+ GOTO 149
+ ENDIF
+ IFOUND = 0
+ DO 160 J=1,NLINES
+
+ IF(PYK(J,7).EQ.1) THEN
+ IPMOTH = PYK(J,15)
+
+ IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
+
+ IBAM = ipho_pdg2id(PYK(J,8))
+
+ IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
+ & 'LUND interface (1) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ IFOUND = IFOUND+1
+
+ PX = PYP(J,1)
+ PY = PYP(J,2)
+ PZ = PYP(J,3)
+ HE = PYP(J,4)
+ XMB = PYP(J,5)**2
+
+C register parton/hadron
+ IS = 1
+ IF(IBAM.EQ.0) THEN
+ IF(ISWMDL(6).EQ.0) THEN
+ IS = -1
+ ELSE
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
+ & 'LUND interface (2) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
+ & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
+
+ ISTHEP(IPOS) = 1
+ ENDIF
+ ENDIF
+ 160 CONTINUE
+ IF(IFOUND.EQ.0) THEN
+ IF(IDEB(2).GE.2) THEN
+ WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
+ & 'no particles found for string (EVE,ISTR):',KEVENT,II
+ ENDIF
+ ISTHEP(NPOS(1,II)) = 2
+ ENDIF
+ 149 CONTINUE
+ 155 CONTINUE
+ ELSE
+C copy hadrons back without history information
+ JDAHEP(1,1) = NHEP1
+ JDAHEP(1,2) = NHEP1
+ DO 170 J=1,NLINES
+
+ IF(PYK(J,7).EQ.1) THEN
+ IBAM = ipho_pdg2id(PYK(J,8))
+
+ IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_STRFRA: LUND interface (3) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ PX = PYP(J,1)
+ PY = PYP(J,2)
+ PZ = PYP(J,3)
+ HE = PYP(J,4)
+ XMB = PYP(J,5)**2
+
+C register parton/hadron
+ IS = 1
+ IF(IBAM.EQ.0) THEN
+ IF(ISWMDL(6).EQ.0) THEN
+ IS = -1
+ ELSE
+ IF(IDEB(22).GE.2) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_STRFRA: LUND interface (4) rejection'
+ CALL PHO_PREVNT(2)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
+ & HE,J,0,0,0,IPOS,1)
+
+ ISTHEP(IPOS) = 1
+ ENDIF
+ 170 CONTINUE
+ DO 180 II=1,ISTR
+ IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
+ & ISTHEP(NPOS(1,II)) = 2
+ 180 CONTINUE
+ ENDIF
+ ENDIF
+
+C debug event status
+ IF(IDEB(22).GE.15) THEN
+ WRITE(LO,'(//1X,A)')
+ & 'PHO_STRFRA: particle system after fragmentation'
+ CALL PHO_PREVNT(2)
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_EVEINI
+ SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
+C********************************************************************
+C
+C prepare /POEVT1/ for new event
+C
+C first subroutine called for each event
+C
+C input: P1(4) particle 1
+C P2(4) particle 2
+C IMODE 0 general initialization
+C 1 initialization of particles and kinematics
+C 2 initialization after internal rejection
+C
+C output: IP1,IP2 index of interacting particles
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4)
+
+ PARAMETER ( EPS = 1.D-5,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+C gamma-lepton or gamma-hadron vertex information
+ INTEGER IGHEL,IDPSRC,IDBSRC
+ DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
+ & RADSRC,AMSRC,GAMSRC
+ COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
+ & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
+ & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
+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 energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+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 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 table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DIMENSION IM(2)
+
+C reset debug variables
+ KSPOM = 0
+ KHPOM = 0
+ KSREG = 0
+ KHDIR = 0
+ KSTRG = 0
+ KHTRG = 0
+ KSLOO = 0
+ KHLOO = 0
+ KSDPO = 0
+ KSOFT = 0
+ KHARD = 0
+C
+ IDNODF = 0
+ IDIFR1 = 0
+ IDIFR2 = 0
+ IDDPOM = 0
+ ISTR = 0
+ IPOIX1 = 0
+ IF(ISWMDL(14).GT.0) IPOIX1 = 1
+ IPOIX2 = 0
+ IPOIX3 = 0
+C reset /POEVT1/ and /POEVT2/
+ CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
+ & 0,0,0,0,IPOS,0)
+ CALL PHO_SELCOL(0,0,0,0,0,0,0)
+ DO 15 I=0,10
+ IPOWGC(I) = 0
+ 15 CONTINUE
+
+C initialization of particle kinematics
+
+C lepton-photon/hadron-photon vertex and initial particles
+ IM(1) = 0
+ IM(2) = 0
+ IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
+ & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
+ ELSE
+ CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
+ & P1(4),0,0,0,0,IP1,1)
+ ENDIF
+ IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
+ & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
+ ELSE
+ CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
+ & P2(4),0,0,0,0,IP2,1)
+ ENDIF
+ IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
+ & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
+ CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
+ & P1(4),0,0,0,0,IP1,1)
+ ENDIF
+ IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
+ CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
+ & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
+ CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
+ & P2(4),0,0,0,0,IP2,1)
+ ENDIF
+ NEVHEP = KACCEP
+
+ IF(IMODE.LE.1) THEN
+C CMS energy
+ ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
+ & -(P1(3)+P2(3))**2)
+* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
+ PMASS(1) = PHEP(5,IP1)
+ PVIRT(1) = 0.D0
+ IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
+ PMASS(2) = PHEP(5,IP2)
+ PVIRT(2) = 0.D0
+ IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
+ ENDIF
+
+C cross section calculations
+
+ IF(IMODE.NE.1) THEN
+ IP = 1
+ CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
+ & ECM,PVIRT(1),PVIRT(2))
+ ENDIF
+
+ IF(IMODE.LE.0) THEN
+C effective cross section
+ SIGGEN(3) = 0.D0
+ IF(ISWMDL(2).ge.1) THEN
+ IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
+ & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
+ & -SIGHDD-SIGDIR
+ IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
+ IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
+ IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
+ IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
+ IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
+ IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
+ IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
+C simulate only hard scatterings
+ ELSE
+ IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
+ IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
+ ENDIF
+
+ ENDIF
+
+C reset of mother/daughter relations only (IMODE = 2)
+
+C debug output
+ IF(IDEB(63).GE.15) THEN
+ WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
+ & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
+ IF(IMODE.LE.0) THEN
+ WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
+ & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
+ & FSUP,FSUH,FSUD
+ ONEM = -1.D0
+ ITMP = IDEB(57)
+ IDEB(57) = MAX(5,ITMP)
+ CALL PHO_XSECT(1,0,ONEM)
+ IDEB(57) = ITMP
+ ENDIF
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_CSINT
+ SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
+C********************************************************************
+C
+C calculate cross sections by interpolation
+C
+C input: IP particle combination
+C IFPA/B particle PDG number
+C IHLA/B particle helicity (photons only)
+C ECM c.m. energy (GeV)
+C PVIR2A virtuality of particle A (GeV**2, positive)
+C PVIR2B virtuality of particle B (GeV**2, positive)
+C
+C output: cross sections stored in /POCSEC/
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-5,
+ & DEPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+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)
+
+ DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
+
+ dimension PD(-6:6),FH_T(2),FH_L(2)
+
+C debug
+ IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
+ & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
+ & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
+
+C check currently stored cross sections
+ IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
+ & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
+ & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
+C nothing to calculate
+ IF(IDEB(15).GE.20)
+ & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
+ RETURN
+ ELSE
+
+C copy to local fields
+ IFPAP(1) = IFPA
+ IFPAP(2) = IFPB
+ IHEL(1) = IHLA
+ IHEL(2) = IHLB
+ PVIRT(1) = PVIR2A
+ PVIRT(2) = PVIR2B
+
+C load cross sections from interpolation table
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ I1 = 1
+ I2 = 2
+ ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
+ DO 50 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 200
+ 50 CONTINUE
+ 200 CONTINUE
+ I1 = I-1
+ I2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,2E12.3)')
+ & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ I1 = ISIMAX-1
+ I2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
+ & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
+ FAC1=1.D0-FAC2
+
+C cross section dependence on photon virtualities
+ DO 140 K=1,2
+ FSUP(K) = 1.D0
+ FSUD(K) = 1.D0
+ FSUH(K) = 1.D0
+ IF(IFPAP(K).EQ.22) THEN
+ IF(ISWMDL(10).GE.1) THEN
+ FSUP(K) = 0.D0
+ FSUT(K) = 0.D0
+ FSUL(K) = 0.D0
+ FSUH(K) = 0.D0
+C GVDM factors for transverse/longitudinal photons
+ DO 150 I=1,3
+ FSUT(K) = FSUT(K)+PARMDL(26+I)
+ & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
+ FSUL(K) = FSUL(K)
+ & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
+ & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
+ 150 CONTINUE
+ FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
+C transverse part
+ IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
+ FSUP(K) = FSUT(K)
+ FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
+C diffraction of trans. photons corresponds mainly to leading twist
+ FSUD(K) = 1.D0
+ ENDIF
+C longitudinal (scalar) part
+ IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
+ FSUP(K) = FSUP(K)+FSUL(K)
+ FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
+C diffraction of long. photons corresponds mainly to higher twist
+ FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
+ & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
+ & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
+ ENDIF
+C debug output
+ if(ideb(15).ge.10) then
+ WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
+ & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
+ & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
+ endif
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+
+ FACP = FSUP(1)*FSUP(2)
+ FACH = FSUH(1)*FSUH(2)
+ FACD = FSUD(1)*FSUD(2)
+
+C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
+
+ if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
+ & .and.(IPAMDL(117).gt.0)) then
+C check kinematic limit
+ Q2_max = max(PVIRT(1),PVIRT(2))
+ Q2_min = min(PVIRT(1),PVIRT(2))
+ if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
+
+C calculate F2 from current parton density
+ if(PVIRT(1).gt.PVIRT(2)) then
+ K = 2
+ else
+ K = 1
+ endif
+ Q2 = Q2_max
+ P2 = Q2_min
+ X = Q2/(ECM**2+Q2+P2)
+ call pho_actpdf(IFPAP(K),K)
+ call pho_pdf(K,X,Q2,P2,PD)
+C light quark contribution
+ F2_light = 0.D0
+ do j=1,3
+ F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
+ enddo
+C heavy quark contribution
+ call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
+ F2_c = 2.D0*4.D0/9.D0*xpdf_c
+ F2 = (F2_light+F2_c)
+
+C calculate model prediction
+ SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
+ SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+
+ if(ISWMDL(10).ge.2) then
+
+C calculate all helicity combinations
+ if(IPAMDL(115).eq.0) then
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
+C photon helicity factors
+ FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
+ FH_L(1) = 1.D0-FH_T(1)
+ FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
+ FH_L(2) = 1.D0-FH_T(2)
+ SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
+ & + SIGDIH*FH_T(1)*FH_T(2)
+ & + SIGSRH(1)*FH_T(1)*FSUT(2)
+ & + SIGSRH(2)*FSUT(1)*FH_T(2)
+ SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
+ & + SIGDIH*FH_T(1)*FH_L(2)
+ & + SIGSRH(1)*FH_T(1)*FSUL(2)
+ & + SIGSRH(2)*FSUT(1)*FH_L(2)
+ SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
+ & + SIGDIH*FH_L(1)*FH_T(2)
+ & + SIGSRH(1)*FH_L(1)*FSUT(2)
+ & + SIGSRH(2)*FSUL(1)*FH_T(2)
+ SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
+ & + SIGDIH*FH_L(1)*FH_L(2)
+ & + SIGSRH(1)*FH_L(1)*FSUL(2)
+ & + SIGSRH(2)*FSUL(1)*FH_L(2)
+ else
+C use explicit PDF virtuality dependence (pre-tabulated)
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
+ print LO,' PHO_CSINT: invalid option for F2 matching'
+ stop
+* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
+* & Max_pro_2,3,4,1)
+* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
+* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
+* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
+* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
+* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
+* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
+* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
+* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
+ endif
+ Xnu = Ecm*Ecm+Q2+P2
+ F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
+ & *137.D0/GeV2mb
+ if(K.eq.2) then
+ F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
+ F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
+ & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
+ else
+ F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
+ F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
+ & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
+ endif
+
+ else
+
+C assume sig_eff = sigtot
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
+ SIGeff = SIGtmp*FSUP(1)*FSUP(2)
+ & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
+ Xnu = Ecm*Ecm+Q2+P2
+ F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
+ & *137.D0/GeV2mb
+ F2m = F2_fac*SIGeff
+ F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
+ endif
+* print LO,' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
+* print LO,' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
+
+C global factor to re-scale suppression of soft contributions
+ Fcorr = (F2-F2m+F2s)/F2s
+* print LO,' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
+ FACP = FACP*Fcorr
+
+ endif
+ endif
+
+ SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
+ SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
+ SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
+ J = 2
+ DO 5 I=0,4
+ DO 6 K=0,4
+ J = J+1
+ SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
+ & *FACP**2
+ 6 CONTINUE
+ 5 CONTINUE
+
+ SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
+ SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
+C suppression of multi-pomeron graphs (diffraction)
+ SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
+ & *FACP**2*FACD
+ SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
+ SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
+ & *FACP**2
+ SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
+ & *FACP*FSUP(2)*FSUD(1)
+ SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
+ & *FACP*FSUP(1)*FSUD(2)
+ SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
+ SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
+ & *FACP**2
+ SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
+ & *FACP**2
+ SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
+ & *FACP**2
+ SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
+ & *FACP**2
+
+C corrections due to photon virtuality dependence of PDFs
+ if(iswmdl(2).eq.1) then
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+C minimum bias event generation
+ IF(IPAMDL(115).GE.1) THEN
+C all the virtuality dependence is given by PDF parametrization
+ SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
+ IF(IPAMDL(116).GE.2) THEN
+C direct interaction according to full QPM calculation
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ ELSE
+C direct interaction suppressed according to helicity factor
+ SIGDIH = HSig(14)*FACH
+ SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
+ SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
+ ENDIF
+ print LO,' PHO_CSINT: option not supported yet'
+ stop
+ ELSE
+C rescale relevant hard processes
+ SIGDIH = HSig(14)
+ SIGSRH(1) = HSig(10)+HSig(11)
+ SIGSRH(2) = HSig(12)+HSig(13)
+ SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
+ SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
+ & +SIGSRH(2)*FSUP(1)*FSUH(2)
+ SIGINE = SIGtmp+SIGDIR
+ SIGTOT = SIGINE+SIGELA
+ ENDIF
+ else
+C only hard interactions
+ CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
+ SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
+ SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
+ SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
+ SIGHAR = HSig(9)*FACH
+ endif
+
+ SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
+ SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
+ SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
+ J = 39
+ DO 9 I=1,4
+ DO 10 K=1,4
+ J = J+1
+ SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
+ 10 CONTINUE
+ 9 CONTINUE
+ SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
+ SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
+
+ IPFIL = IP
+ IFAFIL = IFPA
+ IFBFIL = IFPB
+ ECMFIL = ECM
+ P2AFIL = PVIR2A
+ P2BFIL = PVIR2B
+
+ IF(IDEB(15).GE.20)
+ & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_PRIMKT
+ SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
+C***********************************************************************
+C
+C give primordial kt to partons entering hard scatterings and
+C remants connected to hard parton-parton interactions by color flow
+C
+C input: IMODE -2 output of statistics
+C -1 initialization
+C 1 sampling of primordial kt
+C IF first entry in /POEVT1/ to check
+C IL last entry in /POEVT1/ to check
+C PTCUT current value of PTCUT to distinguish
+C between soft and hard
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION DEPS
+ PARAMETER ( DEPS = 1.D-15 )
+
+ INTEGER IMODE,IF,IL,IREJ
+ DOUBLE PRECISION PTCUT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+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)
+
+ DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
+ DIMENSION PTS(0:2,5),XP(5),
+ & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
+
+ INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
+
+ PARAMETER (IRMAX=200)
+ DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
+
+ DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
+ & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
+ INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
+
+C debug output
+ IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+
+C give primordial kt to partons engaged in a hard scattering
+
+ IF(IMODE.EQ.1) THEN
+
+ ISTART = IF
+
+ 100 CONTINUE
+
+ NHD = 0
+ IBAL(1) = 0
+ IBAL(2) = 0
+ IROT = 0
+ ICOM = 0
+ DO 110 I=ISTART,IL
+ IF(ISTHEP(I).EQ.25) THEN
+C hard scattering number
+ NHD = IPHIST(1,I+1)
+ ICOM = I
+ K = LSIDX(NHD/100)
+C calculate momenta of incoming partons
+ POLD(1,1) = XHD(K,1)*ECMP/2.D0
+ POLD(2,1) = POLD(1,1)
+ POLD(1,2) = -XHD(K,2)*ECMP/2.D0
+ POLD(2,2) = -POLD(1,2)
+ ISTART = I+3
+ GOTO 150
+ ENDIF
+ 110 CONTINUE
+ RETURN
+
+ 150 CONTINUE
+
+C search for partons involved in hard interaction
+ INEXT = 0
+ IROT = 0
+ DO 500 I=ISTART,IL
+ IF(ABS(ISTHEP(I)).EQ.1) THEN
+C hard scatterd partons (including ISR)
+ IF((IPHIST(1,I).EQ.-NHD)
+ & .OR.(IPHIST(1,I).EQ.NHD+1)
+ & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
+ IROT = IROT+1
+
+ IF(IROT.GT.IRMAX) THEN
+ WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'no memory left in IROTT, event rejected (max/IROT)',
+ & IRMAX,IROT
+ CALL PHO_PREVNT(0)
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ IROTT(IROT) = I
+C hard remnant
+ ELSE IF(IPHIST(1,I).EQ.NHD) THEN
+ IF(PHEP(3,I).GT.0.D0) THEN
+ J = 1
+ ELSE
+ J = 2
+ ENDIF
+ IBAL(J) = IBAL(J)+1
+ IBALT(IBAL(J),J) = I
+ XP2(IBAL(J),J) = PHEP(3,I)/ECMP
+ IF(ISWMDL(24).EQ.0) THEN
+ IV2(IBAL(J),J) = 0
+ IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
+ ELSE IF(ISWMDL(24).EQ.1) THEN
+ IV2(IBAL(J),J) = -1
+ ELSE
+ IV2(IBAL(J),J) = 1
+ ENDIF
+ ENDIF
+C possibly further hard scattering
+ ELSE IF(ISTHEP(I).EQ.25) THEN
+ INEXT = 1
+ ISTART = I
+ GOTO 550
+ ENDIF
+ 500 CONTINUE
+ 550 CONTINUE
+
+C debug output
+ if(IDEB(10).ge.15) then
+ WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
+ & 'hard scattering number: ',NHD/100
+ WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
+ & 'number of entries to rotate: ',IROT
+ DO I=1,IROT
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'entries to rotate: ',I,IROTT(I)
+ ENDDO
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
+ & 'number of entries to balance: ',IBAL
+ DO J=1,2
+ DO I=1,IBAL(J)
+ WRITE(LO,'(1X,2A,I2,2I5)')
+ & 'PHO_PRIMKT: entries to balance (side,no,line)',
+ & J,I,IBALT(I,J)
+ ENDDO
+ ENDDO
+ endif
+
+C incoming partons (comment lines), skip direct interacting particles
+ DO 120 K=1,2
+ IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
+ IF(PHEP(3,ICOM+K).GT.0.D0) THEN
+ J = 1
+ ELSE
+ J = 2
+ ENDIF
+ IBAL(J) = IBAL(J)+1
+ IBALT(IBAL(J),J) = -ICOM-K
+ XP2(IBAL(J),J) = POLD(1,J)/ECMP
+ IV2(IBAL(J),J) = -1
+ ENDIF
+ 120 CONTINUE
+
+C check consistency
+ IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
+ WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
+ & 'inconsistent hard scattering remnant for event: ',KEVENT
+ WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+ WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
+ DO 390 I=1,IROT
+ WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
+ 390 CONTINUE
+ DO 392 J=1,2
+ DO 395 I=1,IBAL(J)
+ WRITE(LO,'(1X,A,I2,2I5)')
+ & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
+ 395 CONTINUE
+ 392 CONTINUE
+ IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
+ ENDIF
+
+C calculate primordial kt
+
+C something to do?
+ IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
+
+C add transverse momentum (overwrite /POEVT1/ entries)
+ DO 200 J=1,2
+ IF(IBAL(J).GT.1) THEN
+C sample from truncated distribution
+ K = IBAL(J)
+ DO 180 I=1,K
+ IV(I) = IV2(I,J)
+ XP(I) = XP2(I,J)
+ 180 CONTINUE
+ 190 CONTINUE
+ CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
+ IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
+C transform incoming partons of hard scattering
+ DEL = ABS(POLD(1,J))+POLD(2,J)
+ PT2 = PTS(0,K)**2
+ DEL2 = DEL*DEL
+ PNEW(1,J) = PTS(1,K)
+ PNEW(2,J) = PTS(2,K)
+ PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
+ PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
+C spectator partons
+ ESUM = 0.D0
+ DO 220 I=1,IBAL(J)-1
+ K = IBALT(I,J)
+ PHEP(1,K) = PHEP(1,K)+PTS(1,I)
+ PHEP(2,K) = PHEP(2,K)+PTS(2,I)
+ ESUM = ESUM+PHEP(4,K)
+ 220 CONTINUE
+C long. momentum transfer
+ PP(3) = PNEW(3,J) - POLD(1,J)
+ PP(4) = PNEW(4,J) - POLD(2,J)
+ DO 230 I=1,IBAL(J)-1
+ K = IBALT(I,J)
+ FAC = PHEP(4,K)/ESUM
+ PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
+ PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
+ 230 CONTINUE
+
+C debug output
+ IF(IDEB(10).GE.15) THEN
+ WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
+ & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
+ WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
+ & 'new incoming:',J,(PNEW(I,J),I=1,4)
+ ENDIF
+
+ ELSE
+ PNEW(1,J) = 0.D0
+ PNEW(2,J) = 0.D0
+ PNEW(3,J) = POLD(1,J)
+ PNEW(4,J) = POLD(2,J)
+ ENDIF
+ 200 CONTINUE
+
+C transformation of hard scattering final states (including ISR)
+
+C old parton c.m. energy
+ SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
+ EI = SQRT(SI)
+C new parton c.m. energy
+ SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
+ & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
+ EF = SQRT(SF)
+ FAC = EF/EI
+C debug output
+ IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
+ & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
+
+C calculate Lorentz transformation
+ GAZ = -(POLD(1,1)+POLD(1,2))/EI
+ GAE = (POLD(2,1)+POLD(2,2))/EI
+ DO 240 I=1,4
+ GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
+ 240 CONTINUE
+ CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
+ & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
+ PTOT = MAX(DEPS,PTOT)
+ COD= PP(3)/PTOT
+ SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
+ COF= 1.D0
+ SIF= 0.D0
+ IF(PTOT*SID.GT.1.D-5) THEN
+ COF=PP(1)/(SID*PTOT)
+ SIF=PP(2)/(SID*PTOT)
+ ANORF=SQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+
+C debug output
+C check consistency initial/final configuration before rotation
+ IF(IDEB(10).GE.25) THEN
+ WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
+ & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
+ DO I=1,4
+ PP(I) = 0.D0
+ ENDDO
+ DO I=1,IROT
+ K = IROTT(I)
+ DO J=1,4
+ PP(J) = PP(J)+PHEP(J,K)
+ ENDDO
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: fin. momentum (1):',PP
+ ENDIF
+
+C apply rotation/boost to scattered particles
+ DO 400 I=1,IROT
+ K = IROTT(I)
+ DO 350 J=1,4
+ PP(J) = FAC*PHEP(J,K)
+ 350 CONTINUE
+ CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
+ & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
+ CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
+ & COD,SID,COF,SIF,XX,YY,ZZ)
+ EE = PHEP(4,K)
+ CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
+ 400 CONTINUE
+
+C debug output
+C check consistency initial/final configuration after rotation
+ IF(IDEB(10).GE.25) THEN
+ DO I=1,4
+ PP(I) = PNEW(I,1)+PNEW(I,2)
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: ini. momentum (2):',PP
+ DO I=1,4
+ PP(I) = 0.D0
+ ENDDO
+ DO I=1,IROT
+ K = IROTT(I)
+ DO J=1,4
+ PP(J) = PP(J)+PHEP(J,K)
+ ENDDO
+ ENDDO
+ WRITE(LO,'(1X,A,1P,4E11.3)')
+ & 'PHO_PRIMKT: fin. momentum (2):',PP
+ ENDIF
+
+ ENDIF
+
+ IF(INEXT.EQ.1) GOTO 100
+
+C initialization
+
+ ELSE IF(IMODE.EQ.-1) THEN
+
+C output of statistics etc.
+
+ ELSE IF(IMODE.EQ.-2) THEN
+
+C something wrong
+
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_PARTPT
+ SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
+C********************************************************************
+C
+C assign to soft partons
+C
+C input: IMODE -2 output of statistics
+C -1 initialization
+C 0 sampling of pt for soft partons belonging to
+C soft Pomerons
+C 1 sampling of pt for soft partons belonging to
+C hard Pomerons
+C IF first entry in /POEVT1/ to check
+C IL last entry in /POEVT1/ to check
+C PTCUT current value of PTCUT to distinguish
+C between soft and hard
+C
+C output: IREJ 0 success
+C 1 failure
+C
+C (soft pt is sampled by call to PHO_SOFTPT)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15 )
+
+ INTEGER IMODE,IF,IL,IREJ
+ DOUBLE PRECISION PTCUT
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+
+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)
+
+ DOUBLE PRECISION PTS,PB,XP,XPB,PC
+ DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
+
+ INTEGER MODIFY,IV,IVB
+ DIMENSION MODIFY(50),IV(50),IVB(2)
+
+C debug output
+ IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
+ & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
+ & IMODE,IF,IL,PTCUT
+
+ IF(IMODE.LT.0) GOTO 1000
+
+ IREJ = 0
+ IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
+
+C count entries to modify
+ IENTRY = 0
+ PTCUT2 = PTCUT**2
+ EMIN = 1.D20
+ IPEAK = 1
+ ISTART = IF
+
+C soft Pomerons
+
+ IF(IMODE.EQ.0) THEN
+ DO 300 I=ISTART,IL
+ IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
+ IENTRY = IENTRY+1
+ MODIFY(IENTRY) = I
+ XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
+ IV(IENTRY) = 0
+ IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
+ IF(PHEP(4,I).LT.EMIN) THEN
+ EMIN = PHEP(4,I)
+ IPEAK = IENTRY
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+
+C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+ DO 350 I=ISTART,IL
+ IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
+ IF(MOD(IPHIST(1,I),100).EQ.0) THEN
+ IENTRY = IENTRY+1
+ MODIFY(IENTRY) = I
+ XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
+ IF(ISWMDL(24).EQ.0) THEN
+ IV(IENTRY) = 0
+ IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
+ ELSE IF(ISWMDL(24).EQ.1) THEN
+ IV(IENTRY) = -1
+ ELSE
+ IV(IENTRY) = 1
+ ENDIF
+ IF(PHEP(4,I).LT.EMIN) THEN
+ EMIN = PHEP(4,I)
+ IPEAK = IENTRY
+ ENDIF
+ ENDIF
+ ENDIF
+ 350 CONTINUE
+
+C something wrong
+
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C debug output
+ IF(IDEB(6).GE.5) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
+ & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
+ IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
+ ENDIF
+
+C nothing to do
+ IF(IENTRY.LE.1) RETURN
+
+C sample pt of soft partons
+
+ IF(ISWMDL(5).LE.1) THEN
+ ITER = 0
+ IPEAK = DT_RNDM(DUM)*IENTRY+1
+ CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
+ CALL PHO_SWAPD(XP(IPEAK),XP(1))
+ CALL PHO_SWAPI(IV(IPEAK),IV(1))
+ 400 CONTINUE
+C energy limited sampling
+ PSUMX = 0.D0
+ PSUMY = 0.D0
+ ITER = ITER+1
+ IF(ITER.GE.1000) THEN
+ IF(IDEB(6).GE.3) THEN
+ WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
+ & IMODE,IENTRY,ITER
+ WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
+ & IPEAK
+ DO 405 I=1,IENTRY
+ II = MODIFY(I)
+ WRITE(LO,'(5X,3I5,1P,2E13.4)')
+ & I,II,IV(I),XP(I),PHEP(4,II)
+ 405 CONTINUE
+ IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ENDIF
+ DO 410 I=2,IENTRY
+ II = MODIFY(I)
+ PTMX = MIN(PHEP(4,II),PTCUT)
+ XPB(1) = XP(I)
+ IVB(1) = IV(I)
+ IF(ISWMDL(5).EQ.0) THEN
+ CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
+ ELSE
+ CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
+ ENDIF
+ PTS(0,I) = PB(0,1)
+ PTS(1,I) = PB(1,1)
+ PTS(2,I) = PB(2,1)
+ PSUMX = PSUMX+PB(1,1)
+ PSUMY = PSUMY+PB(2,1)
+ 410 CONTINUE
+ PTREM = SQRT(PSUMX**2+PSUMY**2)
+ IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
+ PTS(1,1) = -PSUMX
+ PTS(2,1) = -PSUMY
+ ELSE IF((ISWMDL(5).EQ.2)
+ & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
+C unlimited sampling
+ IPEAK = DT_RNDM(PSUMX)*IENTRY+1
+ CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
+ CALL PHO_SWAPD(XP(IPEAK),XP(1))
+ CALL PHO_SWAPI(IV(IPEAK),IV(1))
+ CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
+ ELSE IF(ISWMDL(5).EQ.3) THEN
+C each string has balanced pt
+ DO 500 K=1,IENTRY
+ IF(IV(K).LE.-90) GOTO 499
+ I1 = MODIFY(K)
+ IC1 = -ICOLOR(1,I1)
+ DO 510 L=K+1,IENTRY
+ IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
+ 510 CONTINUE
+ WRITE(LO,'(//1X,A,I5)')
+ & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
+ CALL PHO_ABORT
+ 511 CONTINUE
+ I2 = MODIFY(L)
+ AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
+ & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
+ AM = SQRT(AMSQR)
+ PTMX = AM/2.D0
+ IVB(1) = MAX(IV(K),IV(L))
+ XPB(1) = XP(K)
+ CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
+ PTS(1,K) = PB(1,1)
+ PTS(2,K) = PB(2,1)
+ PTS(1,L) = -PB(1,1)
+ PTS(2,L) = -PB(2,1)
+ GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
+ GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
+ PC(1) = PB(1,1)
+ PC(2) = PB(2,1)
+ PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
+ PC(3) = SIGN(PLONG,PHEP(3,I1))
+ PC(4) = PTMX
+ CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
+ & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
+ PC(1) = -PC(1)
+ PC(2) = -PC(2)
+ PC(3) = -PC(3)
+ CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
+ & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
+ IV(K) = IV(K)-100
+ IV(L) = IV(L)-100
+ 499 CONTINUE
+ 500 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
+ CALL PHO_ABORT
+ ENDIF
+
+C change partons in /POEVT1/
+ DO 900 II=1,IENTRY
+ IF(IV(II).GT.-90) THEN
+ I = MODIFY(II)
+ PHEP(1,I) = PHEP(1,I)+PTS(1,II)
+ PHEP(2,I) = PHEP(2,I)+PTS(2,II)
+ AMSQR = PHEP(4,I)**2
+ & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
+ PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
+ ENDIF
+ 900 CONTINUE
+
+C debug output
+ IF(IDEB(6).GE.15) THEN
+ WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
+ & 'I II IV XP EP PTS PTX PTY',IPEAK
+ DO 505 I=1,IENTRY
+ II = MODIFY(I)
+ WRITE(LO,'(2X,3I5,1P,5E12.4)')
+ & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
+ 505 CONTINUE
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+
+C initialization / output of statistics
+ 1000 CONTINUE
+ CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
+
+ END
+
+CDECK ID>, PHO_SOFTPT
+ SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
+C***********************************************************************
+C
+C select pt of soft string ends
+C
+C input: ISOFT number of soft partons
+C -1 initialization
+C >=0 sampling of p_t
+C -2 output of statistics
+C PTCUT cutoff for soft strings
+C PTMAX maximal allowed PT
+C XV field of x values
+C IV 0 sea quark
+C 1 valence quark
+C
+C output: /POINT3/ containing parameters AAS,BETAS
+C PTSOF filed with soft pt values
+C
+C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
+C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
+C ISWMDL(3/4) = 2 photon wave function
+C ISWMDL(3/4) = 10 no soft P_t assignment
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15)
+
+ DIMENSION PTSOF(0:2,*),XV(*)
+ DIMENSION IV(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DIMENSION BETAB(100)
+
+C selection of pt
+ IF(ISOFT.GE.0) THEN
+ CALLS = CALLS + 1.D0
+C sample according to model ISWMDL(3-6)
+ IF(ISOFT.GT.1) THEN
+ 210 CONTINUE
+ PTXS = 0.D0
+ PTYS = 0.D0
+ DO 300 I=2,ISOFT
+ IMODE = ISWMDL(3)
+C valence partons
+ IF(IV(I).EQ.1) THEN
+ BETA = BETAS(1)
+C photon/pomeron valence part
+ IF(IPAMDL(5).EQ.1) THEN
+ IF(XV(I).GE.0.D0) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ELSE
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ENDIF
+ ELSE IF(IPAMDL(5).EQ.2) THEN
+ BETA = PARMDL(20)
+ ELSE IF(IPAMDL(5).EQ.3) THEN
+ BETA = BETAS(3)
+ ENDIF
+C sea partons
+ ELSE IF(IV(I).EQ.0) THEN
+ BETA = BETAS(3)
+C hard scattering remnant
+ ELSE
+ IF(IPAMDL(6).EQ.0) THEN
+ BETA = BETAS(1)
+ ELSE IF(IPAMDL(6).EQ.1) THEN
+ BETA = BETAS(3)
+ ELSE
+ BETA = PARMDL(20)
+ ENDIF
+ ENDIF
+ BETA = MAX(BETA,0.01D0)
+ CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
+ PTS = MIN(PTMAX,PTS)
+ CALL PHO_SFECFE(SIG,COG)
+ PTSOF(0,I) = PTS
+ PTSOF(1,I) = COG*PTS
+ PTSOF(2,I) = SIG*PTS
+ PTXS = PTXS+PTSOF(1,I)
+ PTYS = PTYS+PTSOF(2,I)
+ BETAB(I) = BETA
+ 300 CONTINUE
+C balancing of momenta
+ PTS = SQRT(PTXS**2+PTYS**2)
+ IF(PTS.GE.PTMAX) GOTO 210
+ PTSOF(0,1) = PTS
+ PTSOF(1,1) = -PTXS
+ PTSOF(2,1) = -PTYS
+ BETAB(1) = 0.D0
+C
+*400 CONTINUE
+C
+C single parton only
+ ELSE
+ IMODE = ISWMDL(3)
+C valence partons
+ IF(IV(1).EQ.1) THEN
+ BETA = BETAS(1)
+C photon/Pomeron valence part
+ IF(IPAMDL(5).EQ.1) THEN
+ IF(XV(1).GE.0.D0) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ELSE
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ IMODE = ISWMDL(4)
+ BETA = BETAS(3)
+ ENDIF
+ ENDIF
+ ELSE IF(IPAMDL(5).EQ.2) THEN
+ BETA = PARMDL(20)
+ ELSE IF(IPAMDL(5).EQ.3) THEN
+ BETA = BETAS(3)
+ ENDIF
+C sea partons
+ ELSE IF(IV(1).EQ.0) THEN
+ BETA = BETAS(3)
+C hard scattering remnant
+ ELSE
+ IF(IPAMDL(6).EQ.1) THEN
+ BETA = BETAS(3)
+ ELSE
+ BETA = PARMDL(20)
+ ENDIF
+ ENDIF
+ BETA = MAX(BETA,0.01D0)
+ CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
+ PTS = MIN(PTMAX,PTS)
+ CALL PHO_SFECFE(SIG,COG)
+ PTSOF(0,1) = PTS
+ PTSOF(1,1) = COG*PTS
+ PTSOF(2,1) = SIG*PTS
+ BETAB(1) = BETA
+ ENDIF
+
+C debug output
+ IF(IDEB(29).GE.10) THEN
+ WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
+ WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
+ DO 105 I=1,ISOFT
+ WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
+ & PTSOF(1,I),PTSOF(2,I),BETAB(I)
+ 105 CONTINUE
+ ENDIF
+
+C initialization of statistics and parameters
+
+ ELSE IF(ISOFT.EQ.-1) THEN
+ PTSMIN = 0.D0
+ PTSMAX = PTCUT
+
+ IMODE = -100+ISWMDL(3)
+ CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
+
+C output of statistics
+
+ ELSE IF(ISOFT.EQ.-2) THEN
+
+ ELSE
+ WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
+ & 'unsupported ISOFT ',ISOFT
+ STOP
+ ENDIF
+ END
+
+CDECK ID>, PHO_SELPT
+ SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
+C***********************************************************************
+C
+C select pt from different distributions
+C
+C input: EE energy (for initialization only)
+C otherwise x value of corresponding parton
+C PTLOW lower pt limit
+C PTHIGH upper pt limit
+C (PTHIGH > 20 will cause DEXP underflows)
+C
+C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
+C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
+C IMODE = 2 dNs/dP_t according photon wave function
+C IMODE = 10 no sampling
+C
+C IMODE = -100+IMODE initialization according to
+C given limitations
+C
+C output: PTS sampled pt value
+C initialization:
+C BETA soft pt slope in central region
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( PI2 = 6.28318530718D0,
+ & AMIN = 1.D-2,
+ & EPS = 1.D-7,
+ & DEPS = 1.D-30)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION PHO_CONN0,PHO_CONN1
+ EXTERNAL PHO_CONN0,PHO_CONN1
+
+C initialization
+
+ IF(IMODE.LT.0) GOTO 100
+
+ PX = PTHIGH
+ PTS = 0.D0
+
+C initial checks
+
+ IF(PX.LT.AMIN) RETURN
+
+ IF((PX-PTLOW).LT.0.01) THEN
+ IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
+ & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
+ RETURN
+ ENDIF
+
+C sampling of pt values according to IMODE
+
+ IF(IMODE.EQ.0) THEN
+
+ FAC1 = EXP(-BETA*PX**2)
+ FAC2 = (1.D0-FAC1)
+ 25 CONTINUE
+ XI1 = DT_RNDM(PX)*FAC2 + FAC1
+ PTS = SQRT(-1.D0/BETA*LOG(XI1))
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+ XIMIN = EXP(-BETA*PTHIGH)
+ XIDEL = 1.D0-XIMIN
+ 50 CONTINUE
+ PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
+ & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
+ IF(PTS.LT.XMT) GOTO 50
+ PTS = SQRT(PTS**2-XMT2)
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
+
+ ELSE IF(IMODE.EQ.2) THEN
+
+ IF(EE.GE.0.D0) THEN
+ P2 = PVIRTP(1)
+ ELSE
+ P2 = PVIRTP(2)
+ ENDIF
+ XV = ABS(EE)
+ AA = (1.D0-XV)*XV*P2+PARMDL(25)
+ 75 CONTINUE
+ PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
+ IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
+
+C something wrong
+
+ ELSE IF(IMODE.NE.10) THEN
+ WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C debug output
+ IF(IDEB(5).GE.20) THEN
+ WRITE(LO,'(1X,A,I3,4E10.3)')
+ & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
+ & IMODE,BETA,PTLOW,PTHIGH,PTS
+ ENDIF
+ RETURN
+
+C initialization
+ 100 CONTINUE
+ PTSMIN = PTLOW
+ PTSMAX = PTHIGH
+ PTCON = PTHIGH
+C calculation of parameters
+ INIT = IMODE+100
+ AAS = 0.D0
+
+C initialization for model 0 (gaussian pt distribution)
+
+ IF(INIT.EQ.0) THEN
+ BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
+ BETUP = BETAS(1)
+ BETLO = -2.D0
+ XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
+ IF(XTOL.LT.0.D0) THEN
+ XTOL = 1.D-4
+ METHOD = 1
+ MAXF = 500
+ BETA = 0.D0
+ BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
+* IF(BETA.LT.-1.D+10) THEN
+* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
+* & '(model 0: Ecm,PTcut)',EE,PTCON
+* WRITE(LO,'(1X,A,1P,3E10.3)')
+* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
+* CALL PHO_PREVNT(-1)
+* BETA = 0.01
+* ELSE
+ AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
+* ENDIF
+ ELSE
+ AAS = 0.D0
+ BETA = BETAS(1)
+ ENDIF
+
+C initialization for model 1 (exponential pt distribution)
+
+ ELSE IF(INIT.EQ.1) THEN
+ XMT = PARMDL(43)
+ XMT2 = XMT*XMT
+ BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
+ BETUP = BETAS(1)
+ BETLO = -3.D0
+ XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
+ IF(XTOL.LT.0.D0) THEN
+ XTOL = 1.D-4
+ METHOD = 1
+ MAXF = 500
+ BETA = 0.D0
+ BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
+* IF(BETA.LT.-1.D+10) THEN
+* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
+* & '(model 1: Ecm,PTcut)',EE,PTCON
+* WRITE(LO,'(1X,A,1P,3E10.3)')
+* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
+* CALL PHO_PREVNT(-1)
+* BETA = 0.01
+* ELSE
+ AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
+* ENDIF
+ ELSE
+ AAS = 0.D0
+ BETA = BETAS(1)
+ ENDIF
+ ELSE IF(INIT.EQ.10) THEN
+ IF(IDEB(5).GT.10)
+ & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
+ RETURN
+ ELSE
+ WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
+ & INIT
+ CALL PHO_ABORT
+ ENDIF
+ BETA = MIN(BETA,BETAS(1))
+
+C hard cross section is too big: neg. beta parameter
+ IF(BETA.LE.0.D0) THEN
+ WRITE(LO,'(1X,A,1P,2E12.3)')
+ & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
+ WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
+ & SIGS,DSIGHP,SIGH,PTCON
+ CALL PHO_PREVNT(-1)
+ ENDIF
+
+C output of initialization parameters
+ IF(IDEB(5).GE.10) THEN
+ WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
+ & INIT
+ WRITE(LO,'(5X,A,1P,2E13.3)')
+ & 'BETA,AAS ',BETA,AAS
+ WRITE(LO,'(5X,A,1P,3E13.3)')
+ & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
+ WRITE(LO,'(5X,A,1P,3E13.3)')
+ & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_CONN0
+ DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
+C***********************************************************************
+C
+C auxiliary function to determine parameters of soft
+C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
+C
+C internal factors: FS number of soft partons in soft Pomeron
+C FH number of soft partons in hard Pomeron
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION BETA,XX,FF
+
+ XX = BETA*PTCON**2
+ IF(ABS(XX).LT.1.D-3) THEN
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
+ ELSE
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
+ ENDIF
+ PHO_CONN0 = FF
+
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
+
+ END
+
+CDECK ID>, PHO_CONN1
+ DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
+C***********************************************************************
+C
+C auxiliary function to determine parameters of soft
+C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
+C
+C internal factors: FS number of soft partons in soft Pomeron
+C FH number of soft partons in hard Pomeron
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C average number of cut soft and hard ladders (obsolete)
+ DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
+ COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+
+ DOUBLE PRECISION BETA,XX,FF
+
+ XX = BETA*PTCON
+ IF(ABS(XX).LT.1.D-3) THEN
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
+ ELSE
+ FF = FS*SIGS+FH*SIGH
+ & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
+ ENDIF
+ PHO_CONN1 = FF
+
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
+* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
+
+ END
+
+CDECK ID>, PHO_MSHELL
+ SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
+C********************************************************************
+C
+C rescaling of momenta of two partons to put both
+C on mass shell
+C
+C input: PA1,PA2 input momentum vectors
+C XM1,2 desired masses of particles afterwards
+C P1,P2 changed momentum vectors
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-20 )
+
+ DIMENSION PA1(*),PA2(*),P1(*),P2(*)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+ IDEV = 0
+C debug output
+ IF(IDEB(40).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
+ WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
+ WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
+ ENDIF
+
+C Lorentz transformation into system CMS
+ PX = PA1(1)+PA2(1)
+ PY = PA1(2)+PA2(2)
+ PZ = PA1(3)+PA2(3)
+ EE = PA1(4)+PA2(4)
+ XMS = EE**2-PX**2-PY**2-PZ**2
+ IF(XMS.LT.(XM1+XM2)**2) THEN
+ IREJ = 1
+ IFAIL(37) = IFAIL(37)+1
+
+ if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
+
+ IF(IDEB(40).GE.3) THEN
+ WRITE(LO,'(/1X,A,I12)')
+ & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
+ WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
+ & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
+ WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
+ IDEV = 5
+ IF(IDEB(40).GE.3) GOTO 55
+ ENDIF
+ RETURN
+ ENDIF
+ XMS = SQRT(XMS)
+ BGX = PX/XMS
+ BGY = PY/XMS
+ BGZ = PZ/XMS
+ GAM = EE/XMS
+ CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
+ & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ PTOT1 = MAX(DEPS,PTOT1)
+ COD = P1(3)/PTOT1
+ SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COF = 1.D0
+ SIF = 0.D0
+ IF(PTOT1*SID.GT.1.D-5) THEN
+ COF = P1(1)/(SID*PTOT1)
+ SIF = P1(2)/(SID*PTOT1)
+ ANORF = SQRT(COF*COF+SIF*SIF)
+ COF = COF/ANORF
+ SIF = SIF/ANORF
+ ENDIF
+
+C new CM momentum and energies (for masses XM1,XM2)
+ XM12 = XM1**2
+ XM22 = XM2**2
+ SS = XMS**2
+ PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
+ EE1 = SQRT(XM12+PCMP**2)
+ EE2 = XMS-EE1
+C back rotation
+ CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
+ & PTOT1,P1(1),P1(2),P1(3),P1(4))
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
+ & PTOT2,P2(1),P2(2),P2(3),P2(4))
+
+C check consistency
+ DEL = XMS*0.0001
+ IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
+ IDEV = 1
+ ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
+ IDEV = 2
+ ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
+ IDEV = 3
+ ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
+ IDEV = 4
+ ENDIF
+ 55 CONTINUE
+C debug output
+ IF(IDEV.NE.0) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
+ WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
+ WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
+ WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
+ ELSE IF(IDEB(40).GE.10) THEN
+ WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
+ WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
+ WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
+ ENDIF
+ END
+
+CDECK ID>, PHO_GLU2QU
+ SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
+C********************************************************************
+C
+C split gluon with index I in POEVT1
+C (massless gluon assumed)
+C
+C input: /POEVT1/
+C IG gluon index
+C IQ1 first quark index
+C IQ2 second quark index
+C
+C output: new quarks in /POEVT1/
+C IREJ 1 splitting impossible
+C 0 splitting successful
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4)
+ DATA CUTM /0.02D0/
+
+ IREJ = 0
+
+C calculate string masses max possible
+ IF(ISWMDL(9).EQ.1) THEN
+ CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
+ & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
+ IF(CMASS1.LT.CUTM) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I4,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+ CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
+ & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
+ IF(CMASS2.LT.CUTM) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I4,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+C
+C calculate minimal z
+ ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
+ ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
+ ZMIN = MIN(ZMIN1,ZMIN2)
+ IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
+ IF(IDEB(73).GE.5) THEN
+ WRITE(LO,'(1X,A,3I3,4E10.3)')
+ & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
+ & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
+ ENDIF
+ IFAIL(33) = IFAIL(33) + 1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ELSE
+ ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
+ ENDIF
+C
+ ZFRAC = PHO_GLUSPL(ZMIN)
+ IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
+ ZFRAC = 1.D0-ZFRAC
+ ENDIF
+ DO 200 I=1,4
+ P1(I) = PHEP(I,IG)*ZFRAC
+ P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
+ 200 CONTINUE
+C quark flavours
+ CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
+ CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
+ & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
+ CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
+
+ IF(ABS(IDHEP(IQ1)).GT.6) THEN
+ K = SIGN(ABS(K),IDHEP(IQ1))
+ ELSE
+ K = -SIGN(ABS(K),IDHEP(IQ1))
+ ENDIF
+C colors
+ IF(K.GT.0) THEN
+ IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
+ IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
+ ELSE
+ IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
+ IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
+ ENDIF
+C register new partons
+ CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
+ & IPHIST(1,IG),0,IC1,0,IPOS,1)
+ CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
+ & IPHIST(1,IG),0,IC2,0,IPOS,1)
+C debug output
+ IF(IDEB(73).GE.20) THEN
+ WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
+ & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
+ & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
+ WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
+ & K,-K,IC1,IC2
+ ENDIF
+ END
+
+CDECK ID>, PHO_GLUSPL
+ DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
+C*********************************************************************
+C
+C calculate quark - antiquark light cone momentum fractions
+C according to Altarelli-Parisi g->q aq splitting function
+C (symmetric z interval assumed)
+C
+C input: ZMIN minimal Z value allowed,
+C 1-ZMIN maximal Z value allowed
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( ALEXP= 0.3333333333D0,
+ & DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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
+
+ IF(ZMIN.GE.0.5D0) THEN
+ IF(IDEB(69).GT.2) THEN
+ WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
+ ENDIF
+ ZZ=0.D0
+ GOTO 1000
+ ELSE IF(ZMIN.LE.0.D0) THEN
+ IF(IDEB(69).GT.2) THEN
+ WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
+ ENDIF
+ ZMINL = DEPS
+ ELSE
+ ZMINL = ZMIN
+ ENDIF
+
+ ZMAX = 1.D0-ZMINL
+ XI = DT_RNDM(ZMAX)
+ ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
+ IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
+
+ 1000 CONTINUE
+ IF(IDEB(69).GE.10) THEN
+ WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
+ ENDIF
+ PHO_GLUSPL = ZZ
+ END
+
+CDECK ID>, PHO_STDPAR
+ SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
+C***********************************************************************
+C
+C select the initial parton x-fractions and flavors and
+C the final parton momenta and flavours
+C for standard Pomeron/Reggeon cuts
+C
+C input: IJM1 index of mother particle 1 in /POEVT1/
+C IJM2 index of mother particle 2 in /POEVT1/
+C IGEN production process of mother particles
+C MSPOM soft cut Pomerons
+C MHPOM hard or semihard cut Pomerons
+C MSREG soft cut Reggeons
+C MHDIR direct hard processes
+C
+C IJM1 -1 initialization of statistics
+C -2 output of statistics
+C
+C output: partons are directly written to /POEVT1/,/POEVT2/
+C
+C structure of /POSOFT/
+C XS1(I),XS2(I): x-values of initial partons
+C IJSI1(I),IJSI2(I): flavor of initial parton
+C 0 gluon
+C 1,2,3,4 quarks
+C negative antiquarks
+C IJSF1(I),IJSF2(I): flavor of final state partons
+C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
+C J=1 PX
+C =2 PY
+C =3 PZ
+C =4 ENERGY
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (RHOMAS = 0.766D0,
+ & DEPS = 1.D-10,
+ & TINY = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C internal cross check information on hard scattering limits
+ DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
+ COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
+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)
+
+ double precision pho_alphas
+
+ DIMENSION PC(4),IFLA(2),ICI(2,2)
+
+ IF(IJM1.EQ.-1) THEN
+ DO 116 I=1,15
+ ETAMI(1,I) = 1.D10
+ ETAMA(1,I) = -1.D10
+ ETAMI(2,I) = 1.D10
+ ETAMA(2,I) = -1.D10
+ XXMI(1,I) = 1.D0
+ XXMA(1,I) = 0.D0
+ XXMI(2,I) = 1.D0
+ XXMA(2,I) = 0.D0
+ 116 CONTINUE
+ CALL PHO_HARSCA(IJM1,1)
+ CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
+
+ RETURN
+
+ ELSE IF(IJM1.EQ.-2) THEN
+
+C output internal statistics
+ IF(IDEB(23).GE.1) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
+ DO 117 I=1,15
+ WRITE(LO,'(5X,I3,4E13.5)')
+ & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
+ 117 CONTINUE
+ WRITE(LO,'(1X,A)')
+ & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
+ DO 118 I=1,15
+ WRITE(LO,'(5X,I3,4E13.5)')
+ & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
+ 118 CONTINUE
+ ENDIF
+ CALL PHO_HARSCA(IJM1,1)
+ CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
+
+ RETURN
+ ENDIF
+
+ IREJ = 0
+C debug output
+ IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
+ 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
+
+C get mother data (exchange if first particle is a pomeron)
+ IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
+ JM1 = IJM2
+ JM2 = IJM1
+ ELSE
+ JM1 = IJM1
+ JM2 = IJM2
+ ENDIF
+
+ NPOSP(1) = JM1
+ NPOSP(2) = JM2
+ IDPDG1 = IDHEP(JM1)
+ IDBAM1 = IMPART(JM1)
+ IDPDG2 = IDHEP(JM2)
+ IDBAM2 = IMPART(JM2)
+
+C store current status of /POEVT1/
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ NHEPS = NHEP
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+
+C get nominal masses (photons: VDM assumption)
+ DELMAS = 0.D0
+ IF(IDHEP(JM1).EQ.22) THEN
+ PMASSP(1) = RHOMAS+DELMAS
+ PVIRTP(1) = PHEP(5,JM1)**2
+ ELSE
+ PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
+ PVIRTP(1) = 0.D0
+ ENDIF
+ IF(IDHEP(JM2).EQ.22) THEN
+ PMASSP(2) = RHOMAS+DELMAS
+ PVIRTP(2) = PHEP(5,JM2)**2
+ ELSE
+ PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
+ PVIRTP(2) = 0.D0
+ ENDIF
+
+C calculate c.m. energy and check kinematics
+ PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
+
+ IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
+ WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
+ & 'energy smaller than two-particle threshold (event rejected)'
+ CALL PHO_PREVNT(1)
+ IREJ = 5
+ GOTO 150
+ ENDIF
+ ECMP = SQRT(SS)
+
+ IF(IDEB(23).GE.5) THEN
+ WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
+ & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
+ IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
+ ENDIF
+
+C Lorentz transformation into c.m. system
+ DO 10 I=1,4
+ GAMBEP(I) = PC(I)/ECMP
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
+ & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
+ & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
+C rotation angle: particle 1 moves along +z
+ CODP = PC(3)/PTOT1
+ SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
+ COFP = 1.D0
+ SIFP = 0.D0
+ IF(PTOT1*SIDP.GT.1.D-5) THEN
+ COFP = PC(1)/(SIDP*PTOT1)
+ SIFP = PC(2)/(SIDP*PTOT1)
+ ANORF = SQRT(COFP*COFP+SIFP*SIFP)
+ COFP = COFP/ANORF
+ SIFP = SIFP/ANORF
+ ENDIF
+C get CM momentum
+ XM12 = PMASSP(1)**2
+ XM22 = PMASSP(2)**2
+ PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
+
+C find particle combination
+ II = 0
+ IF(IDPDG2.EQ.IFPAP(2)) THEN
+ IF(IDPDG1.EQ.IFPAP(1)) II = 1
+ ELSE IF(IDPDG2.EQ.990) THEN
+ IF(IDPDG1.EQ.IFPAP(1)) THEN
+ II = 2
+ ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
+ II = 3
+ ELSE IF(IDPDG1.EQ.990) THEN
+ II = 4
+ ENDIF
+ ENDIF
+ IF(II.EQ.0) THEN
+ IF(ISWMDL(14).GT.0) THEN
+ II = 1
+ ELSE
+ WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
+ & 'invalid particle combination:',IDPDG1,IDPDG2
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+
+C select parton distribution functions from tables
+ IF((MHPOM+MHDIR).GT.0) THEN
+ CALL PHO_ACTPDF(IDPDG1,1)
+ CALL PHO_ACTPDF(IDPDG2,2)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+ ENDIF
+
+C interpolate hard cross sections and rejection weights
+ CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
+
+ NTRY = 10
+
+C position of first particle added to /POEVT2/
+ NLOR1 = NHEP+1
+
+C ---------------- direct processes -----------------
+
+ IF(MHDIR.EQ.1) THEN
+ CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
+ IF(IREJ.EQ.50) RETURN
+ IF(IREJ.NE.0) GOTO 150
+C write comments to /POEVT1/
+ CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
+ & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
+ & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
+ CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
+ & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
+ & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
+ & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
+ & IPOS1,1)
+ CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
+ & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
+ & IPOS2,1)
+
+C soft spectator partons
+ ICA1 = 0
+ ICA2 = 0
+ ICB1 = 0
+ ICB2 = 0
+ IPDF1 = 0
+ IPDF2 = 0
+
+C single resolved: QCD compton scattering
+C ------------------------------
+ IF(NPROHD(1).EQ.10) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
+ IPDF2 = 1000*IGRP(2)+ISET(2)
+ ELSE IF(NPROHD(1).EQ.12) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
+ IPDF1 = 1000*IGRP(1)+ISET(1)
+
+C single resolved: photon gluon fusion
+C ---------------------------
+ ELSE IF(NPROHD(1).EQ.11) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
+ IPDF2 = 1000*IGRP(2)+ISET(2)
+ ELSE IF(NPROHD(1).EQ.13) THEN
+C register hadron remnant
+ CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
+ IPDF1 = 1000*IGRP(1)+ISET(1)
+
+C direct process (no remnant)
+C ----------------------------
+ ELSE IF(NPROHD(1).EQ.14) THEN
+
+ ENDIF
+
+C write final high-pt partons to POEVT1
+ IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
+ ICI(1,1) = ICA1
+ ICI(1,2) = ICA2
+ ICI(2,1) = ICB1
+ ICI(2,2) = ICB2
+ I = 1
+ IFLA(1) = NINHD(I,1)
+ IFLA(2) = NINHD(I,2)
+C initial state radiation
+ DO 130 K=1,2
+ DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
+ KK = 1
+ 137 CONTINUE
+ IFLB = IFLISR(K,IPA)
+ IF(ABS(IFLB).LE.6) THEN
+C partons
+ IF(ICI(K,1)*ICI(K,2).NE.0) THEN
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),3)
+ ELSE IF(IFLB.GT.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),4)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
+ & IC1,IC2,4)
+ ENDIF
+ ELSE
+ IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
+ IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
+ CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
+ KK = KK+1
+ GOTO 137
+ ENDIF
+ ENDIF
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
+ & IC1,IC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),2)
+ ENDIF
+ ENDIF
+ IIFL = IPHO_CNV1(IFLB)
+
+ IFLA(K) = IFLA(K)-IFLB
+ IST = -1
+ ELSE
+C other particle
+ IIFL = IFLB
+ IC1 = 0
+ IC2 = 0
+ IST = 1
+ ENDIF
+ CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
+ & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
+ & IGEN,IC1,IC2,IPOS,1)
+ 135 CONTINUE
+ 130 CONTINUE
+ ICOLOR(1,IPOS1-2) = ICI(1,1)
+ ICOLOR(2,IPOS1-2) = ICI(1,2)
+ ICOLOR(1,IPOS1-1) = ICI(2,1)
+ ICOLOR(2,IPOS1-1) = ICI(2,2)
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
+ & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
+ & NOUTHD(I,2),ICI(2,1),ICI(2,2))
+ ICOLOR(1,IPOS1) = ICI(1,1)
+ ICOLOR(2,IPOS1) = ICI(1,2)
+ ICOLOR(1,IPOS2) = ICI(2,1)
+ ICOLOR(2,IPOS2) = ICI(2,2)
+ DO 140 K=1,2
+ IPA = IPOISR(K,1,I)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
+ & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
+ & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
+ 140 CONTINUE
+ ELSE
+ ICOLOR(1,IPOS1-2) = ICA1
+ ICOLOR(2,IPOS1-2) = ICA2
+ ICOLOR(1,IPOS1-1) = ICB1
+ ICOLOR(2,IPOS1-1) = ICB2
+ CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
+ & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
+ & NOUTHD(1,2),ICB1,ICB2)
+ ICOLOR(1,IPOS1) = ICA1
+ ICOLOR(2,IPOS1) = ICA2
+ ICOLOR(1,IPOS2) = ICB1
+ ICOLOR(2,IPOS2) = ICB2
+ I = -1
+ IF(ABS(NOUTHD(1,1)).GT.12) I = 1
+ CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
+ & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
+ & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
+ ENDIF
+
+C assign soft pt to spectators
+ IF(ISWMDL(18).EQ.0) THEN
+ IPOS2 = IPOS2-1
+ CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(26) = IFAIL(26) + 1
+ GOTO 150
+ ENDIF
+
+ ENDIF
+
+C ----------------- resolved processes -------------------
+
+C single Reggeon exchange
+C ----------------------------
+ ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
+C flavours
+ CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(24) = IFAIL(24)+1
+ GOTO 150
+ ENDIF
+
+C colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
+ & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
+ CALL PHO_SWAPI(ICA1,ICB1)
+ ENDIF
+ ECMH = ECMP/2.D0
+
+C registration
+
+C DPMJET call with special projectile / target
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
+ & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
+ & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
+C default treatment
+ ELSE
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
+ & -1,IGEN,ICA1,0,IPOS1,1)
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
+ & -1,IGEN,ICB1,0,IPOS2,1)
+ ENDIF
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+C
+C multi Reggeon / Pomeron exchange
+C----------------------------------------
+ ELSE
+C parton configuration
+
+ CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
+ & MHPAR1,MHPAR2,IREJ)
+
+ IF(IREJ.EQ.50) RETURN
+ IF(IREJ.NE.0) GOTO 150
+
+C register particles
+ IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
+ & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
+ & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
+
+C register soft partons
+ IF(IVAL1.NE.0) THEN
+ IF(IVAL1.LT.0) THEN
+ IND1 = 3
+ IVAL1=-IVAL1
+ ELSE
+ IND1 = 2
+ ENDIF
+ ELSE IF(MSPOM.EQ.0) THEN
+ IND1 = 4
+ ELSE
+ IND1 = 1
+ ENDIF
+ IF(IVAL2.NE.0) THEN
+ IF(IVAL2.LT.0) THEN
+ IND2 = 3
+ IVAL2=-IVAL2
+ ELSE
+ IND2 = 2
+ ENDIF
+ ELSE IF(MSPOM.EQ.0) THEN
+ IND2 = 4
+ ELSE
+ IND2 = 1
+ ENDIF
+
+ IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
+ & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
+
+C soft Pomeron final states
+C -----------------------------------
+ K = MSPOM+MHPOM+MSREG
+ DO 50 I=1,MSPOM
+
+ CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(8) = IFAIL(8) + 1
+ GOTO 150
+ ENDIF
+C
+ 50 CONTINUE
+
+C soft Reggeon final states
+C -----------------------------------------
+ DO 75 I=1,MSREG
+C flavours
+ CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
+ IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
+ CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
+ ELSE
+ CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
+ ENDIF
+
+C colors
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
+ & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
+ & CALL PHO_SWAPI(ICA1,ICB1)
+C registration
+ CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
+ & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
+ & I,IGEN,ICA1,ICA2,IPOS1,1)
+ IND1 = IND1+1
+ CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
+ & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
+ & I,IGEN,ICB1,ICB2,IPOS2,1)
+ IND2 = IND2+1
+
+ IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
+ & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
+ & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
+
+C soft pt assignment
+ IF(ISWMDL(18).EQ.0) THEN
+ CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+ 75 CONTINUE
+
+C hard Pomeron final states
+C ------------------------------------
+ IND1 = MSPAR1
+ IND2 = MSPAR2
+
+ DO 100 L=1,MHPOM
+ I = LSIDX(L)
+
+ IFLI1 = IPHO_CNV1(N0INHD(I,1))
+ IFLI2 = IPHO_CNV1(N0INHD(I,2))
+ IFLO1 = IPHO_CNV1(NOUTHD(I,1))
+ IFLO2 = IPHO_CNV1(NOUTHD(I,2))
+
+C write comments to /POEVT1/
+ CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
+ & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
+ & IFLO1,IFLO2,IPOS,1)
+ I1 = 8*I-7
+ IPDF = 1000*IGRP(1)+ISET(1)
+ CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
+ & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
+ & ICA1,ICA2,IPOS,1)
+ IPDF = 1000*IGRP(2)+ISET(2)
+ CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
+ & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
+ & ICB1,ICB2,IPOS,1)
+ I1 = 8*I-3
+ IPDF = 1000*IGRP(1)+ISET(1)
+ CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
+ & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
+ & ICA1,ICA2,IPOS1,1)
+ IPDF = 1000*IGRP(2)+ISET(2)
+ CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
+ & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
+ & ICB1,ICB2,IPOS2,1)
+
+C spectator partons belonging to hard interaction
+ IF(IVAL1.EQ.I) THEN
+ IVQ = 1
+ IND = 1
+ ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
+ IVQ = 0
+ IND = 1
+ ELSE
+ IVQ = -1
+ IND = IND1
+ ENDIF
+ CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
+ IF(IVQ.LT.0) IND1 = IND1-IUSED
+ IF(IVAL2.EQ.I) THEN
+ IVQ = 1
+ IND = 1
+ ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
+ IVQ = 0
+ IND = 1
+ ELSE
+ IVQ = -1
+ IND = IND2
+ ENDIF
+ CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
+ IF(IVQ.LT.0) IND2 = IND2-IUSED
+C
+C register hard scattered partons
+ IF((ISWMDL(8).GE.2)
+ & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
+ ICI(1,1) = ICA1
+ ICI(1,2) = ICA2
+ ICI(2,1) = ICB1
+ ICI(2,2) = ICB2
+ IFLA(1) = NINHD(I,1)
+ IFLA(2) = NINHD(I,2)
+C initial state radiation
+ DO 230 K=1,2
+ DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
+ KK = 1
+ 237 CONTINUE
+ IFLB = IFLISR(K,IPA)
+ IF(ABS(IFLB).LE.6) THEN
+C partons
+ IF(ICI(K,1)*ICI(K,2).NE.0) THEN
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),3)
+ ELSE IF(IFLB.GT.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),4)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
+ & ICI(K,2),IC1,IC2,4)
+ ENDIF
+ ELSE
+ IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
+ IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
+ CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
+ KK = KK+1
+ GOTO 237
+ ENDIF
+ ENDIF
+ IF(IFLB.EQ.0) THEN
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
+ & ICI(K,2),IC1,IC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
+ & ICI(K,1),ICI(K,2),2)
+ ENDIF
+ ENDIF
+ IIFL = IPHO_CNV1(IFLB)
+
+ IFLA(K) = IFLA(K)-IFLB
+ IST = -1
+ ELSE
+C other particles
+ IIFL = IFLB
+ IC1 = 0
+ IC2 = 0
+ IST = 1
+ ENDIF
+ CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
+ & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
+ & L*100+K,IGEN,IC1,IC2,IPOS,1)
+ 235 CONTINUE
+ 230 CONTINUE
+ ICOLOR(1,IPOS1-2) = ICI(1,1)
+ ICOLOR(2,IPOS1-2) = ICI(1,2)
+ ICOLOR(1,IPOS1-1) = ICI(2,1)
+ ICOLOR(2,IPOS1-1) = ICI(2,2)
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
+ & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
+ & NOUTHD(I,2),ICI(2,1),ICI(2,2))
+ ICOLOR(1,IPOS1) = ICI(1,1)
+ ICOLOR(2,IPOS1) = ICI(1,2)
+ ICOLOR(1,IPOS2) = ICI(2,1)
+ ICOLOR(2,IPOS2) = ICI(2,2)
+ DO 240 K=1,2
+ IPA = IPOISR(K,1,I)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
+ & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
+ & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
+ 240 CONTINUE
+ ELSE
+ ICOLOR(1,IPOS1-2) = ICA1
+ ICOLOR(2,IPOS1-2) = ICA2
+ ICOLOR(1,IPOS1-1) = ICB1
+ ICOLOR(2,IPOS1-1) = ICB2
+ CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
+ & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
+ & NOUTHD(I,2),ICB1,ICB2)
+ ICOLOR(1,IPOS1) = ICA1
+ ICOLOR(2,IPOS1) = ICA2
+ ICOLOR(1,IPOS2) = ICB1
+ ICOLOR(2,IPOS2) = ICB2
+ I1 = 8*I-3
+ CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
+ & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
+ & ICA1,ICA2,IPOS,1)
+ CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
+ & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
+ & ICB1,ICB2,IPOS,1)
+ ENDIF
+ 100 CONTINUE
+C end of resolved parton registration
+ ENDIF
+
+ IF(MHDIR+MHPOM.GT.0) THEN
+
+ IF(ISWMDL(29).GE.1) THEN
+C primordial kt of hard scattering
+ CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(27) = IFAIL(27)+1
+ GOTO 150
+ ENDIF
+ ELSE IF(ISWMDL(24).GE.0) THEN
+C give "soft" pt only to soft (spectator) partons in hard processes
+ CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(26) = IFAIL(26)+1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+C give "soft" pt to partons in soft Pomerons
+ IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
+ CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(25) = IFAIL(25) + 1
+ GOTO 150
+ ENDIF
+ ENDIF
+
+C boost back to lab frame
+ CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
+ & GAMBEP(1),GAMBEP(2),GAMBEP(3))
+ RETURN
+
+C rejection treatment
+ 150 CONTINUE
+ IFAIL(2) = IFAIL(2)+1
+C reset counters
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+C reset mother-daugther relations
+ JDAHEP(1,JM1) = 0
+ JDAHEP(2,JM1) = 0
+ JDAHEP(1,JM2) = 0
+ JDAHEP(2,JM2) = 0
+ ISTHEP(JM1) = 1
+ ISTHEP(JM2) = 1
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ NHEP = NHEPS
+C debug
+ IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
+ & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
+ & MSPOM,MHPOM,MSREG,MHDIR
+ RETURN
+
+ END
+
+CDECK ID>, PHO_HARCOL
+ SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
+ & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
+C*********************************************************************
+C
+C calculate color flow for hard resolved process
+C
+C input: IP1..4 flavour of partons (PDG convention)
+C V parton subprocess Mandelstam variable V = t/s
+C (lightcone momenta assumed)
+C ICA,ICB color labels
+C MSPR process number
+C -1 initialization of statistics
+C -2 output of statistics
+C
+C output: ICC,ICD color label of final partons
+C
+C (it is possible to use the same variables for in and output)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+
+ DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
+
+C initialization
+ IF(MSPR.EQ.-1) THEN
+ DO 200 I=1,8
+ DO 210 K=1,5
+ ICONF(I,K) = 0
+ 210 CONTINUE
+ IRECN(I,1) = 0
+ IRECN(I,2) = 0
+ 200 CONTINUE
+ RETURN
+C output of statistics
+ ELSE IF(MSPR.EQ.-2) THEN
+ IF(IDEB(26).LT.1) RETURN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_HARCOL: sampled color configurations',
+ & '----------------------------------------'
+ WRITE(LO,'(6X,A,15X,A)')
+ & 'diagram color configurations (1-4)','sum'
+ DO 300 I=1,8
+ DO 310 K=1,4
+ ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
+ 310 CONTINUE
+ WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
+ 300 CONTINUE
+ IF(ISWMDL(11).GE.2) THEN
+ WRITE(LO,'(/6X,A)')
+ & 'diagram with / without color re-connection'
+ DO 320 I=1,8
+ WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
+ 320 CONTINUE
+ ENDIF
+ RETURN
+ ENDIF
+C
+C gluons: first color positive, quarks second color zero
+ IF(IP1.EQ.0) THEN
+ IF(ICA1.LT.0) THEN
+ I = ICA2
+ ICA2 = ICA1
+ ICA1 = I
+ ENDIF
+ ELSE
+ ICA2 = 0
+ ENDIF
+ IF(IP2.EQ.0) THEN
+ IF(ICB1.LT.0) THEN
+ I = ICB2
+ ICB2 = ICB1
+ ICB1 = I
+ ENDIF
+ ELSE
+ ICB2 = 0
+ ENDIF
+ IC2 = 0
+ IC4 = 0
+C debug output
+ IF(IDEB(26).GE.15)
+ & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
+ & 'PHO_HARCOL: process',MSPR,
+ & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+C
+ IRC = 0
+ IF(IPAMDL(21).EQ.1) THEN
+C
+C soft color re-connection option
+C
+ IF(MSPR.EQ.1) THEN
+C hard g g final state, only g g --> g g
+ IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
+ IF(DT_RNDM(V).LT.PARMDL(140)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C hard q g final state
+ IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
+ IF(DT_RNDM(V).LT.PARMDL(141)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
+C hard q q final state
+ IF(ICA1.NE.-ICB1) THEN
+ IF(DT_RNDM(V).LT.PARMDL(142)) THEN
+ IC1 = ICA1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = ICB2
+ IRECN(MSPR,1) = IRECN(MSPR,1)+1
+ IRC = 1
+ GOTO 100
+ ENDIF
+ ENDIF
+ ENDIF
+ IRECN(MSPR,2) = IRECN(MSPR,2)+1
+ ENDIF
+C
+ IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
+C
+C large Nc limit of all graphs
+C
+ IF(MSPR.EQ.1) THEN
+C g g --> g g
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB2
+ IC3 = ICB1
+ IC4 = ICA2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.2) THEN
+C q qb --> g g
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(ICA1.LT.0) THEN
+ IC1 = I1
+ IC2 = ICA1
+ IC3 = ICB1
+ IC4 = I2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C q g --> q g
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IF(IP1+IP2.GT.0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = ICB2
+ IC3 = ICB1
+ IC4 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB1
+ IC3 = ICA2
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(IP1.GT.0) THEN
+ CALL PHO_HARCOR(-ICA1,ICB2)
+ IC1 = ICA1
+ IC3 = ICB1
+ IC4 = -ICA1
+ ELSE IF(IP2.GT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IC1 = ICA1
+ IC2 = -ICB1
+ IC3 = ICB1
+ ELSE IF(IP1.LT.0) THEN
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ IC1 = ICA1
+ IC3 = -ICA1
+ IC4 = ICB2
+ ELSE IF(IP2.LT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ IC1 = -ICB1
+ IC2 = ICA2
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.4) THEN
+C g g --> q qb
+ IC1 = ICA1
+ IC3 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC3 = ICA2
+ IF(IP3*IC1.LT.0) THEN
+ I = IC1
+ IC1 = IC3
+ IC3 = I
+ ENDIF
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE IF(MSPR.EQ.5) THEN
+C q qb --> q qb
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = -ICA1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = -ICA1
+ ENDIF
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.6) THEN
+C q qb --> qp qbp
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.7) THEN
+C q q --> q q
+ IF(DT_RNDM(V).LT.0.5D0) THEN
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.8) THEN
+C q qp --> q qp
+ IF(IP1*IP2.GT.0) THEN
+ IF(IP3.EQ.IP1) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ENDIF
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IF(ICA1*IP3.LT.0) THEN
+ IC1 = -ICA1
+ IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC3 = -ICA1
+ ENDIF
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+C unknown process
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+C
+ ELSE
+C
+C color flow according to QCD leading order matrix element
+C
+ U = -(1.D0+V)
+ IF(MSPR.EQ.1) THEN
+C g g --> g g
+ PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
+ PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
+ PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
+ XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
+ PCS = 0.D0
+ DO 110 I=1,3
+ PCS = PCS+PC(I)
+ IF(XI.LT.PCS) GOTO 120
+ 110 CONTINUE
+ 120 CONTINUE
+ IF(I.EQ.1) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = I1
+ IC2 = ICA2
+ IC3 = ICB1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC3 = ICA1
+ ELSE
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC4 = ICA2
+ ENDIF
+ ELSE IF(I.EQ.2) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(DT_RNDM(U).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICA2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC1 = ICA1
+ ELSE
+ IC1 = I1
+ IC2 = ICB2
+ IC3 = ICA1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC2 = ICA2
+ ENDIF
+ ELSE
+ IF(DT_RNDM(V).GT.0.5D0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ IC4 = ICB2
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB2
+ IC3 = ICB1
+ IC4 = ICA2
+ ENDIF
+ ENDIF
+ ICONF(MSPR,I) = ICONF(MSPR,I)+1
+ ELSE IF(MSPR.EQ.2) THEN
+C q qb --> g g
+ PC(1) = U/V-2.D0*U**2
+ PC(2) = V/U-2.D0*V**2
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IF(ICA1.GT.0) THEN
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICB1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I1
+ IC2 = ICA1
+ IC3 = ICB1
+ IC4 = I2
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(ICA1.GT.0) THEN
+ IC1 = I1
+ IC2 = ICB1
+ IC3 = ICA1
+ IC4 = I2
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = ICB1
+ IC2 = I2
+ IC3 = I1
+ IC4 = ICA1
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.3) THEN
+C q g --> q g
+ PC(1) = 2.D0*(U/V)**2-U
+ PC(2) = 2.D0/V**2-1.D0/U
+ XI = (PC(1)+PC(2))*DT_RNDM(V)
+ IF(XI.LT.PC(1)) THEN
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP1.GT.0) THEN
+ IC1 = I1
+ IC3 = ICB1
+ IC4 = I2
+ CALL PHO_HARCOR(-ICA1,ICB2)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = I2
+ IC3 = I1
+ IC4 = ICB2
+ CALL PHO_HARCOR(-ICA1,ICB1)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE IF(IP2.GT.0) THEN
+ IC1 = ICA1
+ IC2 = I2
+ IC3 = I1
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ELSE
+ IC1 = I1
+ IC2 = ICA2
+ IC3 = I2
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP1.GT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ IC4 = ICB2
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE IF(IP1.LT.0) THEN
+ IC1 = ICB2
+ IC3 = ICB1
+ IC4 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE IF(IP2.GT.0) THEN
+ IC1 = ICB1
+ IC2 = ICA2
+ IC3 = ICA1
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ELSE
+ IC1 = ICA1
+ IC2 = ICB1
+ IC3 = ICA2
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.4) THEN
+C g g --> q qb
+ PC(1) = U/V-2.D0*U**2
+ PC(2) = V/U-2.D0*V**2
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IF(IP3.GT.0) THEN
+ IC1 = ICA1
+ IC3 = ICB2
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC3 = ICA2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA2
+ IC3 = ICB1
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC3 = ICA1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP3.GT.0) THEN
+ IC1 = ICB1
+ IC3 = ICA2
+ CALL PHO_HARCOR(-ICB2,ICA1)
+ IF(ICB1.EQ.-ICB2) IC1 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = ICB2
+ IC3 = ICA1
+ CALL PHO_HARCOR(-ICB1,ICA2)
+ IF(ICB2.EQ.-ICB1) IC1 = ICA2
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.5) THEN
+C q qb --> q qb
+ PC(1) = (1.D0+U**2)/V**2
+ PC(2) = (V**2+U**2)
+ XI = (PC(1)+PC(2))*DT_RNDM(V)
+ IF(XI.LT.PC(1)) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP3.GT.0) THEN
+ IC1 = I1
+ IC3 = I2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I2
+ IC3 = I1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IF(IP3.GT.0) THEN
+ IC1 = MAX(ICA1,ICB1)
+ IC3 = MIN(ICA1,ICB1)
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ELSE
+ IC1 = MIN(ICA1,ICB1)
+ IC3 = MAX(ICA1,ICB1)
+ ICONF(MSPR,4) = ICONF(MSPR,4)+1
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.EQ.6) THEN
+C q qb --> qp qpb
+ IF(IP3.GT.0) THEN
+ IC1 = MAX(ICA1,ICB1)
+ IC3 = MIN(ICA1,ICB1)
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = MIN(ICA1,ICB1)
+ IC3 = MAX(ICA1,ICB1)
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.7) THEN
+C q q --> q q
+ PC(1) = (1.D0+U**2)/V**2
+ PC(2) = (1.D0+V**2)/U**2
+ XI = (PC(1)+PC(2))*DT_RNDM(U)
+ IF(XI.LT.PC(1)) THEN
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = ICA1
+ IC3 = ICB1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE IF(MSPR.EQ.8) THEN
+C q qp --> q qp
+ IF(IP1*IP2.LT.0) THEN
+ CALL PHO_HARCOR(-ICB1,ICA1)
+ CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
+ IF(IP1.GT.0) THEN
+ IC1 = I1
+ IC3 = I2
+ ICONF(MSPR,1) = ICONF(MSPR,1)+1
+ ELSE
+ IC1 = I2
+ IC3 = I1
+ ICONF(MSPR,2) = ICONF(MSPR,2)+1
+ ENDIF
+ ELSE
+ IC1 = ICB1
+ IC3 = ICA1
+ ICONF(MSPR,3) = ICONF(MSPR,3)+1
+ ENDIF
+
+ ELSE IF(MSPR.EQ.10) THEN
+C gam q --> q g
+ CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
+ IF(IP3.EQ.0) THEN
+ CALL PHO_SWAPI(IC1,IC3)
+ CALL PHO_SWAPI(IC2,IC4)
+ ENDIF
+ ELSE IF(MSPR.EQ.11) THEN
+C gam g --> q q
+ IC1 = ICB1
+ IC3 = ICB2
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ELSE IF(MSPR.EQ.12) THEN
+C q gam --> q g
+ CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
+ IF(IP3.EQ.0) THEN
+ CALL PHO_SWAPI(IC1,IC3)
+ CALL PHO_SWAPI(IC2,IC4)
+ ENDIF
+ ELSE IF(MSPR.EQ.13) THEN
+C g gam --> q q
+ IC1 = ICA1
+ IC3 = ICA2
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ELSE IF(MSPR.EQ.14) THEN
+ IF(ABS(IP3).GT.12) THEN
+ IC1 = 0
+ IC3 = 0
+ ELSE
+ CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
+ IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
+ ENDIF
+ ELSE
+C unknown process
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARCOL:ERROR:invalid process number',MSPR
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+ 100 CONTINUE
+C debug output
+ IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
+ & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
+C color connection?
+* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
+* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
+* & .OR.(IC2.EQ.0))) THEN
+C color exchange?
+* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
+* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
+* IF(IRC.NE.1) THEN
+* WRITE(LO,'(1X,A,I10,I3)')
+* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
+* ENDIF
+* IRC = 0
+* ENDIF
+* ENDIF
+* IF(IRC.EQ.1) THEN
+* WRITE(LO,'(1X,A,I10,I3)')
+* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
+* WRITE(LO,'(5X,A,3I5,2X,3I5)')
+* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
+* ENDIF
+C
+ ICC1 = IC1
+ ICC2 = IC2
+ ICD1 = IC3
+ ICD2 = IC4
+
+ END
+
+CDECK ID>, PHO_HARCOR
+ SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
+C***********************************************************************
+C
+C substituite color in /POEVT2/
+C
+C input: ICOLD old color
+C ICNEW new color
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+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)
+
+ DO 100 I=NHEP,3,-1
+ IF(ISTHEP(I).EQ.-1) THEN
+ IF(ICOLOR(1,I).EQ.ICOLD) THEN
+ ICOLOR(1,I) = ICNEW
+ RETURN
+ ELSE IF(IDHEP(I).EQ.21) THEN
+ IF(ICOLOR(2,I).EQ.ICOLD) THEN
+ ICOLOR(2,I) = ICNEW
+ RETURN
+ ENDIF
+ ENDIF
+* ELSE IF(ISTHEP(I).EQ.20) THEN
+* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
+* print LO,' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
+* ICOLOR(1,I) = -ICNEW
+* RETURN
+* ELSE IF(IDHEP(I).EQ.21) THEN
+* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
+* print LO,' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
+* ICOLOR(2,I) = -ICNEW
+* RETURN
+* ENDIF
+* ENDIF
+ ENDIF
+ 100 CONTINUE
+ END
+
+CDECK ID>, PHO_HARREM
+ SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
+ & IUSED,IREJ)
+C***********************************************************************
+C
+C sample color structure for initial quark/gluon of hard scattering
+C and write hadron remnant to /POEVT1/
+C
+C input: JM1,2 index of mother particle in POEVT1
+C IGEN mother particle production process
+C IHPOS hard pomeron number
+C INDXH index of hard parton
+C positive for labels 1
+C negative for labels 2
+C IVAL 1 hard valence parton
+C 0 hard sea parton connected by color flow with
+C valence quarks
+C -1 hard sea parton independent off valence
+C quarks
+C INDXS index of soft partons needed
+C
+C output: IC1,IC2 color label of initial parton
+C IUSED number of soft X values used
+C IREJ rejection flag
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IREJ = 0
+
+ INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
+
+ IF(INDXH.GT.0) THEN
+ IJH = IPHO_CNV1(NINHD(INDXH,1))
+ ELSE
+ IJH = IPHO_CNV1(NINHD(-INDXH,2))
+ ENDIF
+C direct process (photon or pomeron)
+ IUSED = 0
+ IC1 = 0
+ IC2 = 0
+ IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
+
+ IHP = 100*ABS(IHPOS)
+ IVSW = 1
+***************************************
+* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
+***************************************
+
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
+ & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
+ & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
+
+C quark
+C****************************************************************
+
+ IF(IJH.NE.21) THEN
+
+C valence quark engaged in hard scattering
+ IF(IVAL.EQ.1) THEN
+ CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
+ IF(IREJ.NE.0) THEN
+ WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
+ & 'invalid valence flavour requested JM,IFLA',JM1,IJH
+ return
+ ENDIF
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
+ & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IREM
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IREM
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IREM,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 1
+
+C sea quark engaged in hard scattering, valence quarks treated
+ ELSE IF(IVAL.EQ.0) THEN
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(DT_RNDM(P1).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ENDIF
+ IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
+ & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IVFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IVFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IVFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IVFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IVFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+C
+ IF(IJH.LT.0) THEN
+ ICB1 = ICC2
+ ICA1 = ICC1
+ ELSE
+ ICB1 = ICC1
+ ICA1 = ICC2
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+2)
+ P2 = PSOFT1(2,INDXS+2)
+ P3 = PSOFT1(3,INDXS+2)
+ P4 = PSOFT1(4,INDXS+2)
+ IJSI1(INDXS+2) = -IJH
+ ELSE
+ P1 = PSOFT2(1,INDXS+2)
+ P2 = PSOFT2(2,INDXS+2)
+ P3 = PSOFT2(3,INDXS+2)
+ P4 = PSOFT2(4,INDXS+2)
+ IJSI2(INDXS+2) = -IJH
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & -IJH,IPOS,SIGN(INDXS+2,INDXH)
+ IUSED = 3
+C
+C sea quark engaged in hard scattering, valences treated separately
+ ELSE IF(IVAL.EQ.-1) THEN
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(IJH.GT.0) THEN
+ ICC1 = ICB1
+ ICB1 = ICA1
+ ICA1 = ICC1
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = -IJH
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = -IJH
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & -IJH,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 1
+ ELSE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
+ & IVAL,IJH
+ CALL PHO_ABORT
+ ENDIF
+C
+ IC1 = ICB1
+ IC2 = 0
+C
+C gluon
+C****************************************************************
+C
+C gluon from valence quarks
+ ELSE
+ IF(IVAL.EQ.1) THEN
+C purely gluonic pomeron remnant
+ IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
+ IJSI1(INDXS) = 0
+ ELSE
+ P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
+ IJSI2(INDXS) = 0
+ ENDIF
+ IFL1 = 21
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(DT_RNDM(P2).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,ICB1,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+ IUSED = 2
+C valence quark remnant
+ ELSE
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P2).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+ IUSED = 2
+ ENDIF
+C
+C gluon from sea quarks connected with valence quarks
+ ELSE IF(IVAL.EQ.0) THEN
+ IF(INDXH.GT.0) THEN
+ E1 = PSOFT1(4,INDXS)
+ E2 = PSOFT1(4,INDXS+1)
+ ELSE
+ E1 = PSOFT2(4,INDXS)
+ E2 = PSOFT2(4,INDXS+1)
+ ENDIF
+ CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P3).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remnant of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+1)
+ P2 = PSOFT1(2,INDXS+1)
+ P3 = PSOFT1(3,INDXS+1)
+ P4 = PSOFT1(4,INDXS+1)
+ IJSI1(INDXS+1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+1)
+ P2 = PSOFT2(2,INDXS+1)
+ P3 = PSOFT2(3,INDXS+1)
+ P4 = PSOFT2(4,INDXS+1)
+ IJSI2(INDXS+1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,IVSW,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+1,INDXH)
+
+ IF(IPAMDL(18).EQ.0) THEN
+C sea quark pair
+ CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
+ IF(ICC1.GT.0) THEN
+ IFL1 = ABS(IFL1)
+ IFL2 = -IFL1
+ ELSE
+ IFL1 = -ABS(IFL1)
+ IFL2 = -IFL1
+ ENDIF
+ IF(DT_RNDM(P4).LT.0.5D0) THEN
+ ICB1 = ICC2
+ CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ ICA1 = ICC1
+ CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+2)
+ P2 = PSOFT1(2,INDXS+2)
+ P3 = PSOFT1(3,INDXS+2)
+ P4 = PSOFT1(4,INDXS+2)
+ IJSI1(INDXS+2) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS+2)
+ P2 = PSOFT2(2,INDXS+2)
+ P3 = PSOFT2(3,INDXS+2)
+ P4 = PSOFT2(4,INDXS+2)
+ IJSI2(INDXS+2) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS+2,INDXH)
+
+C
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS+3)
+ P2 = PSOFT1(2,INDXS+3)
+ P3 = PSOFT1(3,INDXS+3)
+ P4 = PSOFT1(4,INDXS+3)
+ IJSI1(INDXS+3) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS+3)
+ P2 = PSOFT2(2,INDXS+3)
+ P3 = PSOFT2(3,INDXS+3)
+ P4 = PSOFT2(4,INDXS+3)
+ IJSI2(INDXS+3) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,0,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS+3,INDXH)
+
+ IUSED = 4
+ ELSE
+ IUSED = 2
+ ENDIF
+C
+C gluon from independent sea quarks
+ ELSE IF(IVAL.EQ.-1) THEN
+ IF(IPAMDL(18).EQ.0) THEN
+ CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
+ CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
+ IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
+ & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
+ I = ICA1
+ ICA1 = ICB1
+ ICB1 = I
+ ENDIF
+ IF(DT_RNDM(P1).LT.0.5D0) THEN
+ CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
+ ELSE
+ CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
+ ENDIF
+C remainder of hadron
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS)
+ P2 = PSOFT1(2,INDXS)
+ P3 = PSOFT1(3,INDXS)
+ P4 = PSOFT1(4,INDXS)
+ IJSI1(INDXS) = IFL1
+ ELSE
+ P1 = PSOFT2(1,INDXS)
+ P2 = PSOFT2(2,INDXS)
+ P3 = PSOFT2(3,INDXS)
+ P4 = PSOFT2(4,INDXS)
+ IJSI2(INDXS) = IFL1
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICA1,ICA2,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL1,IPOS,SIGN(INDXS,INDXH)
+
+C remnant of sea
+ IF(INDXH.GT.0) THEN
+ P1 = PSOFT1(1,INDXS-1)
+ P2 = PSOFT1(2,INDXS-1)
+ P3 = PSOFT1(3,INDXS-1)
+ P4 = PSOFT1(4,INDXS-1)
+ IJSI1(INDXS-1) = IFL2
+ ELSE
+ P1 = PSOFT2(1,INDXS-1)
+ P2 = PSOFT2(2,INDXS-1)
+ P3 = PSOFT2(3,INDXS-1)
+ P4 = PSOFT2(4,INDXS-1)
+ IJSI2(INDXS-1) = IFL2
+ ENDIF
+C registration
+ CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
+ & IHP,IGEN,ICB1,ICB2,IPOS,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
+ & IFL2,IPOS,SIGN(INDXS-1,INDXH)
+
+ IUSED = 2
+ ELSE
+ CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
+ IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
+ & 'PHO_HARREM: no spectator added:(INDXS)',
+ & SIGN(INDXS,INDXH)
+ IUSED = 0
+ ENDIF
+C
+ ELSE
+ WRITE(LO,'(1X,A,2I5)')
+ & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
+ & IVAL,IJH
+ CALL PHO_ABORT
+ ENDIF
+ IC1 = ICC1
+ IC2 = ICC2
+ ENDIF
+ END
+
+CDECK ID>, PHO_HARDIR
+ SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
+ & IREJ)
+C**********************************************************************
+C
+C parton orientated formulation of direct scattering processes
+C
+C input:
+C
+C output: II particle combination (1..4)
+C IVAL1,2 0 no valence quarks engaged
+C 1 valence quarks engaged
+C MSPAR1,2 number of realized soft partons
+C MHPAR1,2 number of realized hard partons
+C IREJ 1 failure
+C 0 success
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+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 data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4),PD1(-6:6)
+
+ PARAMETER ( TINY = 1.D-10 )
+
+ ITRY = 0
+ NTRY = 10
+ LSC1HD = 0
+ LSIDX(1) = 1
+
+C check phase space
+ IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
+ IFAIL(18) = IFAIL(18)+1
+ IREJ = 50
+ RETURN
+ ENDIF
+
+ AS = (PARMDL(160+II)/ECMP)**2
+ AH = (2.D0*PTWANT/ECMP)**2
+
+ ALNS = LOG(AS)
+ ALNH = LOG(AH)
+
+ XMAX = MAX(TINY,1.D0-AS)
+ Z1MAX = LOG(XMAX)
+ Z1DIF = Z1MAX-ALNH
+C
+C main loop to select hard and soft parton kinematics
+C -----------------------------------------------------
+ 120 CONTINUE
+ IREJ = 0
+ ITRY = ITRY+1
+ LSC1HD = LSC1HD+1
+ IF(ITRY.GT.1) THEN
+ IFAIL(17) = IFAIL(17)+1
+ IF(ITRY.GE.NTRY) THEN
+ IREJ = 1
+ GOTO 450
+ ENDIF
+ ENDIF
+ LINE = 0
+ LSCAHD = 0
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ MSPAR1 = 0
+ MSPAR2 = 0
+
+C select hard V,X
+ CALL PHO_HARSCA(1,II)
+ XSS1 = XSS1+X1
+ XSS2 = XSS2+X2
+C debug output
+ IF(IDEB(25).GE.20) THEN
+ WRITE(LO,'(1X,A,2E12.4,2I5)')
+ & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
+ & AS,XMAX,MSPR,ITRY
+ WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
+ & X1,X2,XSS1,XSS2
+ ENDIF
+
+ IF(MSPR.LE.11) THEN
+ IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
+ ELSE IF(MSPR.LE.13) THEN
+ IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
+ ENDIF
+
+C fill /POHSLT/
+ LSCAHD = 1
+ LSIDX(1) = 1
+ XHD(1,1) = X1
+ XHD(1,2) = X2
+ X0HD(1,1) = X1
+ X0HD(1,2) = X2
+ VHD(1) = V
+ ETAHD(1,1) = ETAC
+ ETAHD(1,2) = ETAD
+ PTHD(1) = PT
+ Q2SCA(1,1) = QQPD
+ Q2SCA(1,2) = QQPD
+ NPROHD(1) = MSPR
+ NBRAHD(1,1)= IDPDG1
+ NBRAHD(1,2)= IDPDG2
+ DO 45 I=1,4
+ PPH(I,1) = PHI1(I)
+ PPH(I,2) = PHI2(I)
+ PPH(4+I,1) = PHO1(I)
+ PPH(4+I,2) = PHO2(I)
+ 45 CONTINUE
+C valence quarks
+ IVAL1 = IV1
+ IVAL2 = IV2
+ PDFVA(1,1) = 0.D0
+ PDFVA(1,2) = 0.D0
+C parton flavours
+ IF(MSPR.LE.11) THEN
+ NINHD(1,1) = IDPDG1
+ NINHD(1,2) = IB
+ PDFVA(1,2) = PDF2(IB)
+ KHDIR = 1
+ ELSE IF(MSPR.LE.13) THEN
+ NINHD(1,1) = IA
+ PDFVA(1,1) = PDF1(IA)
+ NINHD(1,2) = IDPDG2
+ KHDIR = 2
+ ELSE
+ NINHD(1,1) = IDPDG1
+ NINHD(1,2) = IDPDG2
+ KHDIR = 3
+ ENDIF
+ N0INHD(1,1) = NINHD(1,1)
+ N0INHD(1,2) = NINHD(1,2)
+ N0IVAL(1,1) = IVAL1
+ N0IVAL(1,2) = IVAL2
+ NOUTHD(1,1) = IC
+ NOUTHD(1,2) = ID
+
+C reweight according to photon virtuality
+ IF(MSPR.NE.14) THEN
+ IF(IPAMDL(115).GE.1) THEN
+ WGX = 1.D0
+ IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
+ QQPD = Q2SCA(1,2)
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
+ WGX = 0.D0
+ ELSE
+ WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
+ WGX = PD1(IB)/PDFVA(1,2)
+ ENDIF
+ ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
+ & .AND.(IDPDG1.EQ.22)) THEN
+ QQPD = Q2SCA(1,1)
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
+ WGX = 0.D0
+ ELSE
+ WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
+ WGX = PD1(IA)/PDFVA(1,1)
+ ENDIF
+ ENDIF
+
+ IF(IDEB(25).GE.25)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
+ & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
+
+ IF(WGX.LT.DT_RNDM(WGX)) THEN
+ IREJ = 50
+ RETURN
+ ENDIF
+
+ IF(WGX.GT.1.01D0)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
+ & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
+
+ ENDIF
+ ENDIF
+
+C generate ISR
+ IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
+ IF(IPAMDL(109).EQ.1) THEN
+ Q2H = PARMDL(93)*PT**2
+ ELSE
+ Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
+ ENDIF
+ XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
+ XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
+ DO 42 J=1,4
+ P1(J) = PPH(4+J,1)
+ P2(J) = PPH(4+J,2)
+ 42 CONTINUE
+ CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
+ & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
+ & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
+ XSS1 = XSS1+XISR1-XHD(1,1)
+ XSS2 = XSS2+XISR2-XHD(1,2)
+ NINHD(1,1) = IFL1
+ NINHD(1,2) = IFL2
+ XHD(1,1) = XISR1
+ XHD(1,2) = XISR2
+ ELSE
+ IFL1 = NINHD(1,1)
+ IFL2 = NINHD(1,2)
+ ENDIF
+ NIVAL(1,1) = IVAL1
+ NIVAL(1,2) = IVAL2
+
+C add photon/hadron remnant
+
+C incoming gluon
+ IF(IFL2.EQ.0) THEN
+ XMAXX = 1.D0 - XSS2 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
+ IVAL2 = 1
+ MSPAR1 = 0
+ MSPAR2 = 2
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE IF(IFL1.EQ.0) THEN
+ XMAXX = 1.D0 - XSS1 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
+ IVAL1 = 1
+ MSPAR1 = 2
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+
+C incoming quark
+ ELSE IF(ABS(IFL2).LE.12) THEN
+ IF(IVAL2.EQ.1) THEN
+ XS2(1) = 1.D0 - XSS2
+ MSPAR1 = 0
+ MSPAR2 = 1
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE
+ XMAXX = 1.D0 - XSS2 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
+ MSPAR1 = 0
+ MSPAR2 = 3
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ENDIF
+ ELSE IF(ABS(IFL1).LE.12) THEN
+ IF(IVAL1.EQ.1) THEN
+ XS1(1) = 1.D0 - XSS1
+ MSPAR1 = 1
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ELSE
+ XMAXX = 1.D0 - XSS1 - AS
+ XMAXH = MIN(XMAXX,PARMDL(44))
+ CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
+ MSPAR1 = 3
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+ ENDIF
+
+C double direct process
+ ELSE IF(MSPR.EQ.14) THEN
+ MSPAR1 = 0
+ MSPAR2 = 0
+ MHPAR1 = 1
+ MHPAR2 = 1
+
+C unknown process
+ ELSE
+ WRITE(LO,'(/1X,A,I3/)')
+ & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
+ GOTO 120
+ ENDIF
+
+C soft particle momenta
+ IF(MSPAR1.GT.0) THEN
+ DO 50 I=1,MSPAR1
+ PSOFT1(1,I) = 0.D0
+ PSOFT1(2,I) = 0.D0
+ PSOFT1(3,I) = XS1(I)*ECMP/2.D0
+ PSOFT1(4,I) = XS1(I)*ECMP/2.D0
+ 50 CONTINUE
+ ENDIF
+ IF(MSPAR2.GT.0) THEN
+ DO 55 I=1,MSPAR2
+ PSOFT2(1,I) = 0.D0
+ PSOFT2(2,I) = 0.D0
+ PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
+ PSOFT2(4,I) = XS2(I)*ECMP/2.D0
+ 55 CONTINUE
+ ENDIF
+C process counting
+ MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
+ KSOFT = MAX(MSPAR1,MSPAR2)
+ KHARD = MAX(MHPAR1,MHPAR2)
+C debug output
+ IF(IDEB(25).GE.10) THEN
+ WRITE(LO,'(/1X,A,2I3,3I5)')
+ & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
+ & IVAL1,IVAL2,MSPR,ITRY,NTRY
+ IF(MSPAR1.GT.0) THEN
+ WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
+ DO 105 I=1,MSPAR1
+ WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
+ 105 CONTINUE
+ ENDIF
+ IF(MSPAR2.GT.0) THEN
+ WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
+ DO 106 I=1,MSPAR2
+ WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
+ 106 CONTINUE
+ ENDIF
+ WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
+ WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
+ WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
+ WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
+ WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
+ WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
+ WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
+ WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
+ ENDIF
+ RETURN
+
+ 450 CONTINUE
+ IFAIL(16) = IFAIL(16)+1
+ IF(IDEB(25).GE.2) THEN
+ WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
+ WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
+ IF(IDEB(25).GE.5) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_POMSCA
+ SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
+ & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
+C**********************************************************************
+C
+C parton orientated formulation of soft and hard inelastic events
+C
+C
+C input: II particle combiantion (1..4)
+C MSPOM number of soft pomerons
+C MHPOM number of semihard pomerons
+C MSREG number of soft reggeons
+C
+C output: IVAL1,2 0 no valence quark engaged
+C otherwise: position of valence quark engaged
+C neg.number: gluon connected to valence quark
+C by color flow
+C MSPAR1,2 number of realized soft partons
+C MHPAR1,2 number of realized hard partons
+C IREJ 1 failure
+C 0 success
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (TINY = 1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+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 hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ DIMENSION P1(4),P2(4),PD1(-6:6)
+
+ IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
+
+ ITRY = 0
+ NTRY = 10
+ IREJ = 0
+ INMAX = 10
+ MHARD = MHPOM
+
+C phase space limitation (single hard valence-valence quark scattering)
+ IF(MHPOM.GT.0) THEN
+ Emin = 2.D0*PTWANT + 0.2D0
+ IF(ECMP.LT.Emin) THEN
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
+ & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ SAS = PARMDL(160+II)/ECMP
+ SAH = 2.D0*PTWANT/ECMP
+ AS = SAS**2
+ AH = SAH**2
+
+C save energy for leading particle effect
+ XMAXP1 = 1.D0
+ if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
+ XMAXP2 = 1.D0
+ if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
+
+C
+C main loop to select hard and soft parton kinematics
+C -----------------------------------------------------
+ IFAIL(31) = IFAIL(31)+MHARD
+ 20 CONTINUE
+ IREJ = 0
+ IHARD = 0
+ LSC1HD = 0
+ ITRY = ITRY+1
+ IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
+ IF(ITRY.GE.NTRY) THEN
+ IREJ = 1
+ GOTO 450
+ ENDIF
+ LINE = 0
+ LSCAHD = 0
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
+ XSS1 = MAX(0.D0,1.D0-XPSUB)
+ XSS2 = MAX(0.D0,1.D0-XTSUB)
+ ELSE
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ ENDIF
+ 22 continue
+
+C partons needed to construct soft/hard interactions
+ MSPAR1 = 2*MSPOM+MSREG+MHPOM
+ MSPAR2 = MSPAR1
+ MHPAR1 = MHPOM
+ MHPAR2 = MHPOM
+
+C number of strings
+ MSCHA = 2*MSPOM+MSREG
+ MHCHA = 2*MHPOM
+
+ KSOFT = MSCHA
+ KHARD = MHCHA
+
+C check actual phase space limit
+ XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
+ IF(XX.GE.1.D0) THEN
+ IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
+ & 'PHO_POMSCA: internal kin. rejection ',
+ & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
+ & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
+ if(MSPOM+MSREG+MHPOM.gt.1) then
+ if(MSREG.gt.0) then
+ MSREG = MSREG-1
+ else if(MSPOM.gt.0) THEN
+ MSPOM = MSPOM-1
+ else if(MHPOM.gt.1) then
+ MHPOM = MHPOM-1
+ endif
+ goto 22
+ endif
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
+ & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ ENDIF
+
+ XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
+ XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
+
+C very low energy phase space restriction
+ if(MHARD.gt.0) then
+ if((XMAXX1*XMAXX2.le.AH)) then
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
+ & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
+ IREJ = 50
+ IFAIL(6) = IFAIL(6) + 1
+ RETURN
+ endif
+ endif
+
+ AS = MAX(AS,PSOMIN/PCMP)
+ ALNS = LOG(AS)
+ ALNH = LOG(AH)
+ Z1MAX = LOG(XMAXX1)
+ Z2MAX = LOG(XMAXX2)
+ Z1DIF = Z1MAX+Z2MAX-ALNH
+ Z2DIF = Z1DIF
+ PTMAX = 0.D0
+C
+C select hard parton momenta
+C ------------------- begin of inner loop -------------------
+ IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
+
+ IF(MHARD.GT.MSCAHD) THEN
+ WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
+ & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ DO 11 NN=1,MHARD
+C
+C generate one resolved hard scattering
+C
+C high-pt option
+ IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
+ CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM)
+ XSCUT = HSig(9)
+ AHS = AH
+ ALNHS = ALNH
+ Z1DIFS = Z1DIF
+ Z2DIFS = Z2DIF
+ AH = (2.D0*PTWANT/ECMP)**2
+ ALNH = LOG(AH)
+ Z1DIF = Z1MAX+Z2MAX-ALNH
+ Z2DIF = Z1DIF
+ IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
+ IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
+ & 'PHO_POMSCA: kin.rejection, high-pt option ',
+ & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
+ IREJ = 5
+ RETURN
+ ENDIF
+ CALL PHO_HARSCA(2,II)
+ CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
+ & -1,Max_pro_2,1,4,MSPOM+MHPOM)
+ AH = AHS
+ ALNH = ALNHS
+ Z1DIF = Z1DIFS
+ Z2DIF = Z2DIFS
+ IPOWGC(4+II) = IPOWGC(4+II)+1
+ HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
+C minimum bias option
+ ELSE
+ CALL PHO_HARSCA(2,II)
+ ENDIF
+
+C fill /POHSLT/
+ LSIDX(NN) = NN
+ LSCAHD = NN
+ XHD(NN,1) = X1
+ XHD(NN,2) = X2
+ X0HD(NN,1) = X1
+ X0HD(NN,2) = X2
+ VHD(NN) = V
+ ETAHD(NN,1) = ETAC
+ ETAHD(NN,2) = ETAD
+ PTHD(NN) = PT
+ NPROHD(NN) = MSPR
+ Q2SCA(NN,1) = QQPD
+ Q2SCA(NN,2) = QQPD
+ PDFVA(NN,1) = PDF1(IA)
+ PDFVA(NN,2) = PDF2(IB)
+ NINHD(NN,1) = IA
+ NINHD(NN,2) = IB
+ N0INHD(NN,1) = IA
+ N0INHD(NN,2) = IB
+ NIVAL(NN,1) = IV1
+ NIVAL(NN,2) = IV2
+ N0IVAL(NN,1) = IV1
+ N0IVAL(NN,2) = IV2
+ NOUTHD(NN,1) = IC
+ NOUTHD(NN,2) = ID
+ NBRAHD(NN,1) = IDPDG1
+ NBRAHD(NN,2) = IDPDG2
+ I3 = 8*(NN-1)
+ I4 = 8*(NN-1)+4
+ DO 50 I=1,4
+ PPH(I3+I,1) = PHI1(I)
+ PPH(I3+I,2) = PHI2(I)
+ PPH(I4+I,1) = PHO1(I)
+ PPH(I4+I,2) = PHO2(I)
+ 50 CONTINUE
+
+ 11 CONTINUE
+
+C sort according to pt-hat
+ DO 12 NN=1,MHARD
+ PTMX = PTHD(LSIDX(NN))
+ IPTM = NN
+ DO 13 I=NN+1,MHARD
+ IF(PTHD(LSIDX(I)).GT.PTMX) THEN
+ IPTM = I
+ PTMX = PTHD(LSIDX(I))
+ ENDIF
+ 13 CONTINUE
+ IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
+ 12 CONTINUE
+ IPTM = LSIDX(1)
+
+C copy partons, generate ISR
+ DO 15 L=1,MHARD
+ NN = LSIDX(L)
+ XSSS1 = XSS1+XHD(NN,1)
+ XSSS2 = XSS2+XHD(NN,2)
+C debug output
+ IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
+ & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
+ & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
+C check phase space
+ IF( (XSSS1.GT.XMAXX1)
+ & .OR.(XSSS2.GT.XMAXX2)
+ & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
+ IF(IHARD.EQ.0) THEN
+ IF(ISWMDL(2).NE.1) GOTO 20
+ MHPOM = 0
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ GOTO 199
+ ENDIF
+
+C reweight according to photon virtuality
+ IF(IPAMDL(115).GE.1) THEN
+ QQPD = Q2SCA(NN,1)
+ WGX = 1.D0
+ IF(IDPDG1.EQ.22) THEN
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
+ WG1 = 0.D0
+ ELSE
+ WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
+ WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
+ ENDIF
+ WGX = WG1
+ ENDIF
+ QQPD = Q2SCA(NN,2)
+ IF(IDPDG2.EQ.22) THEN
+ IF(IPAMDL(115).EQ.1) THEN
+ IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
+ WG1 = 0.D0
+ ELSE
+ WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
+ & /LOG(QQPD/PARMDL(144))
+ ENDIF
+ IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
+ ELSE IF(IPAMDL(115).EQ.2) THEN
+ CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
+ WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
+ ENDIF
+ WGX = WGX*WG1
+ ENDIF
+
+ IF(IDEB(24).GE.25)
+ & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
+ & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
+
+ IF(WGX.LT.DT_RNDM(WGX)) THEN
+ IF(L.EQ.1) THEN
+ IREJ = 50
+ RETURN
+ ELSE
+ GOTO 199
+ ENDIF
+ ENDIF
+
+ IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
+ & 'PHO_POMSCA: ',
+ & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
+ & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
+
+ ENDIF
+
+C generate ISR
+ IF((ISWMDL(8).GE.2)
+ & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
+ IF(IPAMDL(109).EQ.1) THEN
+ Q2H = PARMDL(93)*PTHD(NN)**2
+ ELSE
+ Q2H = -PARMDL(93)*VHD(NN)
+ & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
+ ENDIF
+ XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
+ XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
+ I3 = 8*NN-4
+ DO 42 J=1,4
+ P1(J) = PPH(I3+J,1)
+ P2(J) = PPH(I3+J,2)
+ 42 CONTINUE
+ IF(IDEB(24).GE.10)
+ & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
+ & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
+ & L,NN,XHD(NN,1),XHD(NN,2),Q2H
+ J = NN
+ IF(L.EQ.1) J = -NN
+ CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
+ & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
+ & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
+ & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
+ XSSS1 = XSSS1+XISR1-XHD(NN,1)
+ XSSS2 = XSSS2+XISR2-XHD(NN,2)
+ NINHD(NN,1) = IFL1
+ NINHD(NN,2) = IFL2
+ XHD(NN,1) = XISR1
+ XHD(NN,2) = XISR2
+ ENDIF
+
+C check phase space
+ IF( (XSSS1.GT.XMAXX1)
+ & .OR.(XSSS2.GT.XMAXX2)
+ & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
+ IF(IHARD.EQ.0) THEN
+ IF(ISWMDL(2).NE.1) GOTO 20
+ MHPOM = 0
+ MSPOM = 1
+ MSREG = 0
+ ENDIF
+ GOTO 199
+ ENDIF
+
+C leave energy for leading particle effect
+ IF((IHARD.GT.0).AND.
+ & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
+ GOTO 199
+ endif
+
+C hard scattering accepted
+ IHARD = IHARD+1
+ XSS1 = XSSS1
+ XSS2 = XSSS2
+ IFAIL(31) = IFAIL(31)-1
+
+ 15 CONTINUE
+
+C ------------------- end of inner (hard) loop -------------------
+ 199 CONTINUE
+
+ MHPOM = IHARD
+ MHPAR1 = IHARD
+ MHPAR2 = IHARD
+
+C count valences involved in hard scattering
+ IVAL1 = 0
+ IVAL2 = 0
+ DO 17 L=1,IHARD
+ NN = LSIDX(L)
+ IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
+ IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
+ 17 CONTINUE
+
+ IQUA1 = 0
+ IQUA2 = 0
+ IVGLU1 = 0
+ IVGLU2 = 0
+ DO 18 L=1,IHARD
+ NN = LSIDX(L)
+
+C photon, pomeron valences
+ IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ NIVAL(NN,1) = 1
+ IVAL1 = NN
+ ENDIF
+ ENDIF
+ IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ NIVAL(NN,2) = 1
+ IVAL2 = NN
+ ENDIF
+ ENDIF
+
+C total number of quarks
+ IF(NINHD(NN,1).NE.0) THEN
+ IQUA1 = IQUA1+1
+ ELSE IF(IVGLU1.EQ.0) THEN
+ IVGLU1 = NN
+ ENDIF
+ IF(NINHD(NN,2).NE.0) THEN
+ IQUA2 = IQUA2+1
+ ELSE IF(IVGLU2.EQ.0) THEN
+ IVGLU2 = NN
+ ENDIF
+ 18 CONTINUE
+
+C gluons emitted by valence quarks
+ VALPRO = 1.D0
+ IF(II.EQ.1) VALPRO = VALPRG(1)
+ IVQ1 = 1
+ IVG1 = 0
+ IVAL1 = MAX(IVAL1,0)
+ IF(IVAL1.EQ.0) THEN
+ IVQ1 = 0
+ IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
+ IVAL1 = -IVGLU1
+ IVG1 = 1
+ ENDIF
+ ENDIF
+ VALPRO = 1.D0
+ IF(II.EQ.1) VALPRO = VALPRG(2)
+ IVQ2 = 1
+ IVG2 = 0
+ IVAL2 = MAX(IVAL2,0)
+ IF(IVAL2.EQ.0) THEN
+ IVQ2 = 0
+ IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
+ IVAL2 = -IVGLU2
+ IVG2 = 1
+ ENDIF
+ ENDIF
+ MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
+C debug output
+ IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
+ & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
+ & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
+
+C select soft X values
+ 25 CONTINUE
+C number of soft/remnant quarks
+ IF(MSPOM.EQ.0) THEN
+ IF(IPAMDL(18).EQ.0) THEN
+ MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
+ MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
+ ELSE
+ MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
+ MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
+ ENDIF
+ ELSE
+ IF(IPAMDL(18).EQ.0) THEN
+ MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
+ MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
+ ELSE
+ MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
+ MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
+ ENDIF
+ ENDIF
+C debug output
+ IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
+ & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
+ & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
+
+ XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
+ XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
+ I1 = IVQ1
+ I2 = IVQ2
+ IF(IVAL1.LE.0) I1 = 0
+ IF(IVAL2.LE.0) I2 = 0
+ IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
+ MSDIFF = 2*MSPOM
+ ELSE
+ MSDIFF = 2*MAX(0,MSPOM-1)
+ ENDIF
+ MSG1 = MSPAR1
+ MSG2 = MSPAR2
+ MSM1 = MSPAR1-MSDIFF
+ MSM2 = MSPAR2-MSDIFF
+ XMAXH1 = MIN(XMAX1,PARMDL(44))
+ XMAXH2 = MIN(XMAX2,PARMDL(44))
+ CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
+ & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
+
+C correct for proper simulation of high pt tail
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
+ & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
+ & MSPOM,MHPOM,I1,I2
+ IF(MSPOM*MHPOM.GT.0) THEN
+ MSPOM = MSPOM-1
+ GOTO 25
+ ELSE IF(MSPOM.GT.1) THEN
+ MSPOM = MSPOM-1
+ GOTO 25
+ ELSE IF(MHPOM.GT.1) THEN
+ IHARD = IHARD-1
+ IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
+ & .AND.(IPROCE.EQ.1)) THEN
+ XSS1 = MAX(0.D0,1.D0-XPSUB)
+ XSS2 = MAX(0.D0,1.D0-XTSUB)
+ ELSE
+ XSS1 = 0.D0
+ XSS2 = 0.D0
+ ENDIF
+ DO 103 K=1,IHARD
+ I = LSIDX(K)
+ XSS1 = XSS1+ XHD(I,1)
+ XSS2 = XSS2+ XHD(I,2)
+ 103 CONTINUE
+ GOTO 199
+ ENDIF
+ IREJ = 4
+ GOTO 450
+ ENDIF
+C accepted
+ MSPOM = MSPOM-(MSPAR1-MSG1)/2
+ MSPAR1 = MSG1
+ MSPAR2 = MSG2
+C ------------ kinematics sampled ---------------
+C debug output
+ IF(IDEB(24).GE.10) THEN
+ WRITE(LO,'(1X,A,I3)')
+ & 'PHO_POMSCA: soft x values, ITRY',ITRY
+ DO 104 I=2,MAX(MSPAR1,MSPAR2)
+ WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
+ 104 CONTINUE
+ ENDIF
+ IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
+
+C end of loop
+ XS1(1) = 1.D0 - XSS1
+ XS2(1) = 1.D0 - XSS2
+
+C process counting
+ DO 30 N=1,LSCAHD
+ MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
+ 30 CONTINUE
+
+C soft particle momenta
+
+ IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
+ WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
+ & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ DO 55 I=1,MSPAR1
+ PSOFT1(1,I) = 0.D0
+ PSOFT1(2,I) = 0.D0
+ PSOFT1(3,I) = XS1(I)*ECMP/2.D0
+ PSOFT1(4,I) = XS1(I)*ECMP/2.D0
+ 55 CONTINUE
+ DO 60 I=1,MSPAR2
+ PSOFT2(1,I) = 0.D0
+ PSOFT2(2,I) = 0.D0
+ PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
+ PSOFT2(4,I) = XS2(I)*ECMP/2.D0
+ 60 CONTINUE
+
+ KSOFT = MAX(MSPAR1,MSPAR2)
+ KHARD = MAX(MHPAR1,MHPAR2)
+ KSPOM = MSPOM
+ KSREG = MSREG
+ KHPOM = MHPOM
+
+C debug output
+ IF(IDEB(24).GE.10) THEN
+ WRITE(LO,'(/1X,A,2I3,2I5)')
+ & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
+ & IVAL1,IVAL2,ITRY,NTRY
+ IF(MSPAR1+MSPAR2.GT.0) THEN
+ WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
+ XTMP1 = 0.D0
+ XTMP2 = 0.D0
+ DO 105 I=1,MAX(MSPAR1,MSPAR2)
+ IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
+ XTMP1 = XTMP1+XS1(I)
+ XTMP2 = XTMP2+XS2(I)
+ ELSE IF(I.LE.MSPAR1) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
+ XTMP1 = XTMP1+XS1(I)
+ ELSE IF(I.LE.MSPAR2) THEN
+ WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
+ XTMP2 = XTMP2+XS2(I)
+ ENDIF
+ 105 CONTINUE
+ WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
+ ENDIF
+ IF(MHPAR1.GT.0) THEN
+ WRITE(LO,'(5X,A)')
+ & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
+ DO 107 K=1,MHPAR1
+ I = LSIDX(K)
+ WRITE(LO,'(5X,3I3,4E12.3,2I3)')
+ & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
+ & NINHD(I,1),NINHD(I,2)
+ XTMP1 = XTMP1+XHD(I,1)
+ XTMP2 = XTMP2+XHD(I,2)
+ 107 CONTINUE
+ WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
+ WRITE(LO,'(5X,A)') 'hard momenta particle1:'
+ DO 108 K=1,MHPAR1
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
+ & NOUTHD(I,1)
+ 108 CONTINUE
+ WRITE(LO,'(5X,A)') 'hard momenta particle2:'
+ DO 110 K=1,MHPAR2
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
+ & NOUTHD(I,2)
+ 110 CONTINUE
+ ENDIF
+ ENDIF
+ RETURN
+
+C event rejected, print debug information
+ 450 CONTINUE
+ IFAIL(4) = IFAIL(4)+1
+ IF(IDEB(24).GE.2) THEN
+ WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
+ & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
+ & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
+ WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
+ IF(IDEB(24).GE.5) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HARX12
+ SUBROUTINE PHO_HARX12
+C**********************************************************************
+C
+C selection of x1 and x2 according to 1/x1*1/x2
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+10 CONTINUE
+ Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
+ Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
+ IF ( (Z1+Z2).LT.ALNH ) GOTO 10
+ X1 = EXP(Z1)
+ X2 = EXP(Z2)
+ AXX = AH/(X1*X2)
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+
+ END
+
+CDECK ID>, PHO_HARDX1
+ SUBROUTINE PHO_HARDX1
+C**********************************************************************
+C
+C selection of x1 according to 1/x1
+C ( x2 = 1 )
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
+ X2 = 1.D0
+ X1 = EXP(Z1)
+ AXX = AH/X1
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+
+ END
+
+CDECK ID>, PHO_HARKIN
+ SUBROUTINE PHO_HARKIN(IREJ)
+C***********************************************************************
+C
+C selection of kinematic variables
+C (resolved and direct processes)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C internal cross check information on hard scattering limits
+ DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
+ COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
+
+ PARAMETER ( Max_pro_2 = 16 )
+ DIMENSION RM(-1:Max_pro_2)
+ DATA RM / 3.31D0, 0.0D0,
+ & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
+ & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
+ & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
+ & 1.0D0 /
+
+ IREJ = 0
+ M = MSPR
+
+C------------- resolved processes -----------
+ IF ( M.EQ.1 ) THEN
+10 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
+20 CALL PHO_HARX12
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.3 ) THEN
+30 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
+ ELSEIF ( M.EQ.5 ) THEN
+50 CALL PHO_HARX12
+ V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
+ ELSEIF ( M.EQ.6 ) THEN
+60 CALL PHO_HARX12
+ V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(U*U+V*V)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
+ ELSEIF ( M.EQ.7 ) THEN
+70 CALL PHO_HARX12
+ V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
+ & -(4.D0/27.D0)*V/U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ ELSEIF ( M.EQ.8 ) THEN
+80 CALL PHO_HARX12
+ V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
+ U =-1.D0-V
+ R = (4.D0/9.D0)*(1.D0+U*U)
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
+ ELSEIF ( M.EQ.-1 ) THEN
+90 CALL PHO_HARX12
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
+ IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
+C------------- direct / single-resolved processes -----------
+ ELSEIF ( M.EQ.10 ) THEN
+100 CALL PHO_HARDX1
+ WL = LOG(AXX/(1.D0+W)**2)
+ U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
+ R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
+ V =-1.D0-U
+ X2 = X1
+ X1 = 1.D0
+ ELSEIF ( M.EQ.11) THEN
+110 CALL PHO_HARDX1
+ WL = LOG(W1)
+ U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ V =-1.D0-U
+ R = (U*U+V*V)/V*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+ X2 = X1
+ X1 = 1.D0
+ ELSEIF ( M.EQ.12 ) THEN
+120 CALL PHO_HARDX1
+ WL = LOG(AXX/(1.D0+W)**2)
+ V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
+ R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
+ ELSEIF ( M.EQ.13) THEN
+130 CALL PHO_HARDX1
+ WL = LOG(W1)
+ V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = (U*U+V*V)/U*WL*AXX
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+C------------- (double) direct process -----------
+ ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
+ X1 = 1.D0
+ X2 = 1.D0
+ AXX= AH
+ W = SQRT(MAX(TINY,1.D0-AXX))
+ W1 = AXX/(1.D0+W)
+ WL = LOG(W1)
+ 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
+ U =-1.D0-V
+ R = -(U*U+V*V)/U
+ IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
+ & 'PHO_HARKIN:weight error',M
+ IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
+ IF ( DT_RNDM(V).LE.0.5D0 ) V = U
+C---------------------------------------------
+ ELSE
+ WRITE(LO,'(/1X,A,I3)')
+ & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+ V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
+ U = -1.D0-V
+ U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
+ PT = SQRT(U*V*X1*X2)*ECMP
+ ETAC = 0.5D0*LOG((U*X1)/(V*X2))
+ ETAD = 0.5D0*LOG((V*X1)/(U*X2))
+
+***************************************************************
+ MM = M
+ IF(M.EQ.-1) MM = 3
+ ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
+ ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
+ ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
+ ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
+ XXMI(1,MM) = MIN(XXMI(1,MM),X1)
+ XXMA(1,MM) = MAX(XXMA(1,MM),X1)
+ XXMI(2,MM) = MIN(XXMI(2,MM),X2)
+ XXMA(2,MM) = MAX(XXMA(2,MM),X2)
+***************************************************************
+
+ IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
+ & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
+
+ END
+
+CDECK ID>, PHO_HARWGH
+ SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
+C***********************************************************************
+C
+C calculate product of PDFs and coupling constants
+C according to selected MSPR (process type)
+C
+C input: /POCKIN/
+C
+C output: PDS resulting from PDFs alone
+C FDISTR complete weight function
+C PDA,PDB fields containing the PDFs
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION PDA(-6:6),PDB(-6:6)
+
+ FDISTR = 0.D0
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
+ ENDIF
+C coupling constants, PDFs
+ IF(MSPR.LT.9) THEN
+ ALPHA1 = PHO_ALPHAS(QQAL,3)
+ ALPHA2 = ALPHA1
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
+ PDS = PDA(0)*PDB(0)
+ ELSE
+ S2 = 0.D0
+ S3 = 0.D0
+ S4 = 0.D0
+ S5 = 0.D0
+ DO 10 I=1,NF
+ S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ S4 = S4+PDA(I)+PDA(-I)
+ S5 = S5+PDB(I)+PDB(-I)
+ 10 CONTINUE
+ IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
+ PDS = S2
+ ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
+ PDS = PDA(0)*S5+PDB(0)*S4
+ ELSE IF(MSPR.EQ.7) THEN
+ PDS = S3
+ ELSE IF(MSPR.EQ.8) THEN
+ PDS = S4*S5-(S2+S3)
+ ENDIF
+ ENDIF
+ ELSE IF(MSPR.LT.12) THEN
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ S4 = 0.D0
+ S6 = 0.D0
+ DO 15 I=1,NF
+ S4 = S4+PDB(I)+PDB(-I)
+C charge counting
+* IF(MOD(I,2).EQ.0) THEN
+* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
+* ELSE
+* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
+* ENDIF
+ S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
+ 15 CONTINUE
+ IF(MSPR.EQ.10) THEN
+ IF(IDPDG1.EQ.990) THEN
+ PDS = S4
+ ELSE
+ PDS = S6
+ ENDIF
+ ELSE
+ PDS = PDB(0)
+ ENDIF
+ ELSE IF(MSPR.LT.14) THEN
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ S4 = 0.D0
+ S6 = 0.D0
+ DO 20 I=1,NF
+ S4 = S4+PDA(I)+PDA(-I)
+C charge counting
+* IF(MOD(I,2).EQ.0) THEN
+* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
+* ELSE
+* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
+* ENDIF
+ S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
+ 20 CONTINUE
+ IF(MSPR.EQ.12) THEN
+ IF(IDPDG2.EQ.990) THEN
+ PDS = S4
+ ELSE
+ PDS = S6
+ ENDIF
+ ELSE
+ PDS = PDA(0)
+ ENDIF
+ ELSE IF(MSPR.EQ.14) THEN
+ SSR = X1*X2*ECMP*ECMP
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(SSR)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(SSR)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ PDS = 1.D0
+ ELSE
+ WRITE(LO,'(/1X,A,I4)')
+ & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
+ CALL PHO_ABORT
+ ENDIF
+
+C complete weight
+ FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
+
+C debug output
+ IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
+ & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
+ & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
+
+ END
+
+CDECK ID>, PHO_HARSCA
+ SUBROUTINE PHO_HARSCA(IMODE,IP)
+C***********************************************************************
+C
+C PHO_HARSCA determines the type of hard subprocess, the partons
+C taking part in this subprocess and the kinematic variables
+C
+C input: IMODE 1 direct processes
+C 2 resolved processes
+C -1 initialization
+C -2 output of statistics
+C IP 1-4 particle combination (hadron/photon)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER( EPS = 1.D-10,
+ & DEPS = 1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+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 cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ 111 CONTINUE
+
+C resolved processes
+ IF(IMODE.EQ.2) THEN
+
+ MH_pro_on(0,IP) = 0
+ HWgx(9) = 0.D0
+ DO 15 M=-1,8
+ IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
+ 15 CONTINUE
+ IF(HWgx(9).LT.DEPS) THEN
+ WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
+ & 'no resolved process possible for IP',IP,HWgx(9)
+ CALL PHO_ABORT
+ ENDIF
+C
+C ----------------------------------------------I
+C begin of iteration loop (resolved processes) I
+C I
+ IREJSC = 0
+ 10 CONTINUE
+ IREJSC = IREJSC+1
+ IF(IREJSC.GT.1000) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
+ CALL PHO_ABORT
+ ENDIF
+
+C find subprocess
+ B = DT_RNDM(X1)*HWgx(9)
+ MSPR =-2
+ SUM = 0.D0
+ 20 MSPR = MSPR+1
+ IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
+ IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
+
+ IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
+ & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
+
+C find kin. variables X1,X2 and V
+ CALL PHO_HARKIN(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(29) = IFAIL(29)+1
+ GOTO 10
+ ENDIF
+C calculate remaining distribution
+ CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
+C actualize counter for cross-section calculation
+ if(F.LE.1.D-15) then
+ F = 0.D0
+ goto 10
+ endif
+* XSECT(5,MSPR) = XSECT(5,MSPR)+F
+* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
+ MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
+C check F against FMAX
+ WEIGHT = F/(HWgx(MSPR)+DEPS)
+ IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
+C-------------------------------------------------------------------
+ IF(WEIGHT.GT.1.D0) THEN
+ WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
+ 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
+ & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
+ WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
+ & ECMP,PTWANT,AS,AH,PT
+ WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
+ & ETAC,ETAD,X1,X2,V
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C-------------------------------------------------------------------
+C I
+C end of iteration loop (resolved processes) I
+C --------------------------------------------I
+C
+C*********************************************************************
+C
+C direct processes
+
+ ELSE IF(IMODE.EQ.1) THEN
+
+C single-resolved processes kinematically forbidden
+ if(Z1DIF.lt.0.D0) then
+ HWgx(10) = 0.D0
+ HWgx(11) = 0.D0
+ HWgx(12) = 0.D0
+ HWgx(13) = 0.D0
+ endif
+
+ HWgx(15) = 0.D0
+ if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
+ DO M= 10,14
+ IF(MH_pro_on(M,IP).EQ.1) then
+ if((M.eq.10).or.(M.eq.11)) then
+ fac = FSUH(1)*FSUP(2)
+ else if((M.eq.12).or.(M.eq.13)) then
+ fac = FSUP(1)*FSUH(2)
+ else
+ fac = FSUH(1)*FSUH(2)
+ endif
+ HWgx(15) = HWgx(15)+HWgx(M)*fac
+ endif
+ ENDDO
+ else
+ DO M= 10,14
+ IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
+ ENDDO
+ endif
+ IF(HWgx(15).LT.DEPS) THEN
+ WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
+ & 'no direct/single-resolved process possible (IP)',IP
+ CALL PHO_ABORT
+ ENDIF
+C
+C ----------------------------------------------I
+C begin of iteration loop (direct processes) I
+C I
+ IREJSC = 0
+ 100 CONTINUE
+ IREJSC = IREJSC+1
+ IF(IREJSC.GT.1000) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
+ CALL PHO_ABORT
+ ENDIF
+
+C find subprocess
+ B = DT_RNDM(X1)*HWgx(15)
+ MSPR = 9
+ SUM = 0.D0
+ if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
+ 150 continue
+ MSPR = MSPR+1
+ IF(MH_pro_on(MSPR,IP).EQ.1) then
+ if((MSPR.eq.10).or.(MSPR.eq.11)) then
+ fac = FSUH(1)*FSUP(2)
+ else if((MSPR.eq.12).or.(MSPR.eq.13)) then
+ fac = FSUP(1)*FSUH(2)
+ else
+ fac = FSUH(1)*FSUH(2)
+ endif
+ SUM = SUM+HWgx(MSPR)*fac
+ endif
+ IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
+ else
+ 200 continue
+ MSPR = MSPR+1
+ IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
+ IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
+ endif
+
+ IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
+ & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
+
+C find kin. variables X1,X2 and V
+ CALL PHO_HARKIN(IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(28) = IFAIL(28)+1
+ GOTO 100
+ ENDIF
+
+C calculate remaining distribution
+ CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
+
+C counter for cross-section calculation
+ if(F.LE.1.D-15) then
+ F=0.D0
+ goto 100
+ endif
+* XSECT(5,MSPR) = XSECT(5,MSPR)+F
+* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
+ MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
+C check F against FMAX
+ WEIGHT = F/(HWgx(MSPR)+DEPS)
+ IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
+C-------------------------------------------------------------------
+ IF(WEIGHT.GT.1.D0) THEN
+ WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
+ 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
+ & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
+ WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
+ & ECMP,PTWANT,AS,AH,PT
+ WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
+ & ETAC,ETAD,X1,X2,V
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C-------------------------------------------------------------------
+C I
+C end of iteration loop (direct processes) I
+C --------------------------------------------I
+
+ ELSE IF(IMODE.EQ.-1) THEN
+
+C initialize cross section calculations
+
+ DO 40 M=-1,Max_pro_2
+* DO 30 I=5,6
+* XSECT(I,M) = 0.D0
+*30 CONTINUE
+C reset counters
+ DO 35 J=1,4
+ MH_tried(M,J) = 0
+ MH_acc_1(M,J) = 0
+ MH_acc_2(M,J) = 0
+ 35 CONTINUE
+ 40 CONTINUE
+ IF(IDEB(78).GE.0) THEN
+C *** Commented by Chiara
+C WRITE(LO,'(/1X,A,/1X,A)')
+C & 'PHO_HARSCA: activated hard processes',
+C & '------------------------------------'
+C WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
+ DO 42 M=1,Max_pro_2
+C WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
+C & (MH_pro_on(M,J),J=1,4)
+ 42 CONTINUE
+ ENDIF
+ RETURN
+
+ ELSE IF(IMODE.EQ.-2) THEN
+
+C calculation of process statistics
+
+ do K=1,4
+
+ MH_tried(0,K) = 0
+ MH_acc_1(0,K) = 0
+ MH_acc_2(0,K) = 0
+ MH_tried(9,K) = 0
+ MH_acc_1(9,K) = 0
+ MH_acc_2(9,K) = 0
+ MH_tried(15,K) = 0
+ MH_acc_1(15,K) = 0
+ MH_acc_2(15,K) = 0
+
+ MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
+ MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
+ MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
+
+ do M=1,8
+ MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
+ MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
+ MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
+ enddo
+ do M=10,14
+ MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
+ MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
+ MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
+ enddo
+ MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
+ MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
+ MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
+ enddo
+
+ IF(IDEB(78).GE.1) THEN
+ WRITE(LO,'(/1X,A,/1X,A)')
+ & 'PHO_HARSCA: internal rejection statistics',
+ & '-----------------------------------------'
+ do K=1,4
+ IF(MH_tried(0,K).GT.0) THEN
+ WRITE(LO,'(5X,A,I3)')
+ & 'process (sampled/accepted) for IP:',K
+ do M=0,Max_pro_2
+ WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
+ & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
+ & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
+ enddo
+ ENDIF
+ enddo
+ ENDIF
+ RETURN
+
+ ELSE
+ WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
+ & 'unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+C the event is accepted now
+C actualize counter for accepted events
+ MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
+ IF(MSPR.EQ.-1) MSPR = 3
+C
+C find flavor of initial partons
+C
+ SUM = 0.D0
+ SCHECK = DT_RNDM(SUM)*PDS-EPS
+ IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
+ IA = 0
+ IB = 0
+ ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
+ DO 610 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 610
+ SUM = SUM+PDF1(IA)*PDF2(-IA)
+ IF ( SUM.GE.SCHECK ) GOTO 620
+ 610 CONTINUE
+ 620 IB =-IA
+ ELSEIF ( MSPR.EQ.3 ) THEN
+ IB = 0
+ DO 630 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 630
+ SUM = SUM+PDF1(0)*PDF2(IA)
+ IF ( SUM.GE.SCHECK ) GOTO 640
+ SUM = SUM+PDF1(IA)*PDF2(0)
+ IF ( SUM.GE.SCHECK ) GOTO 650
+ 630 CONTINUE
+ 640 IB = IA
+ IA = 0
+ 650 CONTINUE
+ ELSEIF ( MSPR.EQ.7 ) THEN
+ DO 660 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 660
+ SUM = SUM+PDF1(IA)*PDF2(IA)
+ IF ( SUM.GE.SCHECK ) GOTO 670
+ 660 CONTINUE
+ 670 IB = IA
+ ELSEIF ( MSPR.EQ.8 ) THEN
+ DO 690 IA=-NF,NF
+ IF ( IA.EQ.0 ) GOTO 690
+ DO 680 IB=-NF,NF
+ IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
+ SUM = SUM+PDF1(IA)*PDF2(IB)
+ IF ( SUM.GE.SCHECK ) GOTO 700
+ 680 CONTINUE
+ 690 CONTINUE
+ 700 CONTINUE
+ ELSEIF ( MSPR.EQ.10 ) THEN
+ IA = 0
+ DO 710 IB=-NF,NF
+ IF ( IB.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IB),2).EQ.0) THEN
+* SUM = SUM+PDF2(IB)*4.D0/9.D0
+* ELSE
+* SUM = SUM+PDF2(IB)*1.D0/9.D0
+* ENDIF
+ SUM = SUM+PDF2(IB)*Q_ch2(IB)
+ ELSE
+ SUM = SUM+PDF2(IB)
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 720
+ ENDIF
+ 710 CONTINUE
+ 720 CONTINUE
+ ELSEIF ( MSPR.EQ.12 ) THEN
+ IB = 0
+ DO 810 IA=-NF,NF
+ IF ( IA.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IA),2).EQ.0) THEN
+* SUM = SUM+PDF1(IA)*4.D0/9.D0
+* ELSE
+* SUM = SUM+PDF1(IA)*1.D0/9.D0
+* ENDIF
+ SUM = SUM+PDF1(IA)*Q_ch2(IA)
+ ELSE
+ SUM = SUM+PDF1(IA)
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 820
+ ENDIF
+ 810 CONTINUE
+ 820 CONTINUE
+ ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
+ IA = 0
+ IB = 0
+ ENDIF
+C final check
+ IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
+ print LO,'PHO_HARSCA: rejection, final check IA,IB',IA,IB
+ print LO,'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
+ GOTO 111
+ ENDIF
+C
+C find flavour of final partons
+C
+ IC = IA
+ ID = IB
+ IF ( MSPR.EQ.2 ) THEN
+ IC = 0
+ ID = 0
+ ELSEIF ( MSPR.EQ.4 ) THEN
+ IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
+ IF ( IC.GT.NF ) IC = NF-IC
+ ID =-IC
+ ELSEIF ( MSPR.EQ.6 ) THEN
+ IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
+ IF ( IC.GT.NF-1 ) IC = NF-1-IC
+ IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
+ ID =-IC
+ ELSEIF ( MSPR.EQ.11) THEN
+ SUM = 0.D0
+ DO 730 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ ENDIF
+ 730 CONTINUE
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 740 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG1.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 750
+ ENDIF
+ 740 CONTINUE
+ 750 CONTINUE
+ ID = -IC
+ ELSEIF ( MSPR.EQ.12) THEN
+ IC = 0
+ ID = IA
+ ELSEIF ( MSPR.EQ.13) THEN
+ SUM = 0.D0
+ DO 830 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ ENDIF
+ 830 CONTINUE
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 840 IC=-NF,NF
+ IF ( IC.NE.0 ) THEN
+ IF(IDPDG2.EQ.22) THEN
+* IF(MOD(ABS(IC),2).EQ.0) THEN
+* SUM = SUM + 4.D0
+* ELSE
+* SUM = SUM + 1.D0
+* ENDIF
+ SUM = SUM + Q_ch2(IC)
+ ELSE
+ SUM = SUM + 1.D0
+ ENDIF
+ IF ( SUM.GE.SCHECK ) GOTO 850
+ ENDIF
+ 840 CONTINUE
+ 850 CONTINUE
+ ID = -IC
+ ELSEIF ( MSPR.EQ.14) THEN
+ SUM = 0.D0
+ DO 930 IC=1,NF
+ FAC1 = 1.D0
+ FAC2 = 1.D0
+ IF(MOD(ABS(IC),2).EQ.0) THEN
+ IF(IDPDG1.EQ.22) FAC1 = 4.D0
+ IF(IDPDG2.EQ.22) FAC2 = 4.D0
+ ENDIF
+ SUM = SUM + FAC1*FAC2
+ 930 CONTINUE
+ IF(IPAMDL(64).NE.0) THEN
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
+ ENDIF
+ SCHECK = DT_RNDM(SUM)*SUM-EPS
+ SUM = 0.D0
+ DO 940 IC=1,NF
+ FAC1 = 1.D0
+ FAC2 = 1.D0
+ IF(MOD(ABS(IC),2).EQ.0) THEN
+ IF(IDPDG1.EQ.22) FAC1 = 4.D0
+ IF(IDPDG2.EQ.22) FAC2 = 4.D0
+ ENDIF
+ SUM = SUM + FAC1*FAC2
+ IF ( SUM.GE.SCHECK ) GOTO 950
+ 940 CONTINUE
+ IC = 15
+ 950 CONTINUE
+ ID = -IC
+ IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
+ ENDIF
+ if(IC.eq.0) then
+ XM3 = 0.D0
+ else
+ XM3 = PHO_PMASS(IC,3)
+ endif
+ if(ID.eq.0) then
+ XM4 = 0.D0
+ else
+ XM4 = PHO_PMASS(ID,3)
+ endif
+ IF(ABS(IC).EQ.15) GOTO 955
+
+C valence quarks involved?
+ IV1 = 0
+ IF(IA.NE.0) THEN
+ IF(IDPDG1.EQ.22) THEN
+ CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
+ IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
+ ELSE
+ IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
+ ENDIF
+ ENDIF
+ IV2 = 0
+ IF(IB.NE.0) THEN
+ IF(IDPDG2.EQ.22) THEN
+ CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
+ IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
+ ELSE
+ IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
+ ENDIF
+ ENDIF
+C
+C fill event record
+C
+ 955 CONTINUE
+ CALL PHO_SFECFE(SINPHI,COSPHI)
+ ECM2 = ECMP/2.D0
+C incoming partons
+ PHI1(1) = 0.D0
+ PHI1(2) = 0.D0
+ PHI1(3) = ECM2*X1
+ PHI1(4) = PHI1(3)
+ PHI1(5) = 0.D0
+ PHI2(1) = 0.D0
+ PHI2(2) = 0.D0
+ PHI2(3) = -ECM2*X2
+ PHI2(4) = -PHI2(3)
+ PHI2(5) = 0.D0
+C outgoing partons
+ PHO1(1) = PT*COSPHI
+ PHO1(2) = PT*SINPHI
+ PHO1(3) = -ECM2*(U*X1-V*X2)
+ PHO1(4) = -ECM2*(U*X1+V*X2)
+ PHO1(5) = XM3
+ PHO2(1) = -PHO1(1)
+ PHO2(2) = -PHO1(2)
+ PHO2(3) = -ECM2*(V*X1-U*X2)
+ PHO2(4) = -ECM2*(V*X1+U*X2)
+ PHO2(5) = XM4
+
+C convert to mass shell
+ CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
+ IF(IREJ.NE.0) THEN
+ IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
+ & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
+ & PT,XM3,XM4
+ GOTO 111
+ ENDIF
+ PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
+
+C debug output
+ IF(IDEB(78).GE.20) THEN
+ SHAT = X1*X2*ECMP*ECMP
+ WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
+ & MSPR,IA,IB,IC,ID
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
+ WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HARFAC
+ SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
+C*********************************************************************
+C
+C initialization: find scaling factors and maxima of remaining
+C weights
+C
+C input: PTCUT transverse momentum cutoff
+C ECMI cms energy
+C
+C output: Hfac(-1:Max_pro_2) field for sampling hard processes
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( MXABWT = 96 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+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)
+
+ DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
+ DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
+ & F124(-1:Max_pro_2)
+ DATA F124 / 1.D0,0.D0,
+ & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
+ & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
+
+ SS = ECMI*ECMI
+ AH = (2.D0*PTCUT/ECMI)**2
+ ALN = LOG(AH)
+ HLN = LOG(0.5D0)
+ NPOINT = NGAUIN
+ CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
+ DO 10 M=-1,Max_pro_2
+ S1(M) = 0.D0
+10 CONTINUE
+
+C resolved processes
+ DO 80 I1=1,NPOINT
+ Z1 = ABSZ(I1)
+ X1 = EXP(ALN*Z1)
+ DO 20 M=-1,9
+ S2(M) = 0.D0
+20 CONTINUE
+
+ DO 60 I2=1,NPOINT
+ Z2 = (1.D0-Z1)*ABSZ(I2)
+ X2 = EXP(ALN*Z2)
+ FAXX = AH/(X1*X2)
+ W = SQRT(1.D0-FAXX)
+ W1 = FAXX/(1.+W)
+ WLOG = LOG(W1)
+ FWW = FAXX*WLOG/W
+ DO 30 M=-1,9
+ S(M) = 0.D0
+30 CONTINUE
+
+ DO 40 I=1,NPOINT
+ Z = ABSZ(I)
+ VA =-0.5D0*W1/(W1+Z*W)
+ UA =-1.D0-VA
+ VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
+ UB =-1.D0-VB
+ VC =-EXP(HLN+Z*WLOG)
+ UC =-1.D0-VC
+ VE =-0.5D0*(1.D0+W)+Z*W
+ UE =-1.D0-VE
+ S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
+ & WEIG(I)
+ S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
+ & WEIG(I)
+ S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
+ S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
+ & (8./27.)*UA*UA*VA)*WEIG(I)
+ S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
+ S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
+ & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
+ S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
+ S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
+40 CONTINUE
+ S(4) = S(2)*(9./32.)
+ DO 50 M=-1,8
+ S2(M) = S2(M)+S(M)*WEIG(I2)*W
+50 CONTINUE
+60 CONTINUE
+ DO 70 M=-1,8
+ S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
+70 CONTINUE
+80 CONTINUE
+ S1(4) = S1(4)*NF
+ S1(6) = S1(6)*MAX(0,NF-1)
+C
+C direct processes
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
+ & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ DO 180 I1=1,NPOINT
+ Z2 = ABSZ(I1)
+ X2 = EXP(ALN*Z2)
+ FAXX = AH/X2
+ W = SQRT(1.D0-FAXX)
+ W1 = FAXX/(1.D0+W)
+ WLOG = LOG(W1)
+ WL = LOG(FAXX/(1.D0+W)**2)
+ FWW1 = FAXX*WL/ALN
+ FWW2 = FAXX*WLOG/ALN
+ DO 130 M=10,12
+ S(M) = 0.D0
+ 130 CONTINUE
+C
+ DO 140 I=1,NPOINT
+ Z = ABSZ(I)
+ UA =-(1.D0+W)/2.D0*EXP(Z*WL)
+ VA =-1.D0-UA
+ VB =-EXP(HLN+Z*WLOG)
+ UB =-1.D0-VB
+ S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
+ S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
+ 140 CONTINUE
+ DO 170 M=10,11
+ S1(M) = S1(M)+S(M)*WEIG(I1)
+ 170 CONTINUE
+ 180 CONTINUE
+ S1(12) = S1(10)
+ S1(13) = S1(11)
+C quark charges fractions
+ IF(IDPDG1.EQ.22) THEN
+ CHRNF = 0.D0
+ DO 100 I=1,NF
+ CHRNF = CHRNF + Q_ch2(I)
+ 100 CONTINUE
+ S1(11) = S1(11)*CHRNF
+ ELSE IF(IDPDG1.EQ.990) THEN
+ S1(11) = S1(11)*NF
+ ELSE
+ S1(11) = 0.D0
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ CHRNF = 0.D0
+ DO 200 I=1,NF
+ CHRNF = CHRNF + Q_ch2(I)
+ 200 CONTINUE
+ S1(13) = S1(13)*CHRNF
+ ELSE IF(IDPDG2.EQ.990) THEN
+ S1(13) = S1(13)*NF
+ ELSE
+ S1(13) = 0.D0
+ ENDIF
+ ENDIF
+C
+C global factors
+ FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
+ DO 90 M=-1,Max_pro_2
+ Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
+90 CONTINUE
+C
+C double direct process
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FAC = 0.D0
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+ F1 = Q_ch2(I)
+ ELSE
+ F1 = 1.D0
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ F2 = Q_ch2(I)
+ ELSE
+ F2 = 1.D0
+ ENDIF
+ FAC = FAC+F1*F2*3.D0
+ 300 CONTINUE
+ ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
+ Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
+ & *GEV2MB*FAC
+ ENDIF
+ END
+
+CDECK ID>, PHO_HARWGX
+ SUBROUTINE PHO_HARWGX(PTCUT,ECM)
+C**********************************************************************
+C
+C find maximum of remaining weight for MC sampling
+C
+C input: PTCUT transverse momentum cutoff
+C ECM cms energy
+C
+C output: HWgx(-1:Max_pro_2) field for sampling hard processes
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( NKM = 10 )
+ PARAMETER ( TINY = 1.D-20 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+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)
+
+ DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
+ & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
+ DIMENSION IFTAB(-1:Max_pro_2)
+ DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
+
+C initial settings
+ AH = (2.D0*PTCUT/ECM)**2
+ ALNH = LOG(AH)
+ FF(0) = 0.D0
+ DO 22 I=1,NKM
+ FF(I) = 0.D0
+ XM1(I) = 0.D0
+ XM2(I) = 0.D0
+ PTM(I) = 0.D0
+ ZMX(1,I) = 0.D0
+ ZMX(2,I) = 0.D0
+ ZMX(3,I) = 0.D0
+ DMX(1,I) = 0.D0
+ DMX(2,I) = 0.D0
+ DMX(3,I) = 0.D0
+ IMX(I) = 0
+ IPO(I) = 0
+ 22 CONTINUE
+
+ NKML = 10
+ DO 40 NKON=1,NKML
+
+ DO 50 IST=1,3
+C start configuration
+ IF(IST.EQ.1) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.5
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.2) THEN
+ Z(1) = 0.999D0
+ Z(2) = 0.5
+ Z(3) = 0.0
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.3) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.1
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ELSE IF(IST.EQ.4) THEN
+ Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
+ Z(2) = 0.9
+ Z(3) = 0.1
+ D(1) =-0.5
+ D(2) = 0.5
+ D(3) = 0.5
+ ENDIF
+ IT = 0
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
+C process possible?
+ IF(F2.LE.0.D0) GOTO 35
+
+ 10 CONTINUE
+ IT = IT+1
+ FOLD = F2
+ DO 30 I=1,3
+ D(I) = D(I)/5.D0
+ Z(I) = Z(I)+D(I)
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
+ IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
+ IF ( F2.GT.F3 ) D(I) =-D(I)
+ 20 CONTINUE
+ F1 = MIN(F2,F3)
+ F2 = MAX(F2,F3)
+ Z(I) = Z(I)+D(I)
+ CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
+ IF ( F3.GT.F2 ) GOTO 20
+ ZZ = Z(I)-D(I)
+ Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
+ IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
+ & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
+ IF ( F1.LE.F2 ) Z(I) = ZZ
+ F2 = MAX(F1,F2)
+ 30 CONTINUE
+ IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
+
+ IF(F2.GT.FF(NKON)) THEN
+ FF(NKON) = MAX(F2,0.D0)
+ XM1(NKON) = X1
+ XM2(NKON) = X2
+ PTM(NKON) = PT
+ ZMX(1,NKON) = Z(1)
+ ZMX(2,NKON) = Z(2)
+ ZMX(3,NKON) = Z(3)
+ DMX(1,NKON) = D(1)
+ DMX(2,NKON) = D(2)
+ DMX(3,NKON) = D(3)
+ IMX(NKON) = IT
+ IPO(NKON) = IST
+ ENDIF
+C
+ 50 CONTINUE
+ 35 CONTINUE
+ 40 CONTINUE
+
+C debug output
+ IF(IDEB(38).GE.5) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
+ DO 60 I=1,NKM
+ IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
+ & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
+ & DMX(2,I),DMX(3,I)
+ 60 CONTINUE
+ ENDIF
+
+ DO 70 I=-1,Max_pro_2
+ HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
+ 70 CONTINUE
+
+C debug output
+ IF(IDEB(38).GE.5) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
+ WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
+ DO 80 I=-1,Max_pro_2
+ IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
+ MSPR = I
+ X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
+ X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
+ PT = PTM(IFTAB(I))
+ CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
+ WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
+ ENDIF
+ 80 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HARWGI
+ SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
+C**********************************************************************
+C
+C auxiliary subroutine to find maximum of remaining weight
+C
+C input: ECMX current CMS energy
+C PTCUT current pt cutoff
+C NKON process label 1..5 resolved
+C 6..7 direct particle 1
+C 8..9 direct particle 2
+C 10 double direct
+C Z(3) transformed variable
+C
+C output: remaining weight
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION Z(3)
+
+ PARAMETER ( NKM = 10 )
+ PARAMETER ( TINY = 1.D-30,
+ & TINY6 = 1.D-06 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
+
+ FDIS = 0.D0
+
+ IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
+ & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
+C check input values
+ IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
+ IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
+ IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
+C transformations
+ Y1 = EXP(ALNH*Z(1))
+ IF(NKON.LE.5) THEN
+C resolved kinematic
+ Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
+ X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
+ X2 = X1-Y2
+ X1 = MIN(X1,0.999999999999D0)
+ X2 = MIN(X2,0.999999999999D0)
+ ELSE IF(NKON.LE.7) THEN
+C direct kinematic 1
+ X1 = 1.D0
+ X2 = MIN(Y1,0.999999999999D0)
+ ELSE IF(NKON.LE.9) THEN
+C direct kinematic 2
+ X1 = MIN(Y1,0.999999999999D0)
+ X2 = 1.D0
+ ELSE
+C double direct kinematic
+ X1 = 1.D0
+ X2 = 1.D0
+ ENDIF
+ W = SQRT(MAX(TINY,1.D0-AH/Y1))
+ V =-0.5D0+W*(Z(3)-0.5D0)
+ U =-(1.D0+V)
+ PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
+
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
+ ENDIF
+C
+ IF(NKON.LE.5) THEN
+ DO 10 N=1,5
+ F(N) = 0.D0
+ 10 CONTINUE
+C resolved processes
+ ALPHA1 = PHO_ALPHAS(QQAL,3)
+ ALPHA2 = ALPHA1
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+C calculate full distribution FDIS
+ DO 20 I=1,NF
+ F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ F(4) = F(4)+PDA(I)+PDA(-I)
+ F(5) = F(5)+PDB(I)+PDB(-I)
+20 CONTINUE
+ F(1) = PDA(0)*PDB(0)
+ T = PDA(0)*F(5)+PDB(0)*F(4)
+ F(5) = F(4)*F(5)-(F(2)+F(3))
+ F(4) = T
+ ELSE IF(NKON.LE.7) THEN
+C direct processes particle 1
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ CH1 = 4.D0/9.D0
+ CH2 = 3.D0/9.D0
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ CH1 = 1.D0
+ CH2 = 0.D0
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
+ F(6) = 0.D0
+ DO 30 I=1,NF
+ F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
+ 30 CONTINUE
+ F(7) = PDB(0)
+ ELSE IF(NKON.LE.9) THEN
+C direct processes particle 2
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ CH1 = 4.D0/9.D0
+ CH2 = 3.D0/9.D0
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ CH1 = 1.D0
+ CH2 = 0.D0
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
+ F(8) = 0.D0
+ DO 40 I=1,NF
+ F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
+ 40 CONTINUE
+ F(9) = PDA(0)
+ ELSE
+C double direct process
+ SSR = ECMX*ECMX
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(SSR)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(SSR)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ELSE
+ FDIS = -1.D0
+ RETURN
+ ENDIF
+ F(10) = 1.D0
+ ENDIF
+
+ FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
+
+C debug output
+ IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
+ & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
+ & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
+
+ END
+
+CDECK ID>, PHO_HARINI
+ SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
+C**********************************************************************
+C
+C initialize calculation of hard cross section
+C
+C must not be called during MC generation
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+
+ double precision pho_alphas
+
+ CHARACTER*20 RFLAG
+
+C set local Pomeron c.m. system data
+ IDPDG1 = IDP1
+ IDPDG2 = IDP2
+ PVIRTP(1) = PV1
+ PVIRTP(2) = PV2
+C initialize PDFs
+ CALL PHO_ACTPDF(IDPDG1,1)
+ CALL PHO_ACTPDF(IDPDG2,2)
+C initialize alpha_s calculation
+ DUMMY = PHO_ALPHAS(0.D0,-4)
+C initialize scales with defaults
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ AQQAL = PARMDL(83)
+ AQQALI = PARMDL(86)
+ AQQALF = PARMDL(89)
+ AQQPD = PARMDL(92)
+ NQQAL = IPAMDL(83)
+ NQQALI = IPAMDL(86)
+ NQQALF = IPAMDL(89)
+ NQQPD = IPAMDL(92)
+ ELSE
+ AQQAL = PARMDL(82)
+ AQQALI = PARMDL(85)
+ AQQALF = PARMDL(88)
+ AQQPD = PARMDL(91)
+ NQQAL = IPAMDL(82)
+ NQQALI = IPAMDL(85)
+ NQQALF = IPAMDL(88)
+ NQQPD = IPAMDL(91)
+ ENDIF
+ ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ AQQAL = PARMDL(82)
+ AQQALI = PARMDL(85)
+ AQQALF = PARMDL(88)
+ AQQPD = PARMDL(91)
+ NQQAL = IPAMDL(82)
+ NQQALI = IPAMDL(85)
+ NQQALF = IPAMDL(88)
+ NQQPD = IPAMDL(91)
+ ELSE
+ AQQAL = PARMDL(81)
+ AQQALI = PARMDL(84)
+ AQQALF = PARMDL(87)
+ AQQPD = PARMDL(90)
+ NQQAL = IPAMDL(81)
+ NQQALI = IPAMDL(84)
+ NQQALF = IPAMDL(87)
+ NQQPD = IPAMDL(90)
+ ENDIF
+ IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
+ IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
+ IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
+ IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
+ IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
+ IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
+ IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
+ IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
+ AQQAL = PARMDL(109+IP)
+ AQQALI = PARMDL(113+IP)
+ AQQALF = PARMDL(117+IP)
+ AQQPD = PARMDL(121+IP)
+ NQQAL = IPAMDL(64+IP)
+ NQQALI = IPAMDL(68+IP)
+ NQQALF = IPAMDL(72+IP)
+ NQQPD = IPAMDL(76+IP)
+ PTCUT(1) = PARMDL(36)
+ PTCUT(2) = PARMDL(37)
+ PTCUT(3) = PARMDL(38)
+ PTCUT(4) = PARMDL(39)
+ PTANO(1) = PARMDL(130)
+ PTANO(2) = PARMDL(131)
+ PTANO(3) = PARMDL(132)
+ PTANO(4) = PARMDL(133)
+ RFLAG = '(energy-independent)'
+ IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
+
+C write out all settings
+C *** Commented by Chiara
+C IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
+C WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
+C & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
+C & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
+C & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
+C1050 FORMAT(/,
+C & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
+C & 5X,'particle 1 / particle 2:',2I8,/,
+C & 5X,'min. PT :',F7.1,2X,A,/,
+C & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
+C & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
+C & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
+C & 5X,'max. number of active flavours NF :',I3,/,
+C & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
+C ENDIF
+
+ END
+
+CDECK ID>, PHO_HARINT
+ SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
+C**********************************************************************
+C
+C interpolate cross sections and weights for hard scattering
+C
+C input: IPP particle combination (neg. for add. user cuts)
+C ECM CMS energy (GeV)
+C P2V1/2 particle virtualities (pos., GeV**2)
+C I1 first subprocess to calculate
+C I2 last subprocess to calculate
+C <-1 only scales and cutoffs calculated
+C K1 first variable to calculate
+C K2 last variable to calculate
+C MSPOM cross sections to use for pt distribution
+C 0 reggeon
+C >0 pomeron
+C
+C for K1 < 3 the soft pt distribution is also calculated
+C
+C output: interpolated values in HWgx, HSig, Hdpt
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-15,
+ & DEPS2 = 2.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C data needed for soft-pt calculation
+ DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
+ COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+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 interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C data on most recent hard scattering
+ INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+ DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
+ & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
+ COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
+ & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
+ & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
+ & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
+ & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ DOUBLE PRECISION XP,PTS
+ DIMENSION XP(2),PTS(0:2,2)
+
+ INTEGER IV
+ DIMENSION IV(2)
+
+ IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
+ & 'PHO_HARINT: called with ',
+ & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
+ & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
+
+ IP = ABS(IPP)
+ IF(IPP.GT.0) THEN
+C default minimum bias cutoff
+ PTCUT(IP) = pho_ptcut(ECM,IP)
+ ELSE
+C user defined additional cutoff
+ PTCUT(IP) = HSWCUT(4+IP)
+ ENDIF
+ PTWANT = PTCUT(IP)
+
+C ISR cutoffs
+ Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
+ Q2MISR(1) = MAX(P2V1,Q2CUT)
+ Q2MISR(2) = MAX(P2V2,Q2CUT)
+C cutoff for direct photon contribution to photon PDF
+ PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
+ PTA1 = PTANO(IP)
+C scales for hard scattering
+ AQQAL = PARMDL(109+IP)
+ AQQALI = PARMDL(113+IP)
+ AQQALF = PARMDL(117+IP)
+ AQQPD = PARMDL(121+IP)
+ NQQAL = IPAMDL(64+IP)
+ NQQALI = IPAMDL(68+IP)
+ NQQALF = IPAMDL(72+IP)
+ NQQPD = IPAMDL(76+IP)
+ IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
+ & 'PHO_HARINT: scales:',
+ & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
+
+ IF(I2.LT.-1) RETURN
+
+ IL = IP
+ IF(IPP.LT.0) IL = 0
+
+C double-log interpolation
+ IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
+ DO 50 M=I1,I2
+ Hfac(M) = 0.D0
+ HWgx(M) = 0.D0
+ HSig(M) = 0.D0
+ Hdpt(M) = 0.D0
+ 50 CONTINUE
+ ELSE
+ I=1
+ 310 CONTINUE
+ I = I+1
+ IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
+
+ Ia = 1
+ Ib = 1
+ fac = LOG(ECM/HEcm_tab(I-1,IL))
+ & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
+ do M=I1,I2
+C factor due to phase space integration
+ XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ Hfac(M) = XX
+C max. weight
+ XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ HWgx(M) = XX*1.2D0
+C hard cross section
+ XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ HSig(M) = XX
+C differential hard cross section
+ XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
+ & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
+ & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
+ XX = EXP(XX)
+ IF(XX.LT.DEPS2) XX = 0.D0
+ Hdpt(M) = XX
+ enddo
+ ENDIF
+
+ IF((K1.LT.3).AND.(K2.GE.3)) THEN
+C cross check
+ IF((I1.GT.9).OR.(I2.LT.9)) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
+ & 'hard cross section not calculated ',I1,I2
+ ENDIF
+ SIGH = HSig(9)
+ DSIGHP = Hdpt(9)
+C load soft cross sections from interpolation table
+ IF(ECM.LE.SIGECM(IP,1)) THEN
+ L1 = 1
+ L2 = 1
+ ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
+ DO 55 I=2,ISIMAX
+ IF(ECM.LE.SIGECM(IP,I)) GOTO 205
+ 55 CONTINUE
+ 205 CONTINUE
+ L1 = I-1
+ L2 = I
+ ELSE
+ WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
+ & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
+ & IP,ECM,SIGECM(IP,ISIMAX)
+ CALL PHO_PREVNT(-1)
+ L1 = ISIMAX-1
+ L2 = ISIMAX
+ ENDIF
+ FAC2=0.D0
+ IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
+ & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
+ FAC1=1.D0-FAC2
+ SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
+ & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
+
+ FS = FPS(IP)
+ FH = FPH(IP)
+ CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
+ ENDIF
+
+ 300 CONTINUE
+
+C debug output
+ IF(IDEB(58).GE.15) THEN
+ WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
+ & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
+ & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
+ DO 162 M=I1,I2
+ WRITE(LO,'(5X,2I3,1p,4E12.3)')
+ & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
+ 162 CONTINUE
+ ENDIF
+
+ END
+
+ DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
+C***********************************************************************
+C
+C calculate energy-dependent transverse momentum cutoff
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ double precision ECM
+ integer IP
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ pho_ptcut = PARMDL(35+IP)
+
+ IF(IPAMDL(7).EQ.1) THEN
+C Bopp et al. type (DPMJET)
+ pho_ptcut = PARMDL(35+IP)
+ & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
+ ELSE IF(IPAMDL(7).EQ.2) THEN
+C Gribov-Levin-Ryskin type
+ pho_ptcut = PARMDL(35+IP)
+ & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HARMCI
+ SUBROUTINE PHO_HARMCI(IP,EMAXF)
+C**********************************************************************
+C
+C initialize MC sampling and calculate hard cross section
+C
+C input: IP particle combination (neg. number for user cut)
+C EMAXF maximum CMS energy for
+C interpolation table in reference to PTCUT(1..4)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-10,
+ & PLARGE = 1.D20 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+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 obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C names of hard scattering processes
+ INTEGER Max_pro_1
+ PARAMETER ( Max_pro_1 = 16 )
+ CHARACTER*18 PROC
+ COMMON /POHPRO/ PROC(0:Max_pro_1)
+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 interpolation tables for hard cross section and MC selection weights
+ INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
+ PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
+ INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
+ DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
+ & HQ2a_tab,HQ2b_tab,HEcm_tab
+ COMMON /POHTAB/
+ & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
+ & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
+ & HEcm_tab(1:Max_tab_E,0:4),
+ & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
+C event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ COMPLEX*16 DSIG
+ DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
+
+C initialization for all pt cutoffs
+ I = ABS(IP)
+ IL = I
+ IF(IP.LT.0) THEN
+ IL = 0
+ PTC = HSWCUT(4+I)
+ else
+ PTC = pho_ptcut(parmdl(19),I)
+ ENDIF
+
+C skip unassigned PTCUT
+ IF(PTC.LT.0.5D0) GOTO 1000
+
+ IH_Q2a_up(I) = 1
+ IH_Q2b_up(I) = 1
+ do ib=1,Max_tab_Q2
+ do ia=1,Max_tab_Q2
+ do ie=1,Max_tab_E
+ do m=-1,Max_pro_2
+ Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
+ HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
+ HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
+ Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ELLOW = LOG(2.05*PTC)
+ DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
+C energy too low
+ IF(DELTA.LE.0.D0) GOTO 1000
+
+C switch between external particles and Pomeron
+ IF(I.EQ.4) THEN
+ IDP1 = 990
+ PV1 = 0.D0
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE IF(I.EQ.3) THEN
+ IDP1 = IFPAP(2)
+ PV1 = PVIRT(2)
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE IF(I.EQ.2) THEN
+ IDP1 = IFPAP(1)
+ PV1 = PVIRT(1)
+ IDP2 = 990
+ PV2 = 0.D0
+ ELSE
+ IDP1 = IFPAP(1)
+ PV1 = PVIRT(1)
+ IDP2 = IFPAP(2)
+ PV2 = PVIRT(2)
+ ENDIF
+
+C initialize PT scales
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ FPS(I) = PARMDL(105)
+ FPH(I) = PARMDL(106)
+ ELSE
+ FPS(I) = PARMDL(103)
+ FPH(I) = PARMDL(104)
+ ENDIF
+ ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ FPS(I) = PARMDL(103)
+ FPH(I) = PARMDL(104)
+ ELSE
+ FPS(I) = PARMDL(101)
+ FPH(I) = PARMDL(102)
+ ENDIF
+
+C initialize hard scattering
+ IF(IP.GT.0) THEN
+ CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
+ ELSE
+ CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
+ ENDIF
+
+C energy/virtuality grid
+ do Ie=1,IH_Ecm_up(IL)
+ HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
+ enddo
+ do Ia=1,IH_Q2a_up(IL)
+ HQ2a_tab(Ia,IL) = 0.D0
+ enddo
+ do Ib=1,IH_Q2b_up(IL)
+ HQ2b_tab(Ib,IL) = 0.D0
+ enddo
+
+C initialization for several energies and particle virtualities
+ do Ie=1,IH_Ecm_up(IL)
+ do Ia=1,IH_Q2a_up(IL)
+ do Ib=1,IH_Q2b_up(IL)
+
+ EE = HEcm_tab(IE,IL)
+ Q2a = HQ2a_tab(Ia,IL)
+ Q2b = HQ2b_tab(Ib,IL)
+ CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
+ IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
+ & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
+ & PTCUT(I),EE,IDPDG1,IDPDG2
+ Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
+ CALL PHO_HARFAC(PTCUT(I),EE)
+ CALL PHO_HARWGX(PTCUT(I),EE)
+ CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
+ IF(IDEB(8).GE.10) THEN
+ WRITE(LO,'(1X,A,/,1X,A)')
+ & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
+ & '------------------------------------------------'
+ DO M=0,Max_pro_2
+ WRITE(LO,'(10X,A,1P2E14.4)')
+ & PROC(M),DREAL(DSIG(M)),DSPT(M)
+ ENDDO
+ ENDIF
+
+C store in interpolation tables
+ Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
+ HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
+ do M=0,Max_pro_2
+ Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
+ HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
+ HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
+ Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
+ enddo
+
+C summed quantities
+ HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
+ Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
+ do M=1,8
+ IF(MH_pro_on(M,I).GT.0) THEN
+ HSig_tab(9,IE,Ia,Ib,IL) =
+ & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
+ Hdpt_tab(9,IE,Ia,Ib,IL) =
+ & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
+ ENDIF
+ enddo
+ HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
+ Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
+ do M=10,14
+ IF(MH_pro_on(M,I).GT.0) THEN
+ HSig_tab(15,IE,Ia,Ib,IL) =
+ & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
+ Hdpt_tab(15,IE,Ia,Ib,IL) =
+ & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
+ ENDIF
+ enddo
+ HSig_tab(0,IE,Ia,Ib,IL) =
+ & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
+ Hdpt_tab(0,IE,Ia,Ib,IL) =
+ & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
+
+ enddo
+ enddo
+ enddo
+
+C debug output of weights
+ 1000 CONTINUE
+ IF(IDEB(8).GE.5) THEN
+ WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
+ & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
+ & IDPDG1,IDPDG2,IP,PTCUT(I),
+ & '------------------------------------------'
+ DO M=-1,Max_pro_2
+ IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
+ WRITE(LO,'(2X,A,I3,2I7)')
+ & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
+ & M,IDPDG1,IDPDG2
+ do k=1,IH_Ecm_up(IL)
+ do ia=1,IH_Q2a_up(IL)
+ do ib=1,IH_Q2b_up(IL)
+ WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
+ & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
+ & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
+ & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
+ enddo
+ enddo
+ enddo
+ 512 CONTINUE
+ ENDDO
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_HARXR3
+ SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DETAD*DPT)
+C
+C input: ECMH CMS energy
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C ETAD pseudorapidity of parton D
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ DIMENSION DSIGM(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+
+ DOUBLE PRECISION PHO_ALPHAS
+ DIMENSION PDA(-6:6),PDB(-6:6)
+
+ DO 10 I=1,9
+ DSIGMC(I) = CMPLX(0.D0,0.D0)
+ DSIGM(I) = 0.D0
+10 CONTINUE
+
+ EC = EXP(ETAC)
+ ED = EXP(ETAD)
+C kinematic conversions
+ XA = PT*(EC+ED)/ECMH
+ XB = XA/(EC*ED)
+ IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
+ WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA = PHO_ALPHAS(QQAL,3)
+ FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
+C parton distributions (times x)
+ CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
+ CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
+ S1 = PDA(0)*PDB(0)
+ S2 = 0.D0
+ S3 = 0.D0
+ S4 = 0.D0
+ S5 = 0.D0
+ DO 20 I=1,NF
+ S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
+ S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
+ S4 = S4+PDA(I)+PDA(-I)
+ S5 = S5+PDB(I)+PDB(-I)
+20 CONTINUE
+C partial cross sections (including color and symmetry factors)
+C resolved photon matrix elements (light quarks)
+ DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
+ DSIGM(6) = (4.D0/9.D0)*(UU+TT)
+ DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
+ DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
+ DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
+ DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
+ DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
+ DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
+ & (8.D0/27.D0)/(UP*TP))
+C
+ DSIGM(1) = FACTOR*DSIGM(1)*S1
+ DSIGM(2) = FACTOR*DSIGM(2)*S2
+ DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
+ DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
+ DSIGM(5) = FACTOR*DSIGM(5)*S2
+ DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
+ DSIGM(7) = FACTOR*DSIGM(7)*S3
+ DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 50 I=1,8
+ IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
+ 50 CONTINUE
+ END
+
+CDECK ID>, PHO_HARXR2
+ SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DPT)
+C
+C input: ECMH CMS energy
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY= 1.D-20 )
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DO 10 M=1,9
+ DSIGMC(M) = CMPLX(0.D0,0.D0)
+ DSIG1(M) = 0.D0
+10 CONTINUE
+C
+ EC = EXP(ETAC)
+ ARG = ECMH/PT
+ IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
+ EDU = LOG(ARG-EC)
+ EDL =-LOG(ARG-1.D0/EC)
+ NPOINT = NGAUET
+ CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
+ DO 20 M=1,9
+ PCTRL= DREAL(DSIG1(M))/TINY
+ IF( PCTRL.GE.1.D0 ) THEN
+ DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
+ ENDIF
+20 CONTINUE
+30 CONTINUE
+ END
+
+CDECK ID>, PHO_HARXD2
+ SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/(DETAC*DPT) for direct processes
+C
+C input: ECMH CMS energy of scattering system
+C PT parton PT
+C ETAC pseudorapidity of parton C
+C
+C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PHO_ALPHAS,pho_alphae
+ DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
+
+* ONE32=1.D0/9.D0
+* TWO32=4.D0/9.D0
+ DO 10 I=10,13
+ DSIGMC(I) = CMPLX(0.D0,0.D0)
+ DSIGM(I) = 0.D0
+ 10 CONTINUE
+ DSIGMC(15) = CMPLX(0.D0,0.D0)
+ DSIGM(15) = 0.D0
+
+C direct particle 1
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
+ EC = EXP(ETAC)
+ ED = ECMH/PT-EC
+C kinematic conversions
+ XA = 1.D0
+ XB = 1.D0/(EC*ED)
+ IF ( XB.GE.1.D0 ) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA2 = PHO_ALPHAS(QQAL,2)
+ IF(IDPDG1.EQ.22) THEN
+ ALPHA1 = pho_alphae(QQAL)
+ ELSE IF(IDPDG1.EQ.990) THEN
+ ALPHA1 = PARMDL(74)
+ ENDIF
+ FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
+C parton distribution (times x)
+ CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
+ S1 = PDB(0)
+C charge counting
+ S2 = 0.D0
+ S3 = 0.D0
+ IF(IDPDG1.EQ.22) THEN
+ DO 20 I=1,NF
+* IF(MOD(I,2).EQ.0) THEN
+* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
+* S3 = S3 + TWO32
+* ELSE
+* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
+* S3 = S3 + ONE32
+* ENDIF
+ S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
+ S3 = S3 + Q_ch2(I)
+ 20 CONTINUE
+ ELSE IF(IDPDG1.EQ.990) THEN
+ DO 25 I=1,NF
+ S2 = S2 + PDB(I)+PDB(-I)
+ 25 CONTINUE
+ S3 = NF
+ ENDIF
+C partial cross sections (including color and symmetry factors)
+C direct photon matrix elements
+ DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
+ DSIGM(11) = (UU+TT)/(UP*TP)
+C
+ DSIGM(10) = FACTOR*DSIGM(10)*S2
+ DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 50 I=10,11
+ IF(DSIGM(I).LT.0.D0) THEN
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
+ DSIGM(I) = 0.D0
+ ENDIF
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
+ 50 CONTINUE
+ ENDIF
+C
+C direct particle 2
+ IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ EC = EXP(ETAC)
+ ED = 1.D0/(ECMH/PT-1.D0/EC)
+C kinematic conversions
+ XA = PT*(EC+ED)/ECMH
+ XB = 1.D0
+ IF ( XA.GE.1.D0 ) THEN
+ WRITE(LO,'(/1X,A,2E12.4)')
+ & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
+ RETURN
+ ENDIF
+ SP = XA*XB*ECMH*ECMH
+ UP =-ECMH*PT*EC*XB
+ UP = UP/SP
+ TP =-(1.D0+UP)
+ UU = UP*UP
+ TT = TP*TP
+C set hard scale QQ for alpha and partondistr.
+ IF ( NQQAL.EQ.1 ) THEN
+ QQAL = AQQAL*PT*PT
+ ELSEIF ( NQQAL.EQ.2 ) THEN
+ QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQAL.EQ.3 ) THEN
+ QQAL = AQQAL*SP
+ ELSEIF ( NQQAL.EQ.4 ) THEN
+ QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+ IF ( NQQPD.EQ.1 ) THEN
+ QQPD = AQQPD*PT*PT
+ ELSEIF ( NQQPD.EQ.2 ) THEN
+ QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
+ ELSEIF ( NQQPD.EQ.3 ) THEN
+ QQPD = AQQPD*SP
+ ELSEIF ( NQQPD.EQ.4 ) THEN
+ QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
+ ENDIF
+
+ ALPHA1 = PHO_ALPHAS(QQAL,1)
+ IF(IDPDG2.EQ.22) THEN
+ ALPHA2 = pho_alphae(QQAL)
+ ELSE IF(IDPDG2.EQ.990) THEN
+ ALPHA2 = PARMDL(74)
+ ENDIF
+ FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
+C parton distribution (times x)
+ CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
+ S1 = PDA(0)
+C charge counting
+ S2 = 0.D0
+ S3 = 0.D0
+ IF(IDPDG2.EQ.22) THEN
+ DO 70 I=1,NF
+* IF(MOD(I,2).EQ.0) THEN
+* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
+* S3 = S3 + TWO32
+* ELSE
+* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
+* S3 = S3 + ONE32
+* ENDIF
+ S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
+ S3 = S3 + Q_ch2(I)
+ 70 CONTINUE
+ ELSE IF(IDPDG2.EQ.990) THEN
+ DO 75 I=1,NF
+ S2 = S2 + PDA(I)+PDA(-I)
+ 75 CONTINUE
+ S3 = NF
+ ENDIF
+C partial cross sections (including color and symmetry factors)
+C direct photon matrix elements
+ DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
+ DSIGM(13) = (UU+TT)/(UP*TP)
+C
+ DSIGM(12) = FACTOR*DSIGM(12)*S2
+ DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
+C complex part
+ X=ABS(TP-UP)
+ FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
+C
+ DO 80 I=12,13
+ IF(DSIGM(I).LT.0.D0) THEN
+ WRITE(LO,'(1X,A,I3,1P,2E12.4)')
+ & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
+ DSIGM(I) = 0.D0
+ ENDIF
+ DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
+ 80 CONTINUE
+ ENDIF
+ END
+
+CDECK ID>, PHO_HARXPT
+ SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
+C**********************************************************************
+C
+C differential cross section DSIG/DPT
+C
+C input: ECMH CMS energy of scattering system
+C PT parton PT
+C IPRO 1 resolved processes
+C 2 direct processes
+C 3 resolved and direct processes
+C
+C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2)
+ PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+
+ double precision pho_alphae
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DO 10 M=0,Max_pro_2
+ DSIGMC(M) = CMPLX(0.D0,0.D0)
+ DSIG1(M) = CMPLX(0.D0,0.D0)
+ 10 CONTINUE
+
+C resolved and direct processes
+ AMT = 2.D0*PT/ECMH
+ IF ( AMT.GE.1.D0 ) RETURN
+ ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
+ ECL = -ECU
+ NPOINT = NGAUET
+ CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ DSIG1(9) = CMPLX(0.D0,0.D0)
+ DSIG1(15) = CMPLX(0.D0,0.D0)
+ IF(IPRO.EQ.1) THEN
+ CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
+ ELSE IF(IPRO.EQ.2) THEN
+ CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
+ ELSE
+ CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
+ CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
+ ENDIF
+ DO 20 M=1,Max_pro_2
+ DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
+ 20 CONTINUE
+ 30 CONTINUE
+
+C direct processes
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FAC = 0.D0
+ SS = ECMH*ECMH
+ ALPHAE = pho_alphae(SS)
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F1 = Q_ch2(I)*ALPHAE
+ ELSE
+ F1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F2 = Q_ch2(I)*ALPHAE
+ ELSE
+ F2 = PARMDL(74)
+ ENDIF
+ FAC = FAC+F1*F2*3.D0
+ 300 CONTINUE
+C direct cross sections
+ ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
+ T1 = -SS/2.D0*(1.D0+ZZ)
+ T2 = -SS/2.D0*(1.D0-ZZ)
+ XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
+C hadronic part
+ DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
+
+C leptonic part (e, mu, tau)
+ DSIGMC(16) = 0.D0
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
+ DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
+C simulation of tau together with quarks
+ IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
+ ENDIF
+ ENDIF
+
+ DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
+ DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
+
+ END
+
+CDECK ID>, PHO_HARXTO
+ SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
+C**********************************************************************
+C
+C total hard cross section (perturbative QCD, Parton Model)
+C
+C input: ECMH CMS energy of scattering system
+C PTCUTR PT cutoff for resolved processes
+C PTCUTD PT cutoff for direct processes (photon, Pomeron)
+C
+C output: DSIGMC(0:MARPR2) cross sections for given cutoff
+C DSDPTC(0:MARPR2) differential cross sections at cutoff
+C
+C note: COMPLEX*16 DSIGMC
+C DOUBLE PRECISION DSDPTC
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( Max_pro_2 = 16 )
+ COMPLEX*16 DSIGMC
+ DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C integration precision for hard cross sections (obsolete)
+ INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+ COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+
+ double precision pho_alphae
+
+ COMPLEX*16 DSIG1
+ DIMENSION DSIG1(0:Max_pro_2)
+ DIMENSION ABSZ(32),WEIG(32)
+
+ DATA FAC / 3.0D0 /
+
+ DO 10 M=0,Max_pro_2
+ DSIGMC(M)= CMPLX(0.D0,0.D0)
+ 10 CONTINUE
+ EEC=ECMH/2.001D0
+C
+ IF ( PTCUTR.GE.EEC ) GOTO 100
+C
+C integration for resolved processes
+ PTMIN = PTCUTR
+ PTMAX = MIN(FAC*PTMIN,EEC)
+ NPOINT = NGAUP1
+ CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
+ DO 60 M=1,9
+ DSDPTC(M) = DREAL(DSIG1(M))
+ 60 CONTINUE
+ DSIGH = DREAL(DSIG1(9))
+ PTMXX = 0.95D0*PTMAX
+ CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
+ DSIGL = DREAL(DSIG1(9))
+ EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
+ EX1 = 1.0D0-EX
+ DO 50 K=1,2
+ IF ( PTMIN.GE.PTMAX ) GOTO 40
+ RL = PTMIN**EX1
+ RU = PTMAX**EX1
+ CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
+ DO 30 I=1,NPOINT
+ R = ABSZ(I)
+ PT = R**(1.0D0/EX1)
+ CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
+ F = WEIG(I)*PT/(R*EX1)
+ DO 20 M=1,9
+ DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 PTMIN = PTMAX
+ PTMAX = EEC
+ NPOINT = NGAUP2
+ 50 CONTINUE
+ 100 CONTINUE
+ DSIGMC(0) = DSIGMC(9)
+ DSDPTC(0) = DSDPTC(9)
+C
+C integration for direct processes
+ IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
+C
+ IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
+ & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
+ PTMIN = PTCUTD
+ PTMAX = MIN(FAC*PTMIN,EEC)
+ NPOINT = NGAUP1
+ CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
+ IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
+ DO 160 M=10,16
+ DSDPTC(M) = DREAL(DSIG1(M))
+ 160 CONTINUE
+ DSIGH = DREAL(DSIG1(15)-DSIG1(14))
+ PTMXX = 0.95D0*PTMAX
+ CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
+ DSIGL = DREAL(DSIG1(15)-DSIG1(14))
+ EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
+ EX1 = 1.0D0-EX
+ DO 150 K=1,2
+ IF ( PTMIN.GE.PTMAX ) GOTO 140
+ RL = PTMIN**EX1
+ RU = PTMAX**EX1
+ CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
+ DO 130 I=1,NPOINT
+ R = ABSZ(I)
+ PT = R**(1.0D0/EX1)
+ CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
+ F = WEIG(I)*PT/(R*EX1)
+ DO 120 M=10,15
+ DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 PTMIN = PTMAX
+ PTMAX = EEC
+ NPOINT = NGAUP2
+ 150 CONTINUE
+ ENDIF
+C
+ 170 CONTINUE
+C
+C double direct process
+ IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
+ & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
+ FACC = 0.D0
+ SS = ECMH*ECMH
+ ALPHAE = pho_alphae(SS)
+ DO 300 I=1,NF
+ IF(IDPDG1.EQ.22) THEN
+* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F1 = Q_ch2(I)*ALPHAE
+ ELSE
+ F1 = PARMDL(74)
+ ENDIF
+ IF(IDPDG2.EQ.22) THEN
+* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
+ F2 = Q_ch2(I)*ALPHAE
+ ELSE
+ F2 = PARMDL(74)
+ ENDIF
+ FACC = FACC + F1*F2*3.D0
+ 300 CONTINUE
+
+ ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
+ R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
+C hadronic cross section
+ DSIGMC(14) = R*FACC*AKFAC
+C leptonic cross section
+ IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
+ DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
+C simulation of tau together with quarks
+ IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
+ DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
+ ELSE
+ DSIGMC(16) = CMPLX(0.D0,0.D0)
+ ENDIF
+C sum of direct part
+ DSIGMC(15) = CMPLX(0.D0,0.D0)
+ DO 400 I=10,14
+ DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
+ 400 CONTINUE
+ ENDIF
+C total sum (hadronic)
+ DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
+ DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
+
+ END
+
+CDECK ID>, PHO_HARISR
+ SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
+ & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
+C********************************************************************
+C
+C initial state radiation according to DGLAP evolution equations
+C (backward evolution, no spin effects)
+C
+C input: IHPOM index of hard Pomeron
+C negative: delete all previous entries
+C P1,P2 4 momenta of hard scattered final partons
+C (in CMS of hard scattering)
+C IPF1,2 flavours of final partons
+C IPA1,2 flavours of initial partons
+C IV1,2 valence quark labels (0/1)
+C Q2H momentum transfer (squared, positive)
+C XH1,XH2 x values of initial partons
+C XHMAX1,2 max. x values allowed
+C
+C output: all emitted partons in /POPISR/, final state
+C partons are the first two entries
+C shower evolution traced in /PODGL1/
+C IPB1,2 flavours of new initial partons
+C XISR1,2 x values of new initial partons
+C IVO1,2 valence quark labels (0/1)
+C
+C attention: quark numbering according to PDG convention,
+C but 0 for gluons
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (RHOMAS = 0.766D0,
+ & DEPS = 1.D-10,
+ & TINY = 1.D-10)
+
+ DIMENSION P1(4),P2(4)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 data of c.m. system of Pomeron / Reggeon exchange
+ INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
+ DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
+ & SIDP,CODP,SIFP,COFP
+ COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
+ & SIDP,CODP,SIFP,COFP,NPOSP(2),
+ & IDPDG1,IDBAM1,IDPDG2,IDBAM2
+C some hadron information, will be deleted in future versions
+ INTEGER NFS
+ DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
+ COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C scale parameters for parton model calculations
+ INTEGER NQQAL,NQQALI,NQQALF,NQQPD
+ DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
+ COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
+ & NQQAL,NQQALI,NQQALF,NQQPD
+C parameters for DGLAP backward evolution in ISR
+ INTEGER NFSISR
+ DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
+ COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C particles created by initial state evolution
+ INTEGER MXISR1,MXISR2
+ PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
+ INTEGER IFLISR,IPOISR,IMXISR
+ DOUBLE PRECISION PHISR
+ COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
+ & IPOISR(2,2,MXISR2),IMXISR(2)
+
+ DOUBLE PRECISION PYP,EER,THER,QMAXR
+ INTEGER PYK
+
+ DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
+ & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
+ & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
+
+ IREJ = 0
+ NTRY = 1000
+ NITER = 0
+C debug output
+ IF(IDEB(79).GE.10) THEN
+ WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
+ & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
+ & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
+ ENDIF
+ IF(IHPOM.EQ.0) RETURN
+C
+ 10 CONTINUE
+ NACC = 0
+ IDMO(1) = IDPDG1
+ IDMO(2) = IDPDG2
+C
+C copy final state partons to local fields
+ IHIDX = ABS(IHPOM)
+
+ IF(IHIDX.GT.MXISR2) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
+ & IHIDX,MXISR2
+ IREJ = 1
+ ENDIF
+
+ DO 50 K=1,2
+ IF(IHPOM.LT.0) IMXISR(K) = 0
+ IPOISR(K,1,IHIDX) = IMXISR(K)+1
+ IPAL(K) = IPOISR(K,1,IHIDX)
+ 50 CONTINUE
+ DO 55 I=1,4
+ PHISR(1,I,IPAL(1)) = P1(I)
+ PHISR(2,I,IPAL(2)) = P2(I)
+ 55 CONTINUE
+ IFLISR(1,IPAL(1)) = IPF1
+ IFLISR(2,IPAL(2)) = IPF2
+C
+C check limitations, initialize /PODGL1/
+ IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
+ NEXT(1) = 1
+ Q2SH(1,1) = Q2H
+ ELSE
+ NEXT(1) = 0
+ Q2SH(1,1) = 0.D0
+ ENDIF
+ IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
+ NEXT(2) = 1
+ Q2SH(2,1) = Q2H
+ ELSE
+ NEXT(2) = 0
+ Q2SH(2,1) = 0.D0
+ ENDIF
+C
+ ISH(1) = 1
+ ISH(2) = 1
+ XPSH(1,1) = XH1
+ XPSH(2,1) = XH2
+C
+ IFL1(1,1) = IPA1
+ IVAL(1) = IV1
+ IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
+ IFL1(2,1) = IPA2
+ IVAL(2) = IV2
+ IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
+C
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
+ & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
+ IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
+C
+C initialize parton shower loop
+ B0QCD = (33.D0-2.D0*NFSISR)/6.D0
+ AL2ISR(1) = PDFLAM(1)
+ AL2ISR(2) = PDFLAM(2)
+ XHMA(1) = XHMAX1
+ XHMA(2) = XHMAX2
+ XHMI(1) = PMISR(1)/PCMP
+ XHMI(2) = PMISR(2)/PCMP
+ ZPSH(1,1) = 1.D0
+ ZPSH(2,1) = 1.D0
+ SHAT1 = XH1*XH2*ECMP**2
+ IF(IPAMDL(109).EQ.1) THEN
+ PT2SH(1,1) = Q2H
+ ELSE
+ PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
+ ENDIF
+ PT2SH(2,1) = PT2SH(1,1)
+ IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
+ IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
+ THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
+ THSH(2,1) = THSH(1,1)
+ IFANO(1) = 0
+ IFANO(2) = 0
+ ZZ = 1.D0
+ IF(IREJ.NE.0) GOTO 800
+C
+C main generation loop
+C -------------------------------------------------
+ 100 CONTINUE
+C choose parton side to become solved
+ IF((NEXT(1)+NEXT(2)).EQ.2) THEN
+ IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
+ IP = 1
+ ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
+ IP = 2
+ ELSE
+ IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
+ ENDIF
+ ELSE IF(NEXT(1).EQ.1) THEN
+ IP = 1
+ ELSE IF(NEXT(2).EQ.1) THEN
+ IP = 2
+ ELSE
+ GOTO 800
+ ENDIF
+ INDX = ISH(IP)
+C INDX now parton position of parton to become solved
+C IP now side to be treated
+ XP = XPSH(IP,INDX)
+ Q2P = Q2SH(IP,INDX)
+ PT2 = PT2SH(IP,INDX)
+ IFLB = IFL1(IP,INDX)
+C check available x
+ XMIP = XHMI(IP)
+C cutoff by x limitation: no further development
+ IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
+ NEXT(IP) = 0
+ Q2SH(IP,INDX) = 0.D0
+ IF(IDEB(79).GE.17) THEN
+ WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
+ & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
+ & XP,XMIP,XHMA(IP),IP,INDX
+ ENDIF
+ GOTO 100
+ ENDIF
+C initial value of evolution variable t
+ TT = LOG(AQQALI*Q2P/AL2ISR(IP))
+ DO 110 I=-NFSISR,NFSISR
+ WGGAP(I) = 0.D0
+ WGPDF(I) = 0.D0
+ 110 CONTINUE
+C DGLAP weights
+ ZMIN = XP/XHMA(IP)
+ ZMAX = XP/(XP+XMIP)
+ CF = 4./3.
+C q --> q g, g --> g g
+ IF(IFLB.EQ.0) THEN
+ WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
+ & +2.D0*LOG(ZMAX/ZMIN))
+ DO 120 I=1,NFSISR
+ WGGAP(I) = WGGAP(0)
+ WGGAP(-I) = WGGAP(0)
+ 120 CONTINUE
+ WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
+ & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
+C q --> g q, g --> q qb
+ ELSE IF(ABS(IFLB).LE.6) THEN
+ WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
+ & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
+ IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
+ & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
+ ELSE
+ WRITE(LO,'(/1X,A,I7)')
+ & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
+ CALL PHO_ABORT
+ ENDIF
+C anomalous/resolved evolution
+ IPDFC = 0
+ IF(IPAMDL(110).GE.1) THEN
+ IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
+ & .AND.(IFLB.NE.21)) THEN
+ WGDIR = 0.D0
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2*AQQPD
+ ELSE
+ SCALE2 = Q2P*AQQPD
+ ENDIF
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ IPDFC = 1
+ CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
+ XI = DT_RNDM(XP)*PD1(IFLB)
+ IF(WGDIR.GT.XI) THEN
+C debug output
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
+ & 'PHO_HARISR: ',
+ & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
+ & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IFANO(IP) = INDX
+ GOTO 100
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C rejection loop for z,t sampling
+C ------------------------------------
+ 200 CONTINUE
+ NITER = NITER+1
+ IF(NITER.GE.NTRY) THEN
+ WRITE(LO,'(1X,A,2I6)')
+ & 'PHO_HARISR: too many rejections',NITER,NTRY
+ CALL PHO_PREVNT(-1)
+C clean up event
+ IREJ = 1
+ GOTO 10
+ ENDIF
+C PDF weights
+ IF(IPDFC.EQ.0) THEN
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2*AQQPD
+ ELSE
+ SCALE2 = Q2P*AQQPD
+ ENDIF
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ ENDIF
+ IPDFC = 0
+C
+ WGTOT = 0.D0
+ DO 210 I=-NFSISR,NFSISR
+ WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
+ WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
+ 210 CONTINUE
+C
+ 215 CONTINUE
+C sample new t value
+ TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
+ Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
+ & 'PHO_HARISR: pre-selected Q2:',Q2NEW
+C compare to limits
+ IF(Q2NEW.LT.Q2MISR(IP)) THEN
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
+ & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
+ & Q2NEW,Q2MISR(IP),IP,INDX
+ GOTO 100
+ ENDIF
+ Q2SH(IP,INDX) = Q2NEW
+ TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
+C selection of flavours
+ XI = WGTOT*DT_RNDM(TT)
+ IFLA = -NFSISR-1
+ 220 CONTINUE
+ IFLA = IFLA+1
+ XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
+ IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
+ & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
+C selection of z
+ CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: pre-selected ZZ',ZZ
+C angular ordering
+ THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
+ IF(THETA.GT.THSH(IP,INDX)) THEN
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
+ & 'PHO_HARISR: reject by angle (NEW/OLD)',
+ & THETA,THSH(IP,INDX)
+ GOTO 215
+ ENDIF
+C rejection weight given by new PDFs
+ XNEW = XP/ZZ
+ PT2NEW = Q2NEW*(1.D0-ZZ)
+ IF(NQQALI.EQ.1) THEN
+ SCALE2 = PT2NEW*AQQPD
+ ELSE
+ SCALE2 = Q2NEW*AQQPD
+ ENDIF
+ IF(SCALE2.LT.Q2MISR(IP)) THEN
+ Q2SH(IP,INDX) = 0.D0
+ NEXT(IP) = 0
+ IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
+ & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
+ & Q2NEW,Q2MISR(IP),IP,INDX
+ GOTO 100
+ ENDIF
+ CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
+ IF(PD2(IFLA).LT.1.D-10) GOTO 200
+ CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
+ PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
+ WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
+ IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
+ & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
+ IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
+ WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: final weight:',WGF
+ WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
+ & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
+ ENDIF
+ IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
+
+ IF(IDEB(79).GE.15) THEN
+ WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
+ & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
+ & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
+ ENDIF
+
+ IF(INDX.GE.MXISR3) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
+ IREJ = 1
+ RETURN
+ ENDIF
+
+C branching accepted, registration
+ Q2SH(IP,INDX) = Q2NEW
+ PT2SH(IP,INDX) = PT2NEW
+ ZPSH(IP,INDX) = ZZ
+ IFL2(IP,INDX) = IFLA-IFLB
+ Q2SH(IP,INDX+1) = Q2NEW
+ PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
+ XPSH(IP,INDX+1) = XNEW
+ THSH(IP,INDX+1) = THETA
+ IFL1(IP,INDX+1) = IFLA
+ ISH(IP) = ISH(IP)+1
+
+ NACC = NACC+1
+
+ IF(NACC.GT.MXISR4) THEN
+ WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
+ & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ SHAT(NACC) = SHAT1
+ IBRA(1,NACC) = IP
+ IBRA(2,NACC) = INDX
+ SHAT1 = SHAT1/ZZ
+
+C generation of next branching
+ IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
+
+ 800 CONTINUE
+
+C new initial flavours, x values
+ IPB1 = IFL1(1,ISH(1))
+ IPB2 = IFL1(2,ISH(2))
+ XISR1 = XPSH(1,ISH(1))
+ XISR2 = XPSH(2,ISH(2))
+ IVO1 = IVAL(1)
+ IVO2 = IVAL(2)
+C valence flavours
+ IF(IPB1.NE.0) THEN
+ IF(ISH(1).GT.1) THEN
+ CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
+ IF(IDPDG1.EQ.22) THEN
+ CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
+ IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
+ ELSE
+ CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
+ IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IPB2.NE.0) THEN
+ IF(ISH(2).GT.1) THEN
+ CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
+ IF(IDPDG2.EQ.22) THEN
+ CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
+ IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
+ ELSE
+ IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+C parton kinematics
+ IF(NACC.GT.0) THEN
+C final partons in CMS
+ PM(3) = (XH1-XH2)*ECMP/2.D0
+ PM(4) = (XH1+XH2)*ECMP/2.D0
+ SH = XH1*XH2*ECMP**2
+ SSH = SQRT(SH)
+ GB(3) = PM(3)/SSH
+ GB(4) = PM(4)/SSH
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
+ & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
+ & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
+ & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
+ & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
+ IL(1) = 1
+ IL(2) = 1
+ DO 900 I=1,NACC
+ IPA = IBRA(1,I)
+ IPB = 3-IPA
+ IL(IPA) = IBRA(2,I)
+C new initial partons in CMS
+ SH = SHAT(I)
+ SSH = SQRT(SH)
+ SHZ = SH/ZPSH(IPA,IL(IPA))
+ SSHZ = SQRT(SHZ)
+ Q2(1) = Q2SH(1,IL(1))
+ Q2(2) = Q2SH(2,IL(2))
+ PC(1,1) = 0.D0
+ PC(1,2) = 0.D0
+ PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
+ & /(2.D0*SSH)
+ PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
+ PC(2,1) = 0.D0
+ PC(2,2) = 0.D0
+ PC(2,3) = -PC(1,3)
+ PC(2,4) = SSH-PC(1,4)
+ XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
+ EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
+ S1 = SH+Q2(IPA)+Q2(IPB)
+ S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
+ R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
+ R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
+ IF(Q2(IPB).LT.0.1D0) THEN
+ XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
+ & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
+ ELSE
+ XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
+ & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
+ ENDIF
+ NGEN = 1
+C max. virtuality for time-like showers
+ QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
+ IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
+C generate time-like parton shower
+ KF = IFL2(IPA,IL(IPA))
+ IF(KF.EQ.0) KF = 21
+ EER = MIN(EE3-PC(IPA,4),ECMP)
+ THER = 0.
+
+ CALL PY1ENT(1,KF,EER,THER,THER)
+ QMAXR = SQRT(QMAX)
+ CALL PYSHOW(1,0,QMAXR)
+C debug output
+ IF(IDEB(79).GE.25) THEN
+ WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
+ & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
+ & EER,QMAX,XMS4M,Q2(IPA)
+ CALL PYLIST(1)
+ ENDIF
+ NGEN = PYK(0,1)
+
+ IF(NGEN.GT.1) THEN
+ PJX = 0.D0
+ PJY = 0.D0
+ PJZ = 0.D0
+ PJE = 0.D0
+ KK = IPAL(IPA)
+ DO 820 K=3,NGEN
+
+ IF(PYK(K,1).LE.4) THEN
+ KK = KK+1
+
+ IF(KK.GT.MXISR1) THEN
+ WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
+ & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ PHISR(IPA,1,KK) = PYP(K,1)
+ PJX = PJX+PHISR(IPA,1,KK)
+ PHISR(IPA,2,KK) = PYP(K,2)
+ PJY = PJY+PHISR(IPA,2,KK)
+ PHISR(IPA,3,KK) = PYP(K,3)
+ PJZ = PJZ+PHISR(IPA,3,KK)
+ PHISR(IPA,4,KK) = PYP(K,4)
+ PJE = PJE+PHISR(IPA,4,KK)
+ IFLISR(IPA,KK) = PYK(K,2)
+
+ IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
+ IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
+ IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
+ ENDIF
+ 820 CONTINUE
+ NGEN = KK-IPAL(IPA)
+ XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
+ PP4 = SQRT(PJE**2-XMS4)
+ EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
+C debug output
+ IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
+ & 'PHO_HARISR: ',
+ & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
+ & PJE,PJX,PJY,PJZ,PP4,XMS4
+ ENDIF
+ ENDIF
+ PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
+ & /(2.D0*PC(IPA,3))
+ PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
+ IF(PT3.LT.0.D0) THEN
+ IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
+ & 'PHO_HARISR: rejection due to PT3',PT3
+ GOTO 10
+ ENDIF
+ PT3 = SQRT(PT3)
+ CALL PHO_SFECFE(SFE,CFE)
+ PX3 = CFE*PT3
+ PY3 = SFE*PT3
+C
+ IF(NGEN.GT.1) THEN
+C time-like shower generated
+ EE4 = EE3-PC(IPA,4)
+ PZ4 = PZ3-PC(IPA,3)
+ PP4 = SQRT(PT3**2+PZ4**2)
+C Lorentz boost
+ GAM = (EE4*PJE-PP4*PJZ)/XMS4
+ BEG = (PJE*PP4-EE4*PJZ)/XMS4
+C rotation angles
+ CODD = PZ4/PP4
+ SIDD = SQRT(PX3**2+PY3**2)/PP4
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PP4*SIDD.GT.1.D-5) THEN
+ COFD = PX3/(SIDD*PP4)
+ SIFD = PY3/(SIDD*PP4)
+ ANORF = SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C copy partons back
+ KK = IPAL(IPA)
+ DO 830 K=1,NGEN
+ KK = KK+1
+ PX = PHISR(IPA,1,KK)
+ PY = PHISR(IPA,2,KK)
+ PZ = PHISR(IPA,3,KK)
+ COH= PHISR(IPA,4,KK)
+ EE = GAM*COH+BEG*PZ
+ PZ = GAM*PZ +BEG*COH
+ PHISR(IPA,4,KK) = EE
+ CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
+ & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
+ 830 CONTINUE
+ IPAL(IPA) = KK
+ ELSE
+C no time-like shower generated
+ IPAL(IPA) = IPAL(IPA)+1
+ PHISR(IPA,1,IPAL(IPA)) = PX3
+ PHISR(IPA,2,IPAL(IPA)) = PY3
+ PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
+ PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
+ IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
+ ENDIF
+ PC(IPA,1) = PX3
+ PC(IPA,2) = PY3
+ PC(IPA,3) = PZ3
+ PC(IPA,4) = EE3
+C boost / rotate into new CMS
+ DO 842 K=1,4
+ GB(K) = (PC(1,K)+PC(2,K))/SSHZ
+ 842 CONTINUE
+ CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
+ & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
+ COG= PM(3)/PTOT1
+ SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
+ COH=1.D0
+ SIH=0.D0
+ IF(PTOT1*SIG.GT.1.D-5) THEN
+ COH=PM(1)/(SIG*PTOT1)
+ SIH=PM(2)/(SIG*PTOT1)
+ ANORF=SQRT(COH*COH+SIH*SIH)
+ COH=COH/ANORF
+ SIH=SIH/ANORF
+ ENDIF
+ DO 845 K=1,2
+ DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
+ CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
+ & PTOT1,PM(1),PM(2),PM(3),PM(4))
+ CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
+ & PN(2),PN(3))
+ CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
+ PHISR(K,4,L) = PM(4)
+ 844 CONTINUE
+ 845 CONTINUE
+ 900 CONTINUE
+C boost back to global CMS
+ PM(3) = (XISR1-XISR2)/2.D0
+ PM(4) = (XISR1+XISR2)/2.D0
+ SSH = SQRT(XISR1*XISR2)
+ GB(3) = PM(3)/SSH
+ GB(4) = PM(4)/SSH
+ DO 945 K=1,2
+ DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
+ CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
+ & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
+ & PM(2),PM(3),PM(4))
+ PHISR(K,1,L) = PM(1)
+ PHISR(K,2,L) = PM(2)
+ PHISR(K,3,L) = PM(3)
+ PHISR(K,4,L) = PM(4)
+ 944 CONTINUE
+ 945 CONTINUE
+ ENDIF
+ IPOISR(1,2,IHIDX) = IPAL(1)
+ IPOISR(2,2,IHIDX) = IPAL(2)
+ IMXISR(1) = IPAL(1)
+ IMXISR(2) = IPAL(2)
+C
+C debug output
+ IF(IDEB(79).GE.10) THEN
+ WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
+ & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
+ IF(NACC.GT.0) THEN
+ WRITE(LO,'(1X,A,2I5,/6X,A)')
+ & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
+ & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
+ DO 600 II=1,NACC
+ K = IBRA(1,II)
+ I = IBRA(2,II)
+ WRITE(LO,'(5X,4I5,4E11.3)')
+ & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
+ & ZPSH(K,I)
+ 600 CONTINUE
+ ENDIF
+C check of final configuration
+ PX3 = 0.D0
+ PY3 = 0.D0
+ PZ3 = 0.D0
+ EE3 = 0.D0
+ IFSUM(1) = 0
+ IFSUM(2) = 0
+ WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
+ DO 745 K=1,2
+ DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
+ WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
+ & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
+ IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
+ PX3 = PX3 + PHISR(K,1,L)
+ PY3 = PY3 + PHISR(K,2,L)
+ PZ3 = PZ3 + PHISR(K,3,L)
+ EE3 = EE3 + PHISR(K,4,L)
+ 744 CONTINUE
+ 745 CONTINUE
+ IFSUM(1) = IFSUM(1)-IPB1
+ IFSUM(2) = IFSUM(2)-IPB2
+ PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
+ EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
+ WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
+ & IFSUM,PX3,PY3,PZ3,EE3
+ ENDIF
+ END
+
+CDECK ID>, PHO_HARZSP
+ SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
+C*********************************************************************
+C
+C sampling of z values from DGLAP kernels
+C
+C input: IFLA,IFLB parton flavours
+C NFSH flavours involved in hard processes
+C ZMIN minimal ZZ allowed
+C ZMAX maximal ZZ allowed
+C
+C output: ZZ z value
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+
+ IF(ZMAX.LE.ZMIN) THEN
+ WRITE(LO,'(1X,A,2E12.3)')
+ & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
+ CALL PHO_PREVNT(-1)
+ ZZ = 0.D0
+ RETURN
+ ENDIF
+C
+ IF(IFLB.EQ.0) THEN
+ IF(IFLA.EQ.0) THEN
+C g --> g g
+ C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
+ C2 = (1.D0-ZMIN)/ZMIN
+ 100 CONTINUE
+ ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
+ IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
+ ELSE IF(ABS(IFLA).LE.NFSH) THEN
+C q --> q g
+ C1 = ZMAX/ZMIN
+ 200 CONTINUE
+ ZZ = ZMIN*C1**DT_RNDM(ZMIN)
+ IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
+ ELSE
+ GOTO 900
+ ENDIF
+ ELSE IF(ABS(IFLB).LE.NFSH) THEN
+ IF(IFLA.EQ.0) THEN
+C g --> q qb
+ C1 = ZMAX-ZMIN
+ 300 CONTINUE
+ ZZ = ZMIN+C1*DT_RNDM(ZMIN)
+ IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
+ ELSE IF(ABS(IFLA).LE.NFSH) THEN
+C q --> g q
+ C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
+ C2 = 1.D0-ZMIN
+ 400 CONTINUE
+ ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
+ IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
+ ELSE
+ GOTO 900
+ ENDIF
+ ELSE
+ GOTO 900
+ ENDIF
+C debug output
+ IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
+ & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
+ & IFLA,IFLB,ZZ,ZMIN,ZMAX
+ RETURN
+
+ 900 CONTINUE
+ WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
+ & IFLA,IFLB
+ CALL PHO_ABORT
+
+ END
+
+CDECK ID>, PHO_ALPHAE
+ DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
+C**********************************************************************
+C
+C calculation of ALPHA_em
+C
+C input: Q2 scale in GeV**2
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION Q2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ DOUBLE PRECISION PYALEM
+
+ pho_alphae = 1.D0/137.D0
+
+ if(ipamdl(120).eq.1) then
+
+ pho_alphae = PYALEM(Q2)
+
+ endif
+
+ END
+
+CDECK ID>, PHO_ALPHAS
+ DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
+C**********************************************************************
+C
+C calculation of ALPHA_S
+C
+C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
+C 2 lambda_QCD**2 for PDF 2 evolution
+C 3 lambda_QCD**2 for hard scattering
+C Q2 scale in GeV**2
+C
+C initialization needed:
+C IMODE = 0 lambda values taken from PDF table
+C -1 given Q2 is 4-flavour lambda 1
+C -2 given Q2 is 4-flavour lambda 2
+C -3 given Q2 is 4-flavour lambda 3
+C
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ DOUBLE PRECISION Q2
+ INTEGER IMODE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 hard scattering parameters used for most recent hard interaction
+ INTEGER NFbeta,NF
+ DOUBLE PRECISION ALQCD2,BQCD
+ COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ INTEGER I
+
+ PHO_ALPHAS = 0.D0
+
+ IF(IMODE.GT.0) THEN
+
+ IF(Q2.LT.PARMDL(148)) THEN
+ NFbeta = 1
+ ELSE IF(Q2.LT.PARMDL(149)) THEN
+ NFbeta = 2
+ ELSE IF(Q2.LT.PARMDL(150)) THEN
+ NFbeta = 3
+ ELSE
+ NFbeta = 4
+ ENDIF
+
+ PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
+ NFbeta = NFbeta+2
+
+ ELSE IF(IMODE.EQ.0) THEN
+
+ DO I=1,3
+ if(I.EQ.3) then
+ ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
+ else
+ ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
+ endif
+ ALQCD2(I,1) = PARMDL(148)
+ & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
+ ALQCD2(I,3) = PARMDL(149)
+ & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
+ ALQCD2(I,4) = PARMDL(150)
+ & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
+
+ ENDDO
+
+ ELSE IF(IMODE.LT.0) THEN
+
+ if(IMODE.eq.-4) then
+ I = 3
+ ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
+ else
+ I = -IMODE
+ ALQCD2(I,2) = Q2
+ endif
+ ALQCD2(I,1) = PARMDL(148)
+ & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
+ ALQCD2(I,3) = PARMDL(149)
+ & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
+ ALQCD2(I,4) = PARMDL(150)
+ & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DFWRAP
+ SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
+C**********************************************************************
+C
+C wrapper for diffraction dissociation in hadron-nucleus and
+C nucleus-nucleus collisions with DPMJET
+C
+C input: MODE 1: transformation into CMS
+C 2: transformation into Lab
+C JM1/2 indices of old mother particles
+C JM1/2N indices of new mother particles
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER MODE,JM1,JM2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 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)
+
+ DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
+ DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
+
+ INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
+
+C transformation into CMS
+
+ IF(MODE.EQ.1) THEN
+
+ JM1S = JM1
+ JM2S = JM2
+ NHEPS = NHEP
+
+ XM1 = PHEP(5,JM1)
+ XM2 = PHEP(5,JM2)
+
+C boost into CMS
+ P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
+ ECMD = SQRT(SS)
+ DO 10 I=1,4
+ GAMBED(I) = P1(I)/ECMD
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
+ & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ CODD = P1(3)/PTOT1
+ SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = P1(1)/(SIDD*PTOT1)
+ SIFD = P1(2)/(SIDD*PTOT1)
+ ANORF= SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+
+C initial particles in CMS
+
+ P1(1) = 0.D0
+ P1(2) = 0.D0
+ P1(3) = ECMD/2.D0*XPSUB
+ P1(4) = P1(3)
+
+ P2(1) = 0.D0
+ P2(2) = 0.D0
+ P2(3) = -ECMD/2.D0*XTSUB
+ P2(4) = -P2(3)
+
+ CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
+
+ CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
+ & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
+ & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
+
+ CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
+ & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
+ & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
+
+ JM1 = JM1N
+ JM2 = JM2N
+
+C transformation into lab.
+
+ ELSE IF(MODE.EQ.2) THEN
+
+ CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
+ & GAMBED(1),GAMBED(2),GAMBED(3))
+
+ JM1 = JM1S
+ JM2 = JM2S
+
+C clean up after rejection
+
+ ELSE IF(MODE.EQ.-2) THEN
+
+ NHEP = NHEPS
+
+ JM1 = JM1S
+ JM2 = JM2S
+
+ ELSE
+
+ WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DIFDIS
+ SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
+ & MSOFT,MHARD,IREJ)
+C***********************************************************************
+C
+C sampling of diffractive events of different kinds,
+C (produced particles stored in /POEVT1/)
+C
+C input: IDIF1/2 diffractive process particle 1/2
+C 0 elastic/quasi-elastic scattering
+C 1 diffraction dissociation
+C IMOTH1/2 index of mother particles in /POEVT1/
+C SPROB suppression factor (survival probability) for
+C resolved diffraction dissociation
+C IMODE mode of operation
+C 0 sampling of diffractive cut
+C 1 sampling of enhanced cut
+C 2 sampling of diffractive cut without
+C scattering (needed for double-pomeron)
+C -1 initialization
+C -2 output of statistics
+C
+C output: MSOFT number of generated soft strings
+C MHARD number of generated hard strings
+C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
+C 0 quasi elastic scattering
+C 1 low-mass diffractive dissociation
+C 2 soft high-mass diffractive dissociation
+C 3 hard resolved diffractive dissociation
+C 4 hard direct diffractive dissociation
+C IREJ rejection label
+C 0 successful generation of partons
+C 1 failure
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-7,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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 c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C obsolete cut-off information
+ DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
+ COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+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 Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+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 event weights and generated cross section
+ INTEGER IPOWGC,ISWCUT,IVWGHT
+ DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
+ COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
+ & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
+
+ DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
+ DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
+ DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
+ & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
+ & IDIR(2),IPROC(2)
+
+ IF(IMODE.EQ.-1) THEN
+C initialization
+ RETURN
+ ELSE IF(IMODE.EQ.-2) THEN
+C output of statistics
+ RETURN
+ ENDIF
+
+ IREJ = 0
+C mass cuts
+ PIMASS = 0.140D0
+C debug output
+ IF(IDEB(45).GE.10) THEN
+ WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
+ & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
+ & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
+ ENDIF
+ IPAR(1) = IDIF1
+ IPAR(2) = IDIF2
+C save current status
+ MSOFT = 0
+ MHARD = 0
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+ IPOIS3 = IPOIX3
+ JDA11 = JDAHEP(1,IMOTH1)
+ JDA21 = JDAHEP(2,IMOTH1)
+ JDA12 = JDAHEP(1,IMOTH2)
+ JDA22 = JDAHEP(2,IMOTH2)
+ ISTH1 = ISTHEP(IMOTH1)
+ ISTH2 = ISTHEP(IMOTH2)
+ NHEPS = NHEP
+C get mother data
+ NPOSD(1) = IMOTH1
+ NPOSD(2) = IMOTH2
+ DO 20 I=1,2
+ IDPDG(I) = IDHEP(NPOSD(I))
+ IDBAM(I) = IMPART(NPOSD(I))
+ AMP(I) = PHO_PMASS(IDBAM(I),0)
+ IF(IDPDG(I).EQ.22) THEN
+ PMASSD(I) = 0.765D0
+ PVIRTD(I) = PHEP(5,NPOSD(I))**2
+ ELSE
+ PMASSD(I) = PHO_PMASS(IDBAM(I),0)
+ PVIRTD(I) = 0.D0
+ ENDIF
+ 20 CONTINUE
+C get CM system
+ P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
+ P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
+ P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
+ P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
+ SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
+ ECMD = SQRT(SS)
+ IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
+ & 'PHO_DIFDIS: availabe energy',ECMD
+C check total available energy
+ IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
+ & 'PHO_DIFDIS: ',
+ & 'not enough energy for inelastic diffraction',
+ & 'ECM, particle masses:',ECMD,AMP
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+C boost into CMS
+ DO 10 I=1,4
+ GAMBED(I) = P1(I)/ECMD
+ 10 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
+ & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
+C rotation angles
+ CODD = P1(3)/PTOT1
+ SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = P1(1)/(SIDD*PTOT1)
+ SIFD = P1(2)/(SIDD*PTOT1)
+ ANORF= SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C initial particles in CMS
+ PDCMS(1,1) = 0.D0
+ PDCMS(2,1) = 0.D0
+ PDCMS(3,1) = PTOT1
+ PDCMS(4,1) = P1(4)
+ PDCMS(1,2) = 0.D0
+ PDCMS(2,2) = 0.D0
+ PDCMS(3,2) = -PTOT1
+ PDCMS(4,2) = ECMD-P1(4)
+C get new CM momentum
+ AM12 = PMASSD(1)**2
+ AM22 = PMASSD(2)**2
+ PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
+
+C coherence constraint (min/max diffractive mass allowed)
+ IF(IMODE.EQ.2) THEN
+ THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
+ THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
+ THRM2 = SQRT(1-PARMDL(72))*ECMD
+ THRM2 = MIN(THRM2,ECMD/PARMDL(70))
+ ELSE
+ THRM1 = PARMDL(46)
+ THRM2 = PARMDL(45)*ECMD
+C check kinematic limits
+ IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
+ IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
+ ENDIF
+
+C check energy vs. coherence constraints
+ IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
+ IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
+
+C no phase space available
+ IF(IPAR(1)+IPAR(2).EQ.0) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
+ & 'PHO_DIFDIS: ',
+ & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
+ & 'side 1: min. mass, upper mass limit:',
+ & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
+ & 'side 2: min. mass, upper mass limit:',
+ & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+
+ ITRY = 0
+ ITRYM = 10
+ IPARS1 = IPAR(1)
+ IPARS2 = IPAR(2)
+
+C main rejection loop
+C -------------------------------
+ 50 CONTINUE
+ ITRY = ITRY+1
+ IF(ITRY.GT.1) THEN
+ IFAIL(13) = IFAIL(13)+1
+ IF(ITRY.GE.ITRYM) THEN
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
+ & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
+ IFAIL(7) = IFAIL(7)+1
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+ IPAR(1) = IPARS1
+ IPAR(2) = IPARS2
+C reset mother-daugther relations
+ NHEP = NHEPS
+ JDAHEP(1,IMOTH1) = JDA11
+ JDAHEP(2,IMOTH1) = JDA21
+ JDAHEP(1,IMOTH2) = JDA12
+ JDAHEP(2,IMOTH2) = JDA22
+ ISTHEP(IMOTH1) = ISTH1
+ ISTHEP(IMOTH2) = ISTH2
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ IPOIX3 = IPOIS3
+C
+ NSLP = 0
+ NCOR = 0
+ 55 CONTINUE
+
+C calculation of kinematics
+ DO 100 I=1,2
+C sampling of masses
+ IRPDG(I) = 0
+ IRBAM(I) = 0
+ IFL1P(I) = IDPDG(I)
+ IFL2P(I) = IDBAM(I)
+ IVEC(I) = 0
+ IDIR(I) = 0
+ ISAM(I) = 0
+ JSAM(I) = 0
+ KSAM(I) = 0
+ IF(IPAR(I).EQ.0) THEN
+C vector meson dominance assumed
+ XMASS(I) = AMP(I)
+ CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
+C diffraction dissociation
+ ELSE IF(IPAR(I).EQ.1) THEN
+ XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
+ PREF2 = PMASSD(I)**2
+ XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
+ ELSE
+ WRITE(LO,'(/1X,A,2I3)')
+ & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
+ CALL PHO_ABORT
+ ENDIF
+ 100 CONTINUE
+
+C sampling of momentum transfer
+ CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
+ & THRM2,TT,SLWGHT,IREJ)
+ IF(IREJ.NE.0) THEN
+ NSLP=NSLP+1
+ IF(NSLP.LT.100) GOTO 55
+ WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
+ & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
+ IREJ = 5
+ RETURN
+ ENDIF
+
+C correct for t-M^2 correlation in diffraction
+ IF(DT_RNDM(TT).GT.SLWGHT) THEN
+ NCOR=NCOR+1
+ IF(NCOR.LT.100) GOTO 55
+ WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
+ & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
+ IREJ = 5
+ RETURN
+ ENDIF
+
+C debug output
+ IF(IDEB(45).GE.5) THEN
+ WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
+ & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
+ ENDIF
+C not double pomeron scattering
+ IF(IMODE.NE.2) THEN
+C sample diffractive interaction processes
+ DO 120 I=1,2
+ IF(IPAR(I).NE.0) THEN
+C find particle combination
+ IF(IDPDG(I).EQ.IFPAP(1)) THEN
+ IP = 2
+ ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
+ IP = 3
+ ELSE IF(IDPDG(I).EQ.990) THEN
+ IP = 4
+ ELSE
+ IP = I+1
+ ENDIF
+C sample dissociation process
+ CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
+ & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
+ & KSAM(I),IDIR(I))
+ IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
+C store process label
+ IF(IDIR(I).GT.0) THEN
+ IPAR(I) = 4
+ ELSE IF(KSAM(I).GT.0) THEN
+ IPAR(I) = 3
+ ELSE IF(ISAM(I).GT.0) THEN
+ IPAR(I) = 2
+ ELSE
+ IPAR(I) = 1
+C mass fine correction
+ CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
+ & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
+ XMASS(I) = XMNEW
+ ENDIF
+ ELSE
+C diffractive pomeron-hadron interaction
+ IPAR(I) = 10+IPROC(I)
+ ENDIF
+C debug output
+ IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
+ & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
+ & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
+ ENDIF
+ 120 CONTINUE
+ ENDIF
+C actualize debug information
+ IF(IMODE.EQ.1) THEN
+ IDIFR1 = IPAR(1)
+ IDIFR2 = IPAR(2)
+ ENDIF
+C calculate new momenta in CMS
+ CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ DO 130 I=1,4
+ PP(I,1) = P1(I)
+ PP(I,2) = P2(I)
+ 130 CONTINUE
+
+C comment line for diffraction
+ CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
+ & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
+C write diffractive strings/particles
+ DO 200 I=1,2
+ I1 = I
+ I2 = 3-I1
+ DO K=1,4
+ PD1(K) = PP(K,I1)
+ PD2(K) = PP(K,I2)
+ ENDDO
+ PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
+ PP(7,I1) = TT
+ IGEN = IPHIST(2,NPOSD(I1))
+ if(IGEN.eq.0) IGEN = -I1*10
+ CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
+ & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(7+I) = IFAIL(7+I)+1
+ IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
+ & I,IPAR(I),XMASS(I)
+ GOTO 50
+ ENDIF
+ ICOLOR(I1,ICPOS) = IPOSP(1,I1)
+ 200 CONTINUE
+C double-pomeron scattering?
+ IF(IMODE.EQ.2) GOTO 150
+
+C diffractive final states
+ DO 300 I=1,2
+ 110 CONTINUE
+ IF(IPAR(I).EQ.0) THEN
+C vector meson production
+ IF(IDPDG(I).EQ.22) THEN
+ IF(ISWMDL(21).GE.0) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
+ ENDIF
+C hadronic state of multi-pomeron coupling
+ ELSE IF(IDPDG(I).EQ.990) THEN
+ CALL PHO_SDECAY(IPOSP(1,I),0,2)
+ ENDIF
+ ELSE
+ IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
+ IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
+ IF(IDIR(I).GT.0) THEN
+ IPAR(I) = 4
+ ELSE IF(KSAM(I).GT.0) THEN
+ IPAR(I) = 3
+ ELSE IF(ISAM(I).GT.0) THEN
+ IPAR(I) = 2
+ ELSE
+ IPAR(I) = 1
+ ENDIF
+ ELSE
+ IPAR(I) = 10+IPROC(I)
+ ENDIF
+ IPHIST(I,ICPOS) = IPAR(I)
+C update debug informantion
+ KSPOM = ISAM(I)
+ KSREG = JSAM(I)
+ KHPOM = KSAM(I)
+ KHDIR = IDIR(I)
+ IDIFR1 = IPAR(1)
+ IDIFR2 = IPAR(2)
+ IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
+
+C resonance decay, pi+pi- background
+ P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
+ P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
+ P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
+ P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
+ CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
+ & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
+C decay
+ IF(IDPDG(I).EQ.22) THEN
+ IPHIST(2,IPOS) = 3
+ IF(ISWMDL(21).GE.0) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(IPOS,ISP,2)
+ ENDIF
+ ELSE
+ CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
+ ENDIF
+ IREJ = 0
+ ELSE
+
+C particle-pomeron scattering
+ IF(IPAR(I).LE.4) THEN
+C non-diffractive particle-pomeron scattering
+ IGEN = IPHIST(2,NPOSD(I))
+ if(IGEN.eq.0) then
+ if(I.eq.1) then
+ IGEN = 5
+ else
+ IGEN = 6
+ endif
+ endif
+ CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
+ & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
+ ELSE
+C diffractive particle-pomeron scattering
+ IPOIX2 = IPOIX2+1
+ IPORES(IPOIX2) = IPROC(I)
+ IPOPOS(1,IPOIX2) = IPOSP(1,I)
+ IPOPOS(2,IPOIX2) = IPOSP(2,I)
+ ENDIF
+ ENDIF
+ ENDIF
+
+C rejection?
+ IF(IREJ.NE.0) THEN
+ IFAIL(20+I) = IFAIL(20+I)+1
+ IF(IPAR(I).GT.1) THEN
+ IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
+ IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
+ IF(IDIR(I).GT.0) THEN
+ IDIR(I) = 0
+ ELSE IF(KSAM(I).GT.0) THEN
+ KSAM(I) = KSAM(I)-1
+ ELSE IF(ISAM(I).GT.0) THEN
+ ISAM(I) = ISAM(I)-1
+ ENDIF
+ GOTO 110
+ ELSE
+ IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
+ & I,IPAR(I),XMASS(I)
+ GOTO 50
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+
+ IDIF1 = IPAR(1)
+ IDIF2 = IPAR(2)
+C update debug information
+ KSPOM = KSPOMS+ISAM(1)+ISAM(2)
+ KSREG = KSREGS+JSAM(1)+JSAM(2)
+ KHPOM = KHPOMS+KSAM(1)+KSAM(2)
+ KHDIR = KHDIRS+IDIR(1)+IDIR(2)
+
+ 150 CONTINUE
+
+C debug output
+ IF(IDEB(45).GE.10) THEN
+ WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
+ & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
+ & IPAR,NPOSD,MSOFT,MHARD,IMODE
+ ENDIF
+ IF(IDEB(45).GE.15) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
+ & '------------------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DIFPRO
+ SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
+ & IPROC,ISAM,JSAM,KSAM,IDIR)
+C*********************************************************************
+C
+C sampling of diffraction dissociation process
+C
+C input: IP particle combination
+C ICUT user imposed limitations
+C ID1/2 PDG particle code of scattering particles
+C XMASS diffractively produced mass (GeV)
+C P2V1/2 virtuality of scattering particles (Gev**2)
+C SPROB suppression factor for resolved single and
+C double diffraction dissociation
+C
+C output: IRPOC process ID
+C ISAM number of cut pomerons (soft)
+C JSAM number of cut reggeons
+C KSAM number of cut pomerons (hard)
+C IDIR direct hard interaction
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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)
+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 energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+
+ ISAM = 0
+ JSAM = 0
+ KSAM = 0
+ IDIR = 0
+
+ IF(XMASS.GT.3.D0) THEN
+C rapidity gap survival probability
+ SPRO = 1.D0
+ IF(ISWMDL(28).GE.1) SPRO = SPROB
+C sample interaction
+ IPROC = 0
+ CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
+ ELSE
+ IPROC = 1
+ ENDIF
+ IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
+C non-diffractive hadron-pomeron interaction
+ IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
+C option for suppression of multiple interaction
+ IF(ICUT.EQ.0) THEN
+ IPROC = 1
+ IF(ISAM+KSAM+IDIR.GT.0) THEN
+ ISAM = 1
+ JSAM = 0
+ ELSE
+ JSAM = 1
+ ENDIF
+ KSAM = 0
+ IDIR = 0
+ ELSE IF(ICUT.EQ.1) THEN
+ IF(IDIR.GT.0) THEN
+ ELSE IF(KSAM.GT.0) THEN
+ KSAM = 1
+ ISAM = 0
+ JSAM = 0
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = 1
+ JSAM = 0
+ ELSE
+ JSAM = 1
+ ENDIF
+ ELSE IF(ICUT.EQ.2) THEN
+ KSAM = MIN(KSAM,1)
+ ELSE IF(ICUT.EQ.3) THEN
+ ISAM = MIN(ISAM,1)
+ ENDIF
+ ENDIF
+ END
+
+CDECK ID>, PHO_DIFPAR
+ SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
+ & IPOSH1,IPOSH2,IMODE,IREJ)
+C***********************************************************************
+C
+C perform string construction for diffraction dissociation
+C
+C input: IMOTH1,2 index of mother particles in POEVT1
+C IGENM production process of mother particles
+C IFL1,IFL2 particle numbers
+C (IDPDG,IDBAM for quasi-elas. hadron)
+C IPAR 0 quasi-elasic scattering
+C 1 single string configuration
+C 2 two string configuration
+C P1 massive 4 momentum of first
+C P1(6) virtuality/squ.mass of particle (GeV**2)
+C P1(7) virtuality of Pomeron (neg, GeV**2)
+C P2 massive 4 momentum of second particle
+C IMODE 1 diffraction dissociation
+C 2 double-pomeron scattering
+C
+C output: IPOSH1,2 index of the particles in /POEVT1/
+C IREJ 0 successful string construction
+C 1 no string construction possible
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(7),P2(7)
+
+ PARAMETER ( EPS = 1.D-7,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+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)
+
+ DIMENSION PCH1(2,4)
+ data IC1 /0/
+ data IC2 /0/
+
+ IREJ = 0
+ ILTR1 = NHEP+1
+ IGEN = IGENM
+ if(IGENM.le.-10) IGEN = 0
+
+C elastic part
+ IF(IPAR.EQ.0) THEN
+ IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
+ if(IGEN.eq.0) IGEN = 3
+C pi+/pi- isotropic background
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
+ & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
+ CALL PHO_SDECAY(IPOSH1,0,-2)
+ ELSE
+ if(IGEN.eq.0) then
+ IGEN = 2
+ if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
+ endif
+C registration of particle or resonance
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
+ & P1(4),0,IGEN,0,0,IPOSH1,1)
+ ENDIF
+
+C diffraction dissociation
+ ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
+C calculation of resulting particle momenta
+ IF(IMOTH1.EQ.NPOSD(1)) THEN
+ K = 2
+ ELSE
+ K = 1
+ ENDIF
+ DO 100 I=1,4
+ PCH1(2,I) = PDCMS(I,K)-P2(I)
+ PCH1(1,I) = P1(I)-PCH1(2,I)
+ 100 CONTINUE
+
+C registration
+ if(IMODE.LT.2) then
+ if(IGEN.eq.0) IGEN = -IGENM/10+4
+ CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
+ & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
+ else
+ if(IGEN.eq.0) IGEN = 4
+ endif
+ CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
+ & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
+
+C invalid IPAR
+ ELSE
+ WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
+ CALL PHO_ABORT
+ ENDIF
+
+C back transformation
+ CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
+ & GAMBED(1),GAMBED(2),GAMBED(3))
+
+ END
+
+CDECK ID>, PHO_QELAST
+ SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
+C**********************************************************************
+C
+C sampling of quasi elastic processes
+C
+C input: IPROC 2 purely elastic scattering
+C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
+C IPROC 4 double pomeron scattering
+C IPROC -1 initialization
+C IPROC -2 output of statistics
+C JM1/2 index of initial particle 1/2
+C
+C output: initial and final particles in /POEVT1/ involving
+C polarized resonances in /POEVT1/ and decay
+C products
+C
+C IREJ 0 successful
+C 1 failure
+C 50 user rejection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( NTAB = 20,
+ & EPS = 1.D-10,
+ & PIMASS = 0.13D0,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+
+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)
+
+ DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
+ DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
+ DIMENSION IFL(2),IDPRO(4)
+ character*15 pho_pname
+ CHARACTER*8 VMESA(0:4),VMESB(0:4)
+ DIMENSION ISAMVM(4,4)
+ DATA IDPRO / 113,223,333,92 /
+ DATA VMESA / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+ DATA VMESB / 'vmeson ','rho ','omega ','phi ',
+ & 'pi+pi- ' /
+
+C sampling of elastic/quasi-elastic processes
+ IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
+ IREJ = 0
+ NPOSD(1) = JM1
+ NPOSD(2) = JM2
+ DO 55 I=1,2
+ PMI(I) = PHEP(5,NPOSD(I))
+ IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
+ 55 CONTINUE
+C get CM system
+ PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
+ PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
+ PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
+ PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
+ SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
+ ECMD = SQRT(SS)
+
+ IF(ECMD.LE.PMI(1)+PMI(2)) THEN
+ IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
+ & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
+ & ECMD,PMI
+ IREJ = 5
+ RETURN
+ ENDIF
+
+ DO 60 I=1,4
+ GAMBED(I) = PK1(I)/ECMD
+ 60 CONTINUE
+ CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
+ & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
+ & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
+C rotation angles
+ CODD = PK1(3)/PTOT1
+ SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
+ COFD = 1.D0
+ SIFD = 0.D0
+ IF(PTOT1*SIDD.GT.1.D-5) THEN
+ COFD = PK1(1)/(SIDD*PTOT1)
+ SIFD = PK1(2)/(SIDD*PTOT1)
+ ANORF = SQRT(COFD*COFD+SIFD*SIFD)
+ COFD = COFD/ANORF
+ SIFD = SIFD/ANORF
+ ENDIF
+C get CM momentum
+ AM12 = PMI(1)**2
+ AM22 = PMI(2)**2
+ PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
+
+C production process of mother particles
+ IGEN = IPHIST(2,NPOSD(1))
+ if(IGEN.eq.0) IGEN = IPROC
+
+ ICALL = ICALL + 1
+C main rejection label
+ 50 CONTINUE
+C determine process and final particles
+ IFL(1) = IDHEP(NPOSD(1))
+ IFL(2) = IDHEP(NPOSD(2))
+ IF(IPROC.EQ.3) THEN
+ ITRY = 0
+ 100 CONTINUE
+ ITRY = ITRY+1
+ IF(ITRY.GT.50) THEN
+ IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
+ & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
+ & ITRY,ECMD
+ IREJ = 5
+ RETURN
+ ENDIF
+ XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
+ DO 110 I=1,4
+ DO 120 J=1,4
+ XI = XI-SIGVM(I,J)
+ IF(XI.LE.0.D0) GOTO 130
+ 120 CONTINUE
+ 110 CONTINUE
+ 130 CONTINUE
+ IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
+ IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
+ ISAMVM(I,J) = ISAMVM(I,J)+1
+ ISAMQE = ISAMQE+1
+C sample new masses
+ CALL PHO_SAMASS(IFL(1),RMASS(1))
+ CALL PHO_SAMASS(IFL(2),RMASS(2))
+ IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
+ ELSE IF(IPROC.EQ.2) THEN
+ I = 0
+ J = 0
+ ISAMEL = ISAMEL+1
+ RMASS(1) = PHO_PMASS(NPOSD(1),2)
+ RMASS(2) = PHO_PMASS(NPOSD(2),2)
+ ELSE
+ WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
+ CALL PHO_ABORT
+ ENDIF
+C sample momentum transfer
+ CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
+ & SLWGHT,IREJ)
+ IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
+ & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
+C calculate new momenta
+ CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ DO K=1,4
+ P(K,1) = PK1(K)
+ P(K,2) = PK2(K)
+ ENDDO
+C comment line for elastic/quasi-elastic scattering
+ CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
+ & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
+
+ I1 = NHEP+1
+C fill /POEVT1/
+ DO 200 I=1,2
+ K = 3-I
+ IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
+C pi+/pi- isotropic background
+ IGEN = 3
+ CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
+ & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
+ ICOLOR(I,ICPOS) = IPOS
+ CALL PHO_SDECAY(IPOS,0,-2)
+ ELSE
+C registration
+ IGEN = 2
+ if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
+ CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
+ & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
+ ICOLOR(I,ICPOS) = IPOS
+ ENDIF
+ 200 CONTINUE
+ I2 = NHEP
+C search for vector mesons
+ DO 300 I=I1,I2
+C decay according to polarization
+ IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
+ ISP = IPAMDL(3)
+ IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
+ CALL PHO_SDECAY(I,ISP,2)
+ ENDIF
+ 300 CONTINUE
+ I2 = NHEP
+C back transformation
+ CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
+ & GAMBED(2),GAMBED(3))
+
+C initialization of tables
+ ELSE IF(IPROC.EQ.-1) THEN
+ DO 10 I=1,4
+ DO 20 J=1,4
+ ISAMVM(I,J) = 0
+ 20 CONTINUE
+ 10 CONTINUE
+ ISAMEL = 0
+ ISAMQE = 0
+ IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
+ IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
+ CALL PHO_SAMASS(-1,RMASS(1))
+ ICALL = 0
+
+C output of statistics
+ ELSE IF(IPROC.EQ.-2) THEN
+ IF(ICALL.LT.10) RETURN
+ WRITE(LO,'(/,1X,A,I10/,1X,A)')
+ & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
+ & '---------------------------------------------------'
+ WRITE(LO,'(1X,A,I10)')
+ & 'sampled elastic processes:',ISAMEL
+ WRITE(LO,'(1X,A,I10)')
+ & 'sampled quasi-elastic vectormeson production:',ISAMQE
+ WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
+ DO 30 I=1,4
+ WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
+ 30 CONTINUE
+ CALL PHO_SAMASS(-2,RMASS(1))
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
+ & 'unknown process ID',IPROC
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_CDIFF
+ SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
+C**********************************************************************
+C
+C preparation of /POEVT1/ for double-pomeron scattering
+C
+C input: IMOTH1/2 index of mother particles in /POEVT1/
+C
+C IMODE 1 sampling of pomeron-pomeron scattering
+C -1 initialization
+C -2 output of statistics
+C
+C output: MSOFT number of generated soft strings
+C MHARD number of generated hard strings
+C IREJ 0 accepted
+C 1 rejected
+C 50 user rejection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10,
+ & DEPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+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)
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C energy-interpolation table
+ INTEGER IEETA2
+ PARAMETER ( IEETA2 = 20 )
+ INTEGER ISIMAX
+ DOUBLE PRECISION SIGTAB,SIGECM
+ COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
+C table of particle indices for recursive PHOJET calls
+ INTEGER MAXIPX
+ PARAMETER ( MAXIPX = 100 )
+ INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
+ COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
+ & IPOIX1,IPOIX2,IPOIX3
+
+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)
+
+ DIMENSION PD(4)
+
+ if(IMODE.ne.1) return
+
+ IREJ = 0
+ IP = 4
+C select first diffraction
+ IF(DT_RNDM(DUM).GT.0.5D0) THEN
+ IPAR1 = 1
+ IPAR2 = 0
+ ELSE
+ IPAR1 = 0
+ IPAR2 = 1
+ ENDIF
+ ITRY2 = 0
+ ITRYM = 1000
+
+C save current status
+ MSOFT = 0
+ MHARD = 0
+ KHPOMS = KHPOM
+ KSPOMS = KSPOM
+ KSREGS = KSREG
+ KHDIRS = KHDIR
+ IPOIS1 = IPOIX1
+ IPOIS2 = IPOIX2
+ IPOIS3 = IPOIX3
+ JDA11 = JDAHEP(1,IMOTH1)
+ JDA21 = JDAHEP(2,IMOTH1)
+ JDA12 = JDAHEP(1,IMOTH2)
+ JDA22 = JDAHEP(2,IMOTH2)
+ ISTH1 = ISTHEP(IMOTH1)
+ ISTH2 = ISTHEP(IMOTH2)
+ NHEPS = NHEP
+
+C find mother particle production process
+ IGEN = IPHIST(2,IMOTH1)
+ if(IGEN.eq.0) IGEN = 4
+
+C main generation loop
+ 60 CONTINUE
+
+ KSPOM = KSPOMS
+ KHPOM = KHPOMS
+ KHDIR = KHDIRS
+ KSREG = KSREGS
+ I1 = IPAR1
+ I2 = IPAR2
+C reset mother-daugther relations
+ NHEP = NHEPS
+ JDAHEP(1,IMOTH1) = JDA11
+ JDAHEP(2,IMOTH1) = JDA21
+ JDAHEP(1,IMOTH2) = JDA12
+ JDAHEP(2,IMOTH2) = JDA22
+ ISTHEP(IMOTH1) = ISTH1
+ ISTHEP(IMOTH2) = ISTH2
+ IPOIX1 = IPOIS1
+ IPOIX2 = IPOIS2
+ IPOIX3 = IPOIS3
+C rejection counter
+ ITRY2 = ITRY2+1
+ IF(ITRY2.GT.1) THEN
+ IFAIL(39) = IFAIL(39)+1
+ IF(ITRY2.GE.ITRYM) GOTO 50
+ ENDIF
+C generate two diffractive events
+ CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+ CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
+ IF(IREJ.NE.0) GOTO 50
+C mass of pomeron-pomeron system
+ DO 100 I2 = NHEP,1,-1
+ IF(IDHEP(I2).EQ.990) GOTO 110
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 I1 = I2-1,1,-1
+ IF(IDHEP(I1).EQ.990) GOTO 130
+ 120 CONTINUE
+ 130 CONTINUE
+ DO 140 I=1,4
+ PD(I) = PHEP(I,I1)+PHEP(I,I2)
+ 140 CONTINUE
+ XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
+ IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
+ & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
+ IF(XMASS.LT.0.1D0) GOTO 60
+ XMASS = SQRT(XMASS)
+ IF(XMASS.LT.PARMDL(71)) GOTO 60
+
+C sample pomeron-pomeron interaction process
+ CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
+ & IPROC,ISAM,JSAM,KSAM,IDIR)
+
+C non-diffractive pomeron-pomeron interactions
+ IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
+ 200 CONTINUE
+ IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
+C debug output
+ IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
+ & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
+ & IP,XMASS,ISAM,JSAM,KSAM,IDIR
+C store debug information
+ IF(IDIR.GT.0) THEN
+ IPAR = 4
+ ELSE IF(KSAM.GT.0) THEN
+ IPAR = 3
+ ELSE IF(ISAM.GT.0) THEN
+ IPAR = 2
+ ELSE
+ IPAR = 1
+ ENDIF
+ IDDPOM = IPAR
+ IF(ISAM+JSAM.GT.0) KSDPO = 1
+ IF(KSAM+IDIR.GT.0) KHDPO = 1
+ KSPOM = ISAM
+ KSREG = JSAM
+ KHPOM = KSAM
+ KHDIR = IDIR
+ KSTRG = 0
+ KSLOO = 0
+C generate pomeron-pomeron interaction
+ CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
+ IF(IREJ.NE.0) THEN
+ IFAIL(3) = IFAIL(3)+1
+ IF(IPAR.GT.1) THEN
+ IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
+ IF(IDIR.GT.0) THEN
+ IFAIL(10) = IFAIL(10)+1
+ IDIR = 0
+ ELSE IF(KSAM.GT.0) THEN
+ KSAM = KSAM-1
+ ELSE IF(ISAM.GT.0) THEN
+ ISAM = ISAM-1
+ ENDIF
+ GOTO 200
+ ELSE
+ IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
+ & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
+ & I,IPAR,XMASS
+ GOTO 50
+ ENDIF
+ ENDIF
+
+C diffractive pomeron-pomeron interactions
+ ELSE
+ IPOIX2 = IPOIX2+1
+ IPORES(IPOIX2) = IPROC
+ IPOPOS(1,IPOIX2) = I1
+ IPOPOS(2,IPOIX2) = I2
+ IPAR = 10+IPROC
+ IDDPOM = IPAR
+ ENDIF
+
+C update debug information
+ KSPOM = KSPOMS+ISAM
+ KSREG = KSREGS+JSAM
+ KHPOM = KHPOMS+KSAM
+ KHDIR = KHDIRS+IDIR
+C comment line for central diffraction
+ CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
+ & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
+ PHEP(5,IPOS) = XMASS
+C debug output
+ IF(IDEB(59).GE.15) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
+ & '-----------------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+ RETURN
+
+C treatment of rejection
+ 50 CONTINUE
+ IREJ = 1
+ IFAIL(40) = IFAIL(40)+1
+ IF(IDEB(59).GE.3) THEN
+ WRITE(LO,'(1X,A)')
+ & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
+ IF(IDEB(59).GE.10) THEN
+ CALL PHO_PREVNT(0)
+ ELSE
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SAMASS
+ SUBROUTINE PHO_SAMASS(IFLA,RMASS)
+C**********************************************************************
+C
+C resonance mass sampling of quasi elastic processes
+C
+C input: IFLA PDG number of particle
+C IFLA -1 initialization
+C IFLA -2 output of statistics
+C
+C output: RMASS particle mass (in GeV)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+
+ PARAMETER(NTABM=50)
+ DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
+ DIMENSION SUM(4),ICALL(4)
+
+C*****************************************************************
+C initialization of tables
+ IF(IFLA.EQ.-1) THEN
+C
+ NSTEP = NTABM
+ DO 102 I=1,4
+ ICALL(I) = 0
+
+ DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
+ DO 105 K=1,NSTEP
+ RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
+ 105 CONTINUE
+ 102 CONTINUE
+C calculate table of dsig/dm
+ CALL PHO_DSIGDM(RMA,XMA,NSTEP)
+C output of table
+ IF(IDEB(35).GE.1) THEN
+ WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
+ WRITE(LO,'(1X,A,/1X,A)')
+ & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
+ & ' -------------------------------------------------------'
+ DO 106 K=1,NSTEP
+ WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
+ & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
+ 106 CONTINUE
+ ENDIF
+C make second table for sampling
+ DO 109 I=1,4
+ SUM(I) = 0.D0
+ DO 108 K=2,NSTEP
+ SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
+ XMC(I,K) = SUM(I)
+ 108 CONTINUE
+ 109 CONTINUE
+C normalization
+ DO 118 K=1,NSTEP
+ DO 119 I=1,4
+ XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
+ 119 CONTINUE
+ 118 CONTINUE
+ IF(IDEB(35).GE.10) THEN
+ WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
+ WRITE(LO,'(1X,A,/1X,A)')
+ & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
+ & ' -------------------------------------------------------'
+ DO 120 K=1,NSTEP
+ WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
+ & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
+ 120 CONTINUE
+ ENDIF
+C
+C**************************************************
+C output of statistics
+ ELSE IF(IFLA.EQ.-2) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
+ & '----------------------'
+ WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
+ & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
+
+C
+C********************************************************
+C sampling of RMASS
+ ELSE
+C quasi-elastic vector meson production
+ IF(IFLA.EQ.113) THEN
+ KP = 1
+ ELSE IF(IFLA.EQ.223) THEN
+ KP = 2
+ ELSE IF(IFLA.EQ.333) THEN
+ KP = 3
+ ELSE IF(IFLA.EQ.92) THEN
+ KP = 4
+C quasi-elastic production of h*
+ ELSE IF(IFLA.EQ.91) THEN
+ RMASS = 0.35D0
+ RETURN
+C elastic hadron scattering
+ ELSE
+ RMASS = PHO_PMASS(IFLA,1)
+ IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
+ & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
+ RETURN
+ ENDIF
+C
+C sample mass of vector mesonsn / two-pi background
+ XI = DT_RNDM(RMASS) + EPS
+C binary search
+ IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
+ KMIN=1
+ KMAX=NSTEP
+ 300 CONTINUE
+ IF((KMAX-KMIN).EQ.1) GOTO 400
+ KK=(KMAX+KMIN)/2
+ IF(XI.LE.XMC(KP,KK)) THEN
+ KMAX=KK
+ ELSE
+ KMIN=KK
+ ENDIF
+ GOTO 300
+ 400 CONTINUE
+ ELSE
+ WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
+ WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
+ & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
+ CALL PHO_ABORT
+ ENDIF
+C fine interpolation
+ RMASS = RMA(KP,KMIN)+
+ & (RMA(KP,KMAX)-RMA(KP,KMIN))/
+ & (XMC(KP,KMAX)-XMC(KP,KMIN))
+ & *(XI-XMC(KP,KMIN))
+ IF(IDEB(35).GE.20) THEN
+ IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
+ & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
+ & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
+ WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
+ & IFLA,RMASS
+ ENDIF
+ ICALL(KP) = ICALL(KP)+1
+
+ ENDIF
+ END
+
+CDECK ID>, PHO_DSIGDM
+ SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
+C**********************************************************************
+C
+C differential cross section DSIG/DM of low mass enhancement
+C
+C input: RMA(4,NTABM) mass values
+C output: XMA(4,NTABM) DSIG/DM of resonances
+C 1 rho production
+C 2 omega production
+C 3 phi production
+C 4 pi-pi continuum
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-10 )
+
+ PARAMETER(NTABM=50)
+ DIMENSION XMA(4,NTABM),RMA(4,NTABM)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+
+ PIMASS = 0.135
+C rho meson shape (mass dependent width)
+ QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
+ DO 100 I=1,NSTEP
+ XMASS = RMA(1,I)
+ QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
+ GAMMA = GAMM(1)*(QQ/QRES)**3
+ XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
+ & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
+ 100 CONTINUE
+C omega/phi meson (constant width)
+ DO 200 K=2,3
+ DO 300 I=1,NSTEP
+ XMASS = RMA(K,I)
+ XMA(K,I) = XMASS*GAMM(K)
+ & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
+ 300 CONTINUE
+ 200 CONTINUE
+C pi-pi continuum
+ DO 400 I=1,NSTEP
+ XMASS = RMA(4,I)
+ XMA(4,I) = (XMASS-0.29D0)**2/XMASS
+ 400 CONTINUE
+
+ END
+
+CDECK ID>, PHO_SDECAY
+ SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
+C**********************************************************************
+C
+C decay of single resonance of /POEVT1/:
+C decay in helicity frame according to polarization, isotropic
+C decay and decay with limited transverse phase space possible
+C
+C ATTENTION:
+C reference to particle number of CPC has to exist
+C
+C input: NPOS position in /POEVT1/
+C ISP 0 decay according to phase space
+C 1 decay according to transversal polarization
+C 2 decay according to longitudinal polarization
+C 3 decay with limited phase space
+C ILEV decay mode to use
+C 1 strong only
+C 2 strong and ew of tau, charm, and bottom
+C 3 strong and electro-weak decays
+C negative: remove mother resonance after decay
+C
+C output: /POEVT1/,/POEVT2/ final particles according to decay mode
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( EPS = 1.D-15,
+ & DEPS = 1.D-10 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+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 general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ DIMENSION WGHD(20),KCH(20),ID(3)
+
+ IMODE = ABS(ILEV)
+ IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
+ & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
+
+C comment entry
+ IF(ISTHEP(NPOS).GT.11) RETURN
+
+C particle stable?
+ IDcpc = IMPART(NPOS)
+ IF(IDcpc.EQ.0) return
+ if(idec_list(1,IDcpc).eq.0) return
+ IDabs = iabs(IDcpc)
+
+C different decay modi (times)
+ IF(IMODE.EQ.1) THEN
+ if(idec_list(1,IDabs).ne.1) return
+ ELSE IF(IMODE.EQ.2) THEN
+ if(idec_list(1,IDabs).gt.2) return
+ ELSE IF(IMODE.EQ.3) THEN
+ if(idec_list(1,IDabs).gt.3) return
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
+ CALL PHO_ABORT
+ ENDIF
+
+C decay products, check for mass limitations
+ K = 0
+ WGSUM = 0.D0
+ AMIST = PHEP(5,NPOS)
+ DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
+ AMSUM = 0.D0
+ DO 200 L=1,3
+ ID(L) = isec_list(L,I)
+ IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
+ 200 CONTINUE
+ IF(AMSUM.LT.AMIST) THEN
+ K = K+1
+ WGHD(K) = wg_sec_list(I)
+ KCH(K) = I
+ ENDIF
+ 100 CONTINUE
+ IF(K.EQ.0)THEN
+ WRITE(LO,'(/1X,A,I6,3E12.4)')
+ & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
+ & NPOS,AMIST,AMSUM
+ CALL PHO_PREVNT(0)
+ RETURN
+ ENDIF
+
+C sample new decay channel
+ XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
+ K = 0
+ WGSUM = 0.D0
+ 500 CONTINUE
+ K = K+1
+ WGSUM = WGSUM+WGHD(K)
+ IF(XI.GT.WGSUM) GOTO 500
+ IK = KCH(K)
+ ID(1) = isec_list(1,IK)
+ ID(2) = isec_list(2,IK)
+ ID(3) = isec_list(3,IK)
+ if(IDcpc.lt.0) then
+ ID(1) = ipho_anti(ID(1))
+ ID(2) = ipho_anti(ID(2))
+ ID(3) = ipho_anti(ID(3))
+ endif
+
+C rotation
+ PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
+ CXS = PHEP(1,NPOS)/PTOT
+ CYS = PHEP(2,NPOS)/PTOT
+ CZS = PHEP(3,NPOS)/PTOT
+C boost
+ GBET = PTOT/AMIST
+ GAM = PHEP(4,NPOS)/AMIST
+
+ IF(ID(3).EQ.0) THEN
+C two particle decay
+ CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
+ ELSE
+C three particle decay
+ CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
+ & pho_pmass(ID(3),0),ISP)
+ ENDIF
+
+ IF(ILEV.LT.0) THEN
+ IF(NHEP.NE.NPOS) THEN
+ WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
+ & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
+ CALL PHO_ABORT
+ ENDIF
+ IMO1 = JMOHEP(1,NPOS)
+ IMO2 = JMOHEP(2,NPOS)
+ NHEP = NHEP-1
+ ELSE
+ IMO1 = NPOS
+ IMO2 = 0
+ ENDIF
+ IPH1 = IPHIST(1,NPOS)
+ IPH2 = IPHIST(2,NPOS)
+
+C back transformation and registration
+ DO 300 I=1,3
+ IF(ID(I).NE.0) THEN
+ CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
+ & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
+ XX = PTOT*CX
+ YY = PTOT*CY
+ ZZ = PTOT*CZ
+ CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
+ & IPH1,IPH2,0,0,IPOS,1)
+ ENDIF
+ 300 CONTINUE
+
+ 400 CONTINUE
+C debug output
+ IF(IDEB(36).GE.20) THEN
+ WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
+ & '--------------------'
+ CALL PHO_PREVNT(0)
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_SDECY2
+ SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
+C**********************************************************************
+C
+C isotropic/anisotropic two particle decay in CM system,
+C (transversely/longitudinally polarized boson into two
+C pseudo-scalar mesons)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ UMO2=UMO*UMO
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
+ ECM(2)=UMO-ECM(1)
+ WAU=ECM(1)*ECM(1)-AM11
+ IF(WAU.LT.0.D0) THEN
+ WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
+ CALL PHO_ABORT
+ ENDIF
+ PCM(1)=SQRT(WAU)
+ PCM(2)=PCM(1)
+
+ CALL PHO_SFECFE(SIF(1),COF(1))
+ IF(ISP.EQ.0) THEN
+C no polarization
+ COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
+ ELSE IF(ISP.EQ.1) THEN
+C transverse polarization
+ 400 CONTINUE
+ COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
+ SID12 = 1.D0-COD(1)*COD(1)
+ IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
+ ELSE IF(ISP.EQ.2) THEN
+C longitudinal polarization
+ 500 CONTINUE
+ COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
+ COD12 = COD(1)*COD(1)
+ IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
+ & 'invalid polarization',ISP
+ CALL PHO_ABORT
+ ENDIF
+
+ COD(2) = -COD(1)
+ COF(2) = -COF(1)
+ SIF(2) = -SIF(1)
+
+ END
+
+CDECK ID>, PHO_SDECY3
+ SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
+C**********************************************************************
+C
+C isotropic/anisotropic three particle decay in CM system,
+C (transversely/longitudinally polarized boson into three
+C pseudo-scalar mesons)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-30,
+ & EPS = 1.D-15 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C auxiliary data for three particle decay
+ DOUBLE PRECISION ECM,PCM,COD,COF,SIF
+ COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
+
+ DIMENSION F(5),XX(5)
+
+C calculation of maximum of S2 phase space weight
+ UMOO=UMO+UMO
+ GU=(AM2+AM3)**2
+ GO=(UMO-AM1)**2
+ UFAK=1.0000000000001D0
+ IF (GU.GT.GO) UFAK=0.99999999999999D0
+ OFAK=2.D0-UFAK
+ GU=GU*UFAK
+ GO=GO*OFAK
+ DS2=(GO-GU)/99.D0
+ AM11=AM1*AM1
+ AM22=AM2*AM2
+ AM33=AM3*AM3
+ UMO2=UMO*UMO
+ RHO2=0.D0
+ S22=GU
+ DO 124 I=1,100
+ S21=S22
+ S22=GU+(I-1.D0)*DS2
+ RHO1=RHO2
+ RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
+ IF(RHO2.LT.RHO1) GOTO 125
+ 124 CONTINUE
+
+ 125 CONTINUE
+ S2SUP=(S22-S21)/2.D0+S21
+ SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
+ & /(S2SUP+EPS)
+ SUPRHO=SUPRHO*1.05D0
+ XO=S21-DS2
+ IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
+ IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
+ XX(1)=XO
+ XX(3)=S22
+ X1=(XO+S22)*0.5D0
+ XX(2)=X1
+ F(3)=RHO2
+ F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
+ F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
+ DO 126 I=1,16
+ X4=(XX(1)+XX(2))*0.5D0
+ X5=(XX(2)+XX(3))*0.5D0
+ F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
+ F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
+ XX(4)=X4
+ XX(5)=X5
+ DO 128 II=1,5
+ IA=II
+ DO 131 III=IA,5
+ IF(F(II).LT.F(III)) THEN
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+ ENDIF
+ 131 CONTINUE
+ 128 CONTINUE
+ SUPRHO=F(1)
+ S2SUP=XX(1)
+ DO 129 II=1,3
+ IA=II
+ DO 130 III=IA,3
+ IF (XX(II).LT.XX(III)) THEN
+ FH=F(II)
+ F(II)=F(III)
+ F(III)=FH
+ FH=XX(II)
+ XX(II)=XX(III)
+ XX(III)=FH
+ ENDIF
+ 130 CONTINUE
+ 129 CONTINUE
+ 126 CONTINUE
+
+ AM23=(AM2+AM3)**2
+
+C selection of S1
+ ITH=0
+ 200 CONTINUE
+ ITH=ITH+1
+ IF(ITH.GT.200) THEN
+ WRITE(LO,'(/1X,A,I10)')
+ & 'PHO_SDECY3:ERROR: too many iterations',ITH
+ CALL PHO_ABORT
+ ENDIF
+ S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
+ Y=DT_RNDM(AM23)*SUPRHO
+ RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
+ IF(Y.GT.RHO) GOTO 200
+
+C selection of S2
+ S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
+ & /(2.D0*S2)-RHO/2.D0
+ S3=UMO2+AM11+AM22+AM33-S1-S2
+ ECM(1)=(UMO2+AM11-S2)/UMOO
+ ECM(2)=(UMO2+AM22-S3)/UMOO
+ ECM(3)=(UMO2+AM33-S1)/UMOO
+ PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
+ PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
+ PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
+
+C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
+ IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
+ COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
+ ELSE
+ COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
+ ENDIF
+ COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
+ & /(2.D0*PCM(2)*PCM(3))
+ SINTH2=SQRT(1.D0-COSTH2*COSTH2)
+ SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
+ COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
+
+C selection of the sperical coordinates of particle 3
+ CALL PHO_SFECFE(SIF(3),COF(3))
+ IF(ISP.EQ.0) THEN
+C no polarization
+ COD(3) = 2.D0*DT_RNDM(S2)-1.D0
+ ELSE IF(ISP.EQ.1) THEN
+C transverse polarization
+ 400 CONTINUE
+ COD(3) = 2.D0*DT_RNDM(S1)-1.D0
+ SID32 = 1.D0-COD(3)*COD(3)
+ IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
+ ELSE IF(ISP.EQ.2) THEN
+C longitudinal polarization
+ 500 CONTINUE
+ COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
+ COD32 = COD(3)*COD(3)
+ IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
+ ELSE
+ WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
+ & 'invalid polarization',ISP
+ CALL PHO_ABORT
+ ENDIF
+
+C selection of the rotation angle of p1-p2 plane along p3
+ IF(ISP.EQ.0) THEN
+ CALL PHO_SFECFE(SFE,CFE)
+ ELSE
+ SFE = 0.D0
+ CFE = 1.D0
+ ENDIF
+ CX11=-COSTH1
+ CY11=SINTH1*CFE
+ CZ11=SINTH1*SFE
+ CX22=-COSTH2
+ CY22=-SINTH2*CFE
+ CZ22=-SINTH2*SFE
+
+ SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
+ COD(1)=CX11*COD(3)+CZ11*SID3
+ IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
+ WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
+ & COD(1),COF(3),SID3,CX11,CZ11
+ CALL PHO_PREVNT(-1)
+ ENDIF
+
+ SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
+ COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
+ SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
+ COD(2)=CX22*COD(3)+CZ22*SID3
+ SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
+ COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
+ SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
+
+ END
+
+CDECK ID>, PHO_DFMASS
+ DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
+C**********************************************************************
+C
+C sampling of Mx diffractive mass distribution within
+C limits XMIN, XMAX
+C
+C input: XMIN,XMAX mass limitations (GeV)
+C PREF2 original particle mass/ reference mass
+C (squared, GeV**2)
+C PVIRT2 particle virtuality
+C IMODE M**2 mass distribution
+C 1 1/(M**2+Q**2)
+C 2 1/(M**2+Q**2)**alpha
+C -1 1/(M**2-Mref**2+Q**2)
+C -2 1/(M**2-Mref**2+Q**2)**alpha
+C
+C output: diffractive mass (GeV)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
+ WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
+ & 'invalid mass limits',XMIN,XMAX,PREF2
+ CALL PHO_PREVNT(-1)
+ PHO_DFMASS = 0.135D0
+ RETURN
+ ENDIF
+
+ IF(IMODE.GT.0) THEN
+ PM2 = -PVIRT2
+ ELSE
+ PM2 = PREF2 - PVIRT2
+ ENDIF
+
+C critical pomeron
+ IF(ABS(IMODE).EQ.1) THEN
+ XMIN2 = LOG(XMIN**2-PM2)
+ XMAX2 = LOG(XMAX**2-PM2)
+ XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
+ XMA2 = EXP(XI)+PM2
+
+C supercritical pomeron
+ ELSE IF(ABS(IMODE).EQ.2) THEN
+ DDELTA = 1.D0-PARMDL(48)
+ XMIN2 = (XMIN**2-PM2)**DDELTA
+ XMAX2 = (XMAX**2-PM2)**DDELTA
+ XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
+ XMA2 = XI**(1.D0/DDELTA)+PM2
+ ELSE
+ WRITE(LO,'(/,1X,A,I3)')
+ & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
+ CALL PHO_ABORT
+ ENDIF
+
+ PHO_DFMASS = SQRT(XMA2)
+C debug output
+ IF(IDEB(43).GE.15) THEN
+ WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
+ & XMIN,XMAX,PREF2,SQRT(XMA2)
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DIFSLP
+ SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
+ & TT,SLWGHT,IREJ)
+C**********************************************************************
+C
+C sampling of T (Mandelstam variable) distribution within
+C certain limits TMIN, TMAX
+C
+C input: IDF1,2 type of diffractive vertex
+C 0 elastic/quasi-elastic scattering
+C 1 diffraction dissociation
+C IVEC1,2 vector meson IDs in case of quasi-elastic
+C scattering, otherwise 0
+C XM1 mass of diffractive system 1 (GeV)
+C XM2 mass of diffractive system 2 (GeV)
+C XMX max. mass of diffractive system (GeV)
+C
+C output: TT squared momentum transfer ( < 0, GeV**2)
+C SLWGHT weight to allow for mass-dependent slope
+C IREJ 0 successful sampling
+C 1 masses too big for given T range
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C cross sections
+ INTEGER IPFIL,IFAFIL,IFBFIL
+ DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
+ & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
+ & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
+ COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
+ & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
+ & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
+ & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
+ & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
+ & IPFIL,IFAFIL,IFBFIL
+C Reggeon phenomenology parameters
+ DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
+ & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
+ COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
+ & ALREG,ALREGP,GR(2),B0REG(2),
+ & GPPP,GPPR,B0PPP,B0PPR,
+ & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
+C parameters of 2x2 channel model
+ DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
+ COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
+C parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ IREJ = 0
+ XM12 = XM1**2
+ XM22 = XM2**2
+ SS = ECMD**2
+C
+C range of momentum transfer t
+ TMIN = -PARMDL(68)
+ TMAX = -PARMDL(69)
+C determine min. abs(t) necessary to produce masses
+ PCM2 = PCMD**2
+ PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
+ IF(PCMP2.LE.0.D0) THEN
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+ TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
+ & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
+C
+ IF(TMINP.LT.TMAX) THEN
+ IF(IDEB(44).GE.3) THEN
+ WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
+ & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
+ & XM1,XM2,TMIN,TMAX,TMINP
+ ENDIF
+ IFAIL(32) = IFAIL(32)+1
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+ TMINA = MIN(TMIN,TMINP)
+C
+C calculation of slope (mass-dependent parametrization)
+ IF(IDF1+IDF2.GT.0) THEN
+C diffraction dissociation
+ XMP12 = XM1**2+PVIRTD(1)
+ XMP22 = XM2**2+PVIRTD(2)
+ XMX1 = SQRT(XMP12)
+ XMX2 = SQRT(XMP22)
+ CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
+ FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
+ SLOPE = DBLE(IDF1+IDF2)*B0PPP
+ & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
+ & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
+ SLOPE = MAX(SLOPE,1.D0)
+C
+ XMA1 = XMX
+ XMA2 = XMX
+ IF(IDF1.EQ.0) THEN
+ XMA1 = XM1
+ ELSE IF(IDF1.EQ.0) THEN
+ XMA2 = XM2
+ ENDIF
+ XMP12 = XMA1**2+PVIRTD(1)
+ XMP22 = XMA2**2+PVIRTD(2)
+ XMX1 = SQRT(XMP12)
+ XMX2 = SQRT(XMP22)
+ CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
+ SLMIN = DBLE(IDF1+IDF2)*B0PPP
+ & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
+ & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
+ SLMIN = MAX(SLMIN,1.D0)
+ ELSE
+C elastic/quasi-elastic scattering
+ IF(ISWMDL(13).EQ.0) THEN
+C external slope values
+ PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
+ CALL PHO_ABORT
+ ELSE IF(ISWMDL(13).EQ.1) THEN
+C model slopes
+ IF(IVEC1*IVEC2.EQ.0) THEN
+ SLOPE = SLOEL
+ ELSE
+ SLOPE = SLOVM(IVEC1,IVEC2)
+ ENDIF
+ SLMIN = SLOPE
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
+ & ISWMDL(13)
+ CALL PHO_ABORT
+ ENDIF
+ ENDIF
+C
+C determine max. abs(t) to avoid underflows
+ TMAXP = -25.D0/SLOPE
+ TMAXA = MAX(TMAX,TMAXP)
+C
+ IF(TMINA.LT.TMAXA) THEN
+ IF(IDEB(44).GE.3) THEN
+ WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
+ & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
+ & XM1,XM2,TMINA,TMAXA,SLOPE
+ ENDIF
+ IFAIL(32) = IFAIL(32)+1
+ IREJ = 1
+ TT = 0.D0
+ RETURN
+ ENDIF
+C
+C sampling from corrected range of T
+ TMINE = EXP(SLMIN*TMINA)
+ TMAXE = EXP(SLMIN*TMAXA)
+ XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
+ TT = LOG(XI)/SLMIN
+ SLWGHT = EXP((SLOPE-SLMIN)*TT)
+C
+C debug output
+ IF(IDEB(44).GE.15) THEN
+ WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
+ & 'PHO_DIFSLP: sampled momentum transfer:',TT,
+ & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
+ & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
+ ENDIF
+ END
+
+CDECK ID>, PHO_DIFKIN
+ SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
+C**********************************************************************
+C
+C calculation of diffractive kinematics
+C
+C input: XMP1 mass of outgoing particle system 1 (GeV)
+C XMP2 mass of outgoing particle system 2 (GeV)
+C TT momentum transfer (GeV**2, negative)
+C
+C output: PMOM1(5) four momentum of outgoing system 1
+C PMOM2(5) four momentum of outgoing system 2
+C IREJ 0 kinematics consistent
+C 1 kinematics inconsistent
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10,
+ & DEPS = 0.001)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 c.m. kinematics of diffraction
+ INTEGER NPOSD
+ DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
+ & SIDD,CODD,SIFD,COFD,PDCMS
+ COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
+ & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION PMOM1,PMOM2
+ DIMENSION PMOM1(5),PMOM2(5)
+
+C debug output
+ IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
+ & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
+ & ECMD,PCMD,XMP1,XMP2,TT
+
+C general kinematic constraints
+ IREJ = 1
+ IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
+
+C new squared cms momentum
+ XMP12 = XMP1**2
+ XMP22 = XMP2**2
+ SS = ECMD**2
+ PCM2 = PCMD**2
+ PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
+
+C new longitudinal/transverse momentum
+ E1I = SQRT(PCM2+PMASSD(1)**2)
+ E1F = SQRT(PCMP2+XMP12)
+ E2F = SQRT(PCMP2+XMP22)
+ PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
+ PTRAN = PCMP2-PLONG**2
+
+C check consistency of kinematics
+ IF(PTRAN.LT.0.D0) THEN
+ IF(IDEB(49).GE.1) THEN
+ WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
+ & 'inconsistent kinematics in event call: ',KEVENT
+ WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
+ & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
+ & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
+ ENDIF
+ IREJ = 1
+ RETURN
+ ELSE
+ PTRAN = SQRT(PTRAN)
+ ENDIF
+ XI = PI2*DT_RNDM(PTRAN)
+
+C outgoing momenta in cm. system
+ PMOM1(4) = E1F
+ PMOM1(1) = PTRAN*COS(XI)
+ PMOM1(2) = PTRAN*SIN(XI)
+ PMOM1(3) = PLONG
+ PMOM1(5) = XMP1
+
+ PMOM2(4) = E2F
+ PMOM2(1) = -PMOM1(1)
+ PMOM2(2) = -PMOM1(2)
+ PMOM2(3) = -PLONG
+ PMOM2(5) = XMP2
+ IREJ = 0
+
+C debug output / precision check
+ IF(IDEB(49).GE.0) THEN
+C check kinematics
+ XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
+ & -PMOM1(1)**2-PMOM1(2)**2
+ XM1 = SIGN(SQRT(ABS(XM1)),XM1)
+ XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
+ & -PMOM2(1)**2-PMOM2(2)**2
+ XM2 = SIGN(SQRT(ABS(XM2)),XM2)
+ IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
+ WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
+ & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
+ & XMP1,XM1,XMP2,XM2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+C output
+ IF(IDEB(49).GT.10) THEN
+ WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
+ & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_VECRES
+ SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
+C**********************************************************************
+C
+C sampling of vector meson resonance in diffractive processes
+C (nothing done for hadrons)
+C
+C input: /POSVDM/ VDMFAC factors
+C
+C output: IVEC 0 incoming hadron
+C 1 rho 0
+C 2 omega
+C 3 phi
+C 4 pi+/pi- background
+C RMASS mass of vector meson (GeV)
+C IDPDG particle ID according to PDG
+C IDBAM particle ID according to CPC
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER(EPS = 1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 parameters of the "simple" Vector Dominance Model
+ DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
+ COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+C particle code translation
+ DIMENSION ITRANS(4)
+C rho0,omega,phi,pi+/pi-
+ DATA ITRANS /113, 223, 333, 92 /
+
+ IDPDO = IDPDG
+C
+C vector meson production
+ IF(IDPDG.EQ.22) THEN
+ XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
+ SUM = 0.D0
+ DO 55 K=1,4
+ SUM = SUM + VMFA(K)
+ IF(XI.LE.SUM) GOTO 65
+ 55 CONTINUE
+ 65 CONTINUE
+C
+ IDPDG = ITRANS(K)
+ IDBAM = ipho_pdg2id(IDPDG)
+ IVEC = K
+C sample mass of vector meson
+ CALL PHO_SAMASS(IDPDG,RMASS)
+
+C hadronic resonance of multi-pomeron coupling
+ ELSE IF(IDPDG.EQ.990) THEN
+ K = 4
+ IDPDG = 91
+ IDBAM = ipho_pdg2id(IDPDG)
+ IVEC = 4
+C sample mass of two-pion system
+ CALL PHO_SAMASS(IDPDG,RMASS)
+
+C hadron remnants in inucleus interactions
+ ELSE IF(IDPDG.EQ.81) THEN
+ IF(IHFLD(1,1).EQ.0) THEN
+ CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
+ CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
+ ELSE
+ CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
+ ENDIF
+ RMAS1 = PHO_PMASS(IDBA1,0)
+ RMAS2 = PHO_PMASS(IDBA2,0)
+ IF((IDBA2.NE.0).AND.
+ & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
+ IDBAM = IDBA2
+ RMASS = RMAS2
+ ELSE
+ IDBAM = IDBA1
+ RMASS = RMAS1
+ ENDIF
+ IDPDG = IPHO_ID2PDG(IDBAM)
+ IVEC = 0
+ ELSE IF(IDPDG.EQ.82) THEN
+ IF(IHFLD(2,1).EQ.0) THEN
+ CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
+ CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
+ ELSE
+ CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
+ ENDIF
+ RMAS1 = PHO_PMASS(IDBA1,0)
+ RMAS2 = PHO_PMASS(IDBA2,0)
+ IF((IDBA2.NE.0).AND.
+ & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
+ IDBAM = IDBA2
+ RMASS = RMAS2
+ ELSE
+ IDBAM = IDBA1
+ RMASS = RMAS1
+ ENDIF
+ IDPDG = IPHO_ID2PDG(IDBAM)
+ IVEC = 0
+ ENDIF
+C debug output
+ IF(IDEB(47).GE.5) THEN
+ WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
+ & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
+ & IDPDO,IDPDG,IDBAM,RMASS
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_DIFRES
+ SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
+ & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
+C**********************************************************************
+C
+C list of resonance states for low mass resonances
+C
+C input: IDMOTH PDG ID of mother particle
+C IVAL1,2 quarks (photon only)
+C
+C output: IDPDG list of PDG IDs for possible resonances
+C IDBAM list of corresponding CPC IDs
+C RMASS mass
+C RGAMS decay width
+C RMASS additional weight factor
+C LISTL entries in current list
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
+
+ PARAMETER (EPS = 1.D-10,
+ & DEPS = 1.D-15)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
+ DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
+ & 12212, 42212, -12212, -42212,
+ & 8*0 /
+ DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
+ & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
+ & 8*1.D0 /
+
+ DATA init /0/
+
+C initialize table
+ if(init.eq.0) then
+ do i=1,20
+ if(IRPDG(i).ne.0) then
+ IRBAM(i) = ipho_pdg2id(IRPDG(i))
+ endif
+ enddo
+ init = 1
+ endif
+
+C copy table with particles and isospin weights
+ LISTL = 0
+ IF(IDMOTH.EQ.22) THEN
+ I1 = 4
+ I2 = 8
+ ELSE IF(IDMOTH.EQ.2212) THEN
+ I1 = 9
+ I2 = 10
+ ELSE IF(IDMOTH.EQ.-2212) THEN
+ I1 = 11
+ I2 = 12
+ ELSE
+ RETURN
+ ENDIF
+
+ DO 100 I=I1,I2
+ LISTL = LISTL+1
+ IDBAM(LISTL) = IRBAM(I)
+ IDPDG(LISTL) = IRPDG(I)
+ RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
+ RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
+ RWG(LISTL) = RWGHT(I)
+ 100 CONTINUE
+
+C debug output
+ IF(IDEB(85).GE.20) THEN
+ WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
+ & IVAL1,IVAL2
+ DO 200 I=1,LISTL
+ WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
+ 200 CONTINUE
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_MASSAD
+ SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
+ & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
+C***********************************************************************
+C
+C fine-correction of low mass strings to mass of corresponding
+C resonance or two particle threshold
+C
+C input: IFLMO PDG ID of mother particle
+C IFL1,2 requested parton flavours
+C (not used at the moment)
+C PMASS reference mass (mass of mother particle)
+C XMCON conjecture of mass
+C
+C output: XMOUT output mass (adjusted input mass)
+C moved ot nearest mass possible
+C IDPDG PDG resonance ID
+C IDcpc CPC resonance ID
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DEPS = 1.D-8 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+ DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
+
+ XMINP = XMCON
+ IDPDG = 0
+ IDcpc = 0
+ XMOUT = XMINP
+
+C resonance treatment activated?
+ IF(ISWMDL(23).EQ.0) RETURN
+
+ CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
+ IF(LISTL.LT.1) THEN
+ IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
+ & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
+ & IFLMO,IFL1,IFL2
+ GOTO 50
+ ENDIF
+C mass small?
+ PMASSL = (PMASS+0.15D0)**2
+ XMINP2 = XMINP**2
+C determine resonance probability
+ DM2 = 1.1D0
+ RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
+ IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
+C sample new resonance
+ XWGSUM = 0.D0
+ DO 100 I=1,LISTL
+ XWG(I) = RWG(I)/RMA(I)**2
+ XWGSUM = XWGSUM+XWG(I)
+ 100 CONTINUE
+
+ ITER = 0
+ 150 CONTINUE
+ ITER = ITER+1
+ IF(ITER.GE.5) THEN
+ IDcpc = 0
+ IDPDG = 0
+ XMOUT = XMINP
+ GOTO 50
+ ENDIF
+
+ I = 0
+ XI = XWGSUM*DT_RNDM(XMOUT)
+ 200 CONTINUE
+ I = I+1
+ XWGSUM = XWGSUM-XWG(I)
+ IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
+ IDPDG = IRPDG(I)
+ IDcpc = IRBAM(I)
+ GARES = RGA(I)
+ XMRES = RMA(I)
+ XMRES2 = XMRES**2
+C sample new mass (from Breit-Wigner cross section)
+ ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
+ AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
+ XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
+ XMOUT = XMRES*GARES*TAN(XI)+XMRES2
+ XMOUT = SQRT(XMOUT)
+
+C check mass for decay
+ AMDCY = 2.D0*XMRES
+ ID = abs(IDcpc)
+ DO 250 IK=idec_list(2,ID),idec_list(3,ID)
+ AMSUM = 0.D0
+ DO 275 I=1,3
+ IF(isec_list(I,IK).NE.0)
+ & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
+ 275 CONTINUE
+ AMDCY = MIN(AMDCY,AMSUM)
+ 250 CONTINUE
+ IF(AMDCY.GE.XMOUT) GOTO 150
+
+C debug output
+ IF(IDEB(7).GE.10)
+ & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
+ & 'PHO_MASSAD: ',
+ & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
+ & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
+ RETURN
+ ENDIF
+
+ 50 CONTINUE
+C debug output
+ IF(IDEB(7).GE.15)
+ & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
+ & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
+ & IFLMO,IFL1,IFL2,XMCON,XMOUT
+
+ END
+
+CDECK ID>, PHO_PDF
+ SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
+C***************************************************************
+C
+C call different PDF sets for different particle types
+C
+C input: NPAR 1 IGRP(1),ISET(1)
+C 2 IGRP(2),ISET(2)
+C X momentum fraction
+C SCALE2 squared scale (GeV**2)
+C P2VIR particle virtuality (positive, GeV**2)
+C
+C output PD(-6:6) field containing the x*PDF fractions
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION PD(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+
+ REAL XR,P2R,Q2R,F2GM,XPDFGM
+ DIMENSION XPDFGM(-6:6)
+
+C check of kinematic boundaries
+ XI = X
+ IF(X.GT.1.D0) THEN
+ IF(IDEB(37).GE.0) THEN
+ WRITE(LO,'(/,1X,A,E15.8/)')
+ & 'PHO_PDF: x>1 (corrected to x=1)',X
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ XI = 0.99999999999D0
+ ELSE IF(X.LE.0.D0) THEN
+ IF(IDEB(37).GE.0) THEN
+ WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ XI = 0.0001D0
+ ENDIF
+
+ DO 100 I=-6,6
+ PD(I) = 0.D0
+ 100 CONTINUE
+ IRET = 1
+
+ IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
+
+C internal PDFs
+
+ IF(IEXT(NPAR).EQ.0) THEN
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.3) THEN
+ CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
+ UV = UDV-DV
+ UDB = 2.D0*UDB
+ DEL = 0.D0
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
+ UV = UDV-DV
+ UDB = 2.D0*UDB
+ DEL = 0.D0
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.5) THEN
+ CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
+C heavy quarks from GRV92-HO
+ AMU2 = 0.3
+ ALAM2 = 0.248 * 0.248
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.6) THEN
+ CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.7) THEN
+ CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
+C heavy quarks from GRV92-HO
+ AMU2 = 0.3
+ ALAM2 = 0.248 * 0.248
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.8) THEN
+ CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
+ DEL = DS-US
+ UDB = DS+US
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.9) THEN
+* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
+ DEL = DS-US
+ UDB = DS+US
+C heavy quarks from GRV92-LO
+ AMU2 = 0.25
+ ALAM2 = 0.232D0**2
+ S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+ IRET = 0
+ ENDIF
+ PD(-5) = BB
+ PD(-4) = CB
+ PD(-3) = SB
+ PD(-2) = 0.5D0*(UDB-DEL)
+ PD(-1) = 0.5D0*(UDB+DEL)
+ PD(0) = GL
+ PD(1) = DV+PD(-1)
+ PD(2) = UV+PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pion PDFs (default for pi+)
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
+ IRET = 0
+ ENDIF
+ PD(-5) = BB
+ PD(-4) = CB
+ PD(-3) = QB
+ PD(-2) = QB
+ PD(-1) = QB+VA
+ PD(0) = GL
+ PD(1) = QB
+ PD(2) = VA+QB
+ PD(3) = QB
+ PD(4) = CB
+ PD(5) = BB
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
+ IRET = 0
+ ENDIF
+C reweight with Drees-Godbole factor
+ WGX = 1.D0
+ IF(P2VIR.GT.0.001D0) THEN
+ WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
+ & /LOG(SCALE2/PARMDL(144))
+ WGX = MAX(WGX,0.D0)
+ ENDIF
+ PD(-5) = BB*WGX/137.D0
+ PD(-4) = CB*WGX/137.D0
+ PD(-3) = SB*WGX/137.D0
+ PD(-2) = UB*WGX/137.D0
+ PD(-1) = DB*WGX/137.D0
+ PD(0) = GL*WGX*WGX/137.D0
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ELSE IF(IGRP(NPAR).EQ.8) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ CALL PHO_PHGAL (XI,SCALE2,PD)
+ IRET = 0
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.20) THEN
+C Pomeron PDFs
+ MODE = IGRP(NPAR)
+ IF(MODE.EQ.1) THEN
+ PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.2) THEN
+ PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.3) THEN
+ PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
+ IRET = 0
+ ELSE IF(MODE.EQ.4) THEN
+ CALL PHO_CKMTPD(990,XI,SCALE2,PD)
+ DO 105 I=-4,4
+ PD(I) = PD(I)*PARMDL(78)
+ 105 CONTINUE
+ IRET = 0
+ ENDIF
+ ENDIF
+
+C external PDFs
+
+ ELSE IF(IEXT(NPAR).EQ.2) THEN
+C PDFLIB call: new PDF numbering
+ IF(NPAR.NE.NPAOLD) THEN
+ PARAM(1) = 'NPTYPE'
+ PARAM(2) = 'NGROUP'
+ PARAM(3) = 'NSET'
+ PARAM(4) = ' '
+ VALUE(1) = ITYPE(NPAR)
+ VALUE(2) = ABS(IGRP(NPAR))
+ VALUE(3) = ISET(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ ENDIF
+ IF(ITYPE(NPAR).EQ.3) THEN
+ IP2 = 0
+ CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
+ & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
+ ELSE
+ SCALE = SQRT(SCALE2)
+ CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
+ & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
+ ENDIF
+ DO 115 I=3,6
+ PD(I) = PD(-I)
+ 115 CONTINUE
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton valence quarks
+ PD(1) = PD(1)+PD(-1)
+ PD(2) = PD(2)+PD(-2)
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pi+ valences
+ DVAL = PD(1)
+ PD(1) = PD(-1)
+ PD(-1) = DVAL+PD(1)
+ PD(2) = PD(2)+PD(-2)
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon conventions
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ IRET = 0
+
+ ELSE IF(IEXT(NPAR).EQ.3) THEN
+C PHOLIB call: version 2.0
+ CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
+ IF(IRET.LT.0) THEN
+ WRITE(LO,'(/1X,A,I2)')
+ & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
+ CALL PHO_ABORT
+ ENDIF
+ IRET = 0
+
+C photon PDFs depending on photon virtuality
+
+ ELSE IF(IEXT(NPAR).EQ.4) THEN
+ IF(IGRP(NPAR).EQ.1) THEN
+C Schuler/Sjostrand PDF (interface to single precision)
+ XR = XI
+ Q2R = SCALE2
+ P2R = P2VIR
+ IP2 = 0
+ CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
+ DO 120 I=-6,6
+ PD(I) = DBLE(XPDFGM(I))
+ 120 CONTINUE
+ IRET = 0
+ ELSE IF(IGRP(NPAR).EQ.5) THEN
+C Gluck/Reya/Stratmann
+ IF(ISET(NPAR).EQ.4) THEN
+ CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
+ CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
+ IRET = 0
+ PD(-5) = 0.D0
+ PD(-4) = CB
+ PD(-3) = SB/137.D0
+ PD(-2) = UB/137.D0
+ PD(-1) = DB/137.D0
+ PD(0) = GL/137.D0
+ PD(1) = PD(-1)
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(3) = PD(-3)
+ PD(4) = PD(-4)
+ PD(5) = PD(-5)
+ ENDIF
+ ENDIF
+ ENDIF
+
+C check for errors
+
+ IF(IRET.NE.0) THEN
+ WRITE(LO,'(/1X,A,/10X,5I6)')
+ & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
+ & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
+ CALL PHO_ABORT
+ ENDIF
+C error in NPAR
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
+ CALL PHO_ABORT
+ ENDIF
+ NPAOLD = NPAR
+
+C valence quark treatment
+
+ IF(ITYPE(NPAR).EQ.2) THEN
+C meson conventions
+ IF(IPARID(NPAR).EQ.111) THEN
+C pi0 valence quarks
+ PD(-1) = (PD(1)+PD(-1))/2.D0
+ PD(1) = PD(-1)
+ PD(-2) = (PD(2)+PD(-2))/2.D0
+ PD(2) = PD(-2)
+ ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
+C K+/-
+ VALS = PD(-1)-PD(1)
+ PD(-1) = PD(1)
+ PD(-3) = PD(-3)+VALS
+ ELSE IF( (IPARID(NPAR).EQ.311)
+ & .OR.(IPARID(NPAR).EQ.310)
+ & .OR.(IPARID(NPAR).EQ.130)) THEN
+C neutral kaons
+ VALS = PD(-1)-PD(1)
+ VALU = PD(2)-PD(-2)
+ PD(-1) = PD(1)
+ PD(2) = PD(-2)
+ PD(2) = PD(2)+VALU/2.D0
+ PD(-2) = PD(-2)+VALU/2.D0
+ PD(3) = PD(3)+VALS/2.D0
+ PD(-3) = PD(-3)+VALS/2.D0
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.1) THEN
+C nucleon conventions
+ IF(ABS(IPARID(NPAR)).EQ.2112) THEN
+C neutron valence quarks
+ DUM = PD(1)
+ PD(1) = PD(2)
+ PD(2) = DUM
+ ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
+C (anti-)sigma+
+ VALS = PD(1)-PD(-1)
+ PD(1) = PD(-1)
+ PD(3) = PD(3)+VALS
+ ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
+C (anti-)sigma-
+ VALS = PD(1)-PD(-1)
+ VALD = PD(2)-PD(-2)
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(1) = PD(1)+VALD
+ PD(3) = PD(3)+VALS
+ ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
+ & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
+C (anti-)sigma0 and (anti-)lambda
+ VALS = PD(1)-PD(-1)
+ VALD = (PD(2)-PD(-2))/2.D0
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ PD(1) = PD(1)+VALD
+ PD(2) = PD(2)+VALD
+ PD(3) = PD(3)+VALS
+ ENDIF
+ ENDIF
+
+C antiparticle
+ IF(IPARID(NPAR).LT.0) THEN
+ DO 190 I=1,4
+ DUM=PD(I)
+ PD(I)=PD(-I)
+ PD(-I)=DUM
+ 190 CONTINUE
+ ENDIF
+
+C optionally remove valence quarks
+ IF(IPAVA(NPAR).EQ.0) THEN
+ DO 200 I=1,4
+ PD(I) = MIN(PD(-I),PD(I))
+ PD(-I) = PD(I)
+ 200 CONTINUE
+ ENDIF
+
+C debug information
+ IF(IDEB(37).GE.30) WRITE(LO,
+ & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
+ & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
+ & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
+ & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
+
+ END
+
+CDECK ID>, PHO_QPMPDF
+ SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
+C***************************************************************
+C
+C contribution to photon PDF from box graph
+C (Bethe-Heitler process)
+C
+C input: IQ quark flavour
+C SCALE2 scale (GeV**2, positive)
+C PTREF reference scale (GeV, positive)
+C X parton momentum fraction
+C PVIRT photon virtuality (GeV**2, positive)
+C FXP x*f(x,Q**2), x times parton density
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 internal rejection counters
+ INTEGER NMXJ
+ PARAMETER (NMXJ=60)
+ CHARACTER*10 REJTIT
+ INTEGER IFAIL
+ COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION QM(6)
+ DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
+
+ FXP = 0.D0
+ I = ABS(IQ)
+C
+* QM2 = MAX(QM(I),PTREF)**2
+* QM2 = MAX(QM2,PVIRT)
+* BBE = (1.D0-X)*SCALE2
+* IF(BBE.LE.0.D0) THEN
+* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
+* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
+* & PVIRT,QM(I)
+* ENDIF
+* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
+* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
+C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
+ QM2 = MAX(QM(I),PTREF)**2
+ W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
+ IF(W2.GT.4.D0*QM2) THEN
+ BE = SQRT(1.D0-4.D0*QM2/W2)
+ BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
+ BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
+* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
+ FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
+ & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
+ & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
+ & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
+ & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
+ ELSE
+ IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
+ & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
+ & PVIRT,QM(I)
+ ENDIF
+C debug output
+ IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
+ & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
+ END
+
+CDECK ID>, PHO_SETPDF
+ SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
+C***************************************************************
+C
+C assigns PDF numbers to particles
+C
+C input: IDPDG PDG number of particle
+C ITYP particle type
+C IPAR PDF paramertization
+C ISET number of set
+C IEXT library number for PDF calculation
+C IPAVAL (only output)
+C 1 PDF with valence quarks
+C 0 PDF without valence quarks
+C MODE -1 add entry to table
+C 1 read from table
+C 2 output of table
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+
+ DIMENSION IPDFS(5,50)
+ DATA IENTRY / 0 /
+
+ IF(MODE.EQ.1) THEN
+ I = 1
+ IF(IDPDG.EQ.81) THEN
+ IDCMP = IDEQP(1)
+ IPAVAL = IHFLS(1)
+ ELSE IF(IDPDG.EQ.82) THEN
+ IDCMP = IDEQP(2)
+ IPAVAL = IHFLS(2)
+ ELSE
+ IDCMP = IDPDG
+ IPAVAL = 1
+ ENDIF
+200 CONTINUE
+ IF(IDCMP.EQ.IPDFS(1,I)) THEN
+ ITYP = IPDFS(2,I)
+ IPAR = IPDFS(3,I)
+ ISET = IPDFS(4,I)
+ IEXT = IPDFS(5,I)
+ IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
+ & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
+ RETURN
+ ENDIF
+ I = I+1
+ IF(I.GT.IENTRY) THEN
+ WRITE(LO,'(/1X,A,I7)')
+ & 'PHO_SETPDF: no PDF assigned to ',IDCMP
+ CALL PHO_ABORT
+ ENDIF
+ GOTO 200
+ ELSE IF(MODE.EQ.-1) THEN
+ DO 50 I=1,IENTRY
+ IF(IDPDG.EQ.IPDFS(1,I)) THEN
+ WRITE(LO,'(/1X,A,5I6)')
+ & 'PHO_SETPDF: overwrite old particle PDF',
+ & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ GOTO 100
+ ENDIF
+ 50 CONTINUE
+ I = IENTRY+1
+ IF(I.GT.50) THEN
+ WRITE(LO,'(/1X,A,/1x,6I6)')
+ & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
+ & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ STOP
+ ENDIF
+ IENTRY = I
+ 100 CONTINUE
+ IPDFS(1,I) = IDPDG
+ IF(IDPDG.EQ.990) THEN
+ ITYP1 = 20
+ ELSE IF(IDPDG.EQ.22) THEN
+ ITYP1 = 3
+ ELSE IF(ABS(IDPDG).LT.1000) THEN
+ ITYP1 = 2
+ ELSE
+ ITYP1 = 1
+ ENDIF
+ IPDFS(2,I) = ITYP1
+ IPDFS(3,I) = IPAR
+ IPDFS(4,I) = ISET
+ IPDFS(5,I) = IEXT
+ ELSE IF(MODE.EQ.-2) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
+ DO 150 I=1,IENTRY
+ WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
+ & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
+ 150 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
+ ENDIF
+ END
+
+CDECK ID>, PHO_GETPDF
+ SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
+C***************************************************************
+C
+C get PDF information
+C
+C input: NPAR 1 first PDF in /POPPDF/
+C 2 second PDF in /POPPDF/
+C
+C output: PDFNA name of PDf parametrization
+C ALA QCD LAMBDA (4 flavours, in GeV)
+C Q2MI minimal Q2
+C Q2MA maximal Q2
+C XMI minimal X
+C XMA maximal X
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CHARACTER*8 PDFNA
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+C PHOLIB 4.15 common
+ COMMON /W50512/ QCDL4,QCDL5
+ COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
+
+C PHOPDF version 2.0 common
+ PARAMETER (MAXS=6,MAXP=10)
+ CHARACTER*4 CHPAR
+ COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
+ & NSET(MAXP,2),NFL(MAXP)
+ COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
+
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ DIMENSION PARAM(20),VALUE(20)
+ CHARACTER*20 PARAM
+
+ IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
+ WRITE(LO,'(/1X,A,I6)')
+ & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
+ CALL PHO_ABORT
+ ENDIF
+ ALA = 0.D0
+
+ IF(IEXT(NPAR).EQ.0) THEN
+
+C internal parametrizations
+
+ IF(ITYPE(NPAR).EQ.1) THEN
+C proton PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.3) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV92 HO'
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV92 LO'
+ ELSE IF(ISET(NPAR).EQ.5) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 HO'
+ ELSE IF(ISET(NPAR).EQ.6) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 LO'
+ ELSE IF(ISET(NPAR).EQ.7) THEN
+ ALA = 0.2D0
+ Q2MI = 0.4D0
+ PDFNA = 'GRV94 DI'
+ ELSE IF(ISET(NPAR).EQ.8) THEN
+ ALA = 0.175D0
+ Q2MI = 0.8D0
+ PDFNA = 'GRV98 LO'
+ ELSE IF(ISET(NPAR).EQ.9) THEN
+ ALA = 0.175D0
+ Q2MI = 0.8D0
+ PDFNA = 'GRV98 SC'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.2) THEN
+C pion PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-P HO'
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV-P LO'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.3) THEN
+C photon PDFs
+ IF(IGRP(NPAR).EQ.5) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-G LH'
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ ALA = 0.2D0
+ Q2MI = 0.3D0
+ PDFNA = 'GRV-G HO'
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ ALA = 0.2D0
+ Q2MI = 0.25D0
+ PDFNA = 'GRV-G LO'
+ ENDIF
+ ELSE IF(IGRP(NPAR).EQ.8) THEN
+ IF(ISET(NPAR).EQ.1) THEN
+ ALA = 0.2D0
+ Q2MI = 4.D0
+ PDFNA = 'AGL-G LO'
+ ENDIF
+ ENDIF
+ ELSE IF(ITYPE(NPAR).EQ.20) THEN
+C pomeron PDFs
+ IF(IGRP(NPAR).EQ.4) THEN
+ CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
+ ELSE
+ ALA = 0.3D0
+ Q2MI = 2.D0
+ PDFNA = 'POM-PDF1'
+ ENDIF
+ ENDIF
+
+C external parametrizations
+
+ ELSE IF(IEXT(NPAR).EQ.1) THEN
+C PDFLIB call: old numbering
+ PARAM(1) = 'MODE'
+ PARAM(2) = ' '
+ VALUE(1) = IGRP(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ Q2MI = Q2MIN
+ Q2MA = Q2MAX
+ XMI = XMIN
+ XMA = XMAX
+ ALA = QCDL4
+ PDFNA = 'PDFLIB1'
+ ELSE IF(IEXT(NPAR).EQ.2) THEN
+C PDFLIB call: new numbering
+ PARAM(1) = 'NPTYPE'
+ PARAM(2) = 'NGROUP'
+ PARAM(3) = 'NSET'
+ PARAM(4) = ' '
+ VALUE(1) = ITYPE(NPAR)
+ VALUE(2) = IGRP(NPAR)
+ VALUE(3) = ISET(NPAR)
+ CALL PDFSET(PARAM,VALUE)
+ Q2MI = Q2MIN
+ Q2MA = Q2MAX
+ XMI = XMIN
+ XMA = XMAX
+ ALA = QCDL4
+ PDFNA = 'PDFLIB2'
+ ELSE IF(IEXT(NPAR).EQ.3) THEN
+C PHOLIB interface
+ ALA = ALM(IGRP(NPAR),ISET(NPAR))
+ Q2MI = 2.D0
+ PDFNA = CHPAR(IGRP(NPAR))
+
+C some special internal parametrizations
+
+ ELSE IF(IEXT(NPAR).EQ.4) THEN
+C photon PDFs depending on virtualities
+ IF(IGRP(NPAR).EQ.1) THEN
+C Schuler/Sjostrand parametrization
+ ALA = 0.2D0
+ IF(ISET(NPAR).EQ.1) THEN
+ Q2MI = 0.2D0
+ PDFNA = 'SaS-1D '
+ ELSE IF(ISET(NPAR).EQ.2) THEN
+ Q2MI = 0.2D0
+ PDFNA = 'SaS-1M '
+ ELSE IF(ISET(NPAR).EQ.3) THEN
+ Q2MI = 2.D0
+ PDFNA = 'SaS-2D '
+ ELSE IF(ISET(NPAR).EQ.4) THEN
+ Q2MI = 2.D0
+ PDFNA = 'SaS-2M '
+ ENDIF
+ ELSE IF(IGRP(NPAR).EQ.5) THEN
+C Gluck/Reya/Stratmann parametrization
+ IF(ISET(NPAR).EQ.4) THEN
+ ALA = 0.2D0
+ Q2MI = 0.6D0
+ PDFNA = 'GRS-G LO'
+ ENDIF
+ ENDIF
+ ELSE IF(IEXT(NPAR).EQ.5) THEN
+C Schuler/Sjostrand anomalous only
+ ALA = 0.2D0
+ Q2MI = 0.2D0
+ PDFNA = 'SaS anom'
+ ENDIF
+ IF(ALA.LT.0.01D0) THEN
+ WRITE(LO,'(/1X,2A,/10X,5I6)')
+ & 'PHO_GETPDF:ERROR: ',
+ & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
+ & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
+ CALL PHO_ABORT
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_ACTPDF
+ SUBROUTINE PHO_ACTPDF(IDPDG,K)
+C***************************************************************
+C
+C activate PDF for QCD calculations
+C
+C input: IDPDG PDG particle number
+C K 1 first PDF in /POPPDF/
+C 2 second PDF in /POPPDF/
+C -2 write current settings
+C
+C output: /POPPDF/
+C
+C***************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+
+ IF(K.GT.0) THEN
+
+C read PDF from table
+ CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
+ & IPAVA(K),1)
+ IPARID(K) = IDPDG
+C get PDF parameters
+ CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
+C initialize alpha_s calculation
+ alam2 = PDFLAM(K)*PDFLAM(K)
+ DUMMY = PHO_ALPHAS(alam2,-K)
+
+ IF(IDEB(2).GE.20) THEN
+ WRITE(LO,'(1X,A)')
+ & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
+ WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
+ & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
+ & IEXT(K),IPARID(K)
+ ENDIF
+ NPAOLD = K
+
+ ELSE IF(K.EQ.-2) THEN
+
+C write table of current PDFs
+ WRITE(LO,'(1X,A)')
+ & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
+ WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
+ & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
+ & IPARID(1)
+ WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
+ & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
+ & IPARID(2)
+
+ ELSE
+
+ WRITE(LO,'(/1X,A,2I4)')
+ & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
+ CALL PHO_ABORT
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_PDFTST
+ SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
+C*********************************************************************
+C
+C structure function test utility
+C
+C input: IDPDG PDG ID of particle
+C SCALE2 squared scale (GeV**2)
+C P2MASS particle virtuality (pos, GeV**2)
+C
+C output: tables of PDF, sum rule checking, table of F2
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C currently activated parton density parametrizations
+ CHARACTER*8 PDFNAM
+ INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
+ DOUBLE PRECISION PDFLAM,PDFQ2M
+ COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
+ & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
+ CHARACTER*8 PDFNA
+
+ CALL PHO_ACTPDF(IDPDG,1)
+ CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
+
+ WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
+ WRITE(LO,'(A)') ' ======================================='
+
+ WRITE(LO,'(/,A,3I10)')
+ & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
+ WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
+ WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
+ WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
+ WRITE(LO,'(/1X,A)') 'x times parton densities'
+ WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
+ WRITE(LO,'(1X,A)')
+ & ' ============================================================'
+
+C logarithmic loop over x values
+C upper bound
+ XUPPER=0.9999D0
+C lower bound
+ XLOWER=1.D-4
+C number of steps
+ NSTEP=50
+
+ XFIRST=LOG(XLOWER)
+ XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
+ DO 100 I=1,NSTEP
+ X=EXP(XFIRST)
+ XCONTR=X
+ CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
+ IF(X.NE.XCONTR) THEN
+ WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
+ ENDIF
+ WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
+ XFIRST=XFIRST+XDELTA
+ 100 CONTINUE
+
+ IF(IDPDG.EQ.22) THEN
+ WRITE(LO,'(/1X,A)')
+ & 'comparison PDF to contribution due to box diagram'
+ WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
+ WRITE(LO,'(1X,A)')
+ & ' ============================================================'
+ XFIRST=LOG(XLOWER)
+ XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
+ DO 110 I=1,NSTEP
+ X=EXP(XFIRST)
+ CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
+ DO 120 K=1,4
+ CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
+ 120 CONTINUE
+ WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
+ XFIRST=XFIRST+XDELTA
+ 110 CONTINUE
+ ENDIF
+
+C check momentum sum rule
+
+ WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
+ DO 199 I=-6,6
+ PDSUM(I) = 0.D0
+ PDAVE(I) = 0.D0
+ 199 CONTINUE
+ ITER=5000
+ DO 200 I=1,ITER
+ XX=DBLE(I)/DBLE(ITER)
+ IF(XX.EQ.1.D0) XX = 0.999999D0
+ CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
+ DO 202 K=-6,6
+ PDSUM(K) = PDSUM(K)+PD(K)/XX
+ PDAVE(K) = PDAVE(K)+PD(K)
+ 202 CONTINUE
+ 200 CONTINUE
+ WRITE(LO,'(1X,A)')
+ & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
+ XSUM = 0.D0
+ DO 204 I=-6,6
+ PDSUM(I) = PDSUM(I)/DBLE(ITER)
+ PDAVE(I) = PDAVE(I)/DBLE(ITER)
+ XSUM = XSUM+PDAVE(I)
+ WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
+ 204 CONTINUE
+ WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
+ DO 205 I=1,6
+ WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
+ 205 CONTINUE
+ WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
+ WRITE(LO,'(A/)') ' ============================================='
+
+C table of F2
+
+ WRITE(LO,'(/1X,A,E12.4,/1X,A)')
+ & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
+ & '-----------------------------------------------------'
+ ITER=100
+ DO 300 I=1,ITER
+ XX=DBLE(I)/DBLE(ITER)
+ IF(XX.EQ.1.D0) XX = 0.9999D0
+ CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
+ F2 = 0.D0
+ DO 302 K=-6,6
+ IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
+ 302 CONTINUE
+ WRITE(LO,'(5X,1P,2E14.5)') XX,F2
+ 300 CONTINUE
+ WRITE(LO,'(A/)') ' ============================================='
+ END
+
+CDECK ID>, PHO_REGPAR
+ SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
+ & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
+C**********************************************************************
+C
+C registration of particle in /POEVT1/ and /POEVT2/
+C
+C input: ISTH status code of particle
+C -2 initial parton hard scattering
+C -1 parton
+C 0 string
+C 1 visible particle (no color)
+C 2 decayed particle
+C IDPDG PDG particle ID code
+C IDBAM CPC particle ID code
+C JM1,JM2 first and second mother index
+C P1..P4 four momentum
+C IPHIS1 extended history information
+C IPHIS1<100: JM1 from particle 1
+C IPHIS1>100: JM1 from particle 2
+C 1 valence quark
+C 2 valence diquark
+C 3 sea quark
+C 4 sea diquark
+C (neg. for antipartons)
+C IPHIS2 extended history information
+C positive: JM2 from particle 1
+C negative: JM2 from particle 2
+C (see IPHIS1)
+C IC1,IC2 color labels for partons
+C IMODE 1 register given parton
+C 0 reset /POEVT1/ and /POEVT2/
+C 2 return data of entry IPOS
+C
+C IPOS position of particle in /POEVT1/
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (DEPS = 1.D-20)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+
+ IF(IMODE.EQ.1) THEN
+ IF(IDEB(76).GE.26) THEN
+ WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
+ & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
+ & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
+ WRITE(LO,'(1X,A,/2X,6I6)')
+ & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
+ & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
+ ENDIF
+ IF(NHEP.EQ.NMXHEP) THEN
+ WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
+ & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
+ CALL PHO_ABORT
+ ENDIF
+ NHEP = NHEP+1
+ IDBAMI = IDBAM
+ IDPDGI = IDPDG
+ IF(ABS(ISTH).LE.2) THEN
+ IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
+ IDPDGI = ipho_id2pdg(IDBAM)
+ ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
+ IDBAMI = ipho_pdg2id(IDPDG)
+ ENDIF
+ ENDIF
+C standard data
+ ISTHEP(NHEP) = ISTH
+ IDHEP(NHEP) = IDPDGI
+ JMOHEP(1,NHEP) = JM1
+ JMOHEP(2,NHEP) = JM2
+C update of mother-daugther relations
+ IF(ABS(ISTH).LE.1) THEN
+ IF(JM1.GT.0) THEN
+ IF(JDAHEP(1,JM1).EQ.0) THEN
+ JDAHEP(1,JM1) = NHEP
+ ISTHEP(JM1) = 2
+ ENDIF
+ JDAHEP(2,JM1) = NHEP
+ ENDIF
+ IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
+ IF(JDAHEP(1,JM2).EQ.0) THEN
+ JDAHEP(1,JM2) = NHEP
+ ISTHEP(JM2) = 2
+ ENDIF
+ JDAHEP(2,JM2) = NHEP
+ ELSE IF(JM2.LT.0) THEN
+ DO 100 II=JM1+1,-JM2
+ IF(JDAHEP(1,II).EQ.0) THEN
+ JDAHEP(1,II) = NHEP
+ ISTHEP(II) = 2
+ ENDIF
+ JDAHEP(2,II) = NHEP
+100 CONTINUE
+ ENDIF
+ ENDIF
+ PHEP(1,NHEP) = P1
+ PHEP(2,NHEP) = P2
+ PHEP(3,NHEP) = P3
+ PHEP(4,NHEP) = P4
+ IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
+ TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
+ PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
+ ELSE
+ PHEP(5,NHEP) = 0.D0
+ ENDIF
+ JDAHEP(1,NHEP) = 0
+ JDAHEP(2,NHEP) = 0
+C extended information
+ IMPART(NHEP) = IDBAMI
+C extended history information
+ IPHIST(1,NHEP) = IPHIS1
+ IPHIST(2,NHEP) = IPHIS2
+C charge/baryon number or color labels
+ IF(ISTH.EQ.1) THEN
+ ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
+ ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
+ ELSE
+ ICOLOR(1,NHEP) = IC1
+ ICOLOR(2,NHEP) = IC2
+ ENDIF
+
+ IPOS = NHEP
+ IF(IDEB(76).GE.26) THEN
+ WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
+ & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
+ & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
+ & PHEP(5,NHEP),IPOS
+ ENDIF
+
+ ELSE IF(IMODE.EQ.0) THEN
+ NHEP = 0
+ ELSE IF(IMODE.EQ.2) THEN
+ IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
+ WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
+ & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
+ RETURN
+ ENDIF
+ ISTH = ISTHEP(IPOS)
+ IDPDG = IDHEP(IPOS)
+ IDBAM = IMPART(IPOS)
+ JM1 = JMOHEP(1,IPOS)
+ JM2 = JMOHEP(2,IPOS)
+ P1 = PHEP(1,IPOS)
+ P2 = PHEP(2,IPOS)
+ P3 = PHEP(3,IPOS)
+ P4 = PHEP(4,IPOS)
+ IPHIS1= IPHIST(1,IPOS)
+ IPHIS2= IPHIST(2,IPOS)
+ IC1 = ICOLOR(1,IPOS)
+ IC2 = ICOLOR(2,IPOS)
+ ELSE
+ WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
+ ENDIF
+ END
+
+CDECK ID>, IPHO_CNV1
+ INTEGER FUNCTION IPHO_CNV1(IPART)
+C*********************************************************************
+C
+C conversion of quark numbering scheme to PARTICLE DATA GROUP
+C convention
+C
+C input: old internal particle code of hard scattering
+C 0 gluon
+C 1 d
+C 2 u
+C 3 s
+C 4 c
+C valence quarks changed to standard numbering
+C
+C output: standard particle codes
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ II = ABS(IPART)
+C change gluon number
+ IF(II.EQ.0) THEN
+ IPHO_CNV1 = 21
+C change valence quark
+ ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
+ IPHO_CNV1 = SIGN(II-6,IPART)
+ ELSE
+ IPHO_CNV1 = IPART
+ ENDIF
+ END
+
+CDECK ID>, PHO_HACODE
+ SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
+C*********************************************************************
+C
+C determination of hadron index from quarks
+C
+C input: ID1,ID2 parton code according to PDG conventions
+C
+C output: IDcpc1,2 CPC particle codes
+C
+C*********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID1,ID2,IDcpc1,IDcpc2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk,i1,i2
+
+ IDcpc1 = 0
+ IDcpc2 = 0
+
+ if(ID1*ID2.lt.0) then
+C meson
+ if(ID1.gt.0) then
+ ii = ID1
+ jj = -ID2
+ else
+ ii = ID2
+ jj = -ID1
+ endif
+ IDcpc1 = ID_psm_list(ii,jj)
+ IDcpc2 = ID_vem_list(ii,jj)
+
+ else
+C baryon
+ i1 = abs(ID1)
+ i2 = abs(ID2)
+ if(i1.gt.6) then
+ ii = i1/1000
+ jj = (i1-ii*1000)/100
+ kk = i2
+ else
+ ii = i1
+ jj = i2/1000
+ kk = (i2-jj*1000)/100
+ endif
+ IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
+ IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
+
+ endif
+
+ END
+
+CDECK ID>, PHO_ID2STR
+ SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
+C*********************************************************************
+C
+C conversion of quark numbering scheme
+C
+C input: standard particle codes:
+C ID1
+C ID2
+C
+C output: NOBAM CPC string code
+C quark codes (PDG convention):
+C IBAM1
+C IBAM2
+C IBAM3
+C IBAM4
+C
+C NOBAM = -1 invalid flavour combinations
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ IDA1 = ABS(ID1)
+ IDA2 = ABS(ID2)
+
+C quark-antiquark string
+ IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
+ IF((ID1*ID2).GE.0) GOTO 100
+ IBAM1 = ID1
+ IBAM2 = ID2
+ IBAM3 = 0
+ IBAM4 = 0
+ NOBAM = 3
+C quark-diquark string
+ ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
+ IF((ID1*ID2).LE.0) GOTO 100
+ IBAM1 = ID1
+ IBAM2 = ID2/1000
+ IBAM3 = (ID2-IBAM2*1000)/100
+ IBAM4 = 0
+ NOBAM = 4
+C diquark-quark string
+ ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
+ IF((ID1*ID2).LE.0) GOTO 100
+ IBAM1 = ID1/1000
+ IBAM2 = (ID1-IBAM1*1000)/100
+ IBAM3 = ID2
+ IBAM4 = 0
+ NOBAM = 6
+C gluon-gluon string
+ ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
+ IBAM1 = 21
+ IBAM2 = 21
+ IBAM3 = 0
+ IBAM4 = 0
+ NOBAM = 7
+C diquark-antidiquark string
+ ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
+ IF((ID1*ID2).GE.0) GOTO 100
+ IBAM1 = ID1/1000
+ IBAM2 = (ID1-IBAM1*1000)/100
+ IBAM3 = ID2/1000
+ IBAM4 = (ID2-IBAM3*1000)/100
+ NOBAM = 5
+ ENDIF
+ RETURN
+
+C invalid combination
+ 100 CONTINUE
+ WRITE(LO,'(//1X,A,2I10)')
+ & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
+ CALL PHO_ABORT
+
+ END
+
+CDECK ID>, PHO_MKSLTR
+ SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
+C********************************************************************
+C
+C calculate successive Lorentz boots for arbitrary Lorentz trans.
+C
+C input: P1 initial 4 vector
+C GAM(3),GAMB(3) Lorentz boost parameters
+C
+C output: P2 final 4 vector
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
+
+ P2(4) = P1(4)
+ DO 150 I=1,3
+ P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
+ P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
+ 150 CONTINUE
+ END
+
+CDECK ID>, PHO_GETLTR
+ SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
+C********************************************************************
+C
+C calculate Lorentz boots for arbitrary Lorentz transformation
+C
+C input: P1 initial 4 vector
+C P2 final 4 vector
+C
+C output: GAM(3),GAMB(3)
+C DELE energy deviation
+C IREJ 0 success
+C 1 failure
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DREL = 0.001D0 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
+
+ IREJ = 1
+ DO 50 K=1,4
+ PA(K) = P1(K)
+ PP(K) = P1(K)
+ 50 CONTINUE
+ PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
+ DO 100 I=1,3
+ PP(I) = P2(I)
+ PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
+ IF(PP(4).LE.0.D0) RETURN
+ PP(4) = SQRT(PP(4))
+ GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
+ & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
+ GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
+ GAMB(I) = GAMB(I)*GAM(I)
+ DO 150 K=1,4
+ PA(K) = PP(K)
+ 150 CONTINUE
+ 100 CONTINUE
+ DELE = P2(4)-PP(4)
+ IREJ = 0
+C consistency check
+* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
+* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
+* WRITE(LO,'(/1X,A,2E12.5)')
+* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
+* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
+* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
+* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
+* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
+* ENDIF
+ END
+
+CDECK ID>, PHO_ALTRA
+ SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
+C*********************************************************************
+C
+C arbitrary Lorentz transformation
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ EP=PCX*BGX+PCY*BGY+PCZ*BGZ
+ PE=EP/(GA+1.D0)+EC
+ PX=PCX+BGX*PE
+ PY=PCY+BGY*PE
+ PZ=PCZ+BGZ*PE
+ P=SQRT(PX*PX+PY*PY+PZ*PZ)
+ E=GA*EC+EP
+
+ END
+
+CDECK ID>, PHO_LTRANS
+ SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
+ & PL,CXL,CYL,CZL,EL)
+C**********************************************************************
+C
+C Lorentz transformation into lab - system
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ SID=SQRT(1.D0-COD*COD)
+ PLX=P*SID*COF
+ PLY=P*SID*SIF
+ PCMZ=P*COD
+ PLZ=GAM*PCMZ+BGAM*ECM
+ PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
+ EL=GAM*ECM+BGAM*PCMZ
+
+C rotation into the original direction
+ COZ=PLZ/PL
+ SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
+
+* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
+
+ AX=ABS(CX)
+ AY=ABS(CY)
+ IF(AX.LT.AY) THEN
+ AMAX=AY
+ AMIN=AX
+ ELSE
+ AMAX=AX
+ AMIN=AY
+ ENDIF
+ IF (ABS(CX)-TINY) 1,1,2
+ 1 IF (ABS(CY)-TINY) 3,3,2
+
+ 3 CONTINUE
+* WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
+ CXL=SIZ*COF
+ CYL=SIZ*SIF
+ CZL=COZ*CZ
+* WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
+* WRITE(LO,*) CXL,CYL,CZL
+ RETURN
+
+ 2 CONTINUE
+ IF(AMAX.GT.TINY2) THEN
+ AR=AMIN/AMAX
+ AR=AR*AR
+ A=AMAX*SQRT(1.D0+AR)
+ ELSE
+* WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
+ GOTO 3
+ ENDIF
+ XI=SIZ*COF
+ YI=SIZ*SIF
+ ZI=COZ
+ CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
+ CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
+ CZL=A*YI+CZ*ZI
+
+ END
+
+CDECK ID>, PHO_TRANS
+ SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+C**********************************************************************
+C
+C rotation of coordinate frame (1) de rotation around y axis
+C (2) fe rotation around z axis
+C (inverse rotation to PHO_TRANI)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
+ Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
+ Z=-SDE *XO +CDE *ZO
+
+ END
+
+CDECK ID>, PHO_TRANI
+ SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+C**********************************************************************
+C
+C rotation of coordinate frame (1) -fe rotation around z axis
+C (2) -de rotation around y axis
+C (inverse rotation to PHO_TRANS)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
+ Y=-SFE *XO+CFE* YO
+ Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
+
+ END
+
+CDECK ID>, pho_cpcini
+ SUBROUTINE pho_cpcini(Nrows,Number,List)
+C***********************************************************************
+C
+C initialization of particle hash table
+C
+C input: Number vector with Nrows entries according to PDG
+C convention
+C
+C output: List vector with hash table
+C
+C (this code is based on the function initpns written by
+C Gerry Lynch, LBL, January 1990)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer Number(*),List(*),Nrows
+
+ Integer Nin,Nout,Ip,I
+
+ do I = 1,577
+ List(I) = 0
+ enddo
+
+C Loop over all of the elements in the Number vector
+
+ Do 500 Ip = 1,Nrows
+ Nin = Number(Ip)
+
+C Calculate a list number for this particle id number
+ If(Nin.Gt.99999.or.Nin.Le.0) Then
+ Nout = -1
+ Else If(Nin.Le.577) Then
+ Nout = Nin
+ Else
+ Nout = Mod(Nin,577)
+ End If
+
+ 200 continue
+
+ If(Nout.Lt.0) Then
+C Count the bad entries
+ WRITE(LO,'(1x,a,i10)')
+ & 'pho_cpcini: invalid particle ID',Nin
+ Go to 500
+ End If
+ If(List(Nout).eq.0) Then
+ List(Nout) = Ip
+ Else
+ If(Nin.eq.Number(List(Nout))) Then
+ WRITE(LO,'(1x,a,i10)')
+ & 'pho_cpcini: double particle ID',Nin
+ End If
+ Nout = Nout + 5
+ If(Nout.Gt.577) Nout = Mod(Nout, 577)
+
+ Go to 200
+ End If
+ 500 Continue
+
+ END
+
+CDECK ID>, ipho_pdg2id
+ INTEGER FUNCTION ipho_pdg2id(IDpdg)
+C**********************************************************************
+C
+C calculation internal particle code using the particle index i
+C according to the PDG proposal.
+C
+C input: IDpdg PDG particle number
+C output: ipho_pdg2id internal particle code
+C (0 for invalid IDpdg)
+C
+C the hash algorithm is based on a program by Gerry Lynch
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer IDpdg
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+
+ integer Nin,Nout
+
+ Nin = abs(IDpdg)
+
+ if((Nin.gt.99999).or.(Nin.eq.0)) then
+C invalid particle number
+ if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
+ & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
+ ipho_pdg2id = 0
+ return
+ else If(Nin.le.577) then
+C simple case
+ Nout = Nin
+ else
+C use hash algorithm
+ Nout = mod(Nin,577)
+ endif
+
+ 100 continue
+
+C particle not in table
+ if(ID_list(Nout).Eq.0) then
+ if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
+ & 'ipho_pdg2id: particle not in table ',IDpdg
+ ipho_pdg2id = 0
+ return
+ endif
+
+ if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
+C particle ID found
+ ipho_pdg2id = sign(ID_list(Nout),IDpdg)
+ return
+ else
+C increment and try again
+ Nout = Nout + 5
+ If(Nout.gt.577) Nout = Mod(Nout,577)
+ goto 100
+ endif
+
+ END
+
+CDECK ID>, IPHO_ID2PDG
+ INTEGER FUNCTION ipho_id2pdg(IDcpc)
+C**********************************************************************
+C
+C conversion of internal particle code to PDG standard
+C
+C input: IDcpc internal particle number
+C output: ipho_id2pdg PDG particle number
+C (0 for invalid IDcpc)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer IDcpc
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+
+ integer IDabs
+
+ IDabs = abs(IDcpc)
+ if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
+ ipho_id2pdg = 0
+ return
+ endif
+
+ ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
+
+ END
+
+CDECK ID>, IPHO_LU2PDG
+ INTEGER FUNCTION IPHO_LU2PDG(LUKF)
+C**********************************************************************
+C
+C conversion of JETSET KF code to PDG code
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (NTAB=10)
+ DIMENSION LU2PD(2,NTAB)
+ DATA LU2PD / 4232, 4322,
+ & 4322, 4232,
+ & 3212, 3122,
+ & 3122, 3212,
+ & 30553, 20553,
+ & 30443, 20443,
+ & 20443, 10443,
+ & 10443, 0,
+ & 511, 0,
+ & 10551, 551 /
+C
+ DO 100 I=1,NTAB
+ IF(LU2PD(1,I).EQ.LUKF) THEN
+ IPHO_LU2PDG=LU2PD(2,I)
+ RETURN
+ ENDIF
+ 100 CONTINUE
+ IPHO_LU2PDG=LUKF
+
+ END
+
+CDECK ID>, IPHO_PDG2LU
+ INTEGER FUNCTION IPHO_PDG2LU(IPDG)
+C**********************************************************************
+C
+C conversion of PDG code to JETSET code
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+ PARAMETER (NTAB=8)
+ DIMENSION LU2PD(2,NTAB)
+ DATA LU2PD / 4232, 4322,
+ & 4322, 4232,
+ & 3212, 3122,
+ & 3122, 3212,
+ & 30553, 20553,
+ & 30443, 20443,
+ & 20443, 10443,
+ & 10551, 551 /
+C
+ DO 100 I=1,NTAB
+ IF(LU2PD(2,I).EQ.IPDG) THEN
+ IPHO_PDG2LU=LU2PD(1,I)
+ RETURN
+ ENDIF
+ 100 CONTINUE
+ IPHO_PDG2LU=IPDG
+
+ END
+
+CDECK ID>, pho_pname
+ CHARACTER*15 FUNCTION pho_pname(ID,mode)
+C***********************************************************************
+C
+C returns particle name for given ID number
+C
+C input: ID particle ID number
+C mode 0: ID treated as compressed particle code
+C 1: ID treated as PDG number
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_id2pdg,ipho_pdg2id
+
+C local variables
+ integer IDpdg,i,ii,k,l,ichar,i_anti
+ character*15 name
+
+ pho_pname = '(?????????????)'
+
+ if(mode.eq.0) then
+ i = ID
+ IDpdg = ipho_id2pdg(ID)
+ if(IDpdg.eq.0) return
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) then
+ if(ISTHEP(ID).eq.20) then
+ pho_pname = 'hard ini. part.'
+ else if(ISTHEP(ID).eq.21) then
+ pho_pname = 'hard fin. part.'
+ else if(ISTHEP(ID).eq.25) then
+ pho_pname = 'hard scattering'
+ else if(ISTHEP(ID).eq.30) then
+ pho_pname = 'diff. diss. '
+ else if(ISTHEP(ID).eq.35) then
+ pho_pname = 'elastic scatt. '
+ else if(ISTHEP(ID).eq.40) then
+ pho_pname = 'central scatt. '
+ endif
+ return
+ endif
+ IDpdg = IDHEP(ID)
+ i = IMPART(ID)
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
+ return
+ endif
+
+ ii = abs(i)
+ if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
+
+ name = name_list(ii)
+ ichar = ich3_list(ii)*sign(1,i)
+ if(mod(ichar,3).ne.0) then
+ ichar = 0
+ else
+ ichar = ichar/3
+ endif
+
+C find position of first blank character
+ k = 1
+ 100 continue
+ k = k+1
+ if(name(k:k).ne.' ') goto 100
+
+C append anti-particle sign
+ if(i.lt.0) then
+ i_anti = 0
+ do l=1,3
+ i_anti = i_anti+iq_list(l,ii)
+ enddo
+ if(iba3_list(ii).ne.0) then
+ name(k:k) = '~'
+ k = K+1
+ else if(((i_anti.ne.0).and.(ichar.eq.0))
+ & .or.(IDpdg.eq.-12)
+ & .or.(IDpdg.eq.-14)
+ & .or.(IDpdg.eq.-16)) then
+ name(k:k) = '~'
+ k = K+1
+ endif
+ endif
+
+C append charge sign
+ if(ichar.eq.-2) then
+ name(k:k+1) = '--'
+ else if(ichar.eq.-1) then
+ name(k:k) = '-'
+ else if(ichar.eq.1) then
+ name(k:k) = '+'
+ else if(ichar.eq.2) then
+ name(k:k+1) = '++'
+ endif
+
+ pho_pname = name
+
+ END
+
+CDECK ID>, ipho_anti
+ INTEGER FUNCTION ipho_anti(ID)
+C**********************************************************************
+C
+C determine antiparticle for given ID
+C
+C input: ID gives CPC particle number
+C
+C output: ipho_anti antiparticle code
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+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 external functions
+ integer ipho_id2pdg,ipho_pdg2id
+
+C local variables
+ integer IDabs,IDpdg,i_anti,l
+
+ ipho_anti = -ID
+ IDabs = abs(ID)
+
+C baryons
+ if(iba3_list(IDabs).ne.0) return
+
+C charged particles
+ if(ich3_list(IDabs).ne.0) return
+
+C K0_s and K0_l
+ IDpdg = ipho_id2pdg(ID)
+ if(IDpdg.eq.310) then
+ ID = ipho_pdg2id(130)
+ return
+ else if(IDpdg.eq.130) then
+ ID = ipho_pdg2id(310)
+ return
+ endif
+
+C neutral mesons with open strangeness, charm, or beauty
+ i_anti = 0
+ do l=1,3
+ i_anti = i_anti+iq_list(l,IDabs)
+ enddo
+ if(i_anti.ne.0) return
+
+C neutrinos
+ IDpdg = abs(IDpdg)
+ if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
+
+ ipho_anti = ID
+
+ END
+
+CDECK ID>, ipho_chr3
+ INTEGER FUNCTION ipho_chr3(ID,mode)
+C**********************************************************************
+C
+C output of three times the electric charge
+C
+C input: mode
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number
+C 2 ID gives position of particle in /POEVT1/
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_pdg2id
+
+C local variables
+ integer i,IDpdg
+
+ ipho_chr3 = 0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ ipho_chr3 = ICOLOR(1,ID)
+ return
+ endif
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,3i8)')
+ & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
+ ipho_chr3 = 1.D0/dble(i)
+ call pho_prevnt(0)
+ return
+ endif
+
+ ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
+
+ END
+
+CDECK ID>, ipho_bar3
+ INTEGER FUNCTION ipho_bar3(ID,mode)
+C**********************************************************************
+C
+C output of three times the baryon charge
+C
+C index: MODE
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number
+C 2 ID gives position of particle in /POEVT1/
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C external functions
+ integer ipho_pdg2id
+
+C local variables
+ integer i,IDpdg
+
+ ipho_bar3 = 0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ IDpdg = ID
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ ipho_bar3 = ICOLOR(2,ID)
+ return
+ endif
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,3i8)')
+ & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
+ ipho_bar3 = 1.D0/dble(i)
+ return
+ endif
+
+ ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
+
+ END
+
+CDECK ID>, pho_pmass
+ DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
+C***********************************************************************
+C
+C particle mass
+C
+C input: mode -1 initialization
+C 0 ID gives CPC particle number
+C 1 ID gives PDG particle number,
+C (for quarks current masses are returned)
+C 2 ID gives position of particle in /POEVT1/
+C 3 ID gives PDG parton number,
+C (for quarks constituent masses are returned)
+C
+C output: average particle mass (in GeV)
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer ID,mode,MSTJ24
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+C external functions
+ integer ipho_pdg2id,ipho_id2pdg
+
+ DOUBLE PRECISION PYMASS
+
+C local variables
+ integer i,IDpdg
+
+ pho_pmass = 0.D0
+
+ if(mode.eq.0) then
+ i = ID
+ else if(mode.eq.1) then
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ else if(mode.eq.2) then
+ if(ISTHEP(ID).gt.11) return
+ i = IMPART(ID)
+ IDpdg = IDHEP(ID)
+ IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
+ pho_pmass = PHEP(5,ID)
+ return
+ endif
+ else if(mode.eq.3) then
+ i = abs(ID)
+ if((i.gt.0).and.(i.le.6)) then
+ pho_pmass = PARMDL(150+i)
+ return
+ else
+ i = ipho_pdg2id(ID)
+ if(i.eq.0) return
+ endif
+ else if(mode.eq.-1) then
+C initialization: take masses for quarks and di-quarks from JETSET
+ MSTJ24 = MSTJ(24)
+ MSTJ(24) = 0
+ do i=1,22
+ IDpdg = ipho_id2pdg(i)
+
+ xm_list(i) = PYMASS(IDpdg)
+
+ enddo
+ MSTJ(24) = MSTJ24
+ return
+ else
+ WRITE(LO,'(1x,a,2i4)')
+ & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
+ return
+ endif
+
+ if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
+ WRITE(LO,'(1x,a,2i8)')
+ & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
+ pho_pmass = 1.D0/dble(i)
+ return
+ endif
+
+ pho_pmass = xm_list(iabs(i))
+
+ END
+
+CDECK ID>, PHO_MEMASS
+ SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
+C**********************************************************************
+C
+C determine meson masses corresponding to the input flavours
+C
+C input: I,J,K quark flavours (PDG convention)
+C
+C output: AMPS pseudo scalar meson mass
+C AMPS2 next possible two particle configuration
+C (two pseudo scalar mesons)
+C AMVE vector meson mass
+C AMVE2 next possible two particle configuration
+C (two vector mesons)
+C IPS,IVE meson numbers in CPC
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,IPS,IVE
+ double precision AMPS,AMPS2,AMVE,AMVE2
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj
+
+ IF(I.GT.0) THEN
+ ii = I
+ jj = -J
+ ELSE
+ ii = J
+ jj = -I
+ ENDIF
+
+C particle ID's
+ IPS = id_psm_list(ii,jj)
+ IVE = id_vem_list(ii,jj)
+C masses
+ if(IPS.ne.0) then
+ AMPS = xm_list(iabs(IPS))
+ else
+ AMPS = 0.D0
+ endif
+ if(IVE.ne.0) then
+ AMVE = xm_list(iabs(IVE))
+ else
+ AMVE = 0.D0
+ endif
+
+C next possible two-particle configurations (add phase space)
+ AMPS2 = xm_psm2_list(ii,jj)*1.5D0
+ AMVE2 = xm_vem2_list(ii,jj)*1.1D0
+
+ END
+
+CDECK ID>, PHO_BAMASS
+ SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
+C**********************************************************************
+C
+C determine baryon masses corresponding to the input flavours
+C
+C input: I,J,K quark flavours (PDG convention)
+C
+C output: AM8 octett baryon mass
+C AM82 next possible two particle configuration
+C (octett baryon and meson)
+C AM10 decuplett baryon mass
+C AM102 next possible two particle configuration
+C (decuplett baryon and meson,
+C baryon built up from first two quarks)
+C I8,I10 internal baryon numbers
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,K,I8,I10
+ double precision AM8,AM82,AM10,AM102
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk
+
+C find particle ID's
+ ii = iabs(I)
+ jj = iabs(J)
+ kk = iabs(K)
+ I8 = id_b8_list(ii,jj,kk)
+ I10 = id_b10_list(ii,jj,kk)
+
+C masses (if combination possible)
+ if(I8.ne.0) then
+ AM8 = xm_list(I8)
+ I8 = sign(I8,i)
+ else
+ AM8 = 0.D0
+ endif
+ if(I10.ne.0) then
+ AM10 = xm_list(I10)
+ I10 = sign(I10,i)
+ else
+ AM10 = 0.D0
+ endif
+
+C next possible two-particle configurations (add phase space)
+ AM82 = xm_b82_list(ii,jj,kk)*1.5D0
+ AM102 = xm_b102_list(ii,jj,kk)*1.1D0
+
+ END
+
+CDECK ID>, PHO_DQMASS
+ SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
+C**********************************************************************
+C
+C determine minimal masses corresponding to the input flavours
+C (diquark a-diquark string system)
+C
+C input: I,J,K,L quark flavours (PDG convention)
+C
+C output: AM82 mass of two octett baryons
+C AM102 mass of two decuplett baryons
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer I,J,K,L
+ double precision AM82,AM102
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+
+C local variables
+ integer ii,jj,kk,ll
+
+ ii = iabs(i)
+ kk = iabs(k)
+ jj = iabs(j)
+ ll = iabs(l)
+
+ AM82 = xm_bb82_list(ii,jj,kk,ll)
+ AM102 = xm_bb102_list(ii,jj,kk,ll)
+
+ END
+
+CDECK ID>, PHO_CHECK
+ SUBROUTINE PHO_CHECK(MD,IDEV)
+C**********************************************************************
+C
+C check quantum numbers of entries in /POEVT1/ and /POEVT2/
+C (energy, momentum, charge, baryon number conservation)
+C
+C input: MD -1 check overall momentum conservation
+C and perform detailed check only in case of
+C deviations
+C 1 test all branchings, mother-daughter
+C relations
+C
+C output: IDEV 0 no deviations
+C 1 deviations found
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 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 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 count number of errors to avoid disk overflow
+ DATA IERR / 0 /
+
+ IDEV = 0
+C conservation check suppressed
+ IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
+
+ IF(IPAMDL(13).GT.0) THEN
+
+C DPMJET call with x limitations
+ MODE = -1
+ ECM1 = SQRT(XPSUB*XTSUB)*ECM
+
+ ELSE
+
+C standard call
+ MODE = MD
+C first two entries are considered as scattering particles
+ EE1 = PHEP(4,1) + PHEP(4,2)
+ PX1 = PHEP(1,1) + PHEP(1,2)
+ PY1 = PHEP(2,1) + PHEP(2,2)
+ PZ1 = PHEP(3,1) + PHEP(3,2)
+
+ ENDIF
+
+ DDREL = PARMDL(75)
+ DDABS = PARMDL(76)
+ IF(MODE.EQ.-1) GOTO 500
+
+ 50 CONTINUE
+
+ I = 1
+ 100 CONTINUE
+
+C recognize only decayed particles as mothers
+ IF(ISTHEP(I).EQ.2) THEN
+C search for other mother particles
+ K = JDAHEP(1,I)
+ IF(K.EQ.0) THEN
+ IF(IPAMDL(178).NE.0)
+ & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
+ & 'entry marked as decayed but no dauther given:',I
+ GOTO 99
+ ENDIF
+ K1 = JMOHEP(1,K)
+ K2 = JMOHEP(2,K)
+C sum over mother particles
+ ICH1 = IPHO_CHR3(K1,2)
+ IBA1 = IPHO_BAR3(K1,2)
+ EE1 = PHEP(4,K1)
+ PX1 = PHEP(1,K1)
+ PY1 = PHEP(2,K1)
+ PZ1 = PHEP(3,K1)
+ IF(K2.LT.0) THEN
+ K2 = -K2
+ IF((K1.GT.I).OR.(K2.LT.I)) THEN
+ WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
+ & 'inconsistent mother/daughter relation found',I,K1,K2
+ CALL PHO_PREVNT(-1)
+ ENDIF
+ DO 400 II=K1+1,K2
+ IF(ABS(ISTHEP(II)).LE.2) THEN
+ ICH1 = ICH1 + IPHO_CHR3(II,2)
+ IBA1 = IBA1 + IPHO_BAR3(II,2)
+ EE1 = EE1 + PHEP(4,II)
+ PX1 = PX1 + PHEP(1,II)
+ PY1 = PY1 + PHEP(2,II)
+ PZ1 = PZ1 + PHEP(3,II)
+ ENDIF
+ 400 CONTINUE
+ ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
+ ICH1 = ICH1 + IPHO_CHR3(K2,2)
+ IBA1 = IBA1 + IPHO_BAR3(K2,2)
+ EE1 = EE1 + PHEP(4,K2)
+ PX1 = PX1 + PHEP(1,K2)
+ PY1 = PY1 + PHEP(2,K2)
+ PZ1 = PZ1 + PHEP(3,K2)
+ ENDIF
+
+C sum over daughter particles
+ ICH2 = 0.D0
+ IBA2 = 0.D0
+ EE2 = 0.D0
+ PX2 = 0.D0
+ PY2 = 0.D0
+ PZ2 = 0.D0
+ DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
+ IF(ABS(ISTHEP(II)).LE.2) THEN
+ ICH2 = ICH2 + IPHO_CHR3(II,2)
+ IBA2 = IBA2 + IPHO_BAR3(II,2)
+ EE2 = EE2 + PHEP(4,II)
+ PX2 = PX2 + PHEP(1,II)
+ PY2 = PY2 + PHEP(2,II)
+ PZ2 = PZ2 + PHEP(3,II)
+ ENDIF
+ 200 CONTINUE
+
+C conservation check
+ ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
+ IF(ABS(EE1-EE2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
+ & 'PHO_CHECK: energy conservation violated for',
+ & 'entry,initial,final:',I,EE1,EE2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
+ IF(ABS(PX1-PX2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: x-momentum conservation violated for',
+ & 'entry,initial,final:',I,PX1,PX2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
+ IF(ABS(PY1-PY2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: y-momentum conservation violated for',
+ & 'entry,initial,final:',I,PY1,PY2
+ IDEV = 1
+ ENDIF
+ ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
+ IF(ABS(PZ1-PZ2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
+ & 'PHO_CHECK: z-momentum conservation violated for',
+ & 'entry,initial,final:',I,PZ1,PZ2
+ IDEV = 1
+ ENDIF
+ IF(ICH1.NE.ICH2) THEN
+ WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
+ & 'PHO_CHECK: charge conservation violated for',
+ & 'entry,initial,final:',I,ICH1,ICH2
+ IDEV = 1
+ ENDIF
+ IF(IBA1.NE.IBA2) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
+ & 'baryon charge conservation violated for',
+ & 'entry,initial,final:',I,IBA1,IBA2
+ IDEV = 1
+ ENDIF
+ IF(IDEB(20).GE.35) THEN
+ WRITE(LO,
+ & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
+ & 'PHO_CHECK diagnostics:',
+ & '(1.mother/l.mother,1.daughter/l.daughter):',
+ & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
+ & 'mother momenta ',PX1,PY1,PZ1,EE1,
+ & 'daughter momenta ',PX2,PY2,PZ2,EE2,
+ & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
+ ENDIF
+ ENDIF
+ 99 CONTINUE
+ I = I+1
+ IF(I.LE.NHEP) GOTO 100
+
+ 55 CONTINUE
+
+ IERR = IERR+IDEV
+
+C write complete event in case of deviations
+ IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
+ CALL PHO_PREVNT(1)
+ IF(ISTR.GT.0) THEN
+ CALL PHO_PRSTRG
+
+ IF(ISWMDL(6).GE.0) CALL PYLIST(1)
+
+ ENDIF
+ ENDIF
+
+C stop after too many errors
+ IF(IERR.GT.IPAMDL(179)) THEN
+ WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
+ & 'too many inconsistencies found, program terminated',IERR
+ CALL PHO_ABORT
+ ENDIF
+
+ RETURN
+
+C overall check only (less time consuming)
+
+ 500 CONTINUE
+
+ ICH2 = 0.D0
+ IBA2 = 0.D0
+ EE2 = 0.D0
+ PX2 = 0.D0
+ PY2 = 0.D0
+ PZ2 = 0.D0
+
+ DO 300 K=3,NHEP
+C recognize only existing particles as possible daughters
+ IF(ABS(ISTHEP(K)).EQ.1) THEN
+ ICH2 = ICH2 + IPHO_CHR3(K,2)
+ IBA2 = IBA2 + IPHO_BAR3(K,2)
+ EE2 = EE2 + PHEP(4,K)
+ PX2 = PX2 + PHEP(1,K)
+ PY2 = PY2 + PHEP(2,K)
+ PZ2 = PZ2 + PHEP(3,K)
+ ENDIF
+ 300 CONTINUE
+
+C check energy-momentum conservation
+ ESC = ECM*DDREL
+
+ IF(IPAMDL(13).GT.0) THEN
+
+C DPMJET call with x limitations
+ ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
+ IF(ABS(ECM1-ECM2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: c.m. energy conservation violated',
+ & 'initial/final energy:',ECM1,ECM2
+ IDEV = 1
+ ENDIF
+
+ ELSE
+
+C standard call
+ IF(ABS(EE1-EE2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: energy conservation violated',
+ & 'initial/final energy:',EE1,EE2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PX1-PX2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: x-momentum conservation violated',
+ & 'initial/final x-momentum:',PX1,PX2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PY1-PY2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: y-momentum conservation violated',
+ & 'initial/final y-momentum:',PY1,PY2
+ IDEV = 1
+ ENDIF
+ IF(ABS(PZ1-PZ2).GT.ESC) THEN
+ WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
+ & 'PHO_CHECK: z-momentum conservation violated',
+ & 'initial/final z-momentum:',PZ1,PZ2
+ IDEV = 1
+ ENDIF
+
+C check of quantum number conservation
+
+ ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
+ IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
+
+ IF(ICH1.NE.ICH2) THEN
+ WRITE(LO,'(1X,A,/,5X,A,2I5)')
+ & 'PHO_CHECK: charge conservation violated',
+ & 'initial/final charge sum',ICH1,ICH2
+ IDEV = 1
+ ENDIF
+ IF(IBA1.NE.IBA2) THEN
+ WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
+ & 'baryonic charge conservation violated',
+ & 'initial/final baryonic charge sum',IBA1,IBA2
+ IDEV = 1
+ ENDIF
+
+ ENDIF
+
+C perform detailed checks in case of deviations
+ IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
+ IF(IPAMDL(13).GT.0) THEN
+ GOTO 55
+ ELSE
+ DDREL = DDREL/2.D0
+ DDABS = DDABS/2.D0
+ WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
+ & 'increasing precision of tests to',DDREL,DDABS
+ GOTO 50
+ ENDIF
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_ABORT
+ SUBROUTINE PHO_ABORT
+C**********************************************************************
+C
+C top MC event generation due to fatal error,
+C print all information of event generation and history
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+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 light-cone x fractions and c.m. momenta of soft cut string ends
+ INTEGER MAXSOF
+ PARAMETER ( MAXSOF = 50 )
+ INTEGER IJSI2,IJSI1
+ DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
+ COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
+ & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
+ & IJSI1(MAXSOF),IJSI2(MAXSOF)
+C hard scattering data
+ INTEGER MSCAHD
+ PARAMETER ( MSCAHD = 50 )
+ INTEGER LSCAHD,LSC1HD,LSIDX,
+ & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
+ DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
+ COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
+ & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
+ & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
+ & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
+ & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
+ & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
+ & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
+
+ WRITE(LO,'(//,1X,A,/,1X,A)')
+ & 'PHO_ABORT: program execution stopped',
+ & '===================================='
+ WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
+C
+ CALL PHO_SETMDL(0,0,-2)
+ CALL PHO_PREVNT(-1)
+ CALL PHO_ACTPDF(0,-2)
+C print selected parton flavours
+ WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
+ DO 700 I=1,KSOFT
+ WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
+ 700 CONTINUE
+ WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
+ DO 750 K=1,KHARD
+ I = LSIDX(K)
+ WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
+ WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
+ & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
+ 750 CONTINUE
+C print selected parton momenta
+ WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
+ DO 300 I=1,KSOFT
+ WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
+ WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
+ 300 CONTINUE
+ WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
+ DO 350 K=1,KHARD
+ I = LSIDX(K)
+ I3 = 8*I-4
+ WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
+ WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
+ 350 CONTINUE
+
+C print /POEVT1/
+ CALL PHO_PREVNT(0)
+
+C fragmentation process
+ IF(ISTR.GT.0) THEN
+C print /POSTRG/
+ CALL PHO_PRSTRG
+
+ IF(ISWMDL(6).GE.0) CALL PYLIST(1)
+
+ ENDIF
+
+C last message
+ WRITE(LO,'(////5X,A,///5X,A,///)')
+ & 'PHO_ABORT: execution terminated due to fatal error',
+ &'*** Simulating division by zero to get traceback information ***'
+ ISTR = 100/IPAMDL(100)
+
+ END
+
+CDECK ID>, PHO_TRACE
+ SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
+C**********************************************************************
+C
+C trace program subroutines according to level,
+C original output levels will be saved
+C
+C input: ISTART first event to trace
+C ISWI number of events to trace
+C 0 loop call, use old values
+C -1 restore original output levels
+C 1 store level and wait for event
+C LEVEL desired output level
+C 0 standard output
+C 3 internal rejections
+C 5 cross sections, slopes etc.
+C 10 parameter of subroutines and
+C results
+C 20 huge amount of debug output
+C 30 maximal possible output
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 IMEM(NMAXD)
+
+C protect ISWI
+ ISW = ISWI
+ 10 CONTINUE
+ IF(ISW.EQ.0) THEN
+ IF(KEVENT.LT.ION) THEN
+ RETURN
+ ELSE IF(KEVENT.EQ.ION) THEN
+ WRITE(LO,'(///,1X,A,///)')
+ & 'PHO_TRACE: trace mode switched on'
+ DO 100 I=1,NMAXD
+ IMEM(I) = IDEB(I)
+ IDEB(I) = MAX(ILEVEL,IMEM(I))
+ 100 CONTINUE
+ ELSE IF(KEVENT.EQ.IOFF) THEN
+ WRITE(LO,'(//,1X,A,///)')
+ & 'PHO_TRACE: trace mode switched off'
+ DO 200 I=1,NMAXD
+ IDEB(I) = IMEM(I)
+ 200 CONTINUE
+ ENDIF
+ ELSE IF(ISW.EQ.-1) THEN
+ DO 300 I=1,NMAXD
+ IDEB(I) = IMEM(I)
+ 300 CONTINUE
+ ELSE
+C save information
+ ION = ISTART
+ IOFF = ISTART+ISW
+ ILEVEL = LEVEL
+ ENDIF
+C check coincidence
+ IF(ISW.GT.0) THEN
+ ISW=0
+ ILEVEL = LEVEL
+ GOTO 10
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_PRSTRG
+ SUBROUTINE PHO_PRSTRG
+C**********************************************************************
+C
+C print information of /POSTRG/
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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
+
+ WRITE(LO,'(/,1X,A,I5)')
+ & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
+ WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
+ & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
+ WRITE(LO,'(1X,A)')
+ & ' ======================================================='
+ DO 800 I=1,ISTR
+ WRITE(LO,'(1X,9I5,1P,E11.3)')
+ & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
+ & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
+ 800 CONTINUE
+
+ END
+
+CDECK ID>, PHO_PREVNT
+ SUBROUTINE PHO_PREVNT(NPART)
+C**********************************************************************
+C
+C print all information of event generation and history
+C
+C input: NPART -1 minimal output: process IDs
+C 0 additional output of /POEVT1/
+C 1 additional output of /POSTRG/
+C 2 additional output of /HEPEVT/
+C (call LULIST(1))
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+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 general process information
+ INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+ COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+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 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)
+
+ CHARACTER*15 PHO_PNAME
+
+ IF(NPART.GE.0) WRITE(LO,'(/)')
+ WRITE(LO,'(1X,A,1PE10.3)')
+ & 'PHO_PREVNT: c.m. energy',ECM
+ CALL PHO_SETPAR(-2,IH,NPART,0.D0)
+ WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
+ & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
+ & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
+ & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
+ & KHDPO
+ WRITE(LO,'(6X,A,I4,4I3)')
+ & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
+ & IDIFR2,IDDPOM
+
+ IF(IPAMDL(13).GT.0) THEN
+ WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
+ WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
+ & ECMN,PCMN,SECM,SPCM
+ WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
+ ENDIF
+
+ IF(NPART.LT.0) RETURN
+
+ IF(NPART.GE.1) CALL PHO_PRSTRG
+
+ WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
+ ICHAS = 0
+ IBARFS = 0
+ IMULC = 0
+ IMUL = 0
+ WRITE(LO,'(/1X,A,A,/,1X,A,A)')
+ & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
+ & ' IH1 IH2 CO1 CO2',
+ & '========================================================',
+ & '===================='
+ DO 20 IH=1,NHEP
+ CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
+ BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
+ WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
+ & IH,ISTHEP(IH),PHO_PNAME(IH,2),
+ & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
+ & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
+ & ICOLOR(1,IH),ICOLOR(2,IH)
+ IF(ABS(ISTHEP(IH)).EQ.1) THEN
+ ICHAS = ICHAS + IPHO_CHR3(IH,2)
+ IBARFS = IBARFS + IPHO_BAR3(IH,2)
+ ENDIF
+ IF(ABS(ISTHEP(IH)).EQ.1) THEN
+ IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
+ IMUL = IMUL+1
+ ENDIF
+ 20 CONTINUE
+ WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
+ & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
+
+ WRITE(LO,7)
+ PXS = 0.D0
+ PYS = 0.D0
+ PZS = 0.D0
+ P0S = 0.D0
+ DO 30 IN=1,NHEP
+ IF( (ABS(PHEP(3,IN)).LT.99999.D0)
+ & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
+ WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
+ & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
+ ELSE
+ WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
+ & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
+ ENDIF
+ IF(ABS(ISTHEP(IN)).EQ.1) THEN
+ PXS = PXS + PHEP(1,IN)
+ PYS = PYS + PHEP(2,IN)
+ PZS = PZS + PHEP(3,IN)
+ P0S = P0S + PHEP(4,IN)
+ ENDIF
+ 30 CONTINUE
+ AMFS = P0S**2-PXS**2-PYS**2-PZS**2
+ AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
+ IF(P0S.LT.99999.D0) THEN
+ WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
+ ELSE
+ WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
+ ENDIF
+ WRITE(LO,'(//)')
+
+ 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
+ & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
+ & 8H CHARGE ,8H BARYON ,/)
+ 6 FORMAT(7I8,2F8.3)
+ 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
+ & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
+ & 2X,'-------------------------------',
+ & '--------------------------------------------')
+ 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
+ 9 FORMAT(I10,14X,5F10.3)
+ 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
+ 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
+ 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
+
+ IF(NPART.GE.2) CALL PYLIST(1)
+
+ END
+
+CDECK ID>, PHO_LTRHEP
+ SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
+C*******************************************************************
+C
+C Lorentz transformation of entries I1 to I2 in /POEVT1/
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER ( DIFF = 0.001D0,
+ & EPS = 1.D-5 )
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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)
+
+ DO 100 I=I1,MIN(I2,NHEP)
+ IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
+ CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ EE=PHEP(4,I)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
+ ELSE IF(ISTHEP(I).EQ.20) THEN
+ EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
+ CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
+ & XX,YY,ZZ)
+ CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
+ & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
+ ENDIF
+ 100 CONTINUE
+
+C debug precision
+ IF(IDEB(70).LT.1) RETURN
+ DO 200 I=I1,MIN(NHEP,I2)
+ IF(ABS(ISTHEP(I)).GT.10) GOTO 190
+ PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
+ PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
+ IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
+ WRITE(LO,'(1X,A,I5,2E13.4)')
+ & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
+ ENDIF
+ 190 CONTINUE
+ 200 CONTINUE
+
+ END
+
+CDECK ID>, PHO_PECMS
+ SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
+C*******************************************************************
+C
+C calculation of cms momentum and energy of massive particle
+C (ID= 1 using PMASS1, 2 using PMASS2)
+C
+C output: PP cms momentum
+C EE energy in CMS of particle ID
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ S=ECM**2
+ PM1 = SIGN(PMASS1**2,PMASS1)
+ PM2 = SIGN(PMASS2**2,PMASS2)
+ PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
+ & + PM1**2 + PM2**2)/(2.D0*ECM)
+
+ IF(ID.EQ.1) THEN
+ EE = SQRT( PM1 + PP**2 )
+ ELSE IF(ID.EQ.2) THEN
+ EE = SQRT( PM2 + PP**2 )
+ ELSE
+ WRITE(LO,'(/1X,A,I3,/)')
+ & 'PHO_PECMS:ERROR: invalid ID number:',ID
+ EE = PP
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_FRAINI
+ SUBROUTINE PHO_FRAINI(IDEFAU)
+C***********************************************************************
+C
+C initialization of fragmentation packages
+C (currently LUND JETSET)
+C
+C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
+C changed to work in PHOJET (R.E. 1/94)
+C
+C input: IDEFAU 0 no hadronization at all
+C 1 do not touch any parameter of JETSET
+C 2 default parameters kept, decay length 10mm to
+C define stable particles
+C 3 load tuned parameters for JETSET 7.3
+C neg. value: prevent strange/charm hadrons from decaying
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ PARAMETER (EPS=1.D-10)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ INTEGER N,NPAD,K
+ DOUBLE PRECISION P,V
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+
+ INTEGER MSTU,MSTJ
+ DOUBLE PRECISION PARU,PARJ
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+
+ INTEGER KCHG
+ DOUBLE PRECISION PMAS,PARF,VCKM
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+
+ INTEGER MDCY,MDME,KFDP
+ DOUBLE PRECISION BRAT
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+
+ INTEGER PYCOMP
+
+ IDEFAB = ABS(IDEFAU)
+
+ IF(IDEFAB.EQ.0) THEN
+ WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
+ RETURN
+ ENDIF
+C defaults
+ DEF2 = PARJ(2)
+ IDEF12 = MSTJ(12)
+ DEF19 = PARJ(19)
+ DEF41 = PARJ(41)
+ DEF42 = PARJ(42)
+ DEF21 = PARJ(21)
+
+C declare stable particles
+ IF(IDEFAB.GE.2) MSTJ(22) = 2
+
+C load optimized parameters
+ IF(IDEFAB.GE.3) THEN
+
+* PARJ(19)=0.19
+C Lund a-parameter
+C (default=0.3)
+ PARJ(41)=0.3
+C Lund b-parameter
+C (default=1.0)
+ PARJ(42)=1.0
+C Lund sigma parameter in pt distribution
+C (default=0.36)
+ PARJ(21)=0.36
+ ENDIF
+C
+C prevent particles decaying
+ IF(IDEFAU.LT.0) THEN
+C K0S
+
+ KC=PYCOMP(310)
+
+ MDCY(KC,1)=0
+C PI0
+
+ KC=PYCOMP(111)
+
+ MDCY(KC,1)=0
+C LAMBDA
+
+ KC=PYCOMP(3122)
+
+ MDCY(KC,1)=0
+C ALAMBDA
+
+ KC=PYCOMP(-3122)
+
+ MDCY(KC,1)=0
+C SIG+
+
+ KC=PYCOMP(3222)
+
+ MDCY(KC,1)=0
+C ASIG+
+
+ KC=PYCOMP(-3222)
+
+ MDCY(KC,1)=0
+C SIG-
+
+ KC=PYCOMP(3112)
+
+ MDCY(KC,1)=0
+C ASIG-
+
+ KC=PYCOMP(-3112)
+
+ MDCY(KC,1)=0
+C SIG0
+
+ KC=PYCOMP(3212)
+
+ MDCY(KC,1)=0
+C ASIG0
+
+ KC=PYCOMP(-3212)
+
+ MDCY(KC,1)=0
+C TET0
+
+ KC=PYCOMP(3322)
+
+ MDCY(KC,1)=0
+C ATET0
+
+ KC=PYCOMP(-3322)
+
+ MDCY(KC,1)=0
+C TET-
+
+ KC=PYCOMP(3312)
+
+ MDCY(KC,1)=0
+C ATET-
+
+ KC=PYCOMP(-3312)
+
+ MDCY(KC,1)=0
+C OMEGA-
+
+ KC=PYCOMP(3334)
+
+ MDCY(KC,1)=0
+C AOMEGA-
+
+ KC=PYCOMP(-3334)
+
+ MDCY(KC,1)=0
+C D+
+
+ KC=PYCOMP(411)
+
+ MDCY(KC,1)=0
+C D-
+
+ KC=PYCOMP(-411)
+
+ MDCY(KC,1)=0
+C D0
+
+ KC=PYCOMP(421)
+
+ MDCY(KC,1)=0
+C A-D0
+
+ KC=PYCOMP(-421)
+
+ MDCY(KC,1)=0
+C DS+
+
+ KC=PYCOMP(431)
+
+ MDCY(KC,1)=0
+C A-DS+
+
+ KC=PYCOMP(-431)
+
+ MDCY(KC,1)=0
+C ETAC
+
+ KC=PYCOMP(441)
+
+ MDCY(KC,1)=0
+C LAMBDAC+
+
+ KC=PYCOMP(4122)
+
+ MDCY(KC,1)=0
+C A-LAMBDAC+
+
+ KC=PYCOMP(-4122)
+
+ MDCY(KC,1)=0
+C SIGMAC++
+
+ KC=PYCOMP(4222)
+
+ MDCY(KC,1)=0
+C SIGMAC+
+
+ KC=PYCOMP(4212)
+
+ MDCY(KC,1)=0
+C SIGMAC0
+
+ KC=PYCOMP(4112)
+
+ MDCY(KC,1)=0
+C A-SIGMAC++
+
+ KC=PYCOMP(-4222)
+
+ MDCY(KC,1)=0
+C A-SIGMAC+
+
+ KC=PYCOMP(-4212)
+
+ MDCY(KC,1)=0
+C A-SIGMAC0
+
+ KC=PYCOMP(-4112)
+
+ MDCY(KC,1)=0
+C KSIC+
+
+ KC=PYCOMP(4232)
+
+ MDCY(KC,1)=0
+C KSIC0
+
+ KC=PYCOMP(4132)
+
+ MDCY(KC,1)=0
+C A-KSIC+
+
+ KC=PYCOMP(-4232)
+
+ MDCY(KC,1)=0
+C A-KSIC0
+
+ KC=PYCOMP(-4132)
+
+ MDCY(KC,1)=0
+ ENDIF
+
+C *** Commented by Chiara
+C WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
+C & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
+C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
+C & ' --------------------------------------------------',/,
+C & 5X,'parameter description default / current',/,
+C & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
+C & 5X,'MSTJ(12) popcorn : ',2I7,/,
+C & 5X,'PARJ(19) popcorn : ',2F7.3,/,
+C & 5X,'PARJ(41) Lund a : ',2F7.3,/,
+C & 5X,'PARJ(42) Lund b : ',2F7.3,/,
+C & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
+
+ END
+
+CDECK ID>, PHO_SETPAR
+ SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
+C**********************************************************************
+C
+C assign a particle to either side 1 or 2
+C (including special treatment for remnants)
+C
+C input: Iside 1,2 side selected for the particle
+C -2 output of current settings
+C IDpdg PDG number
+C IDcpc CPC number
+C 0 CPC determination in subroutine
+C -1 special particle remnant, IDPDG
+C is the particle number the remnant
+C corresponds to (see /POHDFL/)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ integer Iside,IDpdg,IDcpc
+ double precision Pvir
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+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 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 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 particle ID translation table
+ integer ID_pdg_list,ID_list,ID_pdg_max
+ character*12 name_list
+ COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
+ & ID_pdg_max
+C general particle data
+ double precision xm_list,tau_list,gam_list,
+ & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
+ & xm_bb82_list,xm_bb102_list
+ integer ich3_list,iba3_list,iq_list,
+ & id_psm_list,id_vem_list,id_b8_list,id_b10_list
+ COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
+ & xm_psm2_list(6,6),xm_vem2_list(6,6),
+ & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
+ & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
+ & ich3_list(300),iba3_list(300),iq_list(3,300),
+ & id_psm_list(6,6),id_vem_list(6,6),
+ & id_b8_list(6,6,6),id_b10_list(6,6,6)
+C particle decay data
+ double precision wg_sec_list
+ integer idec_list,isec_list
+ COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
+ & isec_list(3,500)
+
+C external functions
+ integer ipho_pdg2id,ipho_chr3,ipho_bar3
+ double precision pho_pmass
+
+C local variables
+ integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
+
+ IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
+ IDcpcN = IDcpc
+C remnant?
+ IF(IDcpc.EQ.-1) THEN
+ IF(Iside.EQ.1) THEN
+ IDpdgR = 81
+ ELSE
+ IDpdgR = 82
+ ENDIF
+ IDcpcR = ipho_pdg2id(IDpdgR)
+ IDEQB(Iside) = ipho_pdg2id(IDpdg)
+ IDEQP(Iside) = IDpdg
+C copy particle properties
+ IDB = abs(IDEQB(Iside))
+ xm_list(IDcpcR) = xm_list(IDB)
+ tau_list(IDcpcR) = tau_list(IDB)
+ gam_list(IDcpcR) = gam_list(IDB)
+ IF(IHFLS(Iside).EQ.1) THEN
+ ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
+ iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
+ ELSE
+ ich3_list(IDcpcR) = 0
+ iba3_list(IDcpcR) = 0
+ ENDIF
+C quark content
+ IFL1 = IHFLD(Iside,1)
+ IFL2 = IHFLD(Iside,2)
+ IFL3 = 0
+ IF(IHFLS(Iside).EQ.1) THEN
+ IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
+ IFL1 = IHFLD(Iside,1)/1000
+ IFL2 = MOD(IHFLD(Iside,1)/100,10)
+ IFL3 = IHFLD(Iside,2)
+ ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
+ IFL1 = IHFLD(Iside,1)
+ IFL2 = IHFLD(Iside,2)/1000
+ IFL3 = MOD(IHFLD(Iside,2)/100,10)
+ ENDIF
+ ENDIF
+ iq_list(1,IDcpcR) = IFL1
+ iq_list(2,IDcpcR) = IFL2
+ iq_list(3,IDcpcR) = IFL3
+
+ IDcpcN = IDcpcR
+ IDPDGN = IDPDGR
+
+ IF(IDEB(87).GE.5) THEN
+ WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
+ & 'pho_setpar: remnant assignment side',Iside,
+ & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
+ ENDIF
+ ELSE IF(IDcpc.EQ.0) THEN
+C ordinary hadron
+ IHFLS(Iside) = 1
+ IHFLD(Iside,1) = 0
+ IHFLD(Iside,2) = 0
+ IDcpcN = ipho_pdg2id(IDpdg)
+ IDpdgN = IDpdg
+ ENDIF
+
+C initialize /POGCMS/
+ IFPAP(Iside) = IDpdgN
+ IFPAB(Iside) = IDcpcN
+ PMASS(Iside) = pho_pmass(IDcpcN,0)
+ IF(IFPAP(Iside).EQ.22) THEN
+ PVIRT(Iside) = ABS(PVIR)
+ ELSE
+ PVIRT(Iside) = 0.D0
+ ENDIF
+
+ ELSE IF(Iside.EQ.-2) THEN
+C output of current settings
+ DO 100 I=1,2
+ WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
+ & 'PHO_SETPAR: side',
+ & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
+ & PVIRT(I)
+ IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
+ WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
+ & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
+ & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
+ ENDIF
+ 100 CONTINUE
+ ELSE
+ WRITE(LO,'(/1X,A,I8)')
+ & 'pho_setpar: invalid argument (Iside)',Iside
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_XLAM
+ DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
+C**********************************************************************
+C
+C auxiliary function for two/three particle decay mode
+C (standard LAMBDA**(1/2) function)
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ YZ=Y-Z
+ XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
+ IF(XLAM.LT.0.D0) XLAM=-XLAM
+ PHO_XLAM=SQRT(XLAM)
+ END
+
+CDECK ID>, PHO_BESSJ0
+ DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
+C**********************************************************************
+C
+C CERN (KERN) LIB function C312
+C
+C modified by R. Engel (03/02/93)
+C
+C**********************************************************************
+ DOUBLE PRECISION DX
+ DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
+ DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
+ SAVE
+
+ DATA EIGHT /8.0D0/
+ DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
+
+ DATA C1( 0) /+0.15772 79714 7489D0/
+ DATA C1( 1) /-0.00872 34423 5285D0/
+ DATA C1( 2) /+0.26517 86132 0334D0/
+ DATA C1( 3) /-0.37009 49938 7265D0/
+ DATA C1( 4) /+0.15806 71023 3210D0/
+ DATA C1( 5) /-0.03489 37694 1141D0/
+ DATA C1( 6) /+0.00481 91800 6947D0/
+ DATA C1( 7) /-0.00046 06261 6621D0/
+ DATA C1( 8) /+0.00003 24603 2882D0/
+ DATA C1( 9) /-0.00000 17619 4691D0/
+ DATA C1(10) /+0.00000 00760 8164D0/
+ DATA C1(11) /-0.00000 00026 7925D0/
+ DATA C1(12) /+0.00000 00000 7849D0/
+ DATA C1(13) /-0.00000 00000 0194D0/
+ DATA C1(14) /+0.00000 00000 0004D0/
+
+ DATA C2( 0) /+0.99946 03493 4752D0/
+ DATA C2( 1) /-0.00053 65220 4681D0/
+ DATA C2( 2) /+0.00000 30751 8479D0/
+ DATA C2( 3) /-0.00000 00517 0595D0/
+ DATA C2( 4) /+0.00000 00016 3065D0/
+ DATA C2( 5) /-0.00000 00000 7864D0/
+ DATA C2( 6) /+0.00000 00000 0517D0/
+ DATA C2( 7) /-0.00000 00000 0043D0/
+ DATA C2( 8) /+0.00000 00000 0004D0/
+ DATA C2( 9) /-0.00000 00000 0001D0/
+
+ DATA C3( 0) /-0.01555 58546 05337D0/
+ DATA C3( 1) /+0.00006 83851 99426D0/
+ DATA C3( 2) /-0.00000 07414 49841D0/
+ DATA C3( 3) /+0.00000 00179 72457D0/
+ DATA C3( 4) /-0.00000 00007 27192D0/
+ DATA C3( 5) /+0.00000 00000 42201D0/
+ DATA C3( 6) /-0.00000 00000 03207D0/
+ DATA C3( 7) /+0.00000 00000 00301D0/
+ DATA C3( 8) /-0.00000 00000 00033D0/
+ DATA C3( 9) /+0.00000 00000 00004D0/
+ DATA C3(10) /-0.00000 00000 00001D0/
+
+ X=DX
+ V=ABS(X)
+ IF(V .LT. EIGHT) THEN
+ Y=V/EIGHT
+ H=2.D0*Y**2-1.D0
+ ALFA=-2.D0*H
+ B1=0.D0
+ B2=0.D0
+ DO 1 I = 14,0,-1
+ B0=C1(I)-ALFA*B1-B2
+ B2=B1
+ 1 B1=B0
+ B1=B0-H*B2
+ ELSE
+ R=1.D0/V
+ Y=EIGHT*R
+ H=2.D0*Y**2-1.D0
+ ALFA=-2.D0*H
+ B1=0.D0
+ B2=0.D0
+ DO 2 I = 9,0,-1
+ B0=C2(I)-ALFA*B1-B2
+ B2=B1
+ 2 B1=B0
+ P=B0-H*B2
+ B1=0.D0
+ B2=0.D0
+ DO 3 I = 10,0,-1
+ B0=C3(I)-ALFA*B1-B2
+ B2=B1
+ 3 B1=B0
+ Q=Y*(B0-H*B2)
+ B0=V-PI2
+ B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
+ ENDIF
+ PHO_BESSJ0=B1
+ RETURN
+ END
+
+CDECK ID>, PHO_BESSI0
+ DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
+C**********************************************************************
+C
+C Bessel Function I0
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ PHO_BESSI0 =
+ & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
+ & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
+ ELSE
+ Y = 3.75D0/AX
+ PHO_BESSI0 =
+ & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
+ & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
+ & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
+ & +Y*0.392377D-2))))))))
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_BESSI1
+ DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
+C**********************************************************************
+C
+C Bessel Function I1
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ AX = ABS(X)
+
+ IF (AX .LT. 3.75D0) THEN
+ Y = (X/3.75D0)**2
+ BESLI1 =
+ & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
+ & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
+ ELSE
+ Y = 3.75D0/AX
+ BESLI1 =
+ & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
+ & -Y*0.420059D-2))
+ BESLI1 =
+ & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
+ & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
+ BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
+ ENDIF
+ IF (X .LT. 0.D0) BESLI1 = -BESLI1
+
+ PHO_BESSI1 = BESLI1
+
+ END
+
+CDECK ID>, PHO_BESSK0
+ DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
+C**********************************************************************
+C
+C Modified Bessel Function K0
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (X .LT. 2.D0) THEN
+ Y = X**2/4.D0
+ PHO_BESSK0 =
+ & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
+ & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
+ & +Y*(0.10750D-3+Y*0.740D-5))))))
+ ELSE
+ Y = 2.D0/X
+ PHO_BESSK0 =
+ & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
+ & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
+ & +Y*(-0.251540D-2+Y*0.53208D-3))))))
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_BESSK1
+ DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
+C**********************************************************************
+C
+C Modified Bessel Function K1
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ IF (X .LT. 2.D0) THEN
+ Y = X**2/4.D0
+ PHO_BESSK1 =
+ & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
+ & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
+ & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
+ ELSE
+ Y=2.D0/X
+ PHO_BESSK1 =
+ & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
+ & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
+ & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_GAUSET
+ SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
+C********************************************************************
+C
+C N-point gauss zeros and weights for the interval (AX,BX) are
+C stored in arrays Z and W respectively.
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /POGDAT/A(273),X(273),KTAB(96)
+ DIMENSION Z(NX),W(NX)
+
+ ALPHA=0.5*(BX+AX)
+ BETA=0.5*(BX-AX)
+ N=NX
+
+C the N=1 case:
+ IF(N.NE.1) GO TO 1
+ Z(1)=ALPHA
+ W(1)=BX-AX
+ RETURN
+
+C the Gauss cases:
+ 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
+ IF(N.EQ.20) GO TO 2
+ IF(N.EQ.24) GO TO 2
+ IF(N.EQ.32) GO TO 2
+ IF(N.EQ.40) GO TO 2
+ IF(N.EQ.48) GO TO 2
+ IF(N.EQ.64) GO TO 2
+ IF(N.EQ.80) GO TO 2
+ IF(N.EQ.96) GO TO 2
+
+C the extended Gauss cases:
+ IF((N/96)*96.EQ.N) GO TO 3
+
+C jump to center of intervall intrgration:
+ GO TO 100
+
+C get Gauss point array
+
+ 2 CALL PHO_GAUDAT
+C extract real points
+ K=KTAB(N)
+ M=N/2
+ DO 21 J=1,M
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+C store them backward
+ Z(J)=ALPHA-DELTA
+ W(J)=WTEMP
+C store them forward
+ JP=N+1-J
+ Z(JP)=ALPHA+DELTA
+ W(JP)=WTEMP
+ 21 CONTINUE
+C store central point (odd N)
+ IF((N-M-M).EQ.0) RETURN
+ Z(M+1)=ALPHA
+ JMID=K+M
+ W(M+1)=BETA*A(JMID)
+ RETURN
+
+C get ND96 times chained 96 Gauss point array
+
+ 3 CALL PHO_GAUDAT
+C print out message
+C -extract real points
+ K=KTAB(96)
+ ND96=N/96
+ DO 31 J=1,48
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+ WTeMP=WTEMP/ND96
+ DeLTA=DELTA/ND96
+ DO 32 JD96=0,ND96-1
+ ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
+C store them backward
+ Z(J+JD96*96)=ZCNTR-DELTA
+ W(J+JD96*96)=WTEMP
+C store them forward
+ JP=96+1-J
+ Z(JP+JD96*96)=ZCNTR+DELTA
+ W(JP+JD96*96)=WTEMP
+ 32 CONTINUE
+ 31 CONTINUE
+ RETURN
+
+C the center of intervall cases:
+ 100 CONTINUE
+C put in constant weight and equally spaced central points
+ N=IABS(N)
+ DO 111 IN=1,N
+ WIN=(BX-AX)/FLOAT(N)
+ Z(IN)=AX + (FLOAT(IN)-.5)*WIN
+ 111 W(IN)=WIN
+
+ END
+
+CDECK ID>, PHO_GAUDAT
+ SUBROUTINE PHO_GAUDAT
+C*********************************************************************
+C
+C store big arrays needed for Gauss integral, CERNLIB D106BD
+C (arrays A,X,ITAB copied on B,Y,LTAB)
+C
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+
+ SAVE
+ COMMON /POGDAT/ B(273),Y(273),LTAB(96)
+ DIMENSION A(273),X(273),KTAB(96)
+
+C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
+ DATA KTAB(2)/1/
+ DATA KTAB(3)/2/
+ DATA KTAB(4)/4/
+ DATA KTAB(5)/6/
+ DATA KTAB(6)/9/
+ DATA KTAB(7)/12/
+ DATA KTAB(8)/16/
+ DATA KTAB(9)/20/
+ DATA KTAB(10)/25/
+ DATA KTAB(11)/30/
+ DATA KTAB(12)/36/
+ DATA KTAB(13)/42/
+ DATA KTAB(14)/49/
+ DATA KTAB(15)/56/
+ DATA KTAB(16)/64/
+ DATA KTAB(20)/72/
+ DATA KTAB(24)/82/
+ DATA KTAB(28)/82/
+ DATA KTAB(32)/94/
+ DATA KTAB(36)/94/
+ DATA KTAB(40)/110/
+ DATA KTAB(44)/110/
+ DATA KTAB(48)/130/
+ DATA KTAB(52)/130/
+ DATA KTAB(56)/130/
+ DATA KTAB(60)/130/
+ DATA KTAB(64)/154/
+ DATA KTAB(68)/154/
+ DATA KTAB(72)/154/
+ DATA KTAB(76)/154/
+ DATA KTAB(80)/186/
+ DATA KTAB(84)/186/
+ DATA KTAB(88)/186/
+ DATA KTAB(92)/186/
+ DATA KTAB(96)/226/
+C
+C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
+C
+C-----N=2
+ DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
+C-----N=3
+ DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
+ DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
+C-----N=4
+ DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
+ DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
+C-----N=5
+ DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
+ DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
+ DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
+C-----N=6
+ DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
+ DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
+ DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
+C-----N=7
+ DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
+ DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
+ DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
+ DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
+C-----N=8
+ DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
+ DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
+ DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
+ DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
+C-----N=9
+ DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
+ DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
+ DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
+ DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
+ DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
+C-----N=10
+ DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
+ DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
+ DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
+ DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
+ DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
+C-----N=11
+ DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
+ DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
+ DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
+ DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
+ DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
+ DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
+C-----N=12
+ DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
+ DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
+ DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
+ DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
+ DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
+ DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
+C-----N=13
+ DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
+ DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
+ DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
+ DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
+ DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
+ DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
+ DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
+C-----N=14
+ DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
+ DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
+ DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
+ DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
+ DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
+ DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
+ DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
+C-----N=15
+ DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
+ DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
+ DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
+ DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
+ DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
+ DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
+ DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
+ DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
+C-----N=16
+ DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
+ DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
+ DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
+ DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
+ DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
+ DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
+ DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
+ DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
+C-----N=20
+ DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
+ DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
+ DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
+ DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
+ DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
+ DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
+ DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
+ DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
+ DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
+ DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
+C-----N=24
+ DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
+ DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
+ DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
+ DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
+ DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
+ DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
+ DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
+ DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
+ DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
+ DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
+ DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
+ DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
+C-----N=32
+ DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
+ DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
+ DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
+ DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
+ DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
+ DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
+ DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
+ DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
+ DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
+ DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
+ DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
+ DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
+ DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
+ DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
+ DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
+ DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
+C-----N=40
+ DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
+ DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
+ DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
+ DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
+ DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
+ DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
+ DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
+ DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
+ DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
+ DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
+ DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
+ DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
+ DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
+ DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
+ DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
+ DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
+ DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
+ DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
+ DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
+ DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
+C-----N=48
+ DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
+ DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
+ DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
+ DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
+ DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
+ DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
+ DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
+ DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
+ DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
+ DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
+ DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
+ DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
+ DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
+ DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
+ DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
+ DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
+ DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
+ DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
+ DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
+ DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
+ DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
+ DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
+ DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
+ DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
+C-----N=64
+ DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
+ DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
+ DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
+ DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
+ DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
+ DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
+ DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
+ DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
+ DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
+ DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
+ DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
+ DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
+ DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
+ DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
+ DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
+ DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
+ DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
+ DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
+ DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
+ DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
+ DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
+ DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
+ DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
+ DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
+ DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
+ DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
+ DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
+ DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
+ DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
+ DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
+ DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
+ DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
+C-----N=80
+ DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
+ DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
+ DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
+ DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
+ DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
+ DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
+ DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
+ DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
+ DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
+ DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
+ DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
+ DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
+ DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
+ DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
+ DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
+ DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
+ DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
+ DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
+ DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
+ DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
+ DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
+ DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
+ DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
+ DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
+ DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
+ DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
+ DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
+ DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
+ DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
+ DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
+ DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
+ DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
+ DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
+ DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
+ DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
+ DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
+ DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
+ DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
+ DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
+ DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
+C-----N=96
+ DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
+ DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
+ DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
+ DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
+ DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
+ DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
+ DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
+ DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
+ DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
+ DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
+ DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
+ DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
+ DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
+ DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
+ DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
+ DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
+ DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
+ DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
+ DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
+ DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
+ DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
+ DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
+ DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
+ DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
+ DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
+ DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
+ DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
+ DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
+ DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
+ DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
+ DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
+ DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
+ DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
+ DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
+ DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
+ DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
+ DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
+ DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
+ DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
+ DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
+ DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
+ DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
+ DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
+ DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
+ DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
+ DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
+ DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
+ DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
+ DATA IBD/0/
+ IF(IBD.NE.0) RETURN
+ IBD=1
+ DO 10 I=1,273
+ B(I) = A(I)
+ Y(I) = X(I)
+ 10 CONTINUE
+ DO 20 I=1,96
+ LTAB(I) = KTAB(I)
+ 20 CONTINUE
+ END
+
+CDECK ID>, PHO_DZEROX
+ DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
+C**********************************************************************
+C
+C Based on
+C
+C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
+C Guaranteed Convergence for Finding a Zero of a Function,
+C ACM Trans. Math. Software 1 (1975) 330-345.
+C
+C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
+C
+C CERNLIB C200
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ CHARACTER NAME*(*)
+ PARAMETER (NAME = 'PHO_DZEROX')
+ LOGICAL LMT
+ DIMENSION IM1(2),IM2(2),LMT(2)
+ EXTERNAL F
+
+ PARAMETER (Z1 = 1, HALF = Z1/2)
+
+ DATA IM1 /2,3/, IM2 /-1,3/
+
+ IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
+ C=-2D+10
+ WRITE(LO,100) NAME,MODE
+ GO TO 99
+ ENDIF
+ FA=F(B0)
+ FB=F(A0)
+ IF(FA*FB .GT. 0) THEN
+ C=-3D+10
+ WRITE(LO,101) NAME
+ GO TO 99
+ ENDIF
+ ATL=ABS(EPS)
+ B=A0
+ A=B0
+ LMT(2)=.TRUE.
+ MF=2
+ 1 C=A
+ FC=FA
+ 2 IE=0
+ 3 IF(ABS(FC) .LT. ABS(FB)) THEN
+ IF(C .NE. A) THEN
+ D=A
+ FD=FA
+ END IF
+ A=B
+ B=C
+ C=A
+ FA=FB
+ FB=FC
+ FC=FA
+ END IF
+ TOL=ATL*(1+ABS(C))
+ H=HALF*(C+B)
+ HB=H-B
+ IF(ABS(HB) .GT. TOL) THEN
+ IF(IE .GT. IM1(MODE)) THEN
+ W=HB
+ ELSE
+ TOL=TOL*SIGN(Z1,HB)
+ P=(B-A)*FB
+ LMT(1)=IE .LE. 1
+ IF(LMT(MODE)) THEN
+ Q=FA-FB
+ LMT(2)=.FALSE.
+ ELSE
+ FDB=(FD-FB)/(D-B)
+ FDA=(FD-FA)/(D-A)
+ P=FDA*P
+ Q=FDB*FA-FDA*FB
+ END IF
+ IF(P .LT. 0) THEN
+ P=-P
+ Q=-Q
+ END IF
+ IF(IE .EQ. IM2(MODE)) P=P+P
+ IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
+ W=TOL
+ ELSEIF(P .LT. HB*Q) THEN
+ W=P/Q
+ ELSE
+ W=HB
+ END IF
+ END IF
+ D=A
+ A=B
+ FD=FA
+ FA=FB
+ B=B+W
+ MF=MF+1
+ IF(MF .GT. MAXF) THEN
+ WRITE(LO,102) NAME
+ GO TO 99
+ ENDIF
+ FB=F(B)
+ IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
+ IF(W .EQ. HB) GO TO 2
+ IE=IE+1
+ GO TO 3
+ END IF
+ 99 CONTINUE
+ PHO_DZEROX=C
+ RETURN
+ 100 FORMAT(1X,A,': mode = ',I3,' illegal')
+ 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
+ 102 FORMAT(1X,A,': too many function calls')
+
+ END
+
+CDECK ID>, PHO_EXPINT
+ DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
+C***********************************************************************
+C
+C function to calculate E_i(x) = -E_1(-x)
+C
+C based on CERNLIB C337 (changed by R.Engel 10/1993)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
+ DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
+ DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
+
+ DATA X0 /0.37250 74107 8137D0/
+ DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
+ DATA P1
+ 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
+ 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
+ 3 -4.34981 43832 952D+2/
+ DATA Q1
+ 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
+ 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
+ 3 +7.53585 64359 843D+2/
+ DATA P2
+ 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
+ 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
+ 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
+ 4 +4.65627 10797 510D-7/
+ DATA Q2
+ 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
+ 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
+ 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
+ 4 +1.00000 00000 000D+0/
+ DATA P3
+ 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
+ 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
+ 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
+ DATA Q3
+ 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
+ 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
+ 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
+ DATA P4
+ 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
+ 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
+ 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
+ 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
+ DATA Q4
+ 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
+ 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
+ 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
+ 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
+ DATA A1
+ 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
+ 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
+ 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
+ 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
+ DATA B1
+ 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
+ 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
+ 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
+ 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
+ DATA A2
+ 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
+ 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
+ 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
+ 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
+ DATA B2
+ 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
+ 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
+ 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
+ 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
+ DATA A3
+ 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
+ 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
+ 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
+ DATA B3
+ 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
+ 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
+ 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
+C
+C conversion to E_i function
+ X = -RXM
+C
+ IF(X .LE. XL(1)) THEN
+ AP=A3(1)-X
+ DO 1 I = 2,5
+ 1 AP=A3(I)-X+B3(I)/AP
+ Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
+ ELSEIF(X .LE. XL(2)) THEN
+ AP=A2(1)-X
+ DO 2 I = 2,7
+ 2 AP=A2(I)-X+B2(I)/AP
+ Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
+ ELSEIF(X .LE. XL(3)) THEN
+ AP=A1(1)-X
+ DO 3 I = 2,7
+ 3 AP=A1(I)-X+B1(I)/AP
+ Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
+ ELSEIF(X .LT. XL(4)) THEN
+ V=-2.D0*(X/3.D0+1.D0)
+ BP=0.D0
+ DP=P4(1)
+ DO 4 I = 2,8
+ AP=BP
+ BP=DP
+ 4 DP=P4(I)-AP+V*BP
+ BQ=0.D0
+ DQ=Q4(1)
+ DO 14 I = 2,8
+ AQ=BQ
+ BQ=DQ
+ 14 DQ=Q4(I)-AQ+V*BQ
+ Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
+ ELSEIF(X .EQ. XL(4)) THEN
+* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
+* IF(MFLAG) THEN
+* IF(LGFILE .EQ. 0) THEN
+* WRITE(LO,100) ENAME
+* ELSE
+* WRITE(LGFILE,100) ENAME
+* ENDIF
+* ENDIF
+* IF(.NOT.RFLAG) CALL ABEND
+ PHO_EXPINT=0.D0
+ RETURN
+ ELSEIF(X .LT. XL(5)) THEN
+ AP=P1(1)
+ AQ=Q1(1)
+ DO 5 I = 2,5
+ AP=P1(I)+X*AP
+ 5 AQ=Q1(I)+X*AQ
+ Y=-LOG(X)+AP/AQ
+ ELSEIF(X .LE. XL(6)) THEN
+ Y=1.D0/X
+ AP=P2(1)
+ AQ=Q2(1)
+ DO 6 I = 2,7
+ AP=P2(I)+Y*AP
+ 6 AQ=Q2(I)+Y*AQ
+ Y=EXP(-X)*AP/AQ
+ ELSE
+ Y=1.D0/X
+ AP=P3(1)
+ AQ=Q3(1)
+ DO 7 I = 2,6
+ AP=P3(I)+Y*AP
+ 7 AQ=Q3(I)+Y*AQ
+ Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
+ ENDIF
+C sign conversion to E_i
+ PHO_EXPINT=-Y
+
+ END
+
+CDECK ID>, PHO_RNDBET
+ DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
+C********************************************************************
+C
+C RANDOM NUMBER GENERATION FROM BETA
+C DISTRIBUTION IN REGION 0 < X < 1.
+C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
+C *GAMM(ETA))
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ Y = PHO_RNDGAM(1.D0,GAM)
+ Z = PHO_RNDGAM(1.D0,ETA)
+
+ PHO_RNDBET = Y/(Y+Z)
+
+ END
+
+CDECK ID>, PHO_RNDGAM
+ DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
+C********************************************************************
+C
+C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
+C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ NCOU=0
+ N = ETA
+ F = ETA - N
+ IF(F.EQ.0.D0) GOTO 20
+ 10 R = DT_RNDM(ETA)
+ NCOU=NCOU+1
+ IF (NCOU.GE.11) GOTO 20
+ IF(R.LT.F/(F+2.71828D0)) GOTO 30
+ YYY=LOG(DT_RNDM(F)+1.0D-9)/F
+ IF(ABS(YYY).GT.50.D0) GOTO 20
+ Y = EXP(YYY)
+ IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
+ GOTO 40
+ 20 Y = 0.D0
+ GOTO 50
+ 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
+ IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
+ 40 IF(N.EQ.0) GOTO 70
+ 50 Z = 1.D0
+ DO 60 I = 1,N
+ 60 Z = Z*DT_RNDM(Y)
+ Y = Y-LOG(Z+1.0D-9)
+ 70 PHO_RNDGAM = Y/ALAM
+ RETURN
+ END
+
+CDECK ID>, PHO_SFECFE
+ SUBROUTINE PHO_SFECFE(SFE,CFE)
+C**********************************************************************
+C
+C fast random SIN(X) COS(X) selection
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+C
+ 1 CONTINUE
+ X=DT_RNDM(XX)
+ Y=DT_RNDM(YY)
+ XX=X*X
+ YY=Y*Y
+ XY=XX+YY
+ IF(XY.GT.1.D0) GOTO 1
+ CFE=(XX-YY)/XY
+ SFE=2.D0*X*Y/XY
+ IF(DT_RNDM(XY).LT.0.5D0) THEN
+ SFE=-SFE
+ ENDIF
+ END
+
+CDECK ID>, PHO_SWAPD
+ SUBROUTINE PHO_SWAPD(D1,D2)
+C********************************************************************
+C
+C exchange of argument values (double precision)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ D = D1
+ D1 = D2
+ D2 = D
+ END
+
+CDECK ID>, PHO_SWAPI
+ SUBROUTINE PHO_SWAPI(I1,I2)
+C********************************************************************
+C
+C exchange of argument values (integer)
+C
+C********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ K = I1
+ I1 = I2
+ I2 = K
+ END
+
+CDECK ID>, PHO_HADCSL
+ SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
+ & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
+C***********************************************************************
+C
+C low-energy cross section parametrizations
+C
+C input: ID1,ID2 PDG IDs of particles (meson first)
+C ECM c.m. energy (GeV)
+C PLAB lab. momentum (second particle at rest)
+C IMODE 1 ECM given, PLAB ignored
+C 2 PLAB given, ECM ignored
+C
+C output: SIGTOT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
+C SLOPE forward elastic slope (GeV**-2)
+C RHO real/imaginary part of elastic amplitude
+C
+C comments:
+C
+C - low-energy data interpolation uses PDG fits from 1992 issue
+C - high-energy extrapolation by Donnachie-Landshoff like fit made
+C by PDG 1996
+C - analytic extension of amplitude to calculate rho
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER ID1,ID2,IMODE
+ DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+C model switches and parameters
+ CHARACTER*8 MDLNA
+ INTEGER ISWMDL,IPAMDL
+ DOUBLE PRECISION PARMDL
+ COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+
+ INTEGER K
+ DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
+ & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
+
+ DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
+
+ DATA TPDG92 /
+ & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
+ & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
+ & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
+ & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
+ & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
+ & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
+ & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
+ & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
+ & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
+ & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
+ & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
+ & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
+
+ DATA TPDG96 /
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,-21.05D0,0.46D0,0.9D0,
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,21.05D0,0.46D0,0.9D0,
+ & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
+ & 31.85D0,-4.05D0,0.45D0,0.9D0,
+ & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
+ & 31.85D0,4.05D0,0.45D0,0.9D0,
+ & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
+ & 17.35D0,-9.05D0,0.50D0,0.9D0,
+ & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
+ & 17.35D0,9.05D0,0.50D0,0.9D0 /
+
+ DATA BURQ83 /
+ & 11.13D0, -6.21D0, 0.30D0,
+ & 11.13D0, 7.23D0, 0.30D0,
+ & 9.11D0, -0.73D0, 0.28D0,
+ & 9.11D0, 0.65D0, 0.28D0,
+ & 8.55D0, -5.98D0, 0.28D0,
+ & 8.55D0, 1.60D0, 0.28D0 /
+
+ DATA XMA /
+ & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
+
+C find index
+ IF(ID2.NE.2212) THEN
+ GOTO 100
+ ELSE IF(ID1.EQ.2212) THEN
+ K = 1
+ ELSE IF(ID1.EQ.-2212) THEN
+ K = 2
+ ELSE IF(ID1.EQ.211) THEN
+ K = 3
+ ELSE IF(ID1.EQ.-211) THEN
+ K = 4
+ ELSE IF(ID1.EQ.321) THEN
+ K = 5
+ ELSE IF(ID1.EQ.-321) THEN
+ K = 6
+ ELSE
+ GOTO 100
+ ENDIF
+
+C calculate lab momentum
+ IF(IMODE.EQ.1) THEN
+ SS = ECM**2
+ E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
+ PL = SQRT(E1*E1-XMA(K)**2)
+ ELSE IF(IMODE.EQ.2) THEN
+ PL = PLAB
+ SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
+ ECM = SQRT(SS)
+ ELSE
+ WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
+ RETURN
+ ENDIF
+ PLL = LOG(PL)
+
+C check against lower limit
+ IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
+
+ XP = TPDG96(2,K)*SS**TPDG96(3,K)
+ YP = TPDG96(6,K)/SS**TPDG96(8,K)
+ YM = TPDG96(7,K)/SS**TPDG96(8,K)
+
+ PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
+ PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
+ RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
+ SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
+
+C select energy range and interpolation method
+ IF(PL.LT.TPDG96(1,K)) THEN
+ SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
+ SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ SIGTO2 = YP+YM+XP
+ SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
+ X1 = 1.D0 - X2
+ SIGTOT = SIGTO2*X2 + SIGTO1*X1
+ SIGEL = SIGEL2*X2 + SIGEL1*X1
+ ELSE
+ SIGTOT = YP+YM+XP
+ SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ ENDIF
+
+C no parametrization of diffraction implemented
+ SIGDIF(1) = -1.D0
+ SIGDIF(2) = -1.D0
+ SIGDIF(3) = -1.D0
+
+ RETURN
+
+ 100 CONTINUE
+ WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
+ & 'invalid particle combination: ',ID1,ID2
+ RETURN
+
+ 200 CONTINUE
+ WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
+ & 'energy too small (Ecm,Plab): ',ECM,PLAB
+
+ END
+
+CDECK ID>, PHO_CSDIFF
+ SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
+ & sig_sd1,sig_sd2,sig_dd)
+C***********************************************************************
+C
+C cross section for diffraction dissociation according to
+C Goulianos' parametrization (Ref: PL B358 (1995) 379)
+C
+C in addition rescaling for different particles is applied using
+C internal rescaling tables (not implemented yet)
+C
+C input: Id1/2 PDG ID's of incoming particles
+C SS squared c.m. energy (GeV**2)
+C Xi_min min. diff mass (squared) = Xi_min*SS
+C Xi_max max. diff mass (squared) = Xi_max*SS
+C
+C output: sig_sd1 cross section for diss. of particle 1 (mb)
+C sig_sd2 cross section for diss. of particle 2 (mb)
+C sig_dd cross section for diss. of both particles
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+ INTEGER Id1,Id2
+ DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+C some constants
+ DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
+ COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
+ & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
+
+ DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
+ DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
+ & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
+ & xms_1,xms_2,CSdiff
+
+ INTEGER Ngau1,Ngau2,i1,i2
+
+C model parameters
+
+ DATA delta / 0.104d0 /
+ DATA alphap / 0.25d0 /
+ DATA beta0 / 6.56d0 /
+ DATA gpom0 / 1.21d0 /
+ DATA xm_p / 0.938d0 /
+ DATA x_rad2 / 0.71d0 /
+
+C integration precision
+
+ DATA Ngau1 / 96 /
+ DATA Ngau2 / 96 /
+
+ sig_sd1 = 0.d0
+ sig_sd2 = 0.d0
+ sig_dd = 0.d0
+
+ IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
+
+ xm4_p2 = 4.D0*xm_p**2
+ fac = beta0**2/(16.D0*PI)
+
+ t1 = -5.D0
+ t2 = 0.D0
+ tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C flux renormalization and cross section
+
+ Xnorm = 0.d0
+
+ xil = log(1.5d0/SS)
+ xiu = log(0.1d0)
+
+ IF(xiu.LE.xil) goto 1000
+
+ CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
+ CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ w_xi = Xwgh1(i1)
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ Xnorm = Xnorm
+ & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ Xnorm = Xnorm*fac
+
+ 1000 continue
+
+ XIL = LOG(Xi_min)
+ XIU = LOG(Xi_max)
+
+ T1 = -5.D0
+ T2 = 0.D0
+
+ TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C single diffraction diss. cross section
+
+ CSdiff = 0.d0
+
+ IF(XIU.LE.XIL) goto 2000
+
+ CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
+ CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ CSdiff = CSdiff
+ & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
+
+* WRITE(LO,'(1x,1p,4e14.3)')
+* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
+
+ sig_sd1 = CSdiff
+ sig_sd2 = CSdiff
+
+ 2000 continue
+
+C double diffraction dissociation cross section
+
+ CSdiff = 0.d0
+
+ xil = log(1.5d0/SS)
+ xiu = log(Xi_max/1.5d0)
+
+ IF(xiu.LE.xil) goto 3000
+
+ fac = (beta0*gpom0*SS**delta
+ & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
+ & /(2.d0*alphap)
+
+ CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
+
+ do i1=1,Ngau1
+
+ xi = exp(xpos1(i1))
+ xms_1 = xi*SS
+
+ xiu = log(Xi_max/(xi*SS))
+
+ if(xil.lt.xiu) then
+
+ CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
+
+ do i2=1,Ngau2
+
+ xms_2 = exp(xpos2(i2))*SS
+ CSdiff = CSdiff
+ & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
+ & *xwgh1(i1)*xwgh2(i2)
+
+ enddo
+
+ endif
+
+ enddo
+
+ sig_dd = CSdiff*fac*GEV2MB
+
+ 3000 continue
+
+ ELSE
+
+ WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
+ & 'invalid particle combination (Id1/2)',Id1,Id2
+
+ ENDIF
+
+ END
+
+CDECK ID>, PHO_ALLM97
+ DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
+C**********************************************************************
+C
+C ALLM97 parametrization for gamma*-p cross section
+C (for F2 see comments, code adapted from V. Shekelyan, H1)
+C
+C**********************************************************************
+
+ IMPLICIT NONE
+
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION Q2,W
+ DOUBLE PRECISION M02,M12,LAM2,M22
+ DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
+ DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
+ DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
+ & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
+ DATA ALFA,XMP2 /112.2D0 , .8802D0 /
+
+ W2=W*W
+ PHO_ALLM97 = 0.D0
+
+C pomeron
+ S11 = 0.28067D0
+ S12 = 0.22291D0
+ S13 = 2.1979D0
+ A11 = -0.0808D0
+ A12 = -0.44812D0
+ A13 = 1.1709D0
+ B11 = 0.60243D0
+ B12 = 1.3754D0
+ B13 = 1.8439D0
+ M12 = 49.457D0
+
+C reggeon
+ S21 = 0.80107D0
+ S22 = 0.97307D0
+ S23 = 3.4942D0
+ A21 = 0.58400D0
+ A22 = 0.37888D0
+ A23 = 2.6063D0
+ B21 = 0.10711D0
+ B22 = 1.9386D0
+ B23 = 0.49338D0
+ M22 = 0.15052D0
+C
+ M02 = 0.31985D0
+ LAM2 = 0.065270D0
+ Q02 = 0.46017D0 +LAM2
+
+C
+ S=0.
+ T=LOG((Q2+Q02)/LAM2)
+ T0=LOG(Q02/LAM2)
+ IF(Q2.GT.0.D0) S=LOG(T/T0)
+ Z=1.D0
+
+ IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
+
+ IF(S.LT.0.01D0) THEN
+
+C pomeron part
+
+ XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
+
+ AP=A11
+ BP=B11**2
+
+ SP=S11
+ F2P=SP*XP**AP*Z**BP
+
+C reggeon part
+
+ XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
+
+ AR=A21
+ BR=B21**2
+
+ SR=S21
+ F2R=SR*XR**AR*Z**BR
+
+ ELSE
+
+C pomeron part
+
+ XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
+
+ AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
+
+ BP=B11**2+B12**2*S**B13
+
+ SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
+
+ F2P=SP*XP**AP*Z**BP
+
+C reggeon part
+
+ XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
+
+ AR=A21+A22*S**A23
+ BR=B21**2+B22**2*S**B23
+
+ SR=S21+S22*S**S23
+ F2R=SR*XR**AR*Z**BR
+
+ ENDIF
+
+* F2 = (F2P+F2R)*Q2/(Q2+M02)
+
+ CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
+ PHO_ALLM97 = CIN*(F2P+F2R)
+
+ END
+
+CDECK ID>, PHO_DOR98LO
+ SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
+C***********************************************************************
+C
+C GRV98 parton densities, leading order set
+C
+C For a detailed explanation see
+C M. Glueck, E. Reya, A. Vogt :
+C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
+C (To appear in Eur. Phys. J. C)
+C
+C interpolation routine based on the original GRV98PA routine,
+C adapted to define interpolation table as DATA statements
+C
+C (R.Engel, 09/98)
+C
+C
+C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
+C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
+C
+C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
+C DS = d(bar), SS = s = s(bar), GL = gluon.
+C Always x times the distribution is returned.
+C
+C******************************************************i****************
+ IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
+ DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
+ 1 XSF(NX,NQ), XGF(NX,NQ),
+ 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
+
+ DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
+ & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
+
+ EQUIVALENCE (XUVF(1,1),XUVF_L(1))
+ EQUIVALENCE (XDVF(1,1),XDVF_L(1))
+ EQUIVALENCE (XDEF(1,1),XDEF_L(1))
+ EQUIVALENCE (XUDF(1,1),XUDF_L(1))
+ EQUIVALENCE (XSF(1,1),XSF_L(1))
+ EQUIVALENCE (XGF(1,1),XGF_L(1))
+
+ DATA (ARRF(K),K= 1, 95) /
+ & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
+ & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
+ & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
+ & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
+ & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
+ & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
+ & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
+ & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
+ & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
+ & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
+ & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
+ & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
+ & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
+ & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
+ & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
+ & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
+ & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
+ & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
+ & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
+ DATA (XUVF_L(K),K= 1, 114) /
+ &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
+ &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
+ &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
+ &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
+ &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
+ &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
+ &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
+ &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
+ &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
+ &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
+ &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
+ &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
+ &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
+ &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
+ &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
+ &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
+ &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
+ &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
+ &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
+ DATA (XUVF_L(K),K= 115, 228) /
+ &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
+ &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
+ &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
+ &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
+ &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
+ &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
+ &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
+ &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
+ &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
+ &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
+ &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
+ &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
+ &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
+ &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
+ &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
+ &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
+ &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
+ &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
+ &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
+ DATA (XUVF_L(K),K= 229, 342) /
+ &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
+ &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
+ &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
+ &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
+ &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
+ &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
+ &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
+ &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
+ &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
+ &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
+ &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
+ &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
+ &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
+ &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
+ &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
+ &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
+ &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
+ &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
+ &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
+ DATA (XUVF_L(K),K= 343, 456) /
+ &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
+ &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
+ &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
+ &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
+ &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
+ &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
+ &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
+ &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
+ &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
+ &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
+ &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
+ &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
+ &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
+ &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
+ &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
+ &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
+ &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
+ &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
+ &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
+ DATA (XUVF_L(K),K= 457, 570) /
+ &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
+ &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
+ &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
+ &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
+ &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
+ &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
+ &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
+ &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
+ &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
+ &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
+ &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
+ &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
+ &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
+ &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
+ &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
+ &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
+ &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
+ &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
+ &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
+ DATA (XUVF_L(K),K= 571, 684) /
+ &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
+ &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
+ &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
+ &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
+ &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
+ &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
+ &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
+ &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
+ &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
+ &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
+ &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
+ &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
+ &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
+ &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
+ &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
+ &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
+ &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
+ &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
+ &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
+ DATA (XUVF_L(K),K= 685, 798) /
+ &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
+ &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
+ &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
+ &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
+ &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
+ &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
+ &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
+ &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
+ &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
+ &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
+ &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
+ &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
+ &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
+ &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
+ &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
+ &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
+ &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
+ &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
+ &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
+ DATA (XUVF_L(K),K= 799, 912) /
+ &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
+ &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
+ &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
+ &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
+ &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
+ &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
+ &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
+ &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
+ &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
+ &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
+ &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
+ &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
+ &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
+ &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
+ &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
+ &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
+ &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
+ &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
+ &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
+ DATA (XUVF_L(K),K= 913, 1026) /
+ &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
+ &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
+ &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
+ &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
+ &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
+ &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
+ &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
+ &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
+ &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
+ &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
+ &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
+ &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
+ &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
+ &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
+ &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
+ &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
+ &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
+ &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
+ &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
+ DATA (XUVF_L(K),K= 1027, 1140) /
+ &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
+ &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
+ &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
+ &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
+ &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
+ &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
+ &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
+ &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
+ &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
+ &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
+ &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
+ &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
+ &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
+ &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
+ &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
+ &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
+ &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
+ &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
+ &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
+ DATA (XUVF_L(K),K= 1141, 1254) /
+ &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
+ &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
+ &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
+ &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
+ &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
+ &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
+ &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
+ &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
+ &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
+ &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
+ &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
+ &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
+ &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
+ &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
+ &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
+ &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
+ &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
+ &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
+ &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
+ DATA (XUVF_L(K),K= 1255, 1368) /
+ &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
+ &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
+ &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
+ &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
+ &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
+ &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
+ &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
+ &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
+ &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
+ &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
+ &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
+ &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
+ &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
+ &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
+ &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
+ &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
+ &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
+ &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
+ &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
+ DATA (XUVF_L(K),K= 1369, 1482) /
+ &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
+ &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
+ &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
+ &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
+ &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
+ &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
+ &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
+ &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
+ &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
+ &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
+ &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
+ &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
+ &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
+ &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
+ &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
+ &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
+ &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
+ &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
+ &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
+ DATA (XUVF_L(K),K= 1483, 1596) /
+ &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
+ &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
+ &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
+ &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
+ &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
+ &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
+ &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
+ &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
+ &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
+ &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
+ &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
+ &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
+ &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
+ &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
+ &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
+ &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
+ &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
+ &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
+ &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
+ DATA (XUVF_L(K),K= 1597, 1710) /
+ &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
+ &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
+ &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
+ &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
+ &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
+ &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
+ &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
+ &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
+ &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
+ &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
+ &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
+ &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
+ &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
+ &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
+ &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
+ &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
+ &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
+ &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
+ &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
+ DATA (XUVF_L(K),K= 1711, 1824) /
+ &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
+ &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
+ &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
+ &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
+ &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
+ &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
+ &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
+ &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
+ &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
+ &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
+ &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
+ &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
+ &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
+ &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
+ &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
+ &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
+ &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
+ &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
+ &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
+ DATA (XUVF_L(K),K= 1825, 1836) /
+ &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
+ &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
+ DATA (XDVF_L(K),K= 1, 114) /
+ &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
+ &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
+ &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
+ &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
+ &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
+ &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
+ &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
+ &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
+ &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
+ &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
+ &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
+ &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
+ &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
+ &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
+ &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
+ &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
+ &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
+ &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
+ &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
+ DATA (XDVF_L(K),K= 115, 228) /
+ &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
+ &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
+ &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
+ &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
+ &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
+ &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
+ &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
+ &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
+ &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
+ &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
+ &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
+ &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
+ &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
+ &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
+ &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
+ &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
+ &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
+ &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
+ &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
+ DATA (XDVF_L(K),K= 229, 342) /
+ &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
+ &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
+ &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
+ &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
+ &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
+ &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
+ &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
+ &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
+ &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
+ &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
+ &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
+ &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
+ &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
+ &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
+ &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
+ &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
+ &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
+ &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
+ &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
+ DATA (XDVF_L(K),K= 343, 456) /
+ &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
+ &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
+ &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
+ &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
+ &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
+ &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
+ &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
+ &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
+ &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
+ &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
+ &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
+ &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
+ &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
+ &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
+ &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
+ &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
+ &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
+ &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
+ &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
+ DATA (XDVF_L(K),K= 457, 570) /
+ &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
+ &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
+ &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
+ &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
+ &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
+ &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
+ &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
+ &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
+ &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
+ &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
+ &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
+ &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
+ &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
+ &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
+ &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
+ &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
+ &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
+ &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
+ &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
+ DATA (XDVF_L(K),K= 571, 684) /
+ &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
+ &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
+ &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
+ &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
+ &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
+ &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
+ &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
+ &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
+ &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
+ &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
+ &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
+ &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
+ &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
+ &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
+ &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
+ &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
+ &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
+ &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
+ &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
+ DATA (XDVF_L(K),K= 685, 798) /
+ &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
+ &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
+ &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
+ &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
+ &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
+ &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
+ &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
+ &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
+ &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
+ &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
+ &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
+ &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
+ &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
+ &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
+ &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
+ &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
+ &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
+ &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
+ &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
+ DATA (XDVF_L(K),K= 799, 912) /
+ &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
+ &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
+ &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
+ &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
+ &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
+ &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
+ &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
+ &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
+ &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
+ &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
+ &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
+ &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
+ &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
+ &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
+ &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
+ &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
+ &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
+ &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
+ &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
+ DATA (XDVF_L(K),K= 913, 1026) /
+ &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
+ &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
+ &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
+ &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
+ &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
+ &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
+ &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
+ &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
+ &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
+ &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
+ &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
+ &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
+ &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
+ &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
+ &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
+ &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
+ &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
+ &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
+ &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
+ DATA (XDVF_L(K),K= 1027, 1140) /
+ &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
+ &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
+ &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
+ &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
+ &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
+ &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
+ &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
+ &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
+ &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
+ &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
+ &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
+ &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
+ &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
+ &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
+ &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
+ &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
+ &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
+ &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
+ &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
+ DATA (XDVF_L(K),K= 1141, 1254) /
+ &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
+ &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
+ &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
+ &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
+ &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
+ &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
+ &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
+ &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
+ &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
+ &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
+ &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
+ &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
+ &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
+ &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
+ &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
+ &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
+ &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
+ &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
+ &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
+ DATA (XDVF_L(K),K= 1255, 1368) /
+ &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
+ &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
+ &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
+ &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
+ &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
+ &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
+ &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
+ &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
+ &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
+ &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
+ &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
+ &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
+ &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
+ &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
+ &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
+ &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
+ &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
+ &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
+ &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
+ DATA (XDVF_L(K),K= 1369, 1482) /
+ &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
+ &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
+ &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
+ &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
+ &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
+ &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
+ &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
+ &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
+ &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
+ &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
+ &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
+ &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
+ &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
+ &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
+ &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
+ &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
+ &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
+ &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
+ &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
+ DATA (XDVF_L(K),K= 1483, 1596) /
+ &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
+ &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
+ &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
+ &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
+ &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
+ &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
+ &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
+ &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
+ &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
+ &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
+ &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
+ &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
+ &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
+ &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
+ &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
+ &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
+ &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
+ &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
+ &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
+ DATA (XDVF_L(K),K= 1597, 1710) /
+ &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
+ &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
+ &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
+ &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
+ &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
+ &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
+ &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
+ &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
+ &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
+ &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
+ &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
+ &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
+ &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
+ &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
+ &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
+ &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
+ &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
+ &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
+ &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
+ DATA (XDVF_L(K),K= 1711, 1824) /
+ &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
+ &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
+ &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
+ &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
+ &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
+ &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
+ &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
+ &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
+ &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
+ &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
+ &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
+ &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
+ &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
+ &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
+ &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
+ &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
+ &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
+ &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
+ &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
+ DATA (XDVF_L(K),K= 1825, 1836) /
+ &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
+ &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
+ DATA (XDEF_L(K),K= 1, 114) /
+ &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
+ &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
+ &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
+ &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
+ &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
+ &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
+ &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
+ &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
+ &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
+ &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
+ &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
+ &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
+ &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
+ &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
+ &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
+ &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
+ &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
+ &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
+ DATA (XDEF_L(K),K= 115, 228) /
+ &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
+ &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
+ &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
+ &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
+ &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
+ &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
+ &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
+ &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
+ &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
+ &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
+ &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
+ &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
+ &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
+ &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
+ &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
+ &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
+ &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
+ DATA (XDEF_L(K),K= 229, 342) /
+ &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
+ &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
+ &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
+ &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
+ &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
+ &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
+ &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
+ &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
+ &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
+ &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
+ &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
+ &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
+ &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
+ &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
+ &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
+ &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
+ &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
+ DATA (XDEF_L(K),K= 343, 456) /
+ &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
+ &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
+ &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
+ &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
+ &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
+ &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
+ &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
+ &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
+ &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
+ &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
+ &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
+ &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
+ &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
+ &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
+ &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
+ &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
+ &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
+ &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
+ DATA (XDEF_L(K),K= 457, 570) /
+ &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
+ &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
+ &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
+ &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
+ &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
+ &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
+ &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
+ &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
+ &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
+ &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
+ &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
+ &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
+ &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
+ &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
+ &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
+ &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
+ &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
+ DATA (XDEF_L(K),K= 571, 684) /
+ &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
+ &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
+ &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
+ &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
+ &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
+ &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
+ &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
+ &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
+ &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
+ &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
+ &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
+ &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
+ &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
+ &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
+ &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
+ &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
+ &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
+ DATA (XDEF_L(K),K= 685, 798) /
+ &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
+ &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
+ &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
+ &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
+ &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
+ &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
+ &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
+ &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
+ &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
+ &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
+ &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
+ &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
+ &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
+ &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
+ &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
+ &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
+ &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
+ &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
+ DATA (XDEF_L(K),K= 799, 912) /
+ &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
+ &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
+ &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
+ &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
+ &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
+ &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
+ &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
+ &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
+ &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
+ &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
+ &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
+ &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
+ &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
+ &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
+ &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
+ &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
+ &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
+ DATA (XDEF_L(K),K= 913, 1026) /
+ &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
+ &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
+ &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
+ &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
+ &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
+ &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
+ &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
+ &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
+ &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
+ &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
+ &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
+ &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
+ &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
+ &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
+ &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
+ &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
+ &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
+ DATA (XDEF_L(K),K= 1027, 1140) /
+ &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
+ &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
+ &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
+ &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
+ &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
+ &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
+ &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
+ &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
+ &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
+ &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
+ &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
+ &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
+ &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
+ &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
+ &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
+ &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
+ &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
+ &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
+ DATA (XDEF_L(K),K= 1141, 1254) /
+ &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
+ &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
+ &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
+ &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
+ &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
+ &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
+ &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
+ &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
+ &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
+ &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
+ &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
+ &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
+ &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
+ &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
+ &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
+ &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
+ &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
+ DATA (XDEF_L(K),K= 1255, 1368) /
+ &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
+ &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
+ &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
+ &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
+ &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
+ &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
+ &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
+ &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
+ &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
+ &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
+ &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
+ &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
+ &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
+ &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
+ &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
+ &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
+ &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
+ DATA (XDEF_L(K),K= 1369, 1482) /
+ &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
+ &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
+ &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
+ &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
+ &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
+ &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
+ &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
+ &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
+ &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
+ &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
+ &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
+ &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
+ &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
+ &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
+ &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
+ &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
+ &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
+ &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
+ DATA (XDEF_L(K),K= 1483, 1596) /
+ &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
+ &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
+ &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
+ &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
+ &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
+ &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
+ &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
+ &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
+ &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
+ &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
+ &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
+ &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
+ &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
+ &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
+ &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
+ &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
+ &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
+ DATA (XDEF_L(K),K= 1597, 1710) /
+ &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
+ &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
+ &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
+ &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
+ &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
+ &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
+ &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
+ &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
+ &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
+ &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
+ &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
+ &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
+ &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
+ &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
+ &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
+ &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
+ &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
+ DATA (XDEF_L(K),K= 1711, 1824) /
+ &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
+ &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
+ &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
+ &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
+ &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
+ &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
+ &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
+ &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
+ &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
+ &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
+ &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
+ &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
+ &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
+ &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
+ &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
+ &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
+ &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
+ &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
+ DATA (XDEF_L(K),K= 1825, 1836) /
+ &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
+ &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
+ DATA (XUDF_L(K),K= 1, 114) /
+ &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
+ &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
+ &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
+ &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
+ &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
+ &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
+ &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
+ &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
+ &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
+ &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
+ &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
+ &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
+ &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
+ &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
+ &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
+ &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
+ &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
+ &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
+ &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
+ DATA (XUDF_L(K),K= 115, 228) /
+ &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
+ &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
+ &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
+ &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
+ &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
+ &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
+ &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
+ &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
+ &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
+ &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
+ &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
+ &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
+ &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
+ &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
+ &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
+ &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
+ &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
+ &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
+ &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
+ DATA (XUDF_L(K),K= 229, 342) /
+ &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
+ &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
+ &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
+ &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
+ &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
+ &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
+ &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
+ &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
+ &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
+ &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
+ &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
+ &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
+ &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
+ &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
+ &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
+ &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
+ &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
+ &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
+ &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
+ DATA (XUDF_L(K),K= 343, 456) /
+ &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
+ &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
+ &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
+ &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
+ &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
+ &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
+ &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
+ &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
+ &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
+ &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
+ &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
+ &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
+ &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
+ &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
+ &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
+ &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
+ &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
+ &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
+ &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
+ DATA (XUDF_L(K),K= 457, 570) /
+ &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
+ &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
+ &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
+ &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
+ &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
+ &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
+ &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
+ &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
+ &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
+ &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
+ &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
+ &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
+ &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
+ &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
+ &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
+ &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
+ &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
+ &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
+ &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
+ DATA (XUDF_L(K),K= 571, 684) /
+ &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
+ &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
+ &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
+ &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
+ &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
+ &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
+ &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
+ &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
+ &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
+ &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
+ &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
+ &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
+ &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
+ &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
+ &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
+ &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
+ &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
+ &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
+ &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
+ DATA (XUDF_L(K),K= 685, 798) /
+ &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
+ &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
+ &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
+ &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
+ &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
+ &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
+ &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
+ &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
+ &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
+ &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
+ &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
+ &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
+ &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
+ &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
+ &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
+ &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
+ &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
+ &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
+ &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
+ DATA (XUDF_L(K),K= 799, 912) /
+ &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
+ &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
+ &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
+ &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
+ &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
+ &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
+ &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
+ &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
+ &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
+ &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
+ &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
+ &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
+ &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
+ &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
+ &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
+ &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
+ &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
+ &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
+ &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
+ DATA (XUDF_L(K),K= 913, 1026) /
+ &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
+ &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
+ &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
+ &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
+ &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
+ &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
+ &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
+ &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
+ &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
+ &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
+ &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
+ &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
+ &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
+ &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
+ &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
+ &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
+ &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
+ &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
+ &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
+ DATA (XUDF_L(K),K= 1027, 1140) /
+ &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
+ &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
+ &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
+ &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
+ &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
+ &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
+ &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
+ &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
+ &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
+ &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
+ &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
+ &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
+ &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
+ &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
+ &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
+ &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
+ &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
+ &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
+ &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
+ DATA (XUDF_L(K),K= 1141, 1254) /
+ &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
+ &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
+ &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
+ &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
+ &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
+ &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
+ &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
+ &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
+ &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
+ &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
+ &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
+ &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
+ &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
+ &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
+ &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
+ &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
+ &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
+ &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
+ &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
+ DATA (XUDF_L(K),K= 1255, 1368) /
+ &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
+ &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
+ &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
+ &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
+ &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
+ &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
+ &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
+ &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
+ &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
+ &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
+ &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
+ &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
+ &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
+ &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
+ &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
+ &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
+ &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
+ &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
+ &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
+ DATA (XUDF_L(K),K= 1369, 1482) /
+ &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
+ &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
+ &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
+ &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
+ &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
+ &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
+ &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
+ &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
+ &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
+ &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
+ &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
+ &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
+ &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
+ &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
+ &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
+ &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
+ &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
+ &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
+ &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
+ DATA (XUDF_L(K),K= 1483, 1596) /
+ &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
+ &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
+ &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
+ &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
+ &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
+ &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
+ &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
+ &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
+ &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
+ &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
+ &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
+ &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
+ &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
+ &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
+ &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
+ &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
+ &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
+ &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
+ &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
+ DATA (XUDF_L(K),K= 1597, 1710) /
+ &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
+ &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
+ &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
+ &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
+ &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
+ &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
+ &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
+ &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
+ &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
+ &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
+ &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
+ &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
+ &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
+ &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
+ &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
+ &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
+ &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
+ &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
+ &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
+ DATA (XUDF_L(K),K= 1711, 1824) /
+ &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
+ &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
+ &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
+ &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
+ &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
+ &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
+ &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
+ &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
+ &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
+ &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
+ &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
+ &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
+ &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
+ &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
+ &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
+ &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
+ &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
+ &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
+ &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
+ DATA (XUDF_L(K),K= 1825, 1836) /
+ &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
+ &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
+ DATA (XSF_L(K),K= 1, 114) /
+ &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
+ &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
+ &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
+ &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
+ &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
+ &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
+ &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
+ &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
+ &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
+ &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
+ &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
+ &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
+ &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
+ &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
+ &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
+ &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
+ &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
+ &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
+ &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
+ DATA (XSF_L(K),K= 115, 228) /
+ &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
+ &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
+ &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
+ &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
+ &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
+ &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
+ &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
+ &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
+ &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
+ &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
+ &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
+ &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
+ &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
+ &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
+ &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
+ &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
+ &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
+ &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
+ &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
+ DATA (XSF_L(K),K= 229, 342) /
+ &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
+ &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
+ &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
+ &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
+ &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
+ &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
+ &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
+ &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
+ &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
+ &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
+ &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
+ &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
+ &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
+ &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
+ &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
+ &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
+ &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
+ &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
+ &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
+ DATA (XSF_L(K),K= 343, 456) /
+ &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
+ &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
+ &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
+ &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
+ &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
+ &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
+ &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
+ &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
+ &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
+ &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
+ &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
+ &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
+ &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
+ &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
+ &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
+ &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
+ &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
+ &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
+ &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
+ DATA (XSF_L(K),K= 457, 570) /
+ &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
+ &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
+ &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
+ &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
+ &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
+ &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
+ &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
+ &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
+ &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
+ &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
+ &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
+ &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
+ &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
+ &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
+ &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
+ &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
+ &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
+ &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
+ &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
+ DATA (XSF_L(K),K= 571, 684) /
+ &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
+ &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
+ &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
+ &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
+ &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
+ &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
+ &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
+ &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
+ &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
+ &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
+ &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
+ &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
+ &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
+ &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
+ &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
+ &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
+ &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
+ &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
+ &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
+ DATA (XSF_L(K),K= 685, 798) /
+ &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
+ &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
+ &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
+ &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
+ &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
+ &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
+ &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
+ &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
+ &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
+ &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
+ &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
+ &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
+ &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
+ &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
+ &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
+ &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
+ &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
+ &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
+ &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
+ DATA (XSF_L(K),K= 799, 912) /
+ &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
+ &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
+ &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
+ &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
+ &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
+ &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
+ &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
+ &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
+ &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
+ &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
+ &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
+ &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
+ &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
+ &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
+ &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
+ &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
+ &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
+ &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
+ &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
+ DATA (XSF_L(K),K= 913, 1026) /
+ &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
+ &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
+ &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
+ &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
+ &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
+ &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
+ &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
+ &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
+ &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
+ &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
+ &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
+ &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
+ &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
+ &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
+ &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
+ &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
+ &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
+ &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
+ &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
+ DATA (XSF_L(K),K= 1027, 1140) /
+ &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
+ &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
+ &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
+ &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
+ &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
+ &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
+ &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
+ &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
+ &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
+ &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
+ &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
+ &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
+ &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
+ &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
+ &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
+ &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
+ &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
+ &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
+ &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
+ DATA (XSF_L(K),K= 1141, 1254) /
+ &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
+ &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
+ &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
+ &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
+ &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
+ &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
+ &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
+ &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
+ &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
+ &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
+ &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
+ &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
+ &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
+ &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
+ &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
+ &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
+ &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
+ &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
+ &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
+ DATA (XSF_L(K),K= 1255, 1368) /
+ &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
+ &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
+ &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
+ &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
+ &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
+ &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
+ &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
+ &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
+ &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
+ &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
+ &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
+ &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
+ &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
+ &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
+ &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
+ &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
+ &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
+ &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
+ &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
+ DATA (XSF_L(K),K= 1369, 1482) /
+ &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
+ &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
+ &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
+ &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
+ &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
+ &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
+ &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
+ &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
+ &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
+ &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
+ &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
+ &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
+ &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
+ &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
+ &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
+ &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
+ &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
+ &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
+ &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
+ DATA (XSF_L(K),K= 1483, 1596) /
+ &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
+ &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
+ &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
+ &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
+ &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
+ &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
+ &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
+ &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
+ &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
+ &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
+ &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
+ &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
+ &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
+ &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
+ &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
+ &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
+ &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
+ &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
+ &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
+ DATA (XSF_L(K),K= 1597, 1710) /
+ &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
+ &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
+ &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
+ &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
+ &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
+ &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
+ &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
+ &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
+ &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
+ &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
+ &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
+ &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
+ &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
+ &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
+ &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
+ &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
+ &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
+ &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
+ &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
+ DATA (XSF_L(K),K= 1711, 1824) /
+ &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
+ &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
+ &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
+ &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
+ &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
+ &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
+ &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
+ &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
+ &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
+ &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
+ &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
+ &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
+ &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
+ &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
+ &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
+ &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
+ &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
+ &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
+ &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
+ DATA (XSF_L(K),K= 1825, 1836) /
+ &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
+ &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
+ DATA (XGF_L(K),K= 1, 114) /
+ &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
+ &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
+ &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
+ &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
+ &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
+ &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
+ &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
+ &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
+ &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
+ &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
+ &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
+ &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
+ &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
+ &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
+ &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
+ &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
+ &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
+ &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
+ &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
+ DATA (XGF_L(K),K= 115, 228) /
+ &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
+ &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
+ &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
+ &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
+ &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
+ &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
+ &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
+ &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
+ &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
+ &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
+ &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
+ &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
+ &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
+ &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
+ &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
+ &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
+ &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
+ &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
+ &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
+ DATA (XGF_L(K),K= 229, 342) /
+ &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
+ &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
+ &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
+ &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
+ &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
+ &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
+ &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
+ &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
+ &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
+ &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
+ &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
+ &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
+ &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
+ &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
+ &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
+ &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
+ &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
+ &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
+ &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
+ DATA (XGF_L(K),K= 343, 456) /
+ &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
+ &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
+ &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
+ &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
+ &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
+ &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
+ &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
+ &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
+ &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
+ &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
+ &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
+ &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
+ &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
+ &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
+ &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
+ &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
+ &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
+ &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
+ &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
+ DATA (XGF_L(K),K= 457, 570) /
+ &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
+ &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
+ &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
+ &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
+ &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
+ &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
+ &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
+ &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
+ &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
+ &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
+ &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
+ &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
+ &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
+ &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
+ &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
+ &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
+ &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
+ &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
+ &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
+ DATA (XGF_L(K),K= 571, 684) /
+ &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
+ &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
+ &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
+ &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
+ &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
+ &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
+ &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
+ &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
+ &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
+ &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
+ &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
+ &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
+ &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
+ &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
+ &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
+ &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
+ &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
+ &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
+ &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
+ DATA (XGF_L(K),K= 685, 798) /
+ &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
+ &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
+ &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
+ &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
+ &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
+ &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
+ &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
+ &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
+ &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
+ &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
+ &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
+ &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
+ &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
+ &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
+ &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
+ &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
+ &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
+ &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
+ &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
+ DATA (XGF_L(K),K= 799, 912) /
+ &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
+ &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
+ &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
+ &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
+ &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
+ &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
+ &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
+ &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
+ &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
+ &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
+ &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
+ &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
+ &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
+ &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
+ &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
+ &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
+ &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
+ &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
+ &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
+ DATA (XGF_L(K),K= 913, 1026) /
+ &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
+ &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
+ &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
+ &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
+ &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
+ &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
+ &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
+ &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
+ &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
+ &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
+ &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
+ &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
+ &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
+ &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
+ &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
+ &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
+ &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
+ &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
+ &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
+ DATA (XGF_L(K),K= 1027, 1140) /
+ &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
+ &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
+ &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
+ &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
+ &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
+ &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
+ &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
+ &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
+ &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
+ &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
+ &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
+ &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
+ &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
+ &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
+ &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
+ &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
+ &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
+ &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
+ &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
+ DATA (XGF_L(K),K= 1141, 1254) /
+ &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
+ &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
+ &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
+ &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
+ &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
+ &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
+ &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
+ &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
+ &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
+ &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
+ &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
+ &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
+ &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
+ &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
+ &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
+ &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
+ &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
+ &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
+ &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
+ DATA (XGF_L(K),K= 1255, 1368) /
+ &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
+ &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
+ &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
+ &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
+ &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
+ &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
+ &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
+ &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
+ &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
+ &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
+ &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
+ &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
+ &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
+ &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
+ &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
+ &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
+ &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
+ &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
+ &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
+ DATA (XGF_L(K),K= 1369, 1482) /
+ &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
+ &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
+ &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
+ &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
+ &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
+ &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
+ &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
+ &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
+ &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
+ &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
+ &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
+ &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
+ &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
+ &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
+ &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
+ &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
+ &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
+ &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
+ &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
+ DATA (XGF_L(K),K= 1483, 1596) /
+ &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
+ &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
+ &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
+ &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
+ &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
+ &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
+ &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
+ &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
+ &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
+ &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
+ &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
+ &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
+ &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
+ &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
+ &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
+ &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
+ &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
+ &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
+ &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
+ DATA (XGF_L(K),K= 1597, 1710) /
+ &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
+ &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
+ &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
+ &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
+ &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
+ &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
+ &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
+ &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
+ &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
+ &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
+ &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
+ &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
+ &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
+ &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
+ &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
+ &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
+ &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
+ &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
+ &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
+ DATA (XGF_L(K),K= 1711, 1824) /
+ &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
+ &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
+ &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
+ &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
+ &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
+ &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
+ &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
+ &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
+ &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
+ &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
+ &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
+ &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
+ &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
+ &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
+ &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
+ &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
+ &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
+ &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
+ &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
+ DATA (XGF_L(K),K= 1825, 1836) /
+ &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
+ &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
+
+*
+ X = Xinp
+*...CHECK OF X AND Q2 VALUES :
+ IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
+* WRITE(LO,91) X
+ 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
+ X = 0.99D-9
+* STOP
+ ENDIF
+
+ Q2 = Q2inp
+ IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
+* WRITE(LO,92) Q2
+ 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
+ Q2 = 0.99E6
+* STOP
+ ENDIF
+
+*
+*...INTERPOLATION :
+ NA(1) = NX
+ NA(2) = NQ
+ XT(1) = DLOG(X)
+ XT(2) = DLOG(Q2)
+ X1 = 1.- X
+ XV = X**0.5
+ XS = X**(-0.2)
+ UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
+ DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
+ DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
+ UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
+ US = 0.5 * (UD - DE)
+ DS = 0.5 * (UD + DE)
+ SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
+ GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
+
+ END
+
+CDECK ID>, PHO_DOR98SC
+ SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
+C***********************************************************************
+C
+C GRV98 parton densities, leading order set
+C
+C For a detailed explanation see
+C M. Glueck, E. Reya, A. Vogt :
+C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
+C (To appear in Eur. Phys. J. C)
+C
+C interpolation routine based on the original GRV98PA routine,
+C adapted to define interpolation table as DATA statements
+C
+C (R.Engel, 09/98)
+C
+C CAUTION: this is a version with gluon shadowing corrections
+C (R.Engel, 09/99)
+C
+C
+C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
+C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
+C
+C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
+C DS = d(bar), SS = s = s(bar), GL = gluon.
+C Always x times the distribution is returned.
+C
+C******************************************************i****************
+ IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
+ DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
+ 1 XSF(NX,NQ), XGF(NX,NQ),
+ 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
+
+ DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
+ & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
+
+ EQUIVALENCE (XUVF(1,1),XUVF_L(1))
+ EQUIVALENCE (XDVF(1,1),XDVF_L(1))
+ EQUIVALENCE (XDEF(1,1),XDEF_L(1))
+ EQUIVALENCE (XUDF(1,1),XUDF_L(1))
+ EQUIVALENCE (XSF(1,1),XSF_L(1))
+ EQUIVALENCE (XGF(1,1),XGF_L(1))
+
+*#################### data statements for shadowed LO PDF ##############
+C ... deleted ...
+*#######################################################################
+
+ X = Xinp
+*...CHECK OF X AND Q2 VALUES :
+ IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
+* WRITE(LO,91) X
+ 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
+ X = 0.99D-9
+* STOP
+ ENDIF
+
+ Q2 = Q2inp
+ IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
+* WRITE(LO,92) Q2
+ 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
+ Q2 = 0.99E6
+* STOP
+ ENDIF
+
+*
+*...INTERPOLATION :
+ NA(1) = NX
+ NA(2) = NQ
+ XT(1) = DLOG(X)
+ XT(2) = DLOG(Q2)
+ X1 = 1.- X
+ XV = X**0.5
+ XS = X**(-0.2)
+ UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
+ DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
+ DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
+ UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
+ US = 0.5 * (UD - DE)
+ DS = 0.5 * (UD + DE)
+ SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
+ GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
+
+ END
+
+CDECK ID>, PHO_DOR94LO
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
+* *
+* 1994 UPDATE *
+* *
+* FOR A DETAILED EXPLANATION SEE *
+* M. GLUECK, E.REYA, A.VOGT : *
+* DO-TH 94/24 = DESY 94-206 *
+* (TO APPEAR IN Z. PHYS. C) *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
+* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
+* X BETWEEN 1.E-5 AND 1. *
+* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
+* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
+* M(C) = 1.5, M(B) = 4.5 *
+* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, *
+* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131. *
+* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
+* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
+* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
+* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
+* GRV PARAMETRIZATION. *
+* *
+* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
+* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
+* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+*
+*...INPUT PARAMETERS :
+*
+* X = MOMENTUM FRACTION
+* Q2 = SCALE Q**2 IN GEV**2
+*
+*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
+*
+* UV = U(VAL) = U - U(BAR)
+* DV = D(VAL) = D - D(BAR)
+* DEL = D(BAR) - U(BAR)
+* UDB = U(BAR) + D(BAR)
+* SB = S = S(BAR)
+* GL = GLUON
+*
+*...LO PARAMETRIZATION :
+*
+ SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.23
+ LAM2 = 0.2322 * 0.2322
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 2.284 + 0.802 * S + 0.055 * S2
+ AKU = 0.590 - 0.024 * S
+ BKU = 0.131 + 0.063 * S
+ AU = -0.449 - 0.138 * S - 0.076 * S2
+ BU = 0.213 + 2.669 * S - 0.728 * S2
+ CU = 8.854 - 9.135 * S + 1.979 * S2
+ DU = 2.997 + 0.753 * S - 0.076 * S2
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.371 + 0.083 * S + 0.039 * S2
+ AKD = 0.376
+ BKD = 0.486 + 0.062 * S
+ AD = -0.509 + 3.310 * S - 1.248 * S2
+ BD = 12.41 - 10.52 * S + 2.267 * S2
+ CD = 6.373 - 6.208 * S + 1.418 * S2
+ DD = 3.691 + 0.799 * S - 0.071 * S2
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.082 + 0.014 * S + 0.008 * S2
+ AKE = 0.409 - 0.005 * S
+ BKE = 0.799 + 0.071 * S
+ AE = -38.07 + 36.13 * S - 0.656 * S2
+ BE = 90.31 - 74.15 * S + 7.645 * S2
+ CE = 0.0
+ DE = 7.486 + 1.217 * S - 0.159 * S2
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 1.451
+ BEX = 0.271
+ AKX = 0.410 - 0.232 * S
+ BKX = 0.534 - 0.457 * S
+ AGX = 0.890 - 0.140 * S
+ BGX = -0.981
+ CX = 0.320 + 0.683 * S
+ DX = 4.752 + 1.164 * S + 0.286 * S2
+ EX = 4.119 + 1.713 * S
+ ESX = 0.682 + 2.978 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.914
+ BES = 0.577
+ AKS = 1.798 - 0.596 * S
+ AS = -5.548 + 3.669 * DS - 0.616 * S
+ BS = 18.92 - 16.73 * DS + 5.168 * S
+ DST = 6.379 - 0.350 * S + 0.142 * S2
+ EST = 3.981 + 1.638 * S
+ ESS = 6.402
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 0.524
+ BEG = 1.088
+ AKG = 1.742 - 0.930 * S
+ BKG = - 0.399 * S2
+ AG = 7.486 - 2.185 * S
+ BG = 16.69 - 22.74 * S + 5.779 * S2
+ CG = -25.59 + 29.71 * S - 7.296 * S2
+ DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
+ EG = 0.807 + 2.005 * S
+ ESG = 3.841 + 0.316 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+*
+*...NLO PARAMETRIZATION (MS(BAR)) :
+*
+CDECK ID>, PHO_DOR94HO
+ SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.34
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 1.304 + 0.863 * S
+ AKU = 0.558 - 0.020 * S
+ BKU = 0.183 * S
+ AU = -0.113 + 0.283 * S - 0.321 * S2
+ BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
+ CU = 7.771 - 10.09 * S + 2.630 * S2
+ DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.102 - 0.017 * S + 0.005 * S2
+ AKD = 0.270 - 0.019 * S
+ BKD = 0.260
+ AD = 2.393 + 6.228 * S - 0.881 * S2
+ BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
+ CD = 17.83 - 53.47 * S + 21.24 * S2
+ DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
+ AKE = 0.409 - 0.007 * S
+ BKE = 0.782 + 0.082 * S
+ AE = -29.65 + 26.49 * S + 5.429 * S2
+ BE = 90.20 - 74.97 * S + 4.526 * S2
+ CE = 0.0
+ DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 0.877
+ BEX = 0.561
+ AKX = 0.275
+ BKX = 0.0
+ AGX = 0.997
+ BGX = 3.210 - 1.866 * S
+ CX = 7.300
+ DX = 9.010 + 0.896 * DS + 0.222 * S2
+ EX = 3.077 + 1.446 * S
+ ESX = 3.173 - 2.445 * DS + 2.207 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.756
+ BES = 0.216
+ AKS = 1.690 + 0.650 * DS - 0.922 * S
+ AS = -4.329 + 1.131 * S
+ BS = 9.568 - 1.744 * S
+ DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
+ EST = 3.031 + 1.639 * S
+ ESS = 5.837 + 0.815 * S
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 1.014
+ BEG = 1.738
+ AKG = 1.724 + 0.157 * S
+ BKG = 0.800 + 1.016 * S
+ AG = 7.517 - 2.547 * S
+ BG = 34.09 - 52.21 * DS + 17.47 * S
+ CG = 4.039 + 1.491 * S
+ DG = 3.404 + 0.830 * S
+ EG = -1.112 + 3.438 * S - 0.302 * S2
+ ESG = 3.256 - 0.436 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+CDECK ID>, PHO_DOR94DI
+*
+*...NLO PARAMETRIZATION (DIS) :
+*
+ SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.34
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+*...UV :
+ NU = 2.484 + 0.116 * S + 0.093 * S2
+ AKU = 0.563 - 0.025 * S
+ BKU = 0.054 + 0.154 * S
+ AU = -0.326 - 0.058 * S - 0.135 * S2
+ BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
+ CU = 11.52 - 12.99 * S + 3.161 * S2
+ DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
+ UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
+*...DV :
+ ND = 0.156 - 0.017 * S
+ AKD = 0.299 - 0.022 * S
+ BKD = 0.259 - 0.015 * S
+ AD = 3.445 + 1.278 * S + 0.326 * S2
+ BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
+ CD = 55.45 - 69.92 * S + 20.78 * S2
+ DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
+ DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
+*...DEL :
+ NE = 0.099 + 0.019 * S + 0.002 * S2
+ AKE = 0.419 - 0.013 * S
+ BKE = 1.064 - 0.038 * S
+ AE = -44.00 + 98.70 * S - 14.79 * S2
+ BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
+ CE = 84.57 - 108.8 * S + 31.52 * S2
+ DE = 7.469 + 2.480 * S - 0.866 * S2
+ DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
+*...UDB :
+ ALX = 1.215
+ BEX = 0.466
+ AKX = 0.326 + 0.150 * S
+ BKX = 0.956 + 0.405 * S
+ AGX = 0.272
+ BGX = 3.794 - 2.359 * DS
+ CX = 2.014
+ DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
+ EX = 3.049 + 1.597 * S
+ ESX = 4.396 - 4.594 * DS + 3.268 * S
+ UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
+*...SB :
+ ALS = 0.175
+ BES = 0.344
+ AKS = 1.415 - 0.641 * DS
+ AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
+ BS = 5.617 + 5.709 * DS - 3.972 * S
+ DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
+ EST = 4.546 + 0.372 * S2
+ ESS = 5.053 - 1.070 * S + 0.805 * S2
+ SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+*...GL :
+ ALG = 1.258
+ BEG = 1.846
+ AKG = 2.423
+ BKG = 2.427 + 1.311 * S - 0.153 * S2
+ AG = 25.09 - 7.935 * S
+ BG = -14.84 - 124.3 * DS + 72.18 * S
+ CG = 590.3 - 173.8 * S
+ DG = 5.196 + 1.857 * S
+ EG = -1.648 + 3.988 * S - 0.432 * S2
+ ESG = 3.232 - 0.542 * S
+ GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
+
+ END
+
+*
+*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
+*
+CDECK ID>, PHO_DOR94FV
+ DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
+
+ END
+
+CDECK ID>, PHO_DOR94FW
+ DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
+ & A,B,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ LX = LOG (1./X)
+ PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
+ 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DOR94FS
+ DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
+ 1 * DEXP (-E + SQRT (ES * S**BE * LX))
+
+ END
+
+CDECK ID>, PHO_DOR92LO
+*
+*
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
+* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ S2 = S * S
+ S3 = S2 * S
+C...X * (UV + DV) :
+ NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
+ AKUD = 0.326
+ AGUD = -1.97 + 6.74 * S - 1.96 * S2
+ BUD = 24.4 - 20.7 * S + 4.08 * S2
+ DUD = 2.86 + 0.70 * S - 0.02 * S2
+ UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
+C...X * DV :
+ ND = 0.579 + 0.283 * S + 0.047 * S2
+ AKD = 0.523 - 0.015 * S
+ AGD = 2.22 - 0.59 * S - 0.27 * S2
+ BD = 5.95 - 6.19 * S + 1.55 * S2
+ DD = 3.57 + 0.94 * S - 0.16 * S2
+ DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
+C...X * G :
+ ALG = 0.558
+ BEG = 1.218
+ AKG = 1.00 - 0.17 * S
+ BKG = 0.0
+ AGG = 0.0 + 4.879 * S - 1.383 * S2
+ BGG = 25.92 - 28.97 * S + 5.596 * S2
+ CG = -25.69 + 23.68 * S - 1.975 * S2
+ DG = 2.537 + 1.718 * S + 0.353 * S2
+ EG = 0.595 + 2.138 * S
+ ESG = 4.066
+ GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * UBAR = X * DBAR :
+ ALU = 1.396
+ BEU = 1.331
+ AKU = 0.412 - 0.171 * S
+ BKU = 0.566 - 0.496 * S
+ AGU = 0.363
+ BGU = -1.196
+ CU = 1.029 + 1.785 * S - 0.459 * S2
+ DU = 4.696 + 2.109 * S
+ EU = 3.838 + 1.944 * S
+ ESU = 2.845
+ UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
+C...X * SBAR = X * S :
+ SS = 0.0
+ ALS = 0.803
+ BES = 0.563
+ AKS = 2.082 - 0.577 * S
+ AGS = -3.055 + 1.024 * S ** 0.67
+ BS = 27.4 - 20.0 * S ** 0.154
+ DS = 6.22
+ EST = 4.33 + 1.408 * S
+ ESS = 8.27 - 0.437 * S
+ SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.888
+ ALC = 1.01
+ BEC = 0.37
+ AKC = 0.0
+ AGC = 0.0
+ BC = 4.24 - 0.804 * S
+ DC = 3.46 + 1.076 * S
+ EC = 4.61 + 1.490 * S
+ ESC = 2.555 + 1.961 * S
+ CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.351
+ ALB = 1.00
+ BEB = 0.51
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 1.848
+ DB = 2.929 + 1.396 * S
+ EB = 4.71 + 1.514 * S
+ ESB = 4.02 + 1.239 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+CDECK ID>, PHO_DOR92HO
+ SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+C...X * (UV + DV) :
+ NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
+ AKUD = 0.285
+ AGUD = -2.28 + 15.73 * S - 4.58 * S2
+ BUD = 56.7 - 53.6 * S + 11.21 * S2
+ DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
+ UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
+C...X * DV :
+ ND = 0.459 + 0.315 * DS + 0.515 * S
+ AKD = 0.624 - 0.031 * S
+ AGD = 8.13 - 6.77 * DS + 0.46 * S
+ BD = 6.59 - 12.83 * DS + 5.65 * S
+ DD = 3.98 + 1.04 * S - 0.34 * S2
+ DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
+C...X * G :
+ ALG = 1.128
+ BEG = 1.575
+ AKG = 0.323 + 1.653 * S
+ BKG = 0.811 + 2.044 * S
+ AGG = 0.0 + 1.963 * S - 0.519 * S2
+ BGG = 0.078 + 6.24 * S
+ CG = 30.77 - 24.19 * S
+ DG = 3.188 + 0.720 * S
+ EG = -0.881 + 2.687 * S
+ ESG = 2.466
+ GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * UBAR = X * DBAR :
+ ALU = 0.594
+ BEU = 0.614
+ AKU = 0.636 - 0.084 * S
+ BKU = 0.0
+ AGU = 1.121 - 0.193 * S
+ BGU = 0.751 - 0.785 * S
+ CU = 8.57 - 1.763 * S
+ DU = 10.22 + 0.668 * S
+ EU = 3.784 + 1.280 * S
+ ESU = 1.808 + 0.980 * S
+ UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
+C...X * SBAR = X * S :
+ SS = 0.0
+ ALS = 0.756
+ BES = 0.101
+ AKS = 2.942 - 1.016 * S
+ AGS = -4.60 + 1.167 * S
+ BS = 9.31 - 1.324 * S
+ DS = 11.49 - 1.198 * S + 0.053 * S2
+ EST = 2.630 + 1.729 * S
+ ESS = 8.12
+ SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = -0.625 - 0.523 * S
+ AGC = 0.0
+ BC = 1.896 + 1.616 * S
+ DC = 4.12 + 0.683 * S
+ EC = 4.36 + 1.328 * S
+ ESC = 0.677 + 0.679 * S
+ CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.193 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 3.447 + 0.927 * S
+ EB = 4.68 + 1.259 * S
+ ESB = 1.892 + 2.199 * S
+ BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+CDECK ID>, PHO_DOR92FV
+ DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+ DX = SQRT (X)
+ PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DOR92FW
+ DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
+ & AL,BE,AK,BK,AG,BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+ LX = LOG (1./X)
+ PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DOR92FS
+ DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ IF (S .LE. ST) THEN
+ PHO_DOR92FS = 0.D0
+ ELSE
+ PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))
+ END IF
+
+ END
+
+CDECK ID>, PHO_DORPLO
+*
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P I O N - P A R A M E T R I Z A T I O N S *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
+* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.519 + 0.180 * S - 0.011 * S2
+ AKV = 0.499 - 0.027 * S
+ AGV = 0.381 - 0.419 * S
+ DV = 0.367 + 0.563 * S
+ VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 0.599
+ BEG = 1.263
+ AKG = 0.482 + 0.341 * DS
+ BKG = 0.0
+ AGG = 0.678 + 0.877 * S - 0.175 * S2
+ BGG = 0.338 - 1.597 * S
+ CG = 0.0 - 0.233 * S + 0.406 * S2
+ DG = 0.390 + 1.053 * S
+ EG = 0.618 + 2.070 * S
+ ESG = 3.676
+ GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0
+ ALS = 0.55
+ BES = 0.56
+ AKS = 2.538 - 0.763 * S
+ AGS = -0.748
+ BS = 0.313 + 0.935 * S
+ DS = 3.359
+ EST = 4.433 + 1.301 * S
+ ESS = 9.30 - 0.887 * S
+ QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.888
+ ALC = 1.02
+ BEC = 0.39
+ AKC = 0.0
+ AGC = 0.0
+ BC = 1.008
+ DC = 1.208 + 0.771 * S
+ EC = 4.40 + 1.493 * S
+ ESC = 2.032 + 1.901 * S
+ CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.351
+ ALB = 1.03
+ BEB = 0.39
+ AKB = 0.0
+ AGB = 0.0
+ BBO = 0.0
+ DB = 0.697 + 0.855 * S
+ EB = 4.51 + 1.490 * S
+ ESB = 3.056 + 1.694 * S
+ BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+CDECK ID>, PHO_DORPHO
+ SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
+ AKV = 0.505 - 0.033 * S
+ AGV = 0.748 - 0.669 * DS - 0.133 * S
+ DV = 0.365 + 0.197 * DS + 0.394 * S
+ VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 1.096
+ BEG = 1.371
+ AKG = 0.437 - 0.689 * DS
+ BKG = -0.631
+ AGG = 1.324 - 0.441 * DS - 0.130 * S
+ BGG = -0.955 + 0.259 * S
+ CG = 1.075 - 0.302 * S
+ DG = 1.158 + 1.229 * S
+ EG = 0.0 + 2.510 * S
+ ESG = 2.604 + 0.165 * S
+ GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0
+ ALS = 0.85
+ BES = 0.96
+ AKS = -0.350 + 0.806 * S
+ AGS = -1.663
+ BS = 3.148
+ DS = 2.273 + 1.438 * S
+ EST = 3.214 + 1.545 * S
+ ESS = 1.341 + 1.938 * S
+ QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
+C...X * CBAR = X * C :
+ SC = 0.820
+ ALC = 0.98
+ BEC = 0.0
+ AKC = 0.0 - 0.457 * S
+ AGC = 0.0
+ BC = -1.00 + 1.40 * S
+ DC = 1.318 + 0.584 * S
+ EC = 4.45 + 1.235 * S
+ ESC = 1.496 + 1.010 * S
+ CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
+C...X * BBAR = X * B :
+ SBO = 1.297
+ ALB = 0.99
+ BEB = 0.0
+ AKB = 0.0 - 0.172 * S
+ AGB = 0.0
+ BBO = 0.0
+ DB = 1.447 + 0.485 * S
+ EB = 4.79 + 1.164 * S
+ ESB = 1.724 + 2.121 * S
+ BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
+
+ END
+
+CDECK ID>, PHO_DORFVP
+ DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DORFGP
+ DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
+ & BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DORFQP
+ DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ IF (S .LE. ST) THEN
+ PHO_DORFQP = 0.0
+ ELSE
+ PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))
+ END IF
+
+ END
+
+CDECK ID>, PHO_DORGLO
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P H O T O N - P A R A M E T R I Z A T I O N S *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
+* *
+* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+ SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25
+ LAM2 = 0.232 * 0.232
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 1.717
+ BE = 0.641
+ AK = 0.500 - 0.176 * S
+ BK = 15.00 - 5.687 * SS - 0.552 * S2
+ AG = 0.235 + 0.046 * SS
+ BG = 0.082 - 0.051 * S + 0.168 * S2
+ C = 0.0 + 0.459 * S
+ D = 0.354 - 0.061 * S
+ E = 4.899 + 1.678 * S
+ ES = 2.046 + 1.389 * S
+ UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 1.549
+ BE = 0.782
+ AK = 0.496 + 0.026 * S
+ BK = 0.685 - 0.580 * SS + 0.608 * S2
+ AG = 0.233 + 0.302 * S
+ BG = 0.0 - 0.818 * S + 0.198 * S2
+ C = 0.114 + 0.154 * S
+ D = 0.405 - 0.195 * S + 0.046 * S2
+ E = 4.807 + 1.226 * S
+ ES = 2.166 + 0.664 * S
+ DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 0.676
+ BE = 1.089
+ AK = 0.462 - 0.524 * SS
+ BK = 5.451 - 0.804 * S2
+ AG = 0.535 - 0.504 * SS + 0.288 * S2
+ BG = 0.364 - 0.520 * S
+ C = -0.323 + 0.115 * S2
+ D = 0.233 + 0.790 * S - 0.139 * S2
+ E = 0.893 + 1.968 * S
+ ES = 3.432 + 0.392 * S
+ GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 1.609
+ BE = 0.962
+ AK = 0.470 - 0.099 * S2
+ BK = 3.246
+ AG = 0.121 - 0.068 * SS
+ BG = -0.090 + 0.074 * S
+ C = 0.062 + 0.034 * S
+ D = 0.0 + 0.226 * S - 0.060 * S2
+ E = 4.288 + 1.707 * S
+ ES = 2.122 + 0.656 * S
+ SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.888
+ AL = 0.970
+ BE = 0.545
+ AK = 1.254 - 0.251 * S
+ BK = 3.932 - 0.327 * S2
+ AG = 0.658 + 0.202 * S
+ BG = -0.699
+ C = 0.965
+ D = 0.0 + 0.141 * S - 0.027 * S2
+ E = 4.911 + 0.969 * S
+ ES = 2.796 + 0.952 * S
+ CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.351
+ AL = 1.016
+ BE = 0.338
+ AK = 1.961 - 0.370 * S
+ BK = 0.923 + 0.119 * S
+ AG = 0.815 + 0.207 * S
+ BG = -2.275
+ C = 1.480
+ D = -0.223 + 0.173 * S
+ E = 5.426 + 0.623 * S
+ ES = 3.819 + 0.901 * S
+ BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+CDECK ID>, PHO_DORGHO
+ SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 0.583
+ BE = 0.688
+ AK = 0.449 - 0.025 * S - 0.071 * S2
+ BK = 5.060 - 1.116 * SS
+ AG = 0.103
+ BG = 0.319 + 0.422 * S
+ C = 1.508 + 4.792 * S - 1.963 * S2
+ D = 1.075 + 0.222 * SS - 0.193 * S2
+ E = 4.147 + 1.131 * S
+ ES = 1.661 + 0.874 * S
+ UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 0.591
+ BE = 0.698
+ AK = 0.442 - 0.132 * S - 0.058 * S2
+ BK = 5.437 - 1.916 * SS
+ AG = 0.099
+ BG = 0.311 - 0.059 * S
+ C = 0.800 + 0.078 * S - 0.100 * S2
+ D = 0.862 + 0.294 * SS - 0.184 * S2
+ E = 4.202 + 1.352 * S
+ ES = 1.841 + 0.990 * S
+ DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 1.161
+ BE = 1.591
+ AK = 0.530 - 0.742 * SS + 0.025 * S2
+ BK = 5.662
+ AG = 0.533 - 0.281 * SS + 0.218 * S2
+ BG = 0.025 - 0.518 * S + 0.156 * S2
+ C = -0.282 + 0.209 * S2
+ D = 0.107 + 1.058 * S - 0.218 * S2
+ E = 0.0 + 2.704 * S
+ ES = 3.071 - 0.378 * S
+ GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 0.635
+ BE = 0.456
+ AK = 1.770 - 0.735 * SS - 0.079 * S2
+ BK = 3.832
+ AG = 0.084 - 0.023 * S
+ BG = 0.136
+ C = 2.119 - 0.942 * S + 0.063 * S2
+ D = 1.271 + 0.076 * S - 0.190 * S2
+ E = 4.604 + 0.737 * S
+ ES = 1.641 + 0.976 * S
+ SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.820
+ AL = 0.926
+ BE = 0.152
+ AK = 1.142 - 0.175 * S
+ BK = 3.276
+ AG = 0.504 + 0.317 * S
+ BG = -0.433
+ C = 3.334
+ D = 0.398 + 0.326 * S - 0.107 * S2
+ E = 5.493 + 0.408 * S
+ ES = 2.426 + 1.277 * S
+ CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.297
+ AL = 0.969
+ BE = 0.266
+ AK = 1.953 - 0.391 * S
+ BK = 1.657 - 0.161 * S
+ AG = 1.076 + 0.034 * S
+ BG = -2.015
+ C = 1.662
+ D = 0.353 + 0.016 * S
+ E = 5.713 + 0.249 * S
+ ES = 3.456 + 0.673 * S
+ BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+CDECK ID>, PHO_DORGH0
+ SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3
+ LAM2 = 0.248 * 0.248
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ SS = SQRT (S)
+ S2 = S * S
+C...X * U = X * UBAR :
+ AL = 1.447
+ BE = 0.848
+ AK = 0.527 + 0.200 * S - 0.107 * S2
+ BK = 7.106 - 0.310 * SS - 0.786 * S2
+ AG = 0.197 + 0.533 * S
+ BG = 0.062 - 0.398 * S + 0.109 * S2
+ C = 0.755 * S - 0.112 * S2
+ D = 0.318 - 0.059 * S
+ E = 4.225 + 1.708 * S
+ ES = 1.752 + 0.866 * S
+ U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * D = X * DBAR :
+ AL = 1.424
+ BE = 0.770
+ AK = 0.500 + 0.067 * SS - 0.055 * S2
+ BK = 0.376 - 0.453 * SS + 0.405 * S2
+ AG = 0.156 + 0.184 * S
+ BG = 0.0 - 0.528 * S + 0.146 * S2
+ C = 0.121 + 0.092 * S
+ D = 0.379 - 0.301 * S + 0.081 * S2
+ E = 4.346 + 1.638 * S
+ ES = 1.645 + 1.016 * S
+ D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * G :
+ AL = 0.661
+ BE = 0.793
+ AK = 0.537 - 0.600 * SS
+ BK = 6.389 - 0.953 * S2
+ AG = 0.558 - 0.383 * SS + 0.261 * S2
+ BG = 0.0 - 0.305 * S
+ C = -0.222 + 0.078 * S2
+ D = 0.153 + 0.978 * S - 0.209 * S2
+ E = 1.429 + 1.772 * S
+ ES = 3.331 + 0.806 * S
+ G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * S = X * SBAR :
+ SF = 0.0
+ AL = 1.578
+ BE = 0.863
+ AK = 0.622 + 0.332 * S - 0.300 * S2
+ BK = 2.469
+ AG = 0.211 - 0.064 * SS - 0.018 * S2
+ BG = -0.215 + 0.122 * S
+ C = 0.153
+ D = 0.0 + 0.253 * S - 0.081 * S2
+ E = 3.990 + 2.014 * S
+ ES = 1.720 + 0.986 * S
+ S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * C = X * CBAR :
+ SF = 0.820
+ AL = 0.929
+ BE = 0.381
+ AK = 1.228 - 0.231 * S
+ BK = 3.806 - 0.337 * S2
+ AG = 0.932 + 0.150 * S
+ BG = -0.906
+ C = 1.133
+ D = 0.0 + 0.138 * S - 0.028 * S2
+ E = 5.588 + 0.628 * S
+ ES = 2.665 + 1.054 * S
+ C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+C...X * B = X * BBAR :
+ SF = 1.297
+ AL = 0.970
+ BE = 0.207
+ AK = 1.719 - 0.292 * S
+ BK = 0.928 + 0.096 * S
+ AG = 0.845 + 0.178 * S
+ BG = -2.310
+ C = 1.558
+ D = -0.191 + 0.151 * S
+ E = 6.089 + 0.282 * S
+ ES = 3.379 + 1.062 * S
+ B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+ END
+
+CDECK ID>, PHO_DORGF
+ DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
+ & AG,BG,C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ SX = SQRT (X)
+ LX = LOG (1./X)
+ PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+
+ END
+
+CDECK ID>, PHO_DORGFS
+ DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
+ & C,D,E,ES)
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ IF (S .LE. SF) THEN
+ PHO_DORGFS = 0.0
+ ELSE
+ SX = SQRT (X)
+ LX = LOG (1./X)
+ DS = S - SF
+ PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
+ END IF
+
+ END
+
+CDECK ID>, PHO_DORGLV
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
+* *
+* FOR A DETAILED EXPLANATION SEE *
+* M. GLUECK, E.REYA, M. STRATMANN : *
+* PHYS. REV. D51 (1995) 3220 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
+* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
+* AND (!) Q**2 > 5 P**2 *
+* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
+* P**2 = 0 <=> REAL PHOTON *
+* X BETWEEN 1.E-4 AND 1. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
+* M(C) = 1.5, M(B) = 4.5 *
+* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, *
+* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
+* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
+* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
+* *
+* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
+* Marco.Stratmann@durham.ac.uk *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+*
+*...INPUT PARAMETERS :
+*
+* X = MOMENTUM FRACTION
+* Q2 = SCALE Q**2 IN GEV**2
+* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
+*
+*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
+*
+********************************************************
+* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
+ subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
+ implicit double precision (a-z)
+ save
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ integer check
+c
+c check limits :
+c
+ check=0
+ if(x.lt.0.0001d0) check=1
+ if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
+ if(q2.lt.5.d0*p2) check=1
+c
+c calculate distributions
+c
+ if(check.eq.0) then
+ call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
+ else
+ WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
+ WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
+ endif
+
+ end
+
+CDECK ID>, PHO_grscalc
+ subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
+ implicit double precision (a-z)
+ save
+
+ dimension u1(40),ds1(40),g1(40)
+ dimension ud2(20),s2(20),g2(20)
+ dimension up0(20),dsp0(20),gp0(20)
+ save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
+c
+ data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
+ & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
+ & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
+ & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
+ & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
+ & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
+ & 0.622d0,0.227d0,-0.184d0/
+ data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
+ & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
+ & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
+ & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
+ & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
+ & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
+ & 0.245d0,-0.171d0/
+ data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
+ & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
+ & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
+ & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
+ & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
+ & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
+ data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
+ & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
+ & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
+ & -0.614d0,3.548d0/
+ data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
+ & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
+ & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
+ & -0.48d0,3.401d0/
+ data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
+ & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
+ & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
+ & -0.079d0/
+ data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
+ & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
+ & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
+ & 2.294d0/
+ data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
+ & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
+ & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
+ & 0.814d0,1.531d0,0.124d0/
+ data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
+ & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
+ & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
+ & 2.264d0,0.2675d0/
+c
+ mu2=0.25d0
+ lam2=0.232d0*0.232d0
+c
+ if(p2.le.0.25d0) then
+ s=log(log(q2/lam2)/log(mu2/lam2))
+ lp1=0.d0
+ lp2=0.d0
+ else
+ s=log(log(q2/lam2)/log(p2/lam2))
+ lp1=log(p2/mu2)*log(p2/mu2)
+ lp2=log(p2/mu2+log(p2/mu2))
+ endif
+c
+ alp=up0(1)+lp1*u1(1)+lp2*u1(2)
+ bet=up0(2)+lp1*u1(3)+lp2*u1(4)
+ a=up0(3)+lp1*u1(5)+lp2*u1(6)+
+ & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
+ b=up0(5)+lp1*u1(9)+lp2*u1(10)+
+ & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
+ & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
+ gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
+ & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
+ & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
+ ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
+ & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
+ gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
+ & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
+ gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
+ & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
+ ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
+ & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
+ gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
+ & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
+ upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
+ bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
+ a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
+ & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
+ b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
+ & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
+ & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
+ gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
+ & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
+ & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
+ ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
+ & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
+ gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
+ & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
+ gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
+ & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
+ ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
+ & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
+ gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
+ & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
+ dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
+ bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
+ a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
+ & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
+ b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
+ & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
+ gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
+ & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
+ ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
+ & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
+ & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
+ gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
+ & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
+ gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
+ & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
+ & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
+ ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
+ & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
+ gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
+ & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
+ gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ s=log(log(q2/lam2)/log(mu2/lam2))
+ suppr=1.d0/(1.d0+p2/0.59d0)**2
+c
+ alp=ud2(1)
+ bet=ud2(2)
+ a=ud2(3)+ud2(4)*s
+ ga=ud2(5)+ud2(6)*s**0.5
+ gc=ud2(7)+ud2(8)*s
+ b=ud2(9)+ud2(10)*s+ud2(11)*s**2
+ gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
+ gd=ud2(15)+ud2(16)*s
+ ge=ud2(17)+ud2(18)*s
+ gep=ud2(19)+ud2(20)*s
+ udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=s2(1)
+ bet=s2(2)
+ a=s2(3)+s2(4)*s
+ ga=s2(5)+s2(6)*s**0.5
+ gc=s2(7)+s2(8)*s
+ b=s2(9)+s2(10)*s+s2(11)*s**2
+ gb=s2(12)+s2(13)*s+s2(14)*s**2
+ gd=s2(15)+s2(16)*s
+ ge=s2(17)+s2(18)*s
+ gep=s2(19)+s2(20)*s
+ spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ alp=g2(1)
+ bet=g2(2)
+ a=g2(3)+g2(4)*s**0.5
+ b=g2(5)+g2(6)*s**2
+ gb=g2(7)+g2(8)*s
+ ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
+ gc=g2(12)+g2(13)*s**2
+ gd=g2(14)+g2(15)*s+g2(16)*s**2
+ ge=g2(17)+g2(18)*s
+ gep=g2(19)+g2(20)*s
+ gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
+c
+ ugam=upart1+udpart2
+ dgam=dspart1+udpart2
+ sgam=dspart1+spart2
+ ggam=gpart1+gpart2
+c
+ end
+
+CDECK ID>, PHO_grsf1
+ DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
+ & ge,gep)
+ implicit double precision (a-z)
+ save
+
+ PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
+ & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
+ & (1.d0-x)**gd
+
+ end
+
+CDECK ID>, PHO_grsf2
+ DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
+ & ge,gep)
+ implicit double precision (a-z)
+ save
+
+ PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
+ & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
+ & (1.d0-x)**gd
+
+ end
+
+CDECK ID>, PHO_CKMTPA
+ SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 990 Pomeron
+C
+C output: parameters of parametrization
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ CHARACTER*8 PDFNA
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ REAL PROP(40),POMP(40)
+ DATA PROP /
+ & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
+ & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
+ & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
+ DATA POMP /
+ & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
+ & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
+ & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
+
+ IF(IPA.EQ.2212) THEN
+ ALA =PROP(1)
+ Q2MI = PROP(39)
+ Q2MA = PROP(40)
+ PDFNA = 'CKMT-PRO'
+ ELSE IF(IPA.EQ.990) THEN
+ ALA = POMP(1)
+ Q2MI = POMP(39)
+ Q2MA = POMP(40)
+ PDFNA = 'CKMT-POM'
+ ELSE
+ WRITE(LO,'(1X,A,I7)')
+ & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
+ STOP
+ ENDIF
+ XMI = 1.D-4
+ XMA = 1.D0
+ END
+
+CDECK ID>, PHO_CKMTPD
+ SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
+C**********************************************************************
+C
+C PDF based on Regge theory, evolved with .... by ....
+C
+C input: IPAR 2212 proton (not installed)
+C 990 Pomeron
+C
+C output: PD(-6:6) x*f(x) parton distribution functions
+C (PDFLIB convention: d = PD(1), u = PD(2) )
+C
+C**********************************************************************
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
+ DIMENSION QQ(7)
+
+ Q2=SNGL(SCALE2)
+ Q1S=Q2
+ XX=SNGL(X)
+C QCD lambda for evolution
+ OWLAM = 0.23D0
+ OWLAM2=OWLAM**2
+C Q0**2 for evolution
+ Q02 = 2.D0
+C
+C
+C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
+C q(6)=x*charm, q(7)=x*gluon
+C
+ SB=0.
+ IF(Q2-Q02) 1,1,2
+ 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
+ 1 CONTINUE
+ IF(IPAR.EQ.2212) THEN
+* CALL PHO_CKMTPR(XX,SB,QQ
+ WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
+ CALL PHO_ABORT
+ ELSE
+ CALL PHO_CKMTPO(XX,SB,QQ)
+ ENDIF
+C
+ PD(-6) = 0.D0
+ PD(-5) = 0.D0
+ PD(-4) = DBLE(QQ(6))
+ PD(-3) = DBLE(QQ(3))
+ PD(-2) = DBLE(QQ(4))
+ PD(-1) = DBLE(QQ(5))
+ PD(0) = DBLE(QQ(7))
+ PD(1) = DBLE(QQ(2))
+ PD(2) = DBLE(QQ(1))
+ PD(3) = DBLE(QQ(3))
+ PD(4) = DBLE(QQ(6))
+ PD(5) = 0.D0
+ PD(6) = 0.D0
+ IF(IPAR.EQ.990) THEN
+ CDN = (PD(1)-PD(-1))/2.D0
+ CUP = (PD(2)-PD(-2))/2.D0
+ PD(-1) = PD(-1) + CDN
+ PD(-2) = PD(-2) + CUP
+ PD(1) = PD(-1)
+ PD(2) = PD(-2)
+ ENDIF
+ END
+
+CDECK ID>, PHO_CKMTPO
+ SUBROUTINE PHO_CKMTPO(X,S,QQ)
+C**********************************************************************
+C
+C calculation partons in Pomeron
+C
+C**********************************************************************
+ SAVE
+
+ DIMENSION QQ(7)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
+ EQUIVALENCE (GF(1,1,1),DL(1))
+ DATA DELTA/.10/
+
+C RNG= -.5
+C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
+C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
+ DATA (DL(K),K= 1, 85) /
+ & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
+ & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
+ & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
+ & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
+ & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
+ & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
+ & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
+ & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
+ & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
+ & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
+ & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
+ & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
+ & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
+ & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
+ & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
+ & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
+ & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
+ DATA (DL(K),K= 86, 170) /
+ & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
+ & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
+ & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
+ & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
+ & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
+ & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
+ & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
+ & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
+ & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
+ & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
+ & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
+ & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
+ DATA (DL(K),K= 171, 255) /
+ & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
+ & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
+ & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
+ & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
+ & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
+ & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
+ & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
+ & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
+ & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
+ & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
+ & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
+ & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
+ & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
+ & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
+ & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
+ & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
+ & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
+ DATA (DL(K),K= 256, 340) /
+ & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
+ & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
+ & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
+ & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
+ & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
+ & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
+ & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
+ & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
+ & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
+ & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
+ & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
+ & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
+ DATA (DL(K),K= 341, 425) /
+ & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
+ & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
+ & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
+ & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
+ & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
+ & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
+ & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
+ & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
+ & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
+ & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
+ & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
+ & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
+ & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
+ & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
+ & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
+ & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
+ & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
+ DATA (DL(K),K= 426, 510) /
+ & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
+ & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
+ & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
+ & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
+ & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
+ & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
+ & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
+ & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
+ & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
+ & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
+ & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
+ & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
+ DATA (DL(K),K= 511, 595) /
+ & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
+ & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
+ & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
+ & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
+ & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
+ & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
+ & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
+ & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
+ & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
+ & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
+ & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
+ & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
+ & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
+ & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
+ & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
+ & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
+ & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
+ DATA (DL(K),K= 596, 680) /
+ & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
+ & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
+ & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
+ & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
+ & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
+ & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
+ & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
+ & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
+ & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
+ & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
+ & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
+ & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
+ DATA (DL(K),K= 681, 765) /
+ & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
+ & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
+ & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
+ & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
+ & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
+ & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
+ & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
+ & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
+ & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
+ & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
+ & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
+ & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
+ & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
+ & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
+ & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
+ & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
+ & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
+ DATA (DL(K),K= 766, 850) /
+ & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
+ & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
+ & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
+ & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
+ & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
+ & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
+ & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
+ & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
+ & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
+ & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
+ & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
+ & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
+ DATA (DL(K),K= 851, 935) /
+ & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
+ & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
+ & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
+ & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
+ & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
+ & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
+ & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
+ & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
+ & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
+ & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
+ & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
+ & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
+ & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
+ & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
+ & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
+ & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
+ & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
+ DATA (DL(K),K= 936, 1020) /
+ & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
+ & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
+ & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
+ & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
+ & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
+ & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
+ & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
+ & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
+ & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
+ & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
+ & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
+ & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
+ DATA (DL(K),K= 1021, 1105) /
+ & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
+ & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
+ & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
+ & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
+ & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
+ & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
+ & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
+ & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
+ & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
+ & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
+ & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
+ & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
+ & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
+ & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
+ & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
+ & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 1106, 1190) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
+ & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
+ & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
+ & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
+ & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
+ & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
+ & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
+ & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
+ & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
+ & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
+ & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
+ & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
+ & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
+ & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
+ DATA (DL(K),K= 1191, 1275) /
+ & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
+ & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
+ & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
+ & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
+ & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
+ & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
+ & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
+ & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
+ & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
+ & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
+ & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
+ & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
+ & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
+ & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 1276, 1360) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
+ & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
+ & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
+ & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
+ & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
+ & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
+ & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
+ & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
+ & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
+ & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
+ & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
+ & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
+ & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
+ & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
+ & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
+ & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
+ DATA (DL(K),K= 1361, 1445) /
+ & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
+ & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
+ & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
+ & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
+ & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
+ & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
+ & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
+ & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
+ & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
+ & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
+ & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
+ & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
+ DATA (DL(K),K= 1446, 1530) /
+ & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
+ & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
+ & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
+ & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
+ & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
+ & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
+ & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
+ & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
+ & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
+ & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
+ & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
+ & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
+ & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
+ & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
+ & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
+ & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
+ & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
+ DATA (DL(K),K= 1531, 1615) /
+ & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
+ & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
+ & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
+ & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
+ & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
+ & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
+ & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
+ & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
+ & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
+ & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
+ & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
+ & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
+ DATA (DL(K),K= 1616, 1700) /
+ & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
+ & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
+ & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
+ & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
+ & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
+ & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
+ & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
+ & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
+ & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
+ & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
+ & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
+ & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
+ & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
+ & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
+ & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
+ & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
+ & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
+ DATA (DL(K),K= 1701, 1785) /
+ & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
+ & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
+ & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
+ & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
+ & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
+ & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
+ & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
+ & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
+ & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
+ & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
+ & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
+ & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
+ DATA (DL(K),K= 1786, 1870) /
+ & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
+ & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
+ & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
+ & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
+ & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
+ & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
+ & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
+ & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
+ & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
+ & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
+ & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
+ & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
+ & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
+ & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
+ & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
+ & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
+ & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
+ DATA (DL(K),K= 1871, 1955) /
+ & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
+ & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
+ & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
+ & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
+ & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
+ & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
+ & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
+ & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
+ & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
+ & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
+ & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
+ & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
+ DATA (DL(K),K= 1956, 2040) /
+ & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
+ & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
+ & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
+ & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
+ & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
+ & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
+ & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
+ & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
+ & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
+ & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
+ & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
+ & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
+ & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
+ & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
+ & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
+ & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
+ & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
+ DATA (DL(K),K= 2041, 2125) /
+ & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
+ & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
+ & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
+ & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
+ & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
+ & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
+ & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
+ & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
+ & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
+ & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
+ & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
+ & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
+ DATA (DL(K),K= 2126, 2210) /
+ & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
+ & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
+ & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
+ & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
+ & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
+ & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
+ & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
+ & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
+ & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
+ & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
+ & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
+ & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
+ & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
+ & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
+ & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
+ & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
+ & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
+ DATA (DL(K),K= 2211, 2295) /
+ & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
+ & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
+ & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
+ & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
+ & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
+ & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
+ & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
+ & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
+ & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
+ & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
+ & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
+ & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
+ DATA (DL(K),K= 2296, 2380) /
+ & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
+ & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
+ & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
+ & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
+ & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
+ & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
+ & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
+ & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
+ & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
+ & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
+ & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
+ & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
+ & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
+ & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
+ & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
+ & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
+ & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2381, 2465) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
+ & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
+ & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
+ & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
+ & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
+ & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
+ & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
+ & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
+ & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
+ & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
+ & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
+ & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
+ & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
+ DATA (DL(K),K= 2466, 2550) /
+ & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
+ & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
+ & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
+ & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
+ & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
+ & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
+ & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
+ & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
+ & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
+ & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
+ & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
+ & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
+ & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
+ & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
+ & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2551, 2635) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
+ & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
+ & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
+ & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
+ & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
+ & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
+ & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
+ & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
+ & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
+ & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
+ & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
+ & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
+ & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
+ & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
+ & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
+ DATA (DL(K),K= 2636, 2720) /
+ & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
+ & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
+ & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
+ & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
+ & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
+ & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
+ & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
+ & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
+ & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
+ & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
+ & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
+ & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
+ & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 2721, 2805) /
+ & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
+ & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
+ & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
+ & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
+ & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
+ & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
+ & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
+ & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
+ & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
+ & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
+ & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
+ & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
+ & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
+ & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
+ & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
+ & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
+ & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
+ DATA (DL(K),K= 2806, 2890) /
+ & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
+ & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
+ & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
+ & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
+ & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
+ & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
+ & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
+ & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
+ & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
+ & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
+ & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
+ & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
+ DATA (DL(K),K= 2891, 2975) /
+ & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
+ & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
+ & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
+ & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
+ & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
+ & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
+ & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
+ & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
+ & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
+ & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
+ & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
+ & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
+ & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
+ & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
+ & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
+ & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
+ & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
+ DATA (DL(K),K= 2976, 3060) /
+ & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
+ & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
+ & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
+ & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
+ & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
+ & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
+ & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
+ & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
+ & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
+ & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
+ & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
+ & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
+ DATA (DL(K),K= 3061, 3145) /
+ & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
+ & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
+ & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
+ & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
+ & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
+ & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
+ & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
+ & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
+ & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
+ & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
+ & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
+ & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
+ & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
+ & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
+ & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
+ & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
+ & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
+ DATA (DL(K),K= 3146, 3230) /
+ & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
+ & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
+ & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
+ & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
+ & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
+ & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
+ & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
+ & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
+ & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
+ & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
+ & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
+ & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
+ DATA (DL(K),K= 3231, 3315) /
+ & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
+ & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
+ & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
+ & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
+ & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
+ & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
+ & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
+ & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
+ & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
+ & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
+ & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
+ & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
+ & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
+ & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
+ & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
+ & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
+ & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
+ DATA (DL(K),K= 3316, 3400) /
+ & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
+ & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
+ & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
+ & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
+ & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
+ & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
+ & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
+ & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
+ & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
+ & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
+ & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
+ & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
+ DATA (DL(K),K= 3401, 3485) /
+ & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
+ & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
+ & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
+ & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
+ & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
+ & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
+ & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
+ & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
+ & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
+ & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
+ & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
+ & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
+ & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
+ & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
+ & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
+ & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
+ & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
+ DATA (DL(K),K= 3486, 3570) /
+ & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
+ & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
+ & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
+ & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
+ & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
+ & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
+ & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
+ & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
+ & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
+ & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
+ & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
+ & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
+ DATA (DL(K),K= 3571, 3655) /
+ & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
+ & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
+ & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
+ & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
+ & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
+ & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
+ & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
+ & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
+ & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
+ & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
+ & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
+ & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
+ & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
+ & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
+ & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
+ & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
+ & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
+ DATA (DL(K),K= 3656, 3740) /
+ & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
+ & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
+ & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
+ & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
+ & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
+ & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
+ & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
+ & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
+ & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
+ & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
+ & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
+ & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
+ DATA (DL(K),K= 3741, 3825) /
+ & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
+ & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
+ & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
+ & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
+ & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
+ & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
+ & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
+ & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
+ & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
+ & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
+ & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
+ & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
+ & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
+ & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
+ & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
+ & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 3826, 3910) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
+ & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
+ & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
+ & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
+ & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
+ & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
+ & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
+ & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
+ & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
+ & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
+ & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
+ & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
+ & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
+ & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
+ DATA (DL(K),K= 3911, 3995) /
+ & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
+ & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
+ & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
+ & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
+ & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
+ & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
+ & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
+ & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
+ & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
+ & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
+ & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
+ & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
+ & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
+ & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+ DATA (DL(K),K= 3996, 4000) /
+ & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
+
+ DO 10 I=1,7
+ QQ(I) = 0.
+ 10 CONTINUE
+ IF(X.GT.0.9985) RETURN
+
+ IS = S/DELTA+1
+ IS = MIN(IS,19)
+ IS1 = IS+1
+ DO 20 I=1,7
+ IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
+ IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
+ DO 30 L=1,25
+ F1(L)=GF(I,IS,L)
+ F2(L)=GF(I,IS1,L)
+ 30 CONTINUE
+ S1=(IS-1)*DELTA
+ S2=S1+DELTA
+ A1 = PHO_CKMTFV(X,F1)
+ A2 = PHO_CKMTFV(X,F2)
+ QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
+ 19 CONTINUE
+ 20 CONTINUE
+
+ END
+
+CDECK ID>, PHO_CKMTFV
+ REAL FUNCTION PHO_CKMTFV(X,FVL)
+C**********************************************************************
+C
+C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
+C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
+C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
+C IN MAIN ROUTINE.
+C
+C**********************************************************************
+ SAVE
+
+ DIMENSION FVL(25),XGRID(25)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
+ *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
+
+ PHO_CKMTFV=0.
+ DO 1 I=1,NX
+ IF(X.LT.XGRID(I)) GO TO 2
+ 1 CONTINUE
+ 2 I=I-1
+ IF(I.EQ.0) THEN
+ I=I+1
+ ELSE IF(I.GT.23) THEN
+ I=23
+ ENDIF
+ J=I+1
+ K=J+1
+ AXI=LOG(XGRID(I))
+ BXI=LOG(1.-XGRID(I))
+ AXJ=LOG(XGRID(J))
+ BXJ=LOG(1.-XGRID(J))
+ AXK=LOG(XGRID(K))
+ BXK=LOG(1.-XGRID(K))
+ FI=LOG(ABS(FVL(I)) +1.E-15)
+ FJ=LOG(ABS(FVL(J)) +1.E-16)
+ FK=LOG(ABS(FVL(K)) +1.E-17)
+ DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
+ ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
+ $ BXI))/DET
+ ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
+ BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
+ IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
+ 1RETURN
+C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
+C WRITE(LO,2001) X,FVL
+C 2001 FORMAT(8E12.4)
+C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
+C ENDIF
+ PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
+
+ END
+
+CDECK ID>, PHO_SASGAM
+C***********************************************************************
+C...SaSgam version 2 - parton distributions of the photon
+C...by Gerhard A. Schuler and Torbjorn Sjostrand
+C...For further information see Z. Phys. C68 (1995) 607
+C...and Phys. Lett. B376 (1996) 193.
+
+C...18 January 1996: original code.
+C...22 July 1996: calculation of BETA moved in SASBEH.
+
+C!!!Note that one further call parameter - IP2 - has been added
+C!!!to the SASGAM argument list compared with version 1.
+
+C...The user should only need to call the SASGAM routine,
+C...which in turn calls the auxiliary routines SASVMD, SASANO,
+C...SASBEH and SASDIR. The package is self-contained.
+
+C...One particular aspect of these parametrizations is that F2 for
+C...the photon is not obtained just as the charge-squared-weighted
+C...sum of quark distributions, but differ in the treatment of
+C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
+C...the kinematics range of heavy-flavour production, but the same
+C...kinematics is not relevant e.g. for jet production) and, for the
+C...'MSbar' fits, in the addition of a Cgamma term related to the
+C...separation of direct processes. Schematically:
+C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
+C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
+C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
+C...The J/psi and Upsilon states have not been included in the VMD sum,
+C...but low c and b masses in the other components should compensate
+C...for this in a duality sense.
+
+C...The calling sequence is the following:
+C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...with the following declaration statement:
+C DIMENSION XPDFGM(-6:6)
+C...and, optionally, further information in:
+C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+C &XPDIR(-6:6)
+C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
+C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
+C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
+C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
+C X : x value.
+C Q2 : Q2 value.
+C P2 : P2 value; should be = 0. for an on-shell photon.
+C IP2 : scheme used to evaluate off-shell anomalous component.
+C = 0 : recommended default, see = 7.
+C = 1 : dipole dampening by integration; very time-consuming.
+C = 2 : P_0^2 = max( Q_0^2, P^2 )
+C = 3 : P_0^2 = Q_0^2 + P^2.
+C = 4 : P_{eff} that preserves momentum sum.
+C = 5 : P_{int} that preserves momentum and average
+C evolution range.
+C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
+C XPFDGM : x times parton distribution functions of the photon,
+C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
+C 6 = t (always empty!), - for antiquarks (result is same).
+C...The breakdown by component is stored in the commonblock SASCOM,
+C with elements as above.
+C XPVMD : rho, omega, phi VMD part only of output.
+C XPANL : d, u, s anomalous part only of output.
+C XPANH : c, b anomalous part only of output.
+C XPBEH : c, b Bethe-Heitler part only of output.
+C XPDIR : Cgamma (direct contribution) part only of output.
+C...The above arrays do not distinguish valence and sea contributions,
+C...although this information is available internally. The additional
+C...commonblock SASVAL provides the valence part only of the above
+C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
+C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
+C...and therefore not given doubly. VXPDGM gives the sum of valence
+C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
+C...and so on, gives the sea part only.
+C***********************************************************************
+
+ SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...Purpose: to construct the F2 and parton distributions of the photon
+C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
+C...For F2, c and b are included by the Bethe-Heitler formula;
+C...in the 'MSbar' scheme additionally a Cgamma term is added.
+ SAVE
+ DIMENSION XPDFGM(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+ SAVE /SASCOM/,/SASVAL/
+
+C...Temporary array.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+C...Charm and bottom masses (low to compensate for J/psi etc.).
+ DATA PMC/1.3/, PMB/4.6/
+C...alpha_em and alpha_em/(2*pi).
+ DATA AEM/0.007297/, AEM2PI/0.0011614/
+C...Lambda value for 4 flavours.
+ DATA ALAM/0.20/
+C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
+ DATA FRACU/0.8/
+C...VMD couplings f_V**2/(4*pi).
+ DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
+C...Masses for rho (=omega) and phi.
+ DATA PMRHO/0.770/, PMPHI/1.020/
+C...Number of points in integration for IP2=1.
+ DATA NSTEP/100/
+
+C...Reset output.
+ F2GM=0.
+ DO 100 KFL=-6,6
+ XPDFGM(KFL)=0.
+ XPVMD(KFL)=0.
+ XPANL(KFL)=0.
+ XPANH(KFL)=0.
+ XPBEH(KFL)=0.
+ XPDIR(KFL)=0.
+ VXPVMD(KFL)=0.
+ VXPANL(KFL)=0.
+ VXPANH(KFL)=0.
+ VXPDGM(KFL)=0.
+ 100 CONTINUE
+
+C...Check that input sensible.
+ IF(ISET.LE.0.OR.ISET.GE.5) THEN
+ WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
+ WRITE(LO,*) ' ISET = ',ISET
+ STOP
+ ENDIF
+ IF(X.LE.0..OR.X.GT.1.) THEN
+ WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
+ WRITE(LO,*) ' X = ',X
+ STOP
+ ENDIF
+
+C...Set Q0 cut-off parameter as function of set used.
+ IF(ISET.LE.2) THEN
+ Q0=0.6
+ ELSE
+ Q0=2.
+ ENDIF
+ Q02=Q0**2
+
+C...Scale choice for off-shell photon; common factors.
+ Q2A=Q2
+ FACNOR=1.
+ IF(IP2.EQ.1) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ FACNOR=LOG(Q2/Q02)/NSTEP
+ ELSEIF(IP2.EQ.2) THEN
+ P2MX=MAX(P2,Q02)
+ ELSEIF(IP2.EQ.3) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ ELSEIF(IP2.EQ.4) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ ELSEIF(IP2.EQ.5) THEN
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
+ ELSEIF(IP2.EQ.6) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ ELSE
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ P2MXB=P2MX
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
+ ENDIF
+
+C...Call VMD parametrization for d quark and use to give rho, omega,
+C...phi. Note dipole dampening for off-shell photon.
+ CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ XFVAL=VXPGA(1)
+ XPGA(1)=XPGA(2)
+ XPGA(-1)=XPGA(-2)
+ FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
+ FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
+ DO 110 KFL=-5,5
+ XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
+ 110 CONTINUE
+ XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
+ XPVMD(3)=XPVMD(3)+FACS*XFVAL
+ XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
+ XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
+ VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(2)=FRACU*FACUD*XFVAL
+ VXPVMD(3)=FACS*XFVAL
+ VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(-2)=FRACU*FACUD*XFVAL
+ VXPVMD(-3)=FACS*XFVAL
+
+ IF(IP2.NE.1) THEN
+C...Anomalous parametrizations for different strategies
+C...for off-shell photons; except full integration.
+
+C...Call anomalous parametrization for d + u + s.
+ CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 120 KFL=-5,5
+ XPANL(KFL)=FACNOR*XPGA(KFL)
+ VXPANL(KFL)=FACNOR*VXPGA(KFL)
+ 120 CONTINUE
+
+C...Call anomalous parametrization for c and b.
+ CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 130 KFL=-5,5
+ XPANH(KFL)=FACNOR*XPGA(KFL)
+ VXPANH(KFL)=FACNOR*VXPGA(KFL)
+ 130 CONTINUE
+ CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 140 KFL=-5,5
+ XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
+ VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
+ 140 CONTINUE
+
+ ELSE
+C...Special option: loop over flavours and integrate over k2.
+ DO 170 KF=1,5
+ DO 160 ISTEP=1,NSTEP
+ Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
+ IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
+ & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
+ CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
+ FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
+ IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
+ IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
+ DO 150 KFL=-5,5
+ IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
+ IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
+ IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
+ IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ ENDIF
+
+C...Call Bethe-Heitler term expression for charm and bottom.
+ CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
+ XPBEH(4)=XPBH
+ XPBEH(-4)=XPBH
+ CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
+ XPBEH(5)=XPBH
+ XPBEH(-5)=XPBH
+
+C...For MSbar subtraction call C^gamma term expression for d, u, s.
+ IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
+ CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
+ DO 180 KFL=-5,5
+ XPDIR(KFL)=XPGA(KFL)
+ 180 CONTINUE
+ ENDIF
+
+C...Store result in output array.
+ DO 190 KFL=-5,5
+ CHSQ=1./9.
+ IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
+ XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
+ IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
+ XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
+ VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
+ 190 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+CDECK ID>, PHO_SASVMD
+ SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the VMD parton distributions of a photon,
+C...evolved homogeneously from an initial scale P2 to Q2.
+C...Does not include dipole suppression factor.
+C...ISET is parton distribution set, see above;
+C...additionally ISET=0 is used for the evolution of an anomalous photon
+C...which branched at a scale P2 and then evolved homogeneously to Q2.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ SAVE
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAM3=ALAM*(PMC/ALAM)**(2./27.)
+ ALAM5=ALAM*(ALAM/PMB)**(2./23.)
+ P2EFF=MAX(P2,1.2*ALAM3**2)
+ IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Find s as sum of 3-, 4- and 5-flavour parts.
+ S=0.
+ IF(NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ IF(NFQ.EQ.3) Q2DIV=Q2EFF
+ S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
+ ENDIF
+ IF(NFP.LE.4.AND.NFQ.GE.4) THEN
+ P2DIV=P2EFF
+ IF(NFP.EQ.3) P2DIV=PMC**2
+ Q2DIV=Q2EFF
+ IF(NFQ.EQ.5) Q2DIV=PMB**2
+ S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
+ ENDIF
+ IF(NFQ.EQ.5) THEN
+ P2DIV=PMB**2
+ IF(NFP.EQ.5) P2DIV=P2EFF
+ S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
+ ENDIF
+
+C...Calculate frequent combinations of x and s.
+ X1=1.-X
+ XL=-LOG(X)
+ S2=S**2
+ S3=S**3
+ S4=S**4
+
+C...Evaluate homogeneous anomalous parton distributions below or
+C...above threshold.
+ IF(ISET.EQ.0) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X * 1.5 * (X**2+X1**2)
+ XGLU = 0.
+ XSEA = 0.
+ ELSE
+ XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
+ & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
+ & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
+ XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
+ & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
+ & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
+ XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
+ & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
+ & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+ ENDIF
+
+C...Evaluate set 1D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.1) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.294 * X**0.80 * X1**0.76
+ XGLU = 1.273 * X**0.40 * X1**1.76
+ XSEA = 0.100 * X1**3.76
+ ELSE
+ XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
+ & X1**(0.76+0.667*S) * XL**(2.*S)
+ XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
+ & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
+ & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
+ XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
+ & X**(-7.32*S2/(1.+10.3*S2)) *
+ & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
+ XSEA0 = 0.100 * X1**3.76
+ ENDIF
+
+C...Evaluate set 1M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.2) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 0.8477 * X**0.51 * X1**1.37
+ XGLU = 3.42 * X**0.255 * X1**2.37
+ XSEA = 0.
+ ELSE
+ XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
+ & * X1**1.37 * XL**(2.667*S)
+ XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
+ & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
+ & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
+ & X1**(2.37+3.*S)
+ XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
+ & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
+ & XL**(2.8*S)
+ XSEA0 = 0.
+ ENDIF
+
+C...Evaluate set 2D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.3) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X**0.46 * X1**0.64 + 0.76 * X
+ XGLU = 1.925 * X1**2
+ XSEA = 0.242 * X1**4
+ ELSE
+ XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
+ & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
+ & (0.76+0.4*S) * X * X1**(2.667*S)
+ XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
+ & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
+ & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
+ XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
+ & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
+ XSEA0 = 0.242 * X1**4
+ ENDIF
+
+C...Evaluate set 2M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.4) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
+ XGLU = 1.808 * X1**2
+ XSEA = 0.209 * X1**4
+ ELSE
+ XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
+ & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
+ & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
+ & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
+ XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
+ & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
+ & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
+ & XL**(10.9*S/(1.+2.5*S))
+ XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
+ & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
+ & X1**(4.+S) * XL**(0.45*S)
+ XSEA0 = 0.209 * X1**4
+ ENDIF
+ ENDIF
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XCHM=XSEA*(1.-(SCH/SLL)**2)
+ ELSE
+ XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
+ ENDIF
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XBOT=XSEA*(1.-(SBT/SLL)**2)
+ ELSE
+ XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
+ ENDIF
+ ENDIF
+
+C...Fill parton distributions.
+ XPGA(0)=XGLU
+ XPGA(1)=XSEA
+ XPGA(2)=XSEA
+ XPGA(3)=XSEA
+ XPGA(4)=XCHM
+ XPGA(5)=XBOT
+ XPGA(KFA)=XPGA(KFA)+XVAL
+ DO 110 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ 110 CONTINUE
+ VXPGA(KFA)=XVAL
+ VXPGA(-KFA)=XVAL
+
+ RETURN
+ END
+
+C*********************************************************************
+
+CDECK ID>, PHO_SASANO
+ SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the parton distributions of the anomalous
+C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
+C...to Q2.
+C...KF=0 gives the sum over (up to) 5 flavours,
+C...KF<0 limits to flavours up to abs(KF),
+C...KF>0 is for flavour KF only.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ SAVE
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
+ DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ IF(Q2.LE.P2) RETURN
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
+ ALAMSQ(4)=ALAM**2
+ ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
+ P2EFF=MAX(P2,1.2*ALAMSQ(3))
+ IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ XL=-LOG(X)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Define range of flavour loop.
+ IF(KF.EQ.0) THEN
+ KFLMN=1
+ KFLMX=5
+ ELSEIF(KF.LT.0) THEN
+ KFLMN=1
+ KFLMX=KFA
+ ELSE
+ KFLMN=KFA
+ KFLMX=KFA
+ ENDIF
+
+C...Loop over flavours the photon can branch into.
+ DO 110 KFL=KFLMN,KFLMX
+
+C...Light flavours: calculate t range and (approximate) s range.
+ IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.GT.NFP) THEN
+ Q2DIV=PMB**2
+ IF(NFQ.EQ.4) Q2DIV=PMC**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+ IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
+ & LOG(P2EFF/ALAMSQ(4)))
+ SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
+ & LOG(P2EFF/ALAMSQ(3)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
+ ENDIF
+
+C...u and s quark do not need a separate treatment when d has been done.
+ ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
+
+C...Charm: as above, but only include range above c threshold.
+ ELSEIF(KFL.EQ.4) THEN
+ IF(Q2.LE.PMC**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMC**2)
+ Q2EFF=MAX(Q2EFF,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
+ Q2DIV=PMB**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+
+C...Bottom: as above, but only include range above b threshold.
+ ELSEIF(KFL.EQ.5) THEN
+ IF(Q2.LE.PMB**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ ENDIF
+
+C...Evaluate flavour-dependent prefactor (charge^2 etc.).
+ CHSQ=1./9.
+ IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
+ FAC=AEM2PI*2.*CHSQ*TDIFF
+
+C...Evaluate parton distributions (normalized to unit momentum sum).
+ IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
+ XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
+ & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
+ & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
+ & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
+ XGLU= 2.*S/(1.+4.*S+7.*S**2) *
+ & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
+ & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
+ XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
+ & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
+ & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XCHM=XSEA*(1.-(SCH/SLL)**3)
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XBOT=XSEA*(1.-(SBT/SLL)**3)
+ ENDIF
+ ENDIF
+
+C...Add contribution of each valence flavour.
+ XPGA(0)=XPGA(0)+FAC*XGLU
+ XPGA(1)=XPGA(1)+FAC*XSEA
+ XPGA(2)=XPGA(2)+FAC*XSEA
+ XPGA(3)=XPGA(3)+FAC*XSEA
+ XPGA(4)=XPGA(4)+FAC*XCHM
+ XPGA(5)=XPGA(5)+FAC*XBOT
+ XPGA(KFL)=XPGA(KFL)+FAC*XVAL
+ VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
+ 110 CONTINUE
+ DO 120 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ VXPGA(-KFL)=VXPGA(KFL)
+ 120 CONTINUE
+
+ END
+
+C*********************************************************************
+
+CDECK ID>, PHO_SASBEH
+ SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
+C...Purpose: to evaluate the Bethe-Heitler cross section for
+C...heavy flavour production.
+ SAVE
+ DATA AEM2PI/0.0011614/
+
+C...Reset output.
+ XPBH=0.
+ SIGBH=0.
+
+C...Check kinematics limits.
+ IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
+ W2=Q2*(1.-X)/X-P2
+ BETA2=1.-4.*PM2/W2
+ IF(BETA2.LT.1E-10) RETURN
+ BETA=SQRT(BETA2)
+ RMQ=4.*PM2/Q2
+
+C...Simple case: P2 = 0.
+ IF(P2.LT.1E-4) THEN
+ IF(BETA.LT.0.99) THEN
+ XBL=LOG((1.+BETA)/(1.-BETA))
+ ELSE
+ XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
+ ENDIF
+ SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
+
+C...Complicated case: P2 > 0, based on approximation of
+C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
+ ELSE
+ RPQ=1.-4.*X**2*P2/Q2
+ IF(RPQ.GT.1E-10) THEN
+ RPBE=SQRT(RPQ*BETA2)
+ IF(RPBE.LT.0.99) THEN
+ XBL=LOG((1.+RPBE)/(1.-RPBE))
+ XBI=2.*RPBE/(1.-RPBE**2)
+ ELSE
+ RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
+ XBL=LOG((1.+RPBE)**2/RPBESN)
+ XBI=2.*RPBE/RPBESN
+ ENDIF
+ SIGBH=BETA*(6.*X*(1.-X)-1.)+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
+ & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
+ ENDIF
+ ENDIF
+
+C...Multiply by charge-squared etc. to get parton distribution.
+ CHSQ=1./9.
+ IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
+ XPBH=3.*CHSQ*AEM2PI*X*SIGBH
+
+ END
+
+C*********************************************************************
+
+CDECK ID>, PHO_SASDIR
+ SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
+C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
+C...as needed in MSbar parametrizations.
+ SAVE
+ DIMENSION XPGA(-6:6)
+ DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ 100 CONTINUE
+
+C...Evaluate common x-dependent expression.
+ XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
+ CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
+
+C...d, u, s part by simple charge factor.
+ XPGA(1)=(1./9.)*CGAM
+ XPGA(2)=(4./9.)*CGAM
+ XPGA(3)=(1./9.)*CGAM
+
+C...Also fill for antiquarks.
+ DO 110 KF=1,5
+ XPGA(-KF)=XPGA(KF)
+ 110 CONTINUE
+
+ END
+
+CDECK ID>, PHO_PHGAL
+ SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
+C***********************************************************************
+C
+C photon parton densities with built-in momentum sum rule and
+C Regge-based low-x behaviour
+C
+C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
+C e-Print Archive: hep-ph/9711355
+C
+C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ SAVE
+
+ PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
+ DOUBLE PRECISION
+ & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
+ & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
+
+ DIMENSION NA(NARG)
+
+ DATA ZEROD/0.D0/
+
+C...100 x values; in (D-4,.77) log spaced (78 points)
+C... in (.78,.995) lineary spaced (22 points)
+ DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
+ DATA XT/
+ &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
+ &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
+ &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
+ &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
+ &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
+ &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
+ &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
+ &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
+ &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
+ &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
+ &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
+ &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
+ &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
+ &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
+ &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
+ &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
+ &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
+
+C...place for DATA blocks
+ DATA (XPV(I,1,0),I=1,100)/
+ &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
+ &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
+ &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
+ &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
+ &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
+ &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
+ &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
+ &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
+ &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
+ &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
+ &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
+ &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
+ &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
+ &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
+ &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
+ &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
+ &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
+ DATA (XPV(I,1,1),I=1,100)/
+ &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
+ &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
+ &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
+ &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
+ &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
+ &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
+ &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
+ &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
+ &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
+ &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
+ &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
+ &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
+ &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
+ &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
+ &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
+ &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
+ &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
+ DATA (XPV(I,1,2),I=1,100)/
+ &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
+ &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
+ &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
+ &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
+ &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
+ &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
+ &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
+ &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
+ &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
+ &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
+ &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
+ &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
+ &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
+ &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
+ &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
+ &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
+ &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
+ DATA (XPV(I,1,3),I=1,100)/
+ &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
+ &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
+ &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
+ &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
+ &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
+ &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
+ &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
+ &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
+ &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
+ &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
+ &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
+ &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
+ &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
+ &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
+ &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
+ &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
+ &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
+ DATA (XPV(I,1,4),I=1,100)/
+ &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
+ &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
+ &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
+ &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
+ &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
+ &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
+ &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
+ &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
+ &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
+ &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
+ &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
+ &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
+ &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
+ &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
+ &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
+ &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
+ &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
+ DATA (XPV(I,2,0),I=1,100)/
+ &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
+ &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
+ &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
+ &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
+ &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
+ &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
+ &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
+ &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
+ &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
+ &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
+ &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
+ &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
+ &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
+ &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
+ &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
+ &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
+ &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
+ DATA (XPV(I,2,1),I=1,100)/
+ &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
+ &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
+ &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
+ &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
+ &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
+ &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
+ &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
+ &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
+ &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
+ &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
+ &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
+ &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
+ &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
+ &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
+ &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
+ &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
+ &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
+ DATA (XPV(I,2,2),I=1,100)/
+ &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
+ &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
+ &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
+ &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
+ &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
+ &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
+ &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
+ &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
+ &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
+ &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
+ &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
+ &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
+ &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
+ &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
+ &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
+ &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
+ &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
+ DATA (XPV(I,2,3),I=1,100)/
+ &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
+ &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
+ &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
+ &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
+ &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
+ &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
+ &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
+ &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
+ &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
+ &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
+ &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
+ &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
+ &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
+ &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
+ &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
+ &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
+ &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
+ DATA (XPV(I,2,4),I=1,100)/
+ &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
+ &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
+ &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
+ &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
+ &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
+ &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
+ &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
+ &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
+ &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
+ &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
+ &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
+ &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
+ &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
+ &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
+ &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
+ &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
+ &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
+ DATA (XPV(I,3,0),I=1,100)/
+ &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
+ &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
+ &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
+ &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
+ &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
+ &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
+ &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
+ &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
+ &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
+ &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
+ &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
+ &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
+ &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
+ &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
+ &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
+ &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
+ &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
+ DATA (XPV(I,3,1),I=1,100)/
+ &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
+ &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
+ &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
+ &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
+ &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
+ &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
+ &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
+ &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
+ &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
+ &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
+ &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
+ &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
+ &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
+ &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
+ &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
+ &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
+ &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
+ DATA (XPV(I,3,2),I=1,100)/
+ &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
+ &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
+ &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
+ &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
+ &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
+ &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
+ &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
+ &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
+ &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
+ &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
+ &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
+ &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
+ &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
+ &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
+ &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
+ &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
+ &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
+ DATA (XPV(I,3,3),I=1,100)/
+ &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
+ &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
+ &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
+ &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
+ &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
+ &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
+ &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
+ &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
+ &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
+ &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
+ &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
+ &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
+ &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
+ &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
+ &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
+ &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
+ &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
+ DATA (XPV(I,3,4),I=1,100)/
+ &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
+ &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
+ &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
+ &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
+ &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
+ &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
+ &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
+ &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
+ &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
+ &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
+ &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
+ &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
+ &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
+ &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
+ &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
+ &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
+ &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
+ DATA (XPV(I,4,0),I=1,100)/
+ &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
+ &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
+ &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
+ &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
+ &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
+ &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
+ &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
+ &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
+ &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
+ &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
+ &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
+ &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
+ &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
+ &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
+ &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
+ &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
+ &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
+ DATA (XPV(I,4,1),I=1,100)/
+ &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
+ &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
+ &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
+ &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
+ &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
+ &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
+ &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
+ &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
+ &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
+ &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
+ &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
+ &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
+ &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
+ &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
+ &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
+ &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
+ &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
+ DATA (XPV(I,4,2),I=1,100)/
+ &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
+ &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
+ &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
+ &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
+ &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
+ &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
+ &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
+ &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
+ &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
+ &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
+ &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
+ &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
+ &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
+ &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
+ &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
+ &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
+ &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
+ DATA (XPV(I,4,3),I=1,100)/
+ &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
+ &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
+ &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
+ &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
+ &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
+ &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
+ &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
+ &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
+ &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
+ &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
+ &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
+ &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
+ &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
+ &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
+ &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
+ &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
+ &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
+ DATA (XPV(I,4,4),I=1,100)/
+ &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
+ &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
+ &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
+ &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
+ &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
+ &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
+ &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
+ &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
+ &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
+ &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
+ &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
+ &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
+ &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
+ &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
+ &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
+ &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
+ &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
+ DATA (XPV(I,5,0),I=1,100)/
+ &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
+ &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
+ &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
+ &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
+ &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
+ &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
+ &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
+ &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
+ &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
+ &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
+ &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
+ &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
+ &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
+ &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
+ &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
+ &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
+ &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
+ DATA (XPV(I,5,1),I=1,100)/
+ &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
+ &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
+ &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
+ &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
+ &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
+ &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
+ &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
+ &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
+ &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
+ &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
+ &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
+ &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
+ &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
+ &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
+ &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
+ &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
+ &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
+ DATA (XPV(I,5,2),I=1,100)/
+ &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
+ &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
+ &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
+ &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
+ &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
+ &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
+ &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
+ &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
+ &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
+ &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
+ &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
+ &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
+ &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
+ &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
+ &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
+ &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
+ &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
+ DATA (XPV(I,5,3),I=1,100)/
+ &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
+ &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
+ &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
+ &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
+ &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
+ &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
+ &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
+ &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
+ &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
+ &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
+ &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
+ &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
+ &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
+ &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
+ &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
+ &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
+ &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
+ DATA (XPV(I,5,4),I=1,100)/
+ &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
+ &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
+ &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
+ &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
+ &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
+ &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
+ &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
+ &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
+ &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
+ &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
+ &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
+ &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
+ &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
+ &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
+ &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
+ &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
+ &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
+ DATA (XPV(I,6,0),I=1,100)/
+ &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
+ &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
+ &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
+ &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
+ &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
+ &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
+ &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
+ &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
+ &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
+ &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
+ &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
+ &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
+ &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
+ &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
+ &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
+ &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
+ &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
+ DATA (XPV(I,6,1),I=1,100)/
+ &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
+ &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
+ &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
+ &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
+ &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
+ &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
+ &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
+ &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
+ &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
+ &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
+ &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
+ &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
+ &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
+ &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
+ &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
+ &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
+ &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
+ DATA (XPV(I,6,2),I=1,100)/
+ &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
+ &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
+ &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
+ &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
+ &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
+ &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
+ &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
+ &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
+ &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
+ &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
+ &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
+ &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
+ &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
+ &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
+ &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
+ &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
+ &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
+ DATA (XPV(I,6,3),I=1,100)/
+ &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
+ &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
+ &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
+ &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
+ &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
+ &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
+ &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
+ &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
+ &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
+ &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
+ &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
+ &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
+ &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
+ &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
+ &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
+ &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
+ &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
+ DATA (XPV(I,6,4),I=1,100)/
+ &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
+ &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
+ &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
+ &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
+ &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
+ &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
+ &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
+ &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
+ &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
+ &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
+ &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
+ &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
+ &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
+ &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
+ &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
+ &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
+ &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
+ DATA (XPV(I,7,0),I=1,100)/
+ &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
+ &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
+ &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
+ &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
+ &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
+ &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
+ &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
+ &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
+ &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
+ &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
+ &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
+ &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
+ &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
+ &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
+ &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
+ &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
+ &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
+ DATA (XPV(I,7,1),I=1,100)/
+ &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
+ &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
+ &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
+ &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
+ &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
+ &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
+ &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
+ &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
+ &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
+ &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
+ &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
+ &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
+ &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
+ &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
+ &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
+ &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
+ &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
+ DATA (XPV(I,7,2),I=1,100)/
+ &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
+ &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
+ &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
+ &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
+ &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
+ &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
+ &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
+ &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
+ &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
+ &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
+ &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
+ &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
+ &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
+ &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
+ &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
+ &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
+ &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
+ DATA (XPV(I,7,3),I=1,100)/
+ &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
+ &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
+ &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
+ &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
+ &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
+ &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
+ &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
+ &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
+ &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
+ &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
+ &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
+ &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
+ &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
+ &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
+ &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
+ &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
+ &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
+ DATA (XPV(I,7,4),I=1,100)/
+ &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
+ &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
+ &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
+ &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
+ &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
+ &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
+ &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
+ &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
+ &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
+ &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
+ &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
+ &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
+ &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
+ &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
+ &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
+ &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
+ &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
+
+C..fetching pdfs
+ DO 5 IP=-6,6
+ XPDF(IP)=ZEROD
+ 5 CONTINUE
+ DO 2 I=1,IX
+ ENT(I)=LOG10(XT(I))
+ 2 CONTINUE
+ NA(1)=IX
+ NA(2)=IQ
+ DO 3 I=1,IQ
+ ENT(IX+I)=LOG10(Q2T(I))
+ 3 CONTINUE
+ ARG(1)=LOG10(X)
+ ARG(2)=LOG10(Q2)
+C..various flavours (u-->2,d-->1)
+ XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
+ XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
+ XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
+ XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
+ XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
+ DO 21 JF=1,4
+ XPDF(-JF)=XPDF(JF)
+ 21 CONTINUE
+
+ END
+
+CDECK ID>, PHO_DBFINT
+ DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
+C***********************************************************************
+C
+C routine based on CERN library E104
+C
+C multi-dimensional interpolation routine, needed for PHOJET
+C internal cross section tables and several PDF sets (GRV98 and AGL)
+C
+C changed to avoid recursive function calls (R.Engel, 09/98)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ INTEGER NA(NARG), INDEX(32)
+ DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
+
+ DATA ZEROD/0.D0/
+ DATA ONED/1.D0/
+
+ DBFINT = ZEROD
+ PHO_DBFINT = ZEROD
+ IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
+
+ LMAX = 0
+ ISTEP = 1
+ KNOTS = 1
+ INDEX(1) = 1
+ WEIGHT(1) = ONED
+ DO 100 N = 1, NARG
+ X = ARG(N)
+ NDIM = NA(N)
+ LOCA = LMAX
+ LMIN = LMAX + 1
+ LMAX = LMAX + NDIM
+ IF(NDIM .GT. 2) GOTO 10
+ IF(NDIM .EQ. 1) GOTO 100
+ H = X - ENT(LMIN)
+ IF(H .EQ. ZEROD) GOTO 90
+ ISHIFT = ISTEP
+ IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
+ ISHIFT = 0
+ ETA = H / (ENT(LMIN+1) - ENT(LMIN))
+ GOTO 30
+ 10 LOCB = LMAX + 1
+ 11 LOCC = (LOCA+LOCB) / 2
+ IF(X-ENT(LOCC)) 12, 20, 13
+ 12 LOCB = LOCC
+ GOTO 14
+ 13 LOCA = LOCC
+ 14 IF(LOCB-LOCA .GT. 1) GOTO 11
+ LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
+ ISHIFT = (LOCA - LMIN) * ISTEP
+ ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
+ GOTO 30
+ 20 ISHIFT = (LOCC - LMIN) * ISTEP
+ 21 DO 22 K = 1, KNOTS
+ INDEX(K) = INDEX(K) + ISHIFT
+ 22 CONTINUE
+ GOTO 90
+ 30 DO 31 K = 1, KNOTS
+ INDEX(K) = INDEX(K) + ISHIFT
+ INDEX(K+KNOTS) = INDEX(K) + ISTEP
+ WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
+ WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
+ 31 CONTINUE
+ KNOTS = 2*KNOTS
+ 90 ISTEP = ISTEP * NDIM
+ 100 CONTINUE
+ DO 200 K = 1, KNOTS
+ I = INDEX(K)
+ DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
+ 200 CONTINUE
+
+ PHO_DBFINT = DBFINT
+
+ END
+
+CDECK ID>, PHVAL
+ SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
+C**********************************************************************
+C
+C dummy subroutine, remove to link PHOLIB
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DIMENSION PD(-6:6)
+ END
--- /dev/null
+C*********************************************************************
+C*********************************************************************
+C* **
+C* March 1997 **
+C* **
+C* The Lund Monte Carlo for Hadronic Processes **
+C* **
+C* PYTHIA version 6.1 **
+C* **
+C* Torbjorn Sjostrand **
+C* Department of Theoretical Physics 2 **
+C* Lund University **
+C* Solvegatan 14A, S-223 62 Lund, Sweden **
+C* phone +46 - 46 - 222 48 16 **
+C* E-mail torbjorn@thep.lu.se **
+C* **
+C* SUSY parts by **
+C* Stephen Mrenna **
+C* Argonne National Laboratory **
+C* 9700 South Cass Avenue, Argonne, IL 60439, USA **
+C* phone + 1 - 630 - 252 - 7615 **
+C* E-mail mrenna@hep.anl.gov **
+C* **
+C* Several parts are written by Hans-Uno Bengtsson **
+C* PYSHOW is written together with Mats Bengtsson **
+C* advanced popcorn baryon production written by Patrik Eden **
+C* CTEQ 3 parton distributions are by the CTEQ collaboration **
+C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
+C* SaS photon parton distributions together with Gerhard Schuler **
+C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
+C* MSSM Higgs mass calculation code by M. Carena, **
+C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
+C* PYGAUS adapted from CERN library (K.S. Kolbig) **
+C* **
+C* The latest program version and documentation is found on WWW **
+C* http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html **
+C* **
+C* Copyright Torbjorn Sjostrand, Lund 1997 **
+C* **
+C*********************************************************************
+C*********************************************************************
+C *
+C List of subprograms in order of appearance, with main purpose *
+C (S = subroutine, F = function, B = block data) *
+C *
+C B PYDATA to contain all default values *
+C S PYTEST to test the proper functioning of the package *
+C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
+C *
+C S PYINIT to administer the initialization procedure *
+C S PYEVNT to administer the generation of an event *
+C S PYSTAT to print cross-section and other information *
+C S PYINRE to initialize treatment of resonances *
+C S PYINBM to read in beam, target and frame choices *
+C S PYINKI to initialize kinematics of incoming particles *
+C S PYINPR to set up the selection of included processes *
+C S PYXTOT to give total, elastic and diffractive cross-sect. *
+C S PYMAXI to find differential cross-section maxima *
+C S PYPILE to select multiplicity of pileup events *
+C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
+C S PYRAND to select subprocess and kinematics for event *
+C S PYSCAT to set up kinematics and colour flow of event *
+C S PYSSPA to simulate initial state spacelike showers *
+C S PYRESD to perform resonance decays *
+C S PYMULT to generate multiple interactions *
+C S PYREMN to add on target remnants *
+C S PYDIFF to set up kinematics for diffractive events *
+C S PYDOCU to compute cross-sections and handle documentation *
+C S PYFRAM to perform boosts between different frames *
+C S PYWIDT to calculate full and partial widths of resonances *
+C S PYOFSH to calculate partial width into off-shell channels *
+C S PYRECO to handle colour reconnection in W+W- events *
+C S PYKLIM to calculate borders of allowed kinematical region *
+C S PYKMAP to construct value of kinematical variable *
+C S PYSIGH to calculate differential cross-sections *
+C S PYPDFU to evaluate parton distributions *
+C S PYPDFL to evaluate parton distributions at low x and Q^2 *
+C S PYPDEL to evaluate electron parton distributions *
+C S PYPDGA to evaluate photon parton distributions (generic) *
+C S PYGGAM to evaluate photon parton distributions (SaS sets) *
+C S PYGVMD to evaluate VMD part of photon parton distributions *
+C S PYGANO to evaluate anomalous part of photon pdf's *
+C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
+C S PYGDIR to evaluate direct contribution to photon pdf's *
+C S PYPDPI to evaluate pion parton distributions *
+C S PYPDPR to evaluate proton parton distributions *
+C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
+C S PYGRVL to evaluate the GRV 94L pronton parton distributions *
+C S PYGRVM to evaluate the GRV 94M pronton parton distributions *
+C S PYGRVD to evaluate the GRV 94D pronton parton distributions *
+C F PYGRVV auxiliary to the PYGRV* routines *
+C F PYGRVW auxiliary to the PYGRV* routines *
+C F PYGRVS auxiliary to the PYGRV* routines *
+C F PYHFTH to evaluate threshold factor for heavy flavour *
+C S PYSPLI to find flavours left in hadron when one removed *
+C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
+C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
+C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
+C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
+C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
+C *
+C S PYMSIN to initialize the supersymmetry simulation *
+C S PYAPPS to determine MSSM parameters from SUGRA input *
+C F PYRNMQ to determine running quark masses *
+C F PYRNMT to determine running top mass *
+C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
+C S PYINOM to calculate neutralino/chargino mass eigenstates *
+C F PYRNM3 to determine running M3, gluino mass *
+C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
+C S PYHGGM to determine Higgs mass spectrum *
+C S PYSUBH to determine Higgs masses in the MSSM *
+C S PYPOLE to determine Higgs masses in the MSSM *
+C S PYVACU to determine Higgs masses in the MSSM *
+C S PYRGHM auxiliary to PYVACU *
+C S PYGFXX auxiliary to PYRGHM *
+C F PYFINT auxiliary to PYVACU *
+C F PYFISB auxiliary to PYFINT *
+C S PYSFDC to calculate sfermion decay partial widths *
+C S PYGLUI to calculate gluino decay partial widths *
+C S PYTBBN to calculate 3-body decay of gluino to neutralino *
+C S PYTBBC to calculate 3-body decay of gluino to chargino *
+C S PYNJDC to calculate neutralino decay partial widths *
+C S PYCJDC to calculate chargino decay partial widths *
+C F PYXXZ5 auxiliary for neutralino 3-body decay *
+C F PYXXW5 auxiliary for ino charge change 3-body decay *
+C F PYXXGA auxiliary for ino -> ino + gamma decay *
+C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
+C F PYX2XH auxiliary for ino -> ino + Higgs decay *
+C F PYXXZ2 auxiliary for chargino 3-body decay *
+C S PYHEXT to calculate non-SM Higgs decay partial widths *
+C F PYH2XX auxiliary for H -> ino + ino decay *
+C F PYGAUS to perform Gaussian integration *
+C F PYSIMP to perform Simpson integration *
+C F PYLAMF to evaluate the lambda kinematics function *
+C S PYTBDY to perform 3-body decay of gauginos *
+C *
+C S PY1ENT to fill one entry (= parton or particle) *
+C S PY2ENT to fill two entries *
+C S PY3ENT to fill three entries *
+C S PY4ENT to fill four entries *
+C S PYJOIN to connect entries with colour flow information *
+C S PYGIVE to fill (or query) commonblock variables *
+C S PYEXEC to administrate fragmentation and decay chain *
+C S PYPREP to rearrange showered partons along strings *
+C S PYSTRF to do string fragmentation of jet system *
+C S PYINDF to do independent fragmentation of one or many jets *
+C S PYDECY to do the decay of a particle *
+C S PYDCYK to select parton and hadron flavours in decays *
+C S PYKFDI to select parton and hadron flavours in fragm *
+C S PYNMES to select number of popcorn mesons *
+C S PYKFIN to calculate falvour prod. ratios from input params. *
+C S PYPTDI to select transverse momenta in fragm *
+C S PYZDIS to select longitudinal scaling variable in fragm *
+C S PYSHOW to do timelike parton shower evolution *
+C S PYBOEI to include Bose-Einstein effects (crudely) *
+C F PYMASS to give the mass of a particle or parton *
+C S PYNAME to give the name of a particle or parton *
+C F PYCHGE to give three times the electric charge *
+C F PYCOMP to compress standard KF flavour code to internal KC *
+C S PYERRM to write error messages and abort faulty run *
+C F PYALEM to give the alpha_electromagnetic value *
+C F PYALPS to give the alpha_strong value *
+C F PYANGL to give the angle from known x and y components *
+C F PYR to provide a random number generator *
+C S PYRGET to save the state of the random number generator *
+C S PYRSET to set the state of the random number generator *
+C S PYROBO to rotate and/or boost an event *
+C S PYEDIT to remove unwanted entries from record *
+C S PYLIST to list event record or particle data *
+C S PYLOGO to write a logo *
+C S PYUPDA to update particle data *
+C F PYK to provide integer-valued event information *
+C F PYP to provide real-valued event information *
+C S PYSPHE to perform sphericity analysis *
+C S PYTHRU to perform thrust analysis *
+C S PYCLUS to perform three-dimensional cluster analysis *
+C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
+C S PYJMAS to give high and low jet mass of event *
+C S PYFOWO to give Fox-Wolfram moments *
+C S PYTABU to analyze events, with tabular output *
+C *
+C S PYEEVT to administrate the generation of an e+e- event *
+C S PYXTEE to give the total cross-section at given CM energy *
+C S PYRADK to generate initial state photon radiation *
+C S PYXKFL to select flavour of primary qqbar pair *
+C S PYXJET to select (matrix element) jet multiplicity *
+C S PYX3JT to select kinematics of three-jet event *
+C S PYX4JT to select kinematics of four-jet event *
+C S PYXDIF to select angular orientation of event *
+C S PYONIA to perform generation of onium decay to gluons *
+C *
+C S PYBOOK to book a histogram *
+C S PYFILL to fill an entry in a histogram *
+C S PYFACT to multiply histogram contents by a factor *
+C S PYOPER to perform operations between histograms *
+C S PYHIST to print and reset all histograms *
+C S PYPLOT to print a single histogram *
+C S PYNULL to reset contents of a single histogram *
+C S PYDUMP to dump histogram contents onto a file *
+C *
+C S PYKCUT dummy routine for user kinematical cuts *
+C S PYEVWT dummy routine for weighting events *
+C S PYUPIN dummy routine to initialize a user process *
+C S PYUPEV dummy routine to generate a user process event *
+C S PDFSET dummy routine to be removed when using PDFLIB *
+C S STRUCTM dummy routine to be removed when using PDFLIB *
+C S PYTAUD dummy routine for interface to tau decay libraries *
+C S PYTIME dummy routine for giving date and time *
+C *
+C*********************************************************************
+
+C...PYDATA
+C...Default values for switches and parameters,
+C...and particle, decay and process data.
+
+ BLOCK DATA PYDATA
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
+ &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
+ &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
+
+C...PYDAT1, containing status codes and most parameters.
+ DATA MSTU/
+ & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
+ 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
+ 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
+ 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
+ 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
+ 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 7 30*0,
+ 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
+ & 80*0/
+ DATA PARU/
+ & 3.141592653589793D0, 6.283185307179586D0,
+ & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
+ 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
+ 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
+ 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
+ 6 40*0D0,
+ & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
+ & 0D0, 0D0, 0D0, 0D0, 0D0,
+ 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
+ 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
+ 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
+ 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
+ 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
+ 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
+ 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
+ DATA MSTJ/
+ & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
+ 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
+ 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
+ 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
+ 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
+ 6 40*0,
+ & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
+ 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
+ 2 80*0/
+ DATA PARJ/
+ & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
+ & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
+ 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
+ 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
+ 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
+ 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
+ 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
+ 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
+ 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
+ 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
+ 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
+ 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
+ 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
+ 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
+ 4 60*0D0/
+
+C...PYDAT2, with particle data and flavour treatment parameters.
+ DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
+ &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
+ &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*3,
+ &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
+ &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
+ &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
+ &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,
+ &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
+ &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
+ DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
+ &3*0,-1,4*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
+ &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
+ &6*1,6*0,2*1,165*0/
+ DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
+ &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
+ &102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,
+ &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
+ DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
+ &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
+ &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
+ &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
+ &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
+ &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
+ &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
+ &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
+ &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
+ &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
+ &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
+ &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
+ &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
+ &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
+ &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
+ &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
+ &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
+ &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
+ &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
+ &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
+ DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
+ &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
+ &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
+ &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
+ &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
+ &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
+ DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
+ &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
+ &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
+ &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
+ &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
+ &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
+ &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
+ &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
+ &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
+ &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
+ &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
+ &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
+ &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
+ &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
+ &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
+ &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
+ &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
+ &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
+ &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
+ &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
+ DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
+ &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
+ &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
+ &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
+ &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
+ &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
+ &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
+ &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
+ &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
+ &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
+ &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
+ &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
+ &4*400D0,163*0D0/
+ DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
+ &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
+ &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
+ &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
+ &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
+ &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
+ &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
+ &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
+ &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
+ &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
+ &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
+ &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
+ &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
+ &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
+ DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
+ &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
+ &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
+ &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
+ &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
+ &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
+ &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
+ &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
+ &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
+ &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
+ &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
+ &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
+ &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
+ &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
+ DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
+ &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
+ &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
+ &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
+ &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
+ &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
+ &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
+ &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
+ DATA PARF/
+ & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
+ 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
+ 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
+ 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
+ 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
+ 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
+ 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
+ 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
+ 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 9 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
+ 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
+ 3 60*0D0,
+ 4 0.2D0, 0.5D0, 8*0D0,
+ 5 1800*0D0/
+ DATA ((VCKM(I,J),J=1,4),I=1,4)/
+ & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
+ & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
+ & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
+ & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
+
+C...PYDAT3, with particle decay parameters and data.
+ DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
+ &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
+ &0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,
+ &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,
+ &1,0,4*1,163*0/
+ DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
+ &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
+ &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
+ &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
+ &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
+ &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
+ &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
+ &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
+ &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
+ &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
+ &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
+ &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
+ &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
+ &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
+ &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
+ &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
+ &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
+ &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
+ &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
+ &2493,2496,163*0/
+ DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
+ &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
+ &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
+ &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
+ &1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,
+ &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,
+ &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,
+ &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
+ &15,0,2*4,3,2,163*0/
+ DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
+ &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
+ &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
+ &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
+ &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
+ &2*-1,1892*1,1503*0/
+ DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
+ &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
+ &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
+ &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
+ &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
+ &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,
+ &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
+ &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
+ &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
+ &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
+ &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
+ &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
+ &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
+ &4*32,2*4,5*0,828*53,1515*0/
+ DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
+ &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
+ &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
+ &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
+ &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
+ &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
+ &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
+ &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
+ &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
+ &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
+ &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
+ &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
+ &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
+ &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
+ &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
+ &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
+ &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
+ &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
+ &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
+ &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
+ DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
+ &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
+ &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
+ &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
+ &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
+ &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
+ &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
+ &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
+ &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
+ &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
+ &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
+ &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
+ &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
+ &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
+ &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
+ &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
+ &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
+ &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
+ &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
+ &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
+ DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
+ &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
+ &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
+ &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
+ &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
+ &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
+ &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
+ &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
+ &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
+ &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
+ &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
+ &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
+ &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
+ &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
+ &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
+ &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
+ &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
+ &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
+ &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
+ &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
+ DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
+ &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
+ &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
+ &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
+ &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
+ &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
+ &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
+ &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
+ &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
+ &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
+ &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
+ &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
+ &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
+ &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
+ &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
+ &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
+ &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
+ &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
+ &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
+ &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
+ DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
+ &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
+ &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
+ &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
+ &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
+ &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
+ &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
+ &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
+ &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
+ &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
+ &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
+ &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
+ &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
+ &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
+ &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
+ &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
+ &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
+ &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
+ &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
+ &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
+ DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
+ &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
+ &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
+ &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
+ &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
+ &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
+ &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
+ &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
+ &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
+ &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
+ DATA (BRAT(I) ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
+ &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
+ &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
+ &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
+ &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
+ &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
+ &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
+ &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
+ &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
+ &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
+ &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
+ &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
+ &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
+ DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
+ &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
+ &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
+ &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
+ &1503*0D0/
+ DATA (KFDP(I,1),I= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
+ &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
+ &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
+ &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
+ &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
+ &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
+ &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
+ &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
+ &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
+ &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
+ &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
+ &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
+ &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
+ &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
+ &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
+ &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
+ &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
+ &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
+ &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
+ &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
+ DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
+ &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
+ &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
+ &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
+ &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
+ &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
+ &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
+ &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
+ &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
+ &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
+ &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
+ &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
+ &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
+ &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
+ &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
+ &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
+ &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
+ &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
+ &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
+ &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
+ DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
+ &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
+ &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
+ &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
+ &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
+ &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
+ &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
+ &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
+ &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
+ &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
+ &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
+ &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
+ &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
+ &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
+ &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
+ &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
+ &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
+ &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
+ &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
+ &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
+ DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
+ &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
+ &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
+ &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
+ &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
+ &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
+ &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
+ &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
+ &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
+ &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
+ &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
+ &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
+ &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
+ &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
+ &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
+ &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
+ &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
+ &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
+ &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
+ &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
+ DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
+ &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
+ &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
+ &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
+ &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
+ &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
+ &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
+ &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
+ &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
+ &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
+ &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
+ &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
+ &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
+ &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
+ &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
+ &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
+ &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
+ &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
+ &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
+ &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
+ DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
+ &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
+ &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
+ &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
+ &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
+ &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
+ &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
+ &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
+ &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
+ &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
+ &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
+ &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
+ &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
+ &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
+ &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
+ &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
+ &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
+ &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
+ &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
+ &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
+ DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
+ &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
+ &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
+ &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
+ &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
+ &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
+ &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
+ &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
+ &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
+ &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
+ &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
+ &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
+ &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
+ &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
+ &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
+ &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
+ &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
+ &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
+ &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
+ &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
+ DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
+ &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
+ &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
+ &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
+ &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
+ &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
+ &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
+ &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
+ &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
+ &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
+ &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
+ &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
+ &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
+ &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
+ &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
+ &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
+ &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
+ &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
+ &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
+ &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
+ DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
+ &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
+ &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
+ &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
+ &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
+ &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
+ &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
+ &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
+ &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
+ &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
+ &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
+ &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
+ &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
+ &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
+ &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
+ &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
+ &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
+ &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
+ &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
+ &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
+ DATA (KFDP(I,2),I= 1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
+ &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,4*1000006,3*7,
+ &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
+ &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
+ &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
+ &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
+ &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
+ &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
+ &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
+ &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
+ &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
+ &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
+ &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
+ &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
+ &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
+ &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
+ &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
+ &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
+ &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
+ &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
+ DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
+ &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
+ &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
+ &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
+ &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
+ &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
+ &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
+ &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
+ &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
+ &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
+ &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
+ &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
+ &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
+ &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
+ &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
+ &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
+ &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
+ &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
+ &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
+ &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
+ DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
+ &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
+ &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
+ &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
+ &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
+ &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
+ &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
+ &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
+ &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
+ &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
+ &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
+ &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
+ &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
+ &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
+ &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
+ &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
+ &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
+ &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
+ &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
+ &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
+ DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
+ &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
+ &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
+ &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
+ &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
+ &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
+ &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
+ &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
+ &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
+ &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
+ &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
+ &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
+ &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
+ &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
+ &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
+ &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
+ &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
+ &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
+ &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
+ &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
+ DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
+ &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
+ &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
+ &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
+ &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
+ &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
+ &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
+ &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
+ &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
+ &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
+ &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
+ &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
+ &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
+ &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
+ &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
+ &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
+ &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
+ &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
+ &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
+ &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
+ DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
+ &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
+ &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
+ &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
+ &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
+ &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
+ &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
+ &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
+ &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
+ &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
+ &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
+ &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
+ &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
+ &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
+ &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
+ &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
+ &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
+ &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
+ &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
+ &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
+ DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
+ &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
+ &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
+ &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
+ &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
+ &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
+ &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
+ &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
+ &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
+ &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
+ &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
+ &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
+ DATA (KFDP(I,3),I= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
+ &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
+ &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
+ &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
+ &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
+ &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
+ &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
+ &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
+ &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
+ &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
+ &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
+ &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
+ &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
+ &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
+ &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
+ &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
+ &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
+ &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
+ &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
+ &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
+ DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
+ &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
+ &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
+ &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
+ &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
+ &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
+ &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
+ &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
+ &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
+ &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
+ &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
+ &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
+ &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
+ &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
+ &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
+ &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
+ &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
+ &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
+ &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
+ &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
+ DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
+ &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
+ &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
+ &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
+ DATA (KFDP(I,4),I= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
+ &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
+ &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
+ &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
+ &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
+ &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
+ &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
+ &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
+ &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
+ &162*81,31*0,-211,111,2450*0/
+ DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
+ &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
+ &3*111,-211,111,3127*0/
+
+C...PYDAT4, with particle names (character strings).
+ DATA (CHAF(I,1),I= 1, 190)/'d','u','s','c','b','t','b''','t''',
+ &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
+ &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
+ &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
+ &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
+ &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
+ &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
+ &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
+ &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
+ &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
+ &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
+ &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
+ &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
+ &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
+ &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
+ &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
+ &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
+ &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
+ &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
+ &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
+ DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
+ &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
+ &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
+ &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
+ &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
+ &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
+ &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
+ &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
+ &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
+ &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
+ &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
+ &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
+ &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
+ &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
+ &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
+ &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
+ &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
+ &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
+ &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
+ &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
+ DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
+ &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
+ &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
+ &'nu*_e0',163*' '/
+ DATA (CHAF(I,2),I= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
+ &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
+ &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
+ &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
+ &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
+ &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
+ &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
+ &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
+ &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
+ &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
+ &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
+ &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
+ &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
+ &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
+ &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
+ &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
+ &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
+ &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
+ &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
+ &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
+ DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
+ &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
+ &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
+ &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
+ &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
+ &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
+ &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
+ &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
+ &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
+ &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
+ &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
+ &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
+ &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
+ &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
+ &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
+ &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
+ &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
+ &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
+ &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
+ &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
+ DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
+ &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
+ &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
+
+C...PYDATR, with initial values for the random number generator.
+ DATA MRPY/19780503,0,0,97,33,0/
+
+C...Default values for allowed processes and kinematics constraints.
+ DATA MSEL/1/
+ DATA MSUB/500*0/
+ DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
+ &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
+ &6*1,4*0,4*1,16*0/
+ DATA CKIN/
+ & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
+ & 1.0D0, -10D0, 10D0, -10D0, 10D0,
+ 1 -10D0, 10D0, -10D0, 10D0, -10D0,
+ 1 10D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
+ 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
+ 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
+ 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
+ 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
+ 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
+ 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
+ 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
+ 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
+ 6 140*0D0/
+
+C...Default values for main switches and parameters. Reset information.
+ DATA (MSTP(I),I=1,100)/
+ & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
+ 1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
+ 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
+ 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
+ 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
+ 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
+ 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
+ 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
+ 9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
+ DATA (MSTP(I),I=101,200)/
+ & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
+ 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
+ 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
+ 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
+ 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
+ 8 6, 115, 1998, 01, 27, 0, 0, 0, 0, 0,
+ 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA (PARP(I),I=1,100)/
+ & 0.25D0, 10D0, 8*0D0,
+ 1 0D0, 0D0, 1.0D0, 0.01D0, 0.6D0, 1.0D0, 1.0D0, 3*0D0,
+ 2 10*0D0,
+ 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
+ 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
+ 5 1.0D0, 9*0D0,
+ 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
+ 7 4.0D0, 0.25D0, 8*0D0,
+ 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
+ 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
+ DATA (PARP(I),I=101,200)/
+ & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
+ 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
+ 2 1.0D0, 0.4D0, 8*0D0,
+ 3 0.01D0, 9*0D0,
+ 4 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
+ 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
+ 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
+ 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
+ 8 20*0D0/
+ DATA MSTI/200*0/
+ DATA PARI/200*0D0/
+ DATA MINT/400*0/
+ DATA VINT/400*0D0/
+
+C...Constants for the generation of the various processes.
+ DATA (ISET(I),I=1,100)/
+ & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
+ 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
+ 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
+ 3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
+ 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
+ 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
+ 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
+ 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
+ 9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
+ DATA (ISET(I),I=101,200)/
+ & -1, 1, 1, -2, -2, 2, 2, 2, -2, 2,
+ 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
+ 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
+ 3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
+ 4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
+ 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
+ 6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
+ 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
+ 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
+ 9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
+ DATA (ISET(I),I=201,300)/
+ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
+ 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
+ 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
+ 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
+ 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
+ 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
+ DATA (ISET(I),I=301,500)/200*-2/
+ DATA ((KFPR(I,J),J=1,2),I=1,50)/
+ & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
+ & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
+ 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
+ 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
+ 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
+ 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
+ 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
+ 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
+ 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
+ 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
+ DATA ((KFPR(I,J),J=1,2),I=51,100)/
+ 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
+ 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
+ 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
+ 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
+ 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
+ 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA ((KFPR(I,J),J=1,2),I=101,150)/
+ & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
+ & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
+ 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
+ 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
+ 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
+ 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
+ 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
+ 4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
+ DATA ((KFPR(I,J),J=1,2),I=151,200)/
+ 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
+ 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
+ 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
+ 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
+ 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
+ 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
+ 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
+ 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
+ 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
+ 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
+ DATA ((KFPR(I,J),J=1,2),I=201,240)/
+ & 1000011, 1000011, 2000011, 2000011, 1000011,
+ & 2000011, 1000013, 1000013, 2000013, 2000013,
+ & 1000013, 2000013, 1000015, 1000015, 2000015,
+ & 2000015, 1000015, 2000015, 1000011, 1000012,
+ 1 1000015, 1000016, 2000015, 1000016, 1000012,
+ 1 1000012, 1000016, 1000016, 0, 0,
+ 1 1000022, 1000022, 1000023, 1000023, 1000025,
+ 1 1000025, 1000035, 1000035, 1000022, 1000023,
+ 2 1000022, 1000025, 1000022, 1000035, 1000023,
+ 2 1000025, 1000023, 1000035, 1000025, 1000035,
+ 2 1000024, 1000024, 1000037, 1000037, 1000024,
+ 2 1000037, 1000022, 1000024, 1000023, 1000024,
+ 3 1000025, 1000024, 1000035, 1000024, 1000022,
+ 3 1000037, 1000023, 1000037, 1000025, 1000037,
+ 3 1000035, 1000037, 1000021, 1000022, 1000021,
+ 3 1000023, 1000021, 1000025, 1000021, 1000035/
+ DATA ((KFPR(I,J),J=1,2),I=241,280)/
+ 4 1000021, 1000024, 1000021, 1000037, 1000021,
+ 4 1000021, 1000021, 1000021, 0, 0,
+ 4 1000002, 1000022, 2000002, 1000022, 1000002,
+ 4 1000023, 2000002, 1000023, 1000002, 1000025,
+ 5 2000002, 1000025, 1000002, 1000035, 2000002,
+ 5 1000035, 1000001, 1000024, 2000005, 1000024,
+ 5 1000001, 1000037, 2000005, 1000037, 1000002,
+ 5 1000021, 2000002, 1000021, 0, 0,
+ 6 1000006, 1000006, 2000006, 2000006, 1000006,
+ 6 2000006, 1000006, 1000006, 2000006, 2000006,
+ 6 0, 0, 0, 0, 0,
+ 6 0, 0, 0, 0, 0,
+ 7 1000002, 1000002, 2000002, 2000002, 1000002,
+ 7 2000002, 1000002, 1000002, 2000002, 2000002,
+ 7 1000002, 2000002, 1000002, 1000002, 2000002,
+ 7 2000002, 1000002, 1000002, 2000002, 2000002/
+ DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
+ DATA COEF/10000*0D0/
+ DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
+ &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
+ &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
+ &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
+ &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
+ &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
+ &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
+ &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
+ &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
+ &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+
+C...Treatment of resonances.
+ DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
+ &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
+
+C...Character constants: name of processes.
+ DATA PROC(0)/ 'All included subprocesses '/
+ DATA (PROC(I),I=1,20)/
+ &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
+ &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
+ &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
+ &' ', 'W+ + W- -> h0 ',
+ &' ', 'f + f'' -> f + f'' (QFD) ',
+ 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
+ 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
+ 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
+ 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
+ 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
+ DATA (PROC(I),I=21,40)/
+ 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
+ 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
+ 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
+ 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
+ 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
+ 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
+ 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
+ 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
+ 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
+ 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
+ DATA (PROC(I),I=41,60)/
+ 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
+ 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
+ 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
+ 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
+ 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
+ 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
+ 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
+ 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
+ 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
+ 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
+ DATA (PROC(I),I=61,80)/
+ 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
+ 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
+ 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
+ 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
+ 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
+ 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
+ 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
+ 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
+ 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
+ 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
+ DATA (PROC(I),I=81,100)/
+ 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
+ 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
+ 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
+ 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
+ 8'g + g -> chi_2c + g ', ' ',
+ 9'Elastic scattering ', 'Single diffractive (XB) ',
+ 9'Single diffractive (AX) ', 'Double diffractive ',
+ 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
+ 9' ', ' ',
+ 9' ', ' '/
+ DATA (PROC(I),I=101,120)/
+ &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
+ &'gamma + gamma -> h0 ', ' ',
+ &' ', 'g + g -> J/Psi + gamma ',
+ &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
+ &' ', 'f + fbar -> gamma + h0 ',
+ 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
+ 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
+ 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
+ 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
+ 1' ', ' '/
+ DATA (PROC(I),I=121,140)/
+ 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
+ 2'f + f'' -> f + f'' + h0 ',
+ 2'f + f'' -> f" + f"'' + h0 ',
+ 2' ', ' ',
+ 2' ', ' ',
+ 2' ', ' ',
+ 3'g + g -> Z0 + q + qbar ', ' ',
+ 3' ', ' ',
+ 3' ', ' ',
+ 3' ', ' ',
+ 3' ', ' '/
+ DATA (PROC(I),I=141,160)/
+ 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
+ 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
+ 4'q + l -> LQ ', ' ',
+ 4'd + g -> d* ', 'u + g -> u* ',
+ 4'g + g -> eta_techni ', ' ',
+ 5'f + fbar -> H0 ', 'g + g -> H0 ',
+ 5'gamma + gamma -> H0 ', ' ',
+ 5' ', 'f + fbar -> A0 ',
+ 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
+ 5' ', ' '/
+ DATA (PROC(I),I=161,180)/
+ 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
+ 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
+ 6'f + fbar -> f'' + fbar'' (g/Z)',
+ 6'f +fbar'' -> f" + fbar"'' (W) ',
+ 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
+ 6' ', ' ',
+ 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
+ 7'f + f'' -> f + f'' + H0 ',
+ 7'f + f'' -> f" + f"'' + H0 ',
+ 7' ', 'f + fbar -> Z0 + A0 ',
+ 7'f + fbar'' -> W+/- + A0 ',
+ 7'f + f'' -> f + f'' + A0 ',
+ 7'f + f'' -> f" + f"'' + A0 ',
+ 7' '/
+ DATA (PROC(I),I=181,200)/
+ 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
+ 8' ', ' ',
+ 8' ', 'g + g -> Q + Qbar + A0 ',
+ 8'q + qbar -> Q + Qbar + A0 ', ' ',
+ 8' ', ' ',
+ 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
+ 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
+ 9' ', ' ',
+ 9' ', ' ',
+ 9' ', ' '/
+ DATA (PROC(I),I=201,220)/
+ &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
+ &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
+ &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
+ &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
+ &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
+ 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
+ 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
+ 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
+ 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
+ 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
+ DATA (PROC(I),I=221,240)/
+ 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
+ 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
+ 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
+ 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
+ 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
+ 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
+ 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
+ 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
+ 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
+ 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
+ DATA (PROC(I),I=241,260)/
+ 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
+ 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
+ 4' ', 'qj + g -> ~qj_L + ~chi1 ',
+ 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
+ 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
+ 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
+ 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
+ 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
+ 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
+ 5'qj + g -> ~qj_R + ~g ', ' '/
+ DATA (PROC(I),I=261,280)/
+ 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
+ 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
+ 6'g + g -> ~t_2 + ~t_2bar ', ' ',
+ 6' ', ' ',
+ 6' ', ' ',
+ 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
+ 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
+ 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
+ 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
+ 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
+ DATA (PROC(I),I=281,500)/220*' '/
+
+C...Cross sections and slope offsets.
+ DATA SIGT/294*0D0/
+
+C...Supersymmetry switches and parameters.
+ DATA IMSS/0,
+ & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
+ 1 89*0/
+ DATA RMSS/0D0,
+ & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
+ 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
+ 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
+ 3 69*0D0/
+
+C...Data for histogramming routines.
+ DATA IHIST/1000,20000,55,1/
+ DATA INDX/1000*0/
+
+ END
+
+C*********************************************************************
+
+C...PYTEST
+C...A simple program (disguised as subroutine) to run at installation
+C...as a check that the program works as intended.
+
+ SUBROUTINE PYTEST(MTEST)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
+C...Local arrays.
+ DIMENSION PSUM(5),PINI(6),PFIN(6)
+
+C...Save defaults for values that are changed.
+ MSTJ1=MSTJ(1)
+ MSTJ3=MSTJ(3)
+ MSTJ11=MSTJ(11)
+ MSTJ42=MSTJ(42)
+ MSTJ43=MSTJ(43)
+ MSTJ44=MSTJ(44)
+ PARJ17=PARJ(17)
+ PARJ22=PARJ(22)
+ PARJ43=PARJ(43)
+ PARJ54=PARJ(54)
+ MST101=MSTJ(101)
+ MST104=MSTJ(104)
+ MST105=MSTJ(105)
+ MST107=MSTJ(107)
+ MST116=MSTJ(116)
+
+C...First part: loop over simple events to be generated.
+ IF(MTEST.GE.1) CALL PYTABU(20)
+ NERR=0
+ DO 180 IEV=1,500
+
+C...Reset parameter values. Switch on some nonstandard features.
+ MSTJ(1)=1
+ MSTJ(3)=0
+ MSTJ(11)=1
+ MSTJ(42)=2
+ MSTJ(43)=4
+ MSTJ(44)=2
+ PARJ(17)=0.1D0
+ PARJ(22)=1.5D0
+ PARJ(43)=1D0
+ PARJ(54)=-0.05D0
+ MSTJ(101)=5
+ MSTJ(104)=5
+ MSTJ(105)=0
+ MSTJ(107)=1
+ IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
+
+C...Ten events each for some single jets configurations.
+ IF(IEV.LE.50) THEN
+ ITY=(IEV+9)/10
+ MSTJ(3)=-1
+ IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
+ IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
+ IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
+ IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
+ IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
+ IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
+
+C...Ten events each for some simple jet systems; string fragmentation.
+ ELSEIF(IEV.LE.130) THEN
+ ITY=(IEV-41)/10
+ IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
+ IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
+ IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
+ IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
+ IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
+ IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
+ IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
+ IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
+
+C...Seventy events with independent fragmentation and momentum cons.
+ ELSEIF(IEV.LE.200) THEN
+ ITY=1+(IEV-131)/16
+ MSTJ(2)=1+MOD(IEV-131,4)
+ MSTJ(3)=1+MOD((IEV-131)/4,4)
+ IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
+ IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
+ IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
+ IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
+
+C...A hundred events with random jets (check invariant mass).
+ ELSEIF(IEV.LE.300) THEN
+ 100 DO 110 J=1,5
+ PSUM(J)=0D0
+ 110 CONTINUE
+ NJET=2D0+6D0*PYR(0)
+ DO 130 I=1,NJET
+ KFL=21
+ IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
+ IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
+ EJET=5D0+20D0*PYR(0)
+ THETA=ACOS(2D0*PYR(0)-1D0)
+ PHI=6.2832D0*PYR(0)
+ IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
+ IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
+ IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
+ IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
+ DO 120 J=1,4
+ PSUM(J)=PSUM(J)+P(I,J)
+ 120 CONTINUE
+ 130 CONTINUE
+ IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
+ & (PSUM(5)+PARJ(32))**2) GOTO 100
+
+C...Fifty e+e- continuum events with matrix elements.
+ ELSEIF(IEV.LE.350) THEN
+ MSTJ(101)=2
+ CALL PYEEVT(0,40D0)
+
+C...Fifty e+e- continuum event with varying shower options.
+ ELSEIF(IEV.LE.400) THEN
+ MSTJ(42)=1+MOD(IEV,2)
+ MSTJ(43)=1+MOD(IEV/2,4)
+ MSTJ(44)=MOD(IEV/8,3)
+ CALL PYEEVT(0,90D0)
+
+C...Fifty e+e- continuum events with coherent shower.
+ ELSEIF(IEV.LE.450) THEN
+ CALL PYEEVT(0,500D0)
+
+C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
+ ELSE
+ CALL PYONIA(5,9.46D0)
+ ENDIF
+
+C...Generate event. Find total momentum, energy and charge.
+ DO 140 J=1,4
+ PINI(J)=PYP(0,J)
+ 140 CONTINUE
+ PINI(6)=PYP(0,6)
+ CALL PYEXEC
+ DO 150 J=1,4
+ PFIN(J)=PYP(0,J)
+ 150 CONTINUE
+ PFIN(6)=PYP(0,6)
+
+C...Check conservation of energy, momentum and charge;
+C...usually exact, but only approximate for single jets.
+ MERR=0
+ IF(IEV.LE.50) THEN
+ IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
+ & MERR=MERR+1
+ EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
+ IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
+ IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
+ ELSE
+ DO 160 J=1,4
+ IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
+ 160 CONTINUE
+ IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
+ ENDIF
+ IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
+ & (PFIN(J),J=1,4),PFIN(6)
+
+C...Check that all KF codes are known ones, and that partons/particles
+C...satisfy energy-momentum-mass relation. Store particle statistics.
+ DO 170 I=1,N
+ IF(K(I,1).GT.20) GOTO 170
+ IF(PYCOMP(K(I,2)).EQ.0) THEN
+ WRITE(MSTU(11),5100) I
+ MERR=MERR+1
+ ENDIF
+ PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
+ IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
+ & THEN
+ WRITE(MSTU(11),5200) I
+ MERR=MERR+1
+ ENDIF
+ 170 CONTINUE
+ IF(MTEST.GE.1) CALL PYTABU(21)
+
+C...List all erroneous events and some normal ones.
+ IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
+ IF(MERR.GE.1) WRITE(MSTU(11),6400)
+ CALL PYLIST(2)
+ ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
+ CALL PYLIST(1)
+ ENDIF
+
+C...Stop execution if too many errors.
+ IF(MERR.NE.0) NERR=NERR+1
+ IF(NERR.GE.10) THEN
+ WRITE(MSTU(11),6300)
+ CALL PYLIST(1)
+ STOP
+ ENDIF
+ 180 CONTINUE
+
+C...Summarize result of run.
+ IF(MTEST.GE.1) CALL PYTABU(22)
+
+C...Reset commonblock variables changed during run.
+ MSTJ(1)=MSTJ1
+ MSTJ(3)=MSTJ3
+ MSTJ(11)=MSTJ11
+ MSTJ(42)=MSTJ42
+ MSTJ(43)=MSTJ43
+ MSTJ(44)=MSTJ44
+ PARJ(17)=PARJ17
+ PARJ(22)=PARJ22
+ PARJ(43)=PARJ43
+ PARJ(54)=PARJ54
+ MSTJ(101)=MST101
+ MSTJ(104)=MST104
+ MSTJ(105)=MST105
+ MSTJ(107)=MST107
+ MSTJ(116)=MST116
+
+C...Second part: complete events of various kinds.
+C...Common initial values. Loop over initiating conditions.
+ MSTP(122)=MAX(0,MIN(2,MTEST))
+ MDCY(PYCOMP(111),1)=0
+ DO 230 IPROC=1,8
+
+C...Reset process type, kinematics cuts, and the flags used.
+ MSEL=0
+ DO 190 ISUB=1,500
+ MSUB(ISUB)=0
+ 190 CONTINUE
+ CKIN(1)=2D0
+ CKIN(3)=0D0
+ MSTP(2)=1
+ MSTP(11)=0
+ MSTP(33)=0
+ MSTP(81)=1
+ MSTP(82)=1
+ MSTP(111)=1
+ MSTP(131)=0
+ MSTP(133)=0
+ PARP(131)=0.01D0
+
+C...Prompt photon production at fixed target.
+ IF(IPROC.EQ.1) THEN
+ PZSUM=300D0
+ PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
+ PQSUM=2D0
+ MSEL=10
+ CKIN(3)=5D0
+ CALL PYINIT('FIXT','pi+','p',PZSUM)
+
+C...QCD processes at ISR energies.
+ ELSEIF(IPROC.EQ.2) THEN
+ PESUM=63D0
+ PZSUM=0D0
+ PQSUM=2D0
+ MSEL=1
+ CKIN(3)=5D0
+ CALL PYINIT('CMS','p','p',PESUM)
+
+C...W production + multiple interactions at CERN Collider.
+ ELSEIF(IPROC.EQ.3) THEN
+ PESUM=630D0
+ PZSUM=0D0
+ PQSUM=0D0
+ MSEL=12
+ CKIN(1)=20D0
+ MSTP(82)=4
+ MSTP(2)=2
+ MSTP(33)=3
+ CALL PYINIT('CMS','p','pbar',PESUM)
+
+C...W/Z gauge boson pairs + pileup events at the Tevatron.
+ ELSEIF(IPROC.EQ.4) THEN
+ PESUM=1800D0
+ PZSUM=0D0
+ PQSUM=0D0
+ MSUB(22)=1
+ MSUB(23)=1
+ MSUB(25)=1
+ CKIN(1)=200D0
+ MSTP(111)=0
+ MSTP(131)=1
+ MSTP(133)=2
+ PARP(131)=0.04D0
+ CALL PYINIT('CMS','p','pbar',PESUM)
+
+C...Higgs production at LHC.
+ ELSEIF(IPROC.EQ.5) THEN
+ PESUM=15400D0
+ PZSUM=0D0
+ PQSUM=2D0
+ MSUB(3)=1
+ MSUB(102)=1
+ MSUB(123)=1
+ MSUB(124)=1
+ PMAS(25,1)=300D0
+ CKIN(1)=200D0
+ MSTP(81)=0
+ MSTP(111)=0
+ CALL PYINIT('CMS','p','p',PESUM)
+
+C...Z' production at SSC.
+ ELSEIF(IPROC.EQ.6) THEN
+ PESUM=40000D0
+ PZSUM=0D0
+ PQSUM=2D0
+ MSEL=21
+ PMAS(32,1)=600D0
+ CKIN(1)=400D0
+ MSTP(81)=0
+ MSTP(111)=0
+ CALL PYINIT('CMS','p','p',PESUM)
+
+C...W pair production at 1 TeV e+e- collider.
+ ELSEIF(IPROC.EQ.7) THEN
+ PESUM=1000D0
+ PZSUM=0D0
+ PQSUM=0D0
+ MSUB(25)=1
+ MSUB(69)=1
+ MSTP(11)=1
+ CALL PYINIT('CMS','e+','e-',PESUM)
+
+C...Deep inelastic scattering at a LEP+LHC ep collider.
+ ELSEIF(IPROC.EQ.8) THEN
+ P(1,1)=0D0
+ P(1,2)=0D0
+ P(1,3)=8000D0
+ P(2,1)=0D0
+ P(2,2)=0D0
+ P(2,3)=-80D0
+ PESUM=8080D0
+ PZSUM=7920D0
+ PQSUM=0D0
+ MSUB(10)=1
+ CKIN(3)=50D0
+ MSTP(111)=0
+ CALL PYINIT('USER','p','e-',PESUM)
+ ENDIF
+
+C...Generate 20 events of each required type.
+ DO 220 IEV=1,20
+ CALL PYEVNT
+ PESUMM=PESUM
+ IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
+
+C...Check conservation of energy/momentum/flavour.
+ PINI(1)=0D0
+ PINI(2)=0D0
+ PINI(3)=PZSUM
+ PINI(4)=PESUMM
+ PINI(6)=PQSUM
+ DO 200 J=1,4
+ PFIN(J)=PYP(0,J)
+ 200 CONTINUE
+ PFIN(6)=PYP(0,6)
+ MERR=0
+ DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
+ DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
+ DEVQ=ABS(PFIN(6)-PINI(6))
+ IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
+ & DEVQ.GT.0.1D0) MERR=1
+ IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
+ & (PFIN(J),J=1,4),PFIN(6)
+
+C...Check that all KF codes are known ones, and that partons/particles
+C...satisfy energy-momentum-mass relation.
+ DO 210 I=1,N
+ IF(K(I,1).GT.20) GOTO 210
+ IF(PYCOMP(K(I,2)).EQ.0) THEN
+ WRITE(MSTU(11),5100) I
+ MERR=MERR+1
+ ENDIF
+ PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
+ & SIGN(1D0,P(I,5))
+ IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
+ & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
+ WRITE(MSTU(11),5200) I
+ MERR=MERR+1
+ ENDIF
+ 210 CONTINUE
+
+C...Listing of erroneous events, and first event of each type.
+ IF(MERR.GE.1) NERR=NERR+1
+ IF(NERR.GE.10) THEN
+ WRITE(MSTU(11),6300)
+ CALL PYLIST(1)
+ STOP
+ ENDIF
+ IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
+ IF(MERR.GE.1) WRITE(MSTU(11),6400)
+ CALL PYLIST(1)
+ ENDIF
+ 220 CONTINUE
+
+C...List statistics for each process type.
+ IF(MTEST.GE.1) CALL PYSTAT(1)
+ 230 CONTINUE
+
+C...Summarize result of run.
+ IF(NERR.EQ.0) WRITE(MSTU(11),6500)
+ IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
+
+C...Format statements for output.
+ 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
+ &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
+ &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
+ &4(1X,F12.5),1X,F8.2)
+ 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
+ 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
+ &'kinematics')
+ 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
+ &'wrong.'/5X,'Execution will be stopped after listing of event.')
+ 6400 FORMAT(5X,'Faulty event follows:')
+ 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
+ 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
+ &5X,'This should not have happened!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYHEPC
+C...Converts PYTHIA event record contents to or from
+C...the standard event record commonblock.
+
+ SUBROUTINE PYHEPC(MCONV)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...HEPEVT commonblock.
+ PARAMETER (NMXHEP=4000)
+ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
+ DOUBLE PRECISION PHEP,VHEP
+ SAVE /HEPEVT/
+
+C...Conversion from PYTHIA to standard, the easy part.
+ IF(MCONV.EQ.1) THEN
+ NEVHEP=0
+ IF(N.GT.NMXHEP) CALL PYERRM(8,
+ & '(PYHEPC:) no more space in /HEPEVT/')
+ NHEP=MIN(N,NMXHEP)
+ DO 140 I=1,NHEP
+ ISTHEP(I)=0
+ IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
+ IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
+ IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
+ IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
+ IDHEP(I)=K(I,2)
+ JMOHEP(1,I)=K(I,3)
+ JMOHEP(2,I)=0
+ IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
+ JDAHEP(1,I)=K(I,4)
+ JDAHEP(2,I)=K(I,5)
+ ELSE
+ JDAHEP(1,I)=0
+ JDAHEP(2,I)=0
+ ENDIF
+ DO 100 J=1,5
+ PHEP(J,I)=P(I,J)
+ 100 CONTINUE
+ DO 110 J=1,4
+ VHEP(J,I)=V(I,J)
+ 110 CONTINUE
+
+C...Check if new event (from pileup).
+ IF(I.EQ.1) THEN
+ INEW=1
+ ELSE
+ IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
+ ENDIF
+
+C...Fill in missing mother information.
+ IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
+ IMO1=I-2
+ IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
+ & IMO1=IMO1-1
+ JMOHEP(1,I)=IMO1
+ JMOHEP(2,I)=IMO1+1
+ ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
+ I1=K(I,3)-1
+ 120 I1=I1+1
+ IF(I1.GE.I) CALL PYERRM(8,
+ & '(PYHEPC:) translation of inconsistent event history')
+ IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
+ KC=PYCOMP(K(I1,2))
+ IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
+ IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
+ JMOHEP(2,I)=I1
+ ELSEIF(K(I,2).EQ.94) THEN
+ NJET=2
+ IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
+ IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
+ JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
+ IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
+ & MOD(K(I+1,4)/MSTU(5),MSTU(5))
+ ENDIF
+
+C...Fill in missing daughter information.
+ IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
+ DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
+ I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
+ JDAHEP(1,I2)=I
+ 130 CONTINUE
+ ENDIF
+ IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
+ I1=JMOHEP(1,I)
+ IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
+ IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
+ IF(JDAHEP(1,I1).EQ.0) THEN
+ JDAHEP(1,I1)=I
+ ELSE
+ JDAHEP(2,I1)=I
+ ENDIF
+ 140 CONTINUE
+ DO 150 I=1,NHEP
+ IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
+ IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
+ 150 CONTINUE
+
+C...Conversion from standard to PYTHIA, the easy part.
+ ELSE
+ IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
+ & '(PYHEPC:) no more space in /PYJETS/')
+ N=MIN(NHEP,MSTU(4))
+ NKQ=0
+ KQSUM=0
+ DO 180 I=1,N
+ K(I,1)=0
+ IF(ISTHEP(I).EQ.1) K(I,1)=1
+ IF(ISTHEP(I).EQ.2) K(I,1)=11
+ IF(ISTHEP(I).EQ.3) K(I,1)=21
+ K(I,2)=IDHEP(I)
+ K(I,3)=JMOHEP(1,I)
+ K(I,4)=JDAHEP(1,I)
+ K(I,5)=JDAHEP(2,I)
+ DO 160 J=1,5
+ P(I,J)=PHEP(J,I)
+ 160 CONTINUE
+ DO 170 J=1,4
+ V(I,J)=VHEP(J,I)
+ 170 CONTINUE
+ V(I,5)=0D0
+ IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
+ I1=JDAHEP(1,I)
+ IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
+ & PHEP(5,I)/PHEP(4,I)
+ ENDIF
+
+C...Fill in missing information on colour connection in jet systems.
+ IF(ISTHEP(I).EQ.1) THEN
+ KC=PYCOMP(K(I,2))
+ KQ=0
+ IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
+ IF(KQ.NE.0) NKQ=NKQ+1
+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
+ IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
+ K(I,1)=2
+ ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
+ IF(K(I+1,2).EQ.21) K(I,1)=2
+ ENDIF
+ ENDIF
+ 180 CONTINUE
+ IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
+ & '(PYHEPC:) input parton configuration not colour singlet')
+ ENDIF
+
+ END
+
+C*********************************************************************
+
+C...PYINIT
+C...Initializes the generation procedure; finds maxima of the
+C...differential cross-sections to be used for weighting.
+
+ SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/,/PYINT5/
+C...Local arrays and character variables.
+ DIMENSION ALAMIN(20),NFIN(20)
+ CHARACTER*(*) FRAME,BEAM,TARGET
+ CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
+
+C...Interface to PDFLIB.
+ COMMON/W50512/QCDL4,QCDL5
+ SAVE /W50512/
+ DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
+ CHARACTER*20 PARM(20)
+ DATA VALUE/20*0D0/,PARM/20*' '/
+
+C...Data:Lambda and n_f values for parton distributions; months.
+ DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
+ &14*0.2D0/,NFIN/20*4/
+ DATA CHLH/'lepton','hadron'/
+
+C...Reset MINT and VINT arrays. Write headers.
+ DO 100 J=1,400
+ MINT(J)=0
+ VINT(J)=0D0
+ 100 CONTINUE
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
+
+C...Maximum 4 generations; set maximum number of allowed flavours.
+ MSTP(1)=MIN(4,MSTP(1))
+ MSTU(114)=MIN(MSTU(114),2*MSTP(1))
+ MSTP(58)=MIN(MSTP(58),2*MSTP(1))
+
+C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
+ DO 120 I=-20,20
+ VINT(180+I)=0D0
+ IA=IABS(I)
+ IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
+ DO 110 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
+ & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
+ 110 CONTINUE
+ ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
+ VINT(180+I)=1D0
+ ENDIF
+ 120 CONTINUE
+
+C...Initialize parton distributions: PDFLIB.
+ IF(MSTP(52).EQ.2) THEN
+ PARM(1)='NPTYPE'
+ VALUE(1)=1
+ PARM(2)='NGROUP'
+ VALUE(2)=MSTP(51)/1000
+ PARM(3)='NSET'
+ VALUE(3)=MOD(MSTP(51),1000)
+ PARM(4)='TMAS'
+ VALUE(4)=PMAS(6,1)
+ CALL PDFSET(PARM,VALUE)
+ MINT(93)=1000000+MSTP(51)
+ ENDIF
+
+C...Choose Lambda value to use in alpha-strong.
+ MSTU(111)=MSTP(2)
+ IF(MSTP(3).GE.2) THEN
+ ALAM=0.2D0
+ NF=4
+ IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
+ ALAM=ALAMIN(MSTP(51))
+ NF=NFIN(MSTP(51))
+ ELSEIF(MSTP(52).EQ.2) THEN
+ ALAM=QCDL4
+ NF=4
+ ENDIF
+ PARP(1)=ALAM
+ PARP(61)=ALAM
+ PARP(72)=ALAM
+ PARU(112)=ALAM
+ MSTU(112)=NF
+ IF(MSTP(3).EQ.3) PARJ(81)=ALAM
+ ENDIF
+
+C...Initialize the SUSY generation: couplings, masses,
+C...decay modes, branching ratios, and so on.
+ CALL PYMSIN
+
+C...Initialize widths and partial widths for resonances.
+ CALL PYINRE
+C...Set Z0 mass and width for e+e- routines.
+ PARJ(123)=PMAS(23,1)
+ PARJ(124)=PMAS(23,2)
+
+C...Identify beam and target particles and frame of process.
+ CHFRAM=FRAME//' '
+ CHBEAM=BEAM//' '
+ CHTARG=TARGET//' '
+ CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
+ IF(MINT(65).EQ.1) GOTO 170
+
+C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
+C...For e-gamma allow 2 alternatives.
+ MINT(121)=1
+ MINT(123)=MSTP(14)
+ IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
+ & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
+ & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
+ ENDIF
+
+C...Set up kinematics of process.
+ CALL PYINKI(0)
+
+C...Precalculate flavour selection weights
+ CALL PYKFIN
+
+C...Loop over gamma-p or gamma-gamma alternatives.
+ DO 160 IGA=1,MINT(121)
+ MINT(122)=IGA
+
+C...Select partonic subprocesses to be included in the simulation.
+ CALL PYINPR
+
+C...Count number of subprocesses on.
+ MINT(48)=0
+ DO 130 ISUB=1,500
+ IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
+ & MSUB(ISUB).EQ.1) THEN
+ WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
+ STOP
+ ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
+ WRITE(MSTU(11),5300) ISUB
+ STOP
+ ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
+ WRITE(MSTU(11),5400) ISUB
+ STOP
+ ELSEIF(MSUB(ISUB).EQ.1) THEN
+ MINT(48)=MINT(48)+1
+ ENDIF
+ 130 CONTINUE
+ IF(MINT(48).EQ.0) THEN
+ WRITE(MSTU(11),5500)
+ STOP
+ ENDIF
+ MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
+
+C...Reset variables for cross-section calculation.
+ DO 150 I=0,500
+ DO 140 J=1,3
+ NGEN(I,J)=0
+ XSEC(I,J)=0D0
+ 140 CONTINUE
+ 150 CONTINUE
+
+C...Find parametrized total cross-sections.
+ CALL PYXTOT
+
+C...Maxima of differential cross-sections.
+ IF(MSTP(121).LE.1) CALL PYMAXI
+
+C...Initialize possibility of pileup events.
+ IF(MINT(121).GT.1) MSTP(131)=0
+ IF(MSTP(131).NE.0) CALL PYPILE(1)
+
+C...Initialize multiple interactions with variable impact parameter.
+ IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
+ & MSTP(82).GE.2) CALL PYMULT(1)
+
+C...Save results for gamma-p and gamma-gamma alternatives.
+ IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
+ 160 CONTINUE
+
+C...Initialization finished.
+ 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
+
+C...Formats for initialization information.
+ 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
+ &'routines',1X,17('*'))
+ 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
+ &'-',A6,' interactions.'/1X,'Execution stopped!')
+ 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
+ &1X,'Execution stopped!')
+ 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
+ &1X,'Execution stopped!')
+ 5500 FORMAT(1X,'Error: no subprocess switched on.'/
+ &1X,'Execution stopped.')
+ 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
+ &22('*'))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEVNT
+C...Administers the generation of a high-pT event via calls to
+C...a number of subroutines.
+
+ SUBROUTINE PYEVNT
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
+ &/PYINT4/,/PYINT5/,/PYUPPR/
+C...Local array.
+ DIMENSION VTX(4)
+
+C...Initial values for some counters.
+ N=0
+ MINT(5)=MINT(5)+1
+ MINT(7)=0
+ MINT(8)=0
+ MINT(83)=0
+ MINT(84)=MSTP(126)
+ MSTU(24)=0
+ MSTU70=0
+ MSTJ14=MSTJ(14)
+
+C...If variable energies: redo incoming kinematics and cross-section.
+ MSTI(61)=0
+ IF(MSTP(171).EQ.1) THEN
+ CALL PYINKI(1)
+ IF(MSTI(61).EQ.1) THEN
+ MINT(5)=MINT(5)-1
+ RETURN
+ ENDIF
+ IF(MINT(121).GT.1) CALL PYSAVE(3,1)
+ CALL PYXTOT
+ ENDIF
+
+C...Loop over number of pileup events; check space left.
+ IF(MSTP(131).LE.0) THEN
+ NPILE=1
+ ELSE
+ CALL PYPILE(2)
+ NPILE=MINT(81)
+ ENDIF
+ DO 260 IPILE=1,NPILE
+ IF(MINT(84)+100.GE.MSTU(4)) THEN
+ CALL PYERRM(11,
+ & '(PYEVNT:) no more space in PYJETS for pileup events')
+ IF(MSTU(21).GE.1) GOTO 270
+ ENDIF
+ MINT(82)=IPILE
+
+C...Generate variables of hard scattering.
+ MINT(51)=0
+ MSTI(52)=0
+ 100 CONTINUE
+ IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
+ MINT(31)=0
+ MINT(51)=0
+ MINT(57)=0
+ CALL PYRAND
+ IF(MSTI(61).EQ.1) THEN
+ MINT(5)=MINT(5)-1
+ RETURN
+ ENDIF
+ IF(MINT(51).EQ.2) RETURN
+ ISUB=MINT(1)
+ IF(MSTP(111).EQ.-1) GOTO 250
+
+ IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
+C...Hard scattering (including low-pT):
+C...reconstruct kinematics and colour flow of hard scattering.
+ 110 MINT(51)=0
+ CALL PYSCAT
+ IF(MINT(51).EQ.1) GOTO 100
+ IPU1=MINT(84)+1
+ IPU2=MINT(84)+2
+ IF(ISUB.EQ.95) GOTO 130
+
+C...Showering of initial state partons (optional).
+ ALAMSV=PARJ(81)
+ PARJ(81)=PARP(72)
+ IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
+ PARJ(81)=ALAMSV
+ IF(MINT(51).EQ.1) GOTO 100
+
+C...Showering of final state partons (optional).
+ ALAMSV=PARJ(81)
+ PARJ(81)=PARP(72)
+ IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
+ & THEN
+ IPU3=MINT(84)+3
+ IPU4=MINT(84)+4
+ IF(ISET(ISUB).EQ.5) IPU4=-3
+ QMAX=VINT(55)
+ IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
+ CALL PYSHOW(IPU3,IPU4,QMAX)
+ ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
+ DO 120 IUP=1,NFUP
+ IPU3=IFUP(IUP,1)+MINT(84)
+ IPU4=IFUP(IUP,2)+MINT(84)
+ QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
+ CALL PYSHOW(IPU3,IPU4,QMAX)
+ 120 CONTINUE
+ ENDIF
+ PARJ(81)=ALAMSV
+
+C...Decay of final state resonances.
+ MINT(32)=0
+ IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
+ IF(MINT(51).EQ.1) GOTO 100
+ MINT(52)=N
+
+C...Multiple interactions.
+ IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
+ MINT(53)=N
+
+C...Hadron remnants and primordial kT.
+ 130 CALL PYREMN(IPU1,IPU2)
+ IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
+ IF(MINT(51).EQ.1) GOTO 100
+
+ ELSE
+C...Diffractive and elastic scattering.
+ CALL PYDIFF
+ ENDIF
+
+C...Check that no odd resonance left undecayed.
+ IF(MSTP(111).GE.1) THEN
+ NFIX=N
+ DO 140 I=MINT(84)+1,NFIX
+ IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
+ & K(I,2).NE.22) THEN
+ IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
+ CALL PYRESD(I)
+ IF(MINT(51).EQ.1) GOTO 100
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+ ENDIF
+
+C...Recalculate energies from momenta and masses (if desired).
+ IF(MSTP(113).GE.1) THEN
+ DO 150 I=MINT(83)+1,N
+ IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
+ & P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ 150 CONTINUE
+ NRECAL=N
+ ENDIF
+
+C...Rearrange partons along strings, check invariant mass cuts.
+ MSTU(28)=0
+ IF(MSTP(111).LE.0) MSTJ(14)=-1
+ CALL PYPREP(MINT(84)+1)
+ MSTJ(14)=MSTJ14
+ IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
+ IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
+ DO 180 I=MINT(84)+1,N
+ IF(K(I,2).EQ.94) THEN
+ DO 170 I1=I+1,MIN(N,I+3)
+ IF(K(I1,3).EQ.I) THEN
+ K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
+ IF(K(I1,3).EQ.0) THEN
+ DO 160 II=MINT(84)+1,I-1
+ IF(K(II,2).EQ.K(I1,2)) THEN
+ IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
+ & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
+ ENDIF
+ 160 CONTINUE
+ IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
+ ENDIF
+ ENDIF
+ 170 CONTINUE
+ ENDIF
+ 180 CONTINUE
+ CALL PYEDIT(12)
+ CALL PYEDIT(14)
+ IF(MSTP(125).EQ.0) CALL PYEDIT(15)
+ IF(MSTP(125).EQ.0) MINT(4)=0
+ DO 200 I=MINT(83)+1,N
+ IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
+ DO 190 I1=I+1,N
+ IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
+ IF(K(I1,3).EQ.I) K(I,5)=I1
+ 190 CONTINUE
+ ENDIF
+ 200 CONTINUE
+ ENDIF
+
+C...Introduce separators between sections in PYLIST event listing.
+ IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
+ MSTU70=1
+ MSTU(71)=N
+ ELSEIF(IPILE.EQ.1) THEN
+ MSTU70=3
+ MSTU(71)=2
+ MSTU(72)=MINT(4)
+ MSTU(73)=N
+ ENDIF
+
+C...Go back to lab frame (needed for vertices, also in fragmentation).
+ CALL PYFRAM(1)
+
+C...Set nonvanishing production vertex (optional).
+ IF(MSTP(151).EQ.1) THEN
+ DO 210 J=1,4
+ VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
+ & SIN(PARU(2)*PYR(0))
+ 210 CONTINUE
+ DO 230 I=MINT(83)+1,N
+ DO 220 J=1,4
+ V(I,J)=V(I,J)+VTX(J)
+ 220 CONTINUE
+ 230 CONTINUE
+ ENDIF
+
+C...Perform hadronization (if desired).
+ IF(MSTP(111).GE.1) THEN
+ CALL PYEXEC
+ IF(MSTU(24).NE.0) GOTO 100
+ ENDIF
+ IF(MSTP(113).GE.1) THEN
+ DO 240 I=NRECAL,N
+ IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
+ & P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ 240 CONTINUE
+ ENDIF
+ IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
+
+C...Store event information and calculate Monte Carlo estimates of
+C...subprocess cross-sections.
+ 250 IF(IPILE.EQ.1) CALL PYDOCU
+
+C...Set counters for current pileup event and loop to next one.
+ MSTI(41)=IPILE
+ IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
+ IF(MSTU70.LT.10) THEN
+ MSTU70=MSTU70+1
+ MSTU(70+MSTU70)=N
+ ENDIF
+ MINT(83)=N
+ MINT(84)=N+MSTP(126)
+ IF(IPILE.LT.NPILE) CALL PYFRAM(2)
+ 260 CONTINUE
+
+C...Generic information on pileup events. Reconstruct missing history.
+ IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
+ PARI(91)=VINT(132)
+ PARI(92)=VINT(133)
+ PARI(93)=VINT(134)
+ IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
+ ENDIF
+ CALL PYEDIT(16)
+
+C...Transform to the desired coordinate frame.
+ 270 CALL PYFRAM(MSTP(124))
+ MSTU(70)=MSTU70
+ PARU(21)=VINT(1)
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYSTAT
+C...Prints out information about cross-sections, decay widths, branching
+C...ratios, kinematical limits, status codes and parameter values.
+
+ SUBROUTINE PYSTAT(MSTAT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
+C...Local arrays, character variables and data.
+ DIMENSION WDTP(0:200),WDTE(0:200,0:5)
+ CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
+ &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
+ DATA PROGA/
+ &'VMD/hadron * VMD ','VMD/hadron * direct ',
+ &'VMD/hadron * anomalous ','direct * direct ',
+ &'direct * anomalous ','anomalous * anomalous '/
+ DATA DISGA/'e * VMD','e * anomalous'/
+ DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
+ &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
+ &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
+ &' y*_small ',' eta*_large ',' eta*_small ',
+ &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
+ &' x_2 ',' x_F ',' cos(theta_hard) ',
+ &'m''_hard (GeV/c^2) ',' tau ',' y* ',
+ &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
+ &' tau'' '/
+
+C...Cross-sections.
+ IF(MSTAT.LE.1) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(5,0)
+ WRITE(MSTU(11),5000)
+ WRITE(MSTU(11),5100)
+ WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
+ DO 100 I=1,500
+ IF(MSUB(I).NE.1) GOTO 100
+ WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
+ 100 CONTINUE
+ IF(MINT(121).GT.1) THEN
+ WRITE(MSTU(11),5300)
+ DO 110 IGA=1,MINT(121)
+ CALL PYSAVE(3,IGA)
+ IF(MINT(121).EQ.2) THEN
+ WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
+ & XSEC(0,3)
+ ELSE
+ WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
+ & XSEC(0,3)
+ ENDIF
+ 110 CONTINUE
+ CALL PYSAVE(5,0)
+ ENDIF
+ WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
+ & MAX(1D0,DBLE(NGEN(0,2)))
+
+C...Decay widths and branching ratios.
+ ELSEIF(MSTAT.EQ.2) THEN
+ WRITE(MSTU(11),5500)
+ WRITE(MSTU(11),5600)
+ DO 140 KC=1,500
+ KF=KCHG(KC,4)
+ CALL PYNAME(KF,CHKF)
+ IOFF=0
+ IF(KC.LE.22) THEN
+ IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
+ IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
+ IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
+ IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
+ IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
+ ELSE
+ IF(MWID(KC).LE.0) GOTO 140
+ IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
+ & KF/KSUSY1.EQ.2)) GOTO 140
+ ENDIF
+C...Off-shell branchings.
+ IF(IOFF.EQ.1) THEN
+ NGP=0
+ IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
+ IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
+ & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
+ DO 120 J=1,MDCY(KC,3)
+ IDC=J+MDCY(KC,2)-1
+ NGP1=0
+ IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
+ & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
+ NGP2=0
+ IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
+ & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
+ CALL PYNAME(KFDP(IDC,1),CHD1)
+ CALL PYNAME(KFDP(IDC,2),CHD2)
+ IF(KFDP(IDC,3).EQ.0) THEN
+ IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
+ & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
+ & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
+ ELSE
+ CALL PYNAME(KFDP(IDC,3),CHD3)
+ IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
+ & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
+ & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
+ ENDIF
+ 120 CONTINUE
+C...On-shell decays.
+ ELSE
+ CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
+ BRFIN=1D0
+ IF(WDTE(0,0).LE.0D0) BRFIN=0D0
+ WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
+ & STATE(MDCY(KC,1)),BRFIN
+ DO 130 J=1,MDCY(KC,3)
+ IDC=J+MDCY(KC,2)-1
+ NGP1=0
+ IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
+ & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
+ NGP2=0
+ IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
+ & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
+ BRFIN=0D0
+ IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
+ CALL PYNAME(KFDP(IDC,1),CHD1)
+ CALL PYNAME(KFDP(IDC,2),CHD2)
+ IF(KFDP(IDC,3).EQ.0) THEN
+ IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
+ & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
+ & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
+ & STATE(MDME(IDC,1)),BRFIN
+ ELSE
+ CALL PYNAME(KFDP(IDC,3),CHD3)
+ IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
+ & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
+ & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
+ & STATE(MDME(IDC,1)),BRFIN
+ ENDIF
+ 130 CONTINUE
+ ENDIF
+ 140 CONTINUE
+ WRITE(MSTU(11),6000)
+
+C...Allowed incoming partons/particles at hard interaction.
+ ELSEIF(MSTAT.EQ.3) THEN
+ WRITE(MSTU(11),6100)
+ CALL PYNAME(MINT(11),CHAU)
+ CHIN(1)=CHAU(1:12)
+ CALL PYNAME(MINT(12),CHAU)
+ CHIN(2)=CHAU(1:12)
+ WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
+ DO 150 I=-20,22
+ IF(I.EQ.0) GOTO 150
+ IA=IABS(I)
+ IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
+ IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
+ CALL PYNAME(I,CHAU)
+ WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
+ & STATE(KFIN(2,I))
+ 150 CONTINUE
+ WRITE(MSTU(11),6400)
+
+C...User-defined limits on kinematical variables.
+ ELSEIF(MSTAT.EQ.4) THEN
+ WRITE(MSTU(11),6500)
+ WRITE(MSTU(11),6600)
+ SHRMAX=CKIN(2)
+ IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
+ WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
+ PTHMIN=MAX(CKIN(3),CKIN(5))
+ PTHMAX=CKIN(4)
+ IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
+ WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
+ WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
+ DO 160 I=4,14
+ WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
+ 160 CONTINUE
+ SPRMAX=CKIN(32)
+ IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
+ WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
+ WRITE(MSTU(11),7000)
+
+C...Status codes and parameter values.
+ ELSEIF(MSTAT.EQ.5) THEN
+ WRITE(MSTU(11),7100)
+ WRITE(MSTU(11),7200)
+ DO 170 I=1,100
+ WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
+ & PARP(100+I)
+ 170 CONTINUE
+
+C...List of all processes implemented in the program.
+ ELSEIF(MSTAT.EQ.6) THEN
+ WRITE(MSTU(11),7400)
+ WRITE(MSTU(11),7500)
+ DO 180 I=1,500
+ IF(ISET(I).LT.0) GOTO 180
+ WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
+ 180 CONTINUE
+ WRITE(MSTU(11),7700)
+ ENDIF
+
+C...Formats for printouts.
+ 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
+ &'Events and Cross-sections',1X,9('*'))
+ 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
+ &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
+ &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
+ &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
+ &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
+ &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
+ &'I',12X,'I')
+ 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
+ &D10.3,1X,'I')
+ 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
+ &1X,'I',34X,'I',28X,'I',12X,'I')
+ 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
+ &1X,'********* Fraction of events that fail fragmentation ',
+ &'cuts =',1X,F8.5,' *********'/)
+ 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
+ &'Ratios',1X,27('*'))
+ 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
+ &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
+ &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
+ &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
+ &1X,98('='))
+ 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
+ &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
+ &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
+ 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
+ &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
+ &1P,D10.3,0P,1X,'I')
+ 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
+ &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
+ &1P,D10.3,0P,1X,'I')
+ 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
+ 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
+ &'Particles at Hard Interaction',1X,7('*'))
+ 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
+ &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
+ &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
+ &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
+ &78('=')/1X,'I',38X,'I',37X,'I')
+ 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
+ 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
+ 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
+ &'Kinematical Variables',1X,12('*'))
+ 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
+ 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
+ &16X,'I')
+ 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
+ &1X,'<',1X,1P,D10.3,0P,16X,'I')
+ 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
+ 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
+ 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
+ &'Parameter Values',1X,12('*'))
+ 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
+ &'PARP(I)'/)
+ 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
+ 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
+ &1X,13('*'))
+ 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
+ &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
+ &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
+ 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
+ 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINRE
+C...Calculates full and effective widths of gauge bosons, stores
+C...masses and widths, rescales coefficients to be used for
+C...resonance production generation.
+
+ SUBROUTINE PYINRE
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
+C...Local arrays and data.
+ DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
+ &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
+
+C...Born level couplings in MSSM Higgs doublet sector.
+ XW=PARU(102)
+ XWV=XW
+ IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
+ XW1=1D0-XW
+ IF(MSTP(4).EQ.2) THEN
+ TANBE=PARU(141)
+ RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
+ SQMZ=PMAS(23,1)**2
+ SQMW=PMAS(24,1)**2
+ SQMH=PMAS(25,1)**2
+ SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
+ SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
+ SQMHC=SQMA+SQMW
+ IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
+ WRITE(MSTU(11),5000)
+ STOP
+ ENDIF
+ PMAS(35,1)=SQRT(SQMHP)
+ PMAS(36,1)=SQRT(SQMA)
+ PMAS(37,1)=SQRT(SQMHC)
+ ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
+ & (SQMA-SQMZ)))
+ BESU=ATAN(TANBE)
+ PARU(142)=1D0
+ PARU(143)=1D0
+ PARU(161)=-SIN(ALSU)/COS(BESU)
+ PARU(162)=COS(ALSU)/SIN(BESU)
+ PARU(163)=PARU(161)
+ PARU(164)=SIN(BESU-ALSU)
+ PARU(165)=PARU(164)
+ PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
+ PARU(171)=COS(ALSU)/COS(BESU)
+ PARU(172)=SIN(ALSU)/SIN(BESU)
+ PARU(173)=PARU(171)
+ PARU(174)=COS(BESU-ALSU)
+ PARU(175)=PARU(174)
+ PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
+ & SIN(BESU+ALSU)
+ PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
+ PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
+ PARU(181)=TANBE
+ PARU(182)=1D0/TANBE
+ PARU(183)=PARU(181)
+ PARU(184)=0D0
+ PARU(185)=PARU(184)
+ PARU(186)=COS(BESU-ALSU)
+ PARU(187)=SIN(BESU-ALSU)
+ PARU(188)=PARU(186)
+ PARU(189)=PARU(187)
+ PARU(190)=0D0
+ PARU(195)=COS(BESU-ALSU)
+ ENDIF
+
+C...Reset effective widths of gauge bosons.
+ DO 110 I=1,500
+ DO 100 J=1,5
+ WIDS(I,J)=1D0
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Order resonances by increasing mass (except Z0 and W+/-).
+ NRES=0
+ DO 140 KC=1,500
+ KF=KCHG(KC,4)
+ IF(KF.EQ.0) GOTO 140
+ IF(MWID(KC).EQ.0) GOTO 140
+ IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
+ IF(MSTP(1).LE.3) GOTO 140
+ ENDIF
+ IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
+ IF(IMSS(1).LE.0) GOTO 140
+ ENDIF
+ NRES=NRES+1
+ PMRES=PMAS(KC,1)
+ IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
+ DO 120 I1=NRES-1,1,-1
+ IF(PMRES.GE.PMORD(I1)) GOTO 130
+ KCORD(I1+1)=KCORD(I1)
+ PMORD(I1+1)=PMORD(I1)
+ 120 CONTINUE
+ 130 KCORD(I1+1)=KC
+ PMORD(I1+1)=PMRES
+ 140 CONTINUE
+
+C...Loop over possible resonances.
+ DO 180 I=1,NRES
+ KC=KCORD(I)
+ KF=KCHG(KC,4)
+
+C...Check that no fourth generation channels on by mistake.
+ IF(MSTP(1).LE.3) THEN
+ DO 150 J=1,MDCY(KC,3)
+ IDC=J+MDCY(KC,2)-1
+ KFA1=IABS(KFDP(IDC,1))
+ KFA2=IABS(KFDP(IDC,2))
+ IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
+ & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
+ & MDME(IDC,1)=-1
+ 150 CONTINUE
+ ENDIF
+
+C...Check that no supersymmetric channels on by mistake.
+ IF(IMSS(1).LE.0) THEN
+ DO 160 J=1,MDCY(KC,3)
+ IDC=J+MDCY(KC,2)-1
+ KFA1S=IABS(KFDP(IDC,1))/KSUSY1
+ KFA2S=IABS(KFDP(IDC,2))/KSUSY1
+ IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
+ & MDME(IDC,1)=-1
+ 160 CONTINUE
+ ENDIF
+
+C...Find mass and evaluate width.
+ PMR=PMAS(KC,1)
+ IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
+ IF(MWID(KC).EQ.3) MINT(63)=1
+ CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
+ MINT(51)=0
+
+C...Evaluate suppression factors due to non-simulated channels.
+ IF(KCHG(KC,3).EQ.0) THEN
+ WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
+ & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
+ WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
+ WIDS(KC,3)=0D0
+ WIDS(KC,4)=0D0
+ WIDS(KC,5)=0D0
+ ELSE
+ IF(MWID(KC).EQ.3) MINT(63)=1
+ CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
+ MINT(51)=0
+ WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
+ & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
+ & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
+ & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
+ WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
+ WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
+ WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
+ & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
+ WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
+ & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
+ & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
+ ENDIF
+
+C...Set resonance widths and branching ratios;
+C...also on/off switch for decays.
+ IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
+ PMAS(KC,2)=WDTP(0)
+ PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
+ MDCY(KC,1)=MSTP(41)
+ DO 170 J=1,MDCY(KC,3)
+ IDC=J+MDCY(KC,2)-1
+ BRAT(IDC)=0D0
+ IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
+ 170 CONTINUE
+ ENDIF
+ 180 CONTINUE
+
+C...Flavours of leptoquark: redefine charge and name.
+ KFLQQ=KFDP(MDCY(39,2),1)
+ KFLQL=KFDP(MDCY(39,2),2)
+ KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
+ &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
+ LL=1
+ IF(IABS(KFLQL).EQ.13) LL=2
+ IF(IABS(KFLQL).EQ.15) LL=3
+ CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
+ &CHAF(IABS(KFLQL),1)(1:LL)//' '
+ CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
+
+C...Special cases in treatment of gamma*/Z0: redefine process name.
+ IF(MSTP(43).EQ.1) THEN
+ PROC(1)='f + fbar -> gamma*'
+ PROC(15)='f + fbar -> g + gamma*'
+ PROC(19)='f + fbar -> gamma + gamma*'
+ PROC(30)='f + g -> f + gamma*'
+ PROC(35)='f + gamma -> f + gamma*'
+ ELSEIF(MSTP(43).EQ.2) THEN
+ PROC(1)='f + fbar -> Z0'
+ PROC(15)='f + fbar -> g + Z0'
+ PROC(19)='f + fbar -> gamma + Z0'
+ PROC(30)='f + g -> f + Z0'
+ PROC(35)='f + gamma -> f + Z0'
+ ELSEIF(MSTP(43).EQ.3) THEN
+ PROC(1)='f + fbar -> gamma*/Z0'
+ PROC(15)='f + fbar -> g + gamma*/Z0'
+ PROC(19)='f + fbar -> gamma + gamma*/Z0'
+ PROC(30)='f + g -> f + gamma*/Z0'
+ PROC(35)='f + gamma -> f + gamma*/Z0'
+ ENDIF
+
+C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
+ IF(MSTP(44).EQ.1) THEN
+ PROC(141)='f + fbar -> gamma*'
+ ELSEIF(MSTP(44).EQ.2) THEN
+ PROC(141)='f + fbar -> Z0'
+ ELSEIF(MSTP(44).EQ.3) THEN
+ PROC(141)='f + fbar -> Z''0'
+ ELSEIF(MSTP(44).EQ.4) THEN
+ PROC(141)='f + fbar -> gamma*/Z0'
+ ELSEIF(MSTP(44).EQ.5) THEN
+ PROC(141)='f + fbar -> gamma*/Z''0'
+ ELSEIF(MSTP(44).EQ.6) THEN
+ PROC(141)='f + fbar -> Z0/Z''0'
+ ELSEIF(MSTP(44).EQ.7) THEN
+ PROC(141)='f + fbar -> gamma*/Z0/Z''0'
+ ENDIF
+
+C...Special cases in treatment of WW -> WW: redefine process name.
+ IF(MSTP(45).EQ.1) THEN
+ PROC(77)='W+ + W+ -> W+ + W+'
+ ELSEIF(MSTP(45).EQ.2) THEN
+ PROC(77)='W+ + W- -> W+ + W-'
+ ELSEIF(MSTP(45).EQ.3) THEN
+ PROC(77)='W+/- + W+/- -> W+/- + W+/-'
+ ENDIF
+
+C...Format for error information.
+ 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
+ &'combination'/1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINBM
+C...Identifies the two incoming particles and the choice of frame.
+
+ SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
+C...Local arrays, character variables and data.
+ CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
+ &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
+ DIMENSION LEN(3),KCDE(29),PM(2)
+ DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
+ &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+ DATA CHCDE/'e- ','e+ ','nu_e ','nu_ebar ',
+ &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
+ &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
+ &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
+ &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
+ &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
+ DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
+ &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
+ &3312,3322,3334,111,28,29/
+
+C...Store initial energy. Default frame.
+ VINT(290)=WIN
+ MINT(111)=0
+
+C...Convert character variables to lowercase and find their length.
+ CHCOM(1)=CHFRAM
+ CHCOM(2)=CHBEAM
+ CHCOM(3)=CHTARG
+ DO 130 I=1,3
+ LEN(I)=8
+ DO 110 LL=8,1,-1
+ IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
+ DO 100 LA=1,26
+ IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
+ & CHALP(1)(LA:LA)
+ 100 CONTINUE
+ 110 CONTINUE
+ CHIDNT(I)=CHCOM(I)
+
+C...Fix up bar, underscore and charge in particle name (if needed).
+ DO 120 LL=1,6
+ IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
+ CHTEMP=CHIDNT(I)
+ CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' '
+ ENDIF
+ 120 CONTINUE
+ IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
+ IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
+ CHTEMP=CHIDNT(I)
+ CHIDNT(I)='nu_'//CHTEMP(3:7)
+ ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
+ CHIDNT(I)(1:3)='n0 '
+ ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
+ CHIDNT(I)(1:5)='nbar0'
+ ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
+ CHIDNT(I)(1:3)='p+ '
+ ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
+ & CHIDNT(I)(1:2).EQ.'p-') THEN
+ CHIDNT(I)(1:5)='pbar-'
+ ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
+ CHIDNT(I)(7:7)='0'
+ ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
+ CHIDNT(I)(1:7)='reggeon'
+ ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
+ CHIDNT(I)(1:7)='pomeron'
+ ENDIF
+ 130 CONTINUE
+
+C...Identify free initialization.
+ IF(CHCOM(1)(1:2).EQ.'no') THEN
+ MINT(65)=1
+ RETURN
+ ENDIF
+
+C...Identify incoming beam and target particles.
+ DO 150 I=1,2
+ DO 140 J=1,29
+ IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
+ 140 CONTINUE
+ PM(I)=PYMASS(MINT(10+I))
+ VINT(2+I)=PM(I)
+ 150 CONTINUE
+ IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
+ IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
+ IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
+
+C...Identify choice of frame and input energies.
+ CHINIT=' '
+
+C...Events defined in the CM frame.
+ IF(CHCOM(1)(1:2).EQ.'cm') THEN
+ MINT(111)=1
+ S=WIN**2
+ IF(MSTP(122).GE.1) THEN
+ IF(CHCOM(2)(1:1).NE.'e') THEN
+ LOFFS=(31-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' collider'//' '
+ ELSE
+ LOFFS=(30-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' collider'//' '
+ ENDIF
+ WRITE(MSTU(11),5200) CHINIT
+ WRITE(MSTU(11),5300) WIN
+ ENDIF
+
+C...Events defined in fixed target frame.
+ ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
+ MINT(111)=2
+ S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
+ IF(MSTP(122).GE.1) THEN
+ LOFFS=(29-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' fixed target'//' '
+ WRITE(MSTU(11),5200) CHINIT
+ WRITE(MSTU(11),5400) WIN
+ WRITE(MSTU(11),5500) SQRT(S)
+ ENDIF
+
+C...Frame defined by user three-vectors.
+ ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
+ MINT(111)=3
+ P(1,5)=PM(1)
+ P(2,5)=PM(2)
+ P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
+ P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
+ S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
+ & (P(1,3)+P(2,3))**2
+ IF(MSTP(122).GE.1) THEN
+ LOFFS=(12-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' user-specified configuration'//' '
+ WRITE(MSTU(11),5200) CHINIT
+ WRITE(MSTU(11),5600)
+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
+ ENDIF
+
+C...Frame defined by user four-vectors.
+ ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
+ MINT(111)=4
+ PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
+ P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
+ PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
+ P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
+ S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
+ & (P(1,3)+P(2,3))**2
+ IF(MSTP(122).GE.1) THEN
+ LOFFS=(12-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' user-specified configuration'//' '
+ WRITE(MSTU(11),5200) CHINIT
+ WRITE(MSTU(11),5600)
+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
+ ENDIF
+
+C...Frame defined by user five-vectors.
+ ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
+ MINT(111)=5
+ S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
+ & (P(1,3)+P(2,3))**2
+ IF(MSTP(122).GE.1) THEN
+ LOFFS=(12-(LEN(2)+LEN(3)))/2
+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
+ & ' user-specified configuration'//' '
+ WRITE(MSTU(11),5200) CHINIT
+ WRITE(MSTU(11),5600)
+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
+ ENDIF
+
+C...Unknown frame. Error for too low CM energy.
+ ELSE
+ WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
+ STOP
+ ENDIF
+ IF(S.LT.PARP(2)**2) THEN
+ WRITE(MSTU(11),5900) SQRT(S)
+ STOP
+ ENDIF
+
+C...Formats for initialization and error information.
+ 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
+ &1X,'Execution stopped!')
+ 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
+ &1X,'Execution stopped!')
+ 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
+ 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
+ &19X,'I'/1X,'I',76X,'I'/1X,78('='))
+ 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
+ 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
+ &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
+ 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
+ &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
+ 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
+ 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
+ &1X,'Execution stopped!')
+ 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
+ &'generation.'/1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINKI
+C...Sets up kinematics, including rotations and boosts to/from CM frame.
+
+ SUBROUTINE PYINKI(MODKI)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
+
+C...Set initial flavour state.
+ N=2
+ DO 100 I=1,2
+ K(I,1)=1
+ K(I,2)=MINT(10+I)
+ 100 CONTINUE
+
+C...Reset boost. Do kinematics for various cases.
+ DO 110 J=6,10
+ VINT(J)=0D0
+ 110 CONTINUE
+
+C...Set up kinematics for events defined in CM frame.
+ IF(MINT(111).EQ.1) THEN
+ WIN=VINT(290)
+ IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
+ S=WIN**2
+ P(1,5)=VINT(3)
+ P(2,5)=VINT(4)
+ P(1,1)=0D0
+ P(1,2)=0D0
+ P(2,1)=0D0
+ P(2,2)=0D0
+ P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
+ & (4D0*S))
+ P(2,3)=-P(1,3)
+ P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
+ P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
+
+C...Set up kinematics for fixed target events.
+ ELSEIF(MINT(111).EQ.2) THEN
+ WIN=VINT(290)
+ IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
+ P(1,5)=VINT(3)
+ P(2,5)=VINT(4)
+ P(1,1)=0D0
+ P(1,2)=0D0
+ P(2,1)=0D0
+ P(2,2)=0D0
+ P(1,3)=WIN
+ P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
+ P(2,3)=0D0
+ P(2,4)=P(2,5)
+ S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
+ VINT(10)=P(1,3)/(P(1,4)+P(2,4))
+ CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
+
+C...Set up kinematics for events in user-defined frame.
+ ELSEIF(MINT(111).EQ.3) THEN
+ P(1,5)=VINT(3)
+ P(2,5)=VINT(4)
+ P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
+ P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
+ DO 120 J=1,3
+ VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
+ 120 CONTINUE
+ CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
+ VINT(7)=PYANGL(P(1,1),P(1,2))
+ CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
+ VINT(6)=PYANGL(P(1,3),P(1,1))
+ CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
+ S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
+
+C...Set up kinematics for events with user-defined four-vectors.
+ ELSEIF(MINT(111).EQ.4) THEN
+ PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
+ P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
+ PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
+ P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
+ DO 130 J=1,3
+ VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
+ 130 CONTINUE
+ CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
+ VINT(7)=PYANGL(P(1,1),P(1,2))
+ CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
+ VINT(6)=PYANGL(P(1,3),P(1,1))
+ CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
+ S=(P(1,4)+P(2,4))**2
+
+C...Set up kinematics for events with user-defined five-vectors.
+ ELSEIF(MINT(111).EQ.5) THEN
+ DO 140 J=1,3
+ VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
+ 140 CONTINUE
+ CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
+ VINT(7)=PYANGL(P(1,1),P(1,2))
+ CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
+ VINT(6)=PYANGL(P(1,3),P(1,1))
+ CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
+ S=(P(1,4)+P(2,4))**2
+ ENDIF
+
+C...Return or error for too low CM energy.
+ IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
+ IF(MSTP(172).LE.1) THEN
+ CALL PYERRM(23,
+ & '(PYINKI:) too low invariant mass in this event')
+ ELSE
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ ENDIF
+
+C...Save information on incoming particles.
+ VINT(1)=SQRT(S)
+ VINT(2)=S
+ IF(MINT(111).GE.4) VINT(3)=P(1,5)
+ IF(MINT(111).GE.4) VINT(4)=P(2,5)
+ VINT(5)=P(1,3)
+ IF(MODKI.EQ.0) VINT(289)=S
+ DO 150 J=1,5
+ V(1,J)=0D0
+ V(2,J)=0D0
+ VINT(290+J)=P(1,J)
+ VINT(295+J)=P(2,J)
+ 150 CONTINUE
+
+C...Store pT cut-off and related constants to be used in generation.
+ IF(MODKI.EQ.0) VINT(285)=CKIN(3)
+ IF(MSTP(82).LE.1) THEN
+ IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
+ & LOG(900D0/200D0)
+ PTMN=PARP(81)
+ ELSE
+ IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
+ & LOG(900D0/200D0)
+ PTMN=PARP(82)
+ ENDIF
+ VINT(149)=4D0*PTMN**2/S
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINPR
+C...Selects partonic subprocesses to be included in the simulation.
+
+ SUBROUTINE PYINPR
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
+
+C...Reset processes to be included.
+ IF(MSEL.NE.0) THEN
+ DO 100 I=1,500
+ MSUB(I)=0
+ 100 CONTINUE
+ ENDIF
+
+C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
+ IF(MINT(121).EQ.2) THEN
+ MSUB(10)=1
+ MINT(123)=MINT(122)+1
+
+C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
+C...Here also set a few parameters otherwise normally not touched.
+ ELSEIF(MINT(121).GT.1) THEN
+
+C...Parton distributions dampened at small Q2; go to low energies,
+C...alpha_s <1; no minimum pT cut-off a priori.
+ MSTP(57)=3
+ MSTP(85)=0
+ PARP(2)=2D0
+ PARU(115)=1D0
+ CKIN(5)=0.2D0
+ CKIN(6)=0.2D0
+
+C...Define pT cut-off parameters and whether run involves low-pT.
+ IF(MSTP(82).LE.1) THEN
+ PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
+ ELSE
+ PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
+ ENDIF
+ PTMDIR=PARP(15)
+ PTMANO=PTMVMD
+ IF(MSTP(15).EQ.5) PTMANO=0.60D0+
+ & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
+ IPTL=1
+ IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
+ IF(MSEL.EQ.2) IPTL=1
+
+C...Set up for p/VMD * VMD.
+ IF(MINT(122).EQ.1) THEN
+ MINT(123)=2
+ MSUB(11)=1
+ MSUB(12)=1
+ MSUB(13)=1
+ MSUB(28)=1
+ MSUB(53)=1
+ MSUB(68)=1
+ IF(IPTL.EQ.1) MSUB(95)=1
+ IF(MSEL.EQ.2) THEN
+ MSUB(91)=1
+ MSUB(92)=1
+ MSUB(93)=1
+ MSUB(94)=1
+ ENDIF
+ PARP(81)=PTMVMD
+ PARP(82)=PTMVMD
+ IF(IPTL.EQ.1) CKIN(3)=0D0
+
+C...Set up for p/VMD * direct gamma.
+ ELSEIF(MINT(122).EQ.2) THEN
+ MINT(123)=0
+ IF(MINT(121).EQ.6) MINT(123)=5
+ MSUB(33)=1
+ MSUB(54)=1
+ IF(IPTL.EQ.1) CKIN(3)=PTMDIR
+
+C...Set up for p/VMD * anomalous gamma.
+ ELSEIF(MINT(122).EQ.3) THEN
+ MINT(123)=3
+ IF(MINT(121).EQ.6) MINT(123)=7
+ MSUB(11)=1
+ MSUB(12)=1
+ MSUB(13)=1
+ MSUB(28)=1
+ MSUB(53)=1
+ MSUB(68)=1
+ IF(MSTP(82).GE.2) MSTP(85)=1
+ IF(IPTL.EQ.1) CKIN(3)=PTMANO
+
+C...Set up for direct * direct gamma (switch off leptons).
+ ELSEIF(MINT(122).EQ.4) THEN
+ MINT(123)=0
+ MSUB(58)=1
+ DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
+ IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
+ 110 CONTINUE
+ IF(IPTL.EQ.1) CKIN(3)=PTMDIR
+
+C...Set up for direct * anomalous gamma.
+ ELSEIF(MINT(122).EQ.5) THEN
+ MINT(123)=6
+ MSUB(33)=1
+ MSUB(54)=1
+ IF(IPTL.EQ.1) CKIN(3)=PTMANO
+
+C...Set up for anomalous * anomalous gamma.
+ ELSEIF(MINT(122).EQ.6) THEN
+ MINT(123)=3
+ MSUB(11)=1
+ MSUB(12)=1
+ MSUB(13)=1
+ MSUB(28)=1
+ MSUB(53)=1
+ MSUB(68)=1
+ IF(MSTP(82).GE.2) MSTP(85)=1
+ IF(IPTL.EQ.1) CKIN(3)=PTMANO
+ ENDIF
+
+C...End of special set up for gamma-p and gamma-gamma.
+ CKIN(1)=2D0*CKIN(3)
+ ENDIF
+
+C...Flavour information for individual beams.
+ DO 120 I=1,2
+ MINT(40+I)=1
+ IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
+ IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
+ IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
+ MINT(44+I)=MINT(40+I)
+ IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
+ 120 CONTINUE
+
+C...If two gammas, whereof one direct, pick the first.
+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
+ IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
+ MINT(41)=1
+ MINT(45)=1
+ ENDIF
+ ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
+ IF(MINT(123).GE.4) CALL PYERRM(26,
+ & '(PYINPR:) unallowed MSTP(14) code for single photon')
+ ENDIF
+
+C...Flavour information on combination of incoming particles.
+ MINT(43)=2*MINT(41)+MINT(42)-2
+ MINT(44)=MINT(43)
+ IF(MINT(123).LE.0) THEN
+ IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
+ IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
+ ELSEIF(MINT(123).LE.3) THEN
+ IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
+ IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
+ ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
+ MINT(43)=4
+ MINT(44)=1
+ ENDIF
+ MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
+ IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
+ MINT(50)=0
+ IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
+ &MINT(50)=0
+ MINT(107)=0
+ IF(MINT(11).EQ.22) THEN
+ MINT(107)=MINT(123)
+ IF(MINT(123).GE.4) MINT(107)=0
+ IF(MINT(123).EQ.7) MINT(107)=2
+ ENDIF
+ MINT(108)=0
+ IF(MINT(12).EQ.22) THEN
+ MINT(108)=MINT(123)
+ IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
+ IF(MINT(123).EQ.7) MINT(108)=3
+ ENDIF
+
+C...Select default processes according to incoming beams
+C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
+ IF(MINT(121).GT.1) THEN
+ ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
+
+ IF(MINT(43).EQ.1) THEN
+C...Lepton + lepton -> gamma/Z0 or W.
+ IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
+ IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
+
+ ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
+ & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
+C...Unresolved photon + lepton: Compton scattering.
+ MSUB(34)=1
+
+ ELSEIF(MINT(43).LE.3) THEN
+C...Lepton + hadron: deep inelastic scattering.
+ MSUB(10)=1
+
+ ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
+ & MINT(12).EQ.22) THEN
+C...Two unresolved photons: fermion pair production.
+ MSUB(58)=1
+
+ ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
+ & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
+ & MINT(12).EQ.22)) THEN
+C...Unresolved photon + hadron: photon-parton scattering.
+ MSUB(33)=1
+ MSUB(34)=1
+ MSUB(54)=1
+
+ ELSEIF(MSEL.EQ.1) THEN
+C...High-pT QCD processes:
+ MSUB(11)=1
+ MSUB(12)=1
+ MSUB(13)=1
+ MSUB(28)=1
+ MSUB(53)=1
+ MSUB(68)=1
+ IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
+ IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
+ IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
+
+ ELSE
+C...All QCD processes:
+ MSUB(11)=1
+ MSUB(12)=1
+ MSUB(13)=1
+ MSUB(28)=1
+ MSUB(53)=1
+ MSUB(68)=1
+ MSUB(91)=1
+ MSUB(92)=1
+ MSUB(93)=1
+ MSUB(94)=1
+ MSUB(95)=1
+ ENDIF
+
+ ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
+C...Heavy quark production.
+ MSUB(81)=1
+ MSUB(82)=1
+ MSUB(84)=1
+ DO 130 J=1,MIN(8,MDCY(21,3))
+ MDME(MDCY(21,2)+J-1,1)=0
+ 130 CONTINUE
+ MDME(MDCY(21,2)+MSEL-1,1)=1
+ MSUB(85)=1
+ DO 140 J=1,MIN(12,MDCY(22,3))
+ MDME(MDCY(22,2)+J-1,1)=0
+ 140 CONTINUE
+ MDME(MDCY(22,2)+MSEL-1,1)=1
+
+ ELSEIF(MSEL.EQ.10) THEN
+C...Prompt photon production:
+ MSUB(14)=1
+ MSUB(18)=1
+ MSUB(29)=1
+
+ ELSEIF(MSEL.EQ.11) THEN
+C...Z0/gamma* production:
+ MSUB(1)=1
+
+ ELSEIF(MSEL.EQ.12) THEN
+C...W+/- production:
+ MSUB(2)=1
+
+ ELSEIF(MSEL.EQ.13) THEN
+C...Z0 + jet:
+ MSUB(15)=1
+ MSUB(30)=1
+
+ ELSEIF(MSEL.EQ.14) THEN
+C...W+/- + jet:
+ MSUB(16)=1
+ MSUB(31)=1
+
+ ELSEIF(MSEL.EQ.15) THEN
+C...Z0 & W+/- pair production:
+ MSUB(19)=1
+ MSUB(20)=1
+ MSUB(22)=1
+ MSUB(23)=1
+ MSUB(25)=1
+
+ ELSEIF(MSEL.EQ.16) THEN
+C...h0 production:
+ MSUB(3)=1
+ MSUB(102)=1
+ MSUB(103)=1
+ MSUB(123)=1
+ MSUB(124)=1
+
+ ELSEIF(MSEL.EQ.17) THEN
+C...h0 & Z0 or W+/- pair production:
+ MSUB(24)=1
+ MSUB(26)=1
+
+ ELSEIF(MSEL.EQ.18) THEN
+C...h0 production; interesting processes in e+e-.
+ MSUB(24)=1
+ MSUB(103)=1
+ MSUB(123)=1
+ MSUB(124)=1
+
+ ELSEIF(MSEL.EQ.19) THEN
+C...h0, H0 and A0 production; interesting processes in e+e-.
+ MSUB(24)=1
+ MSUB(103)=1
+ MSUB(123)=1
+ MSUB(124)=1
+ MSUB(153)=1
+ MSUB(171)=1
+ MSUB(173)=1
+ MSUB(174)=1
+ MSUB(158)=1
+ MSUB(176)=1
+ MSUB(178)=1
+ MSUB(179)=1
+
+ ELSEIF(MSEL.EQ.21) THEN
+C...Z'0 production:
+ MSUB(141)=1
+
+ ELSEIF(MSEL.EQ.22) THEN
+C...W'+/- production:
+ MSUB(142)=1
+
+ ELSEIF(MSEL.EQ.23) THEN
+C...H+/- production:
+ MSUB(143)=1
+
+ ELSEIF(MSEL.EQ.24) THEN
+C...R production:
+ MSUB(144)=1
+
+ ELSEIF(MSEL.EQ.25) THEN
+C...LQ (leptoquark) production.
+ MSUB(145)=1
+ MSUB(162)=1
+ MSUB(163)=1
+ MSUB(164)=1
+
+ ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
+C...Production of one heavy quark (W exchange):
+ MSUB(83)=1
+ DO 150 J=1,MIN(8,MDCY(21,3))
+ MDME(MDCY(21,2)+J-1,1)=0
+ 150 CONTINUE
+ MDME(MDCY(21,2)+MSEL-31,1)=1
+
+CMRENNA++Define SUSY alternatives.
+ ELSEIF(MSEL.EQ.39) THEN
+C...Turn on all SUSY processes.
+ IF(MINT(43).EQ.4) THEN
+C...Hadron-hadron processes.
+ DO 160 I=201,280
+ IF(ISET(I).GE.0) MSUB(I)=1
+ 160 CONTINUE
+ ELSEIF(MINT(43).EQ.1) THEN
+C...Lepton-lepton processes: QED production of squarks.
+ DO 170 I=201,214
+ MSUB(I)=1
+ 170 CONTINUE
+ MSUB(210)=0
+ MSUB(211)=0
+ MSUB(212)=0
+ DO 180 I=216,228
+ MSUB(I)=1
+ 180 CONTINUE
+ DO 190 I=261,263
+ MSUB(I)=1
+ 190 CONTINUE
+ MSUB(277)=1
+ MSUB(278)=1
+ ENDIF
+
+ ELSEIF(MSEL.EQ.40) THEN
+C...Gluinos and squarks.
+ IF(MINT(43).EQ.4) THEN
+ MSUB(243)=1
+ MSUB(244)=1
+ MSUB(258)=1
+ MSUB(259)=1
+ MSUB(261)=1
+ MSUB(262)=1
+ MSUB(264)=1
+ MSUB(265)=1
+ DO 200 I=271,280
+ MSUB(I)=1
+ 200 CONTINUE
+ ELSEIF(MINT(43).EQ.1) THEN
+ MSUB(277)=1
+ MSUB(278)=1
+ ENDIF
+
+ ELSEIF(MSEL.EQ.41) THEN
+C...Stop production.
+ MSUB(261)=1
+ MSUB(262)=1
+ MSUB(263)=1
+ IF(MINT(43).EQ.4) THEN
+ MSUB(264)=1
+ MSUB(265)=1
+ ENDIF
+
+ ELSEIF(MSEL.EQ.42) THEN
+C...Slepton production.
+ DO 210 I=201,214
+ MSUB(I)=1
+ 210 CONTINUE
+ IF(MINT(43).NE.4) THEN
+ MSUB(210)=0
+ MSUB(211)=0
+ MSUB(212)=0
+ ENDIF
+
+ ELSEIF(MSEL.EQ.43) THEN
+C...Neutralino/Chargino + Gluino/Squark.
+ IF(MINT(43).EQ.4) THEN
+ DO 220 I=237,242
+ MSUB(I)=1
+ 220 CONTINUE
+ DO 230 I=246,257
+ MSUB(I)=1
+ 230 CONTINUE
+ ENDIF
+
+ ELSEIF(MSEL.EQ.44) THEN
+C...Neutralino/Chargino pair production.
+ IF(MINT(43).EQ.4) THEN
+ DO 240 I=216,236
+ MSUB(I)=1
+ 240 CONTINUE
+ ELSEIF(MINT(43).EQ.1) THEN
+ DO 250 I=216,228
+ MSUB(I)=1
+ 250 CONTINUE
+ ENDIF
+ ENDIF
+
+C...Find heaviest new quark flavour allowed in processes 81-84.
+ KFLQM=1
+ DO 260 I=1,MIN(8,MDCY(21,3))
+ IDC=I+MDCY(21,2)-1
+ IF(MDME(IDC,1).LE.0) GOTO 260
+ KFLQM=I
+ 260 CONTINUE
+ IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
+ &KFLQM=MSTP(7)
+ MINT(55)=KFLQM
+ KFPR(81,1)=KFLQM
+ KFPR(81,2)=KFLQM
+ KFPR(82,1)=KFLQM
+ KFPR(82,2)=KFLQM
+ KFPR(83,1)=KFLQM
+ KFPR(84,1)=KFLQM
+ KFPR(84,2)=KFLQM
+
+C...Find heaviest new fermion flavour allowed in process 85.
+ KFLFM=1
+ DO 270 I=1,MIN(12,MDCY(22,3))
+ IDC=I+MDCY(22,2)-1
+ IF(MDME(IDC,1).LE.0) GOTO 270
+ KFLFM=KFDP(IDC,1)
+ 270 CONTINUE
+ IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
+ &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
+ MINT(56)=KFLFM
+ KFPR(85,1)=KFLFM
+ KFPR(85,2)=KFLFM
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXTOT
+C...Parametrizes total, elastic and diffractive cross-sections
+C...for different energies and beams. Donnachie-Landshoff for
+C...total and Schuler-Sjostrand for elastic and diffractive.
+C...Process code IPROC:
+C...= 1 : p + p;
+C...= 2 : pbar + p;
+C...= 3 : pi+ + p;
+C...= 4 : pi- + p;
+C...= 5 : pi0 + p;
+C...= 6 : phi + p;
+C...= 7 : J/psi + p;
+C...= 11 : rho + rho;
+C...= 12 : rho + phi;
+C...= 13 : rho + J/psi;
+C...= 14 : phi + phi;
+C...= 15 : phi + J/psi;
+C...= 16 : J/psi + J/psi;
+C...= 21 : gamma + p (DL);
+C...= 22 : gamma + p (VDM).
+C...= 23 : gamma + pi (DL);
+C...= 24 : gamma + pi (VDM);
+C...= 25 : gamma + gamma (DL);
+C...= 26 : gamma + gamma (VDM).
+
+ SUBROUTINE PYXTOT
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
+C...Local arrays.
+ DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
+ &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
+ &CEFFD(10,9),SIGTMP(6,0:5)
+
+C...Common constants.
+ DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
+ &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
+ &FACDD/0.0084D0/
+
+C...Number of multiple processes to be evaluated (= 0 : undefined).
+ DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
+C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
+ DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
+ &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
+ &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
+ DATA YPAR/
+ &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
+ &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
+ &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
+
+C...Beam and target hadron class:
+C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
+ DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
+ DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
+C...Characteristic class masses, slope parameters, beta = sqrt(X).
+ DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
+ DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
+ DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
+
+C...Fitting constants used in parametrizations of diffractive results.
+ DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
+ DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
+ DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
+ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
+ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
+ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
+ &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
+ &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
+ &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
+ &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
+ &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
+ &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
+ &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
+ DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
+ &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
+ &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
+ &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
+ &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
+ &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
+ &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
+ &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
+ &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
+ &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
+ &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
+ &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
+ &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
+ &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
+ &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
+ &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
+
+C...Parameters. Combinations of the energy.
+ AEM=PARU(101)
+ PMTH=PARP(102)
+ S=VINT(2)
+ SRT=VINT(1)
+ SEPS=S**EPS
+ SETA=S**ETA
+ SLOG=LOG(S)
+
+C...Ratio of gamma/pi (for rescaling in parton distributions).
+ VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
+ &(XPAR(5)*SEPS+YPAR(5)*SETA)
+ IF(MINT(50).NE.1) RETURN
+
+C...Order flavours of incoming particles: KF1 < KF2.
+ IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
+ KF1=IABS(MINT(11))
+ KF2=IABS(MINT(12))
+ IORD=1
+ ELSE
+ KF1=IABS(MINT(12))
+ KF2=IABS(MINT(11))
+ IORD=2
+ ENDIF
+ ISGN12=ISIGN(1,MINT(11)*MINT(12))
+
+C...Find process number (for lookup tables).
+ IF(KF1.GT.1000) THEN
+ IPROC=1
+ IF(ISGN12.LT.0) IPROC=2
+ ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
+ IPROC=3
+ IF(ISGN12.LT.0) IPROC=4
+ IF(KF1.EQ.111) IPROC=5
+ ELSEIF(KF1.GT.100) THEN
+ IPROC=11
+ ELSEIF(KF2.GT.1000) THEN
+ IPROC=21
+ IF(MINT(123).EQ.2) IPROC=22
+ ELSEIF(KF2.GT.100) THEN
+ IPROC=23
+ IF(MINT(123).EQ.2) IPROC=24
+ ELSE
+ IPROC=25
+ IF(MINT(123).EQ.2) IPROC=26
+ ENDIF
+
+C... Number of multiple processes to be stored; beam/target side.
+ NPR=NPROC(IPROC)
+ MINT(101)=1
+ MINT(102)=1
+ IF(NPR.EQ.3) THEN
+ MINT(100+IORD)=4
+ ELSEIF(NPR.EQ.6) THEN
+ MINT(101)=4
+ MINT(102)=4
+ ENDIF
+ N1=0
+ IF(MINT(101).EQ.4) N1=4
+ N2=0
+ IF(MINT(102).EQ.4) N2=4
+
+C...Do not do any more for user-set or undefined cross-sections.
+ IF(MSTP(31).LE.0) RETURN
+ IF(NPR.EQ.0) CALL PYERRM(26,
+ &'(PYXTOT:) cross section for this process not yet implemented')
+
+C...Parameters. Combinations of the energy.
+ AEM=PARU(101)
+ PMTH=PARP(102)
+ S=VINT(2)
+ SRT=VINT(1)
+ SEPS=S**EPS
+ SETA=S**ETA
+ SLOG=LOG(S)
+
+C...Loop over multiple processes (for VDM).
+ DO 110 I=1,NPR
+ IF(NPR.EQ.1) THEN
+ IPR=IPROC
+ ELSEIF(NPR.EQ.3) THEN
+ IPR=I+4
+ IF(KF2.LT.1000) IPR=I+10
+ ELSEIF(NPR.EQ.6) THEN
+ IPR=I+10
+ ENDIF
+
+C...Evaluate hadron species, mass, slope contribution and fit number.
+ IHA=IHADA(IPR)
+ IHB=IHADB(IPR)
+ PMA=PMHAD(IHA)
+ PMB=PMHAD(IHB)
+ BHA=BHAD(IHA)
+ BHB=BHAD(IHB)
+ ISD=IFITSD(IPR)
+ IDD=IFITDD(IPR)
+
+C...Skip if energy too low relative to masses.
+ DO 100 J=0,5
+ SIGTMP(I,J)=0D0
+ 100 CONTINUE
+ IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
+
+C...Total cross-section. Elastic slope parameter and cross-section.
+ SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
+ BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
+ SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
+
+C...Diffractive scattering A + B -> X + B.
+ BSD=2D0*BHB
+ SQML=(PMA+PMTH)**2
+ SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
+ SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
+ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
+ BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
+ SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
+ & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
+ SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
+
+C...Diffractive scattering A + B -> A + X.
+ BSD=2D0*BHA
+ SQML=(PMB+PMTH)**2
+ SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
+ SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
+ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
+ BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
+ SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
+ & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
+ SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
+
+C...Order single diffractive correctly.
+ IF(IORD.EQ.2) THEN
+ SIGSAV=SIGTMP(I,2)
+ SIGTMP(I,2)=SIGTMP(I,3)
+ SIGTMP(I,3)=SIGSAV
+ ENDIF
+
+C...Double diffractive scattering A + B -> X1 + X2.
+ YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
+ DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
+ SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
+ IF(YEFF.LE.0) SUM1=0D0
+ SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
+ SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
+ SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
+ SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
+ & (2D0*ALP)
+ SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
+ SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
+ SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
+ & (2D0*ALP)
+ BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
+ SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
+ SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
+ & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
+ SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
+
+C...Non-diffractive by unitarity.
+ SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
+ & SIGTMP(I,4)
+ 110 CONTINUE
+
+C...Put temporary results in output array: only one process.
+ IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
+ DO 120 J=0,5
+ SIGT(0,0,J)=SIGTMP(1,J)
+ 120 CONTINUE
+
+C...Beam multiple processes.
+ ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
+ DO 140 I=1,4
+ CONV=AEM/PARP(160+I)
+ I1=MAX(1,I-1)
+ DO 130 J=0,5
+ SIGT(I,0,J)=CONV*SIGTMP(I1,J)
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 150 J=0,5
+ SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
+ 150 CONTINUE
+
+C...Target multiple processes.
+ ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
+ DO 170 I=1,4
+ CONV=AEM/PARP(160+I)
+ IV=MAX(1,I-1)
+ DO 160 J=0,5
+ SIGT(0,I,J)=CONV*SIGTMP(IV,J)
+ 160 CONTINUE
+ 170 CONTINUE
+ DO 180 J=0,5
+ SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
+ 180 CONTINUE
+
+C...Both beam and target multiple processes.
+ ELSE
+ DO 210 I1=1,4
+ DO 200 I2=1,4
+ CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
+ IF(I1.LE.2) THEN
+ IV=MAX(1,I2-1)
+ ELSEIF(I2.LE.2) THEN
+ IV=MAX(1,I1-1)
+ ELSEIF(I1.EQ.I2) THEN
+ IV=2*I1-2
+ ELSE
+ IV=5
+ ENDIF
+ DO 190 J=0,5
+ JV=J
+ IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
+ SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
+ 190 CONTINUE
+ 200 CONTINUE
+ 210 CONTINUE
+ DO 230 J=0,5
+ DO 220 I=1,4
+ SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
+ SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
+ 220 CONTINUE
+ SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
+ 230 CONTINUE
+ ENDIF
+
+C...Scale up uniformly for Donnachie-Landshoff parametrization.
+ IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
+ RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
+ DO 260 I1=0,N1
+ DO 250 I2=0,N2
+ DO 240 J=0,5
+ SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
+ 240 CONTINUE
+ 250 CONTINUE
+ 260 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYMAXI
+C...Finds optimal set of coefficients for kinematical variable selection
+C...and the maximum of the part of the differential cross-section used
+C...in the event weighting.
+
+ SUBROUTINE PYMAXI
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
+C...Local arrays, character variables and data.
+ CHARACTER CVAR(4)*4
+ DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
+ &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
+ &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
+ DATA CVAR/'tau ','tau''','y* ','cth '/
+ DATA SIGSSM/3*0D0/
+
+C...Select subprocess to study: skip cases not applicable.
+ NPOSI=0
+ VINT(143)=1D0
+ VINT(144)=1D0
+ XSEC(0,1)=0D0
+ DO 460 ISUB=1,500
+ MINT(51)=0
+ IF(ISET(ISUB).EQ.11) THEN
+ XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
+ NPOSI=NPOSI+1
+ GOTO 450
+ ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
+ XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
+ IF(MSUB(ISUB).NE.1) GOTO 460
+ NPOSI=NPOSI+1
+ GOTO 450
+ ELSEIF(ISUB.EQ.96) THEN
+ IF(MINT(50).EQ.0) GOTO 460
+ IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
+ & GOTO 460
+ IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
+ ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
+ & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
+ IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
+ ELSE
+ IF(MSUB(ISUB).NE.1) GOTO 460
+ ENDIF
+ MINT(1)=ISUB
+ ISTSB=ISET(ISUB)
+ IF(ISUB.EQ.96) ISTSB=2
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
+ MWTXS=0
+ IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
+ & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
+
+C...Find resonances (explicit or implicit in cross-section).
+ MINT(72)=0
+ KFR1=0
+ IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
+ KFR1=KFPR(ISUB,1)
+ ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
+ & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
+ KFR1=23
+ ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
+ & .OR.ISUB.EQ.177) THEN
+ KFR1=24
+ ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
+ KFR1=25
+ IF(MSTP(46).EQ.5) THEN
+ KFR1=30
+ PMAS(30,1)=PARP(45)
+ PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
+ ENDIF
+ ELSEIF(ISUB.EQ.194) THEN
+ KFR1=54
+ ENDIF
+ CKMX=CKIN(2)
+ IF(CKMX.LE.0D0) CKMX=VINT(1)
+ KCR1=PYCOMP(KFR1)
+ IF(KFR1.NE.0) THEN
+ IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
+ & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
+ ENDIF
+ IF(KFR1.NE.0) THEN
+ TAUR1=PMAS(KCR1,1)**2/VINT(2)
+ GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
+ MINT(72)=1
+ MINT(73)=KFR1
+ VINT(73)=TAUR1
+ VINT(74)=GAMR1
+ ENDIF
+ KFR2=0
+ IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
+ KFR2=23
+ IF(ISUB.EQ.194) KFR2=56
+ KCR2=PYCOMP(KFR2)
+ TAUR2=PMAS(KCR2,1)**2/VINT(2)
+ GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
+ IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
+ & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
+ IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
+ MINT(72)=2
+ MINT(74)=KFR2
+ VINT(75)=TAUR2
+ VINT(76)=GAMR2
+ ELSEIF(KFR2.NE.0) THEN
+ KFR1=KFR2
+ TAUR1=TAUR2
+ GAMR1=GAMR2
+ MINT(72)=1
+ MINT(73)=KFR1
+ VINT(73)=TAUR1
+ VINT(74)=GAMR1
+ KFR2=0
+ ENDIF
+ ENDIF
+
+C...Find product masses and minimum pT of process.
+ SQM3=0D0
+ SQM4=0D0
+ MINT(71)=0
+ VINT(71)=CKIN(3)
+ VINT(80)=1D0
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ NBW=0
+ DO 110 I=1,2
+ PMMN(I)=0D0
+ IF(KFPR(ISUB,I).EQ.0) THEN
+ ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
+ & PARP(41)) THEN
+ IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
+ IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
+ ELSE
+ NBW=NBW+1
+C...This prevents SUSY/t particles from becoming too light.
+ KFLW=KFPR(ISUB,I)
+ IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
+ KCW=PYCOMP(KFLW)
+ PMMN(I)=PMAS(KCW,1)
+ DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
+ IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
+ PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
+ & PMAS(PYCOMP(KFDP(IDC,2)),1)
+ IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
+ & PMAS(PYCOMP(KFDP(IDC,3)),1)
+ PMMN(I)=MIN(PMMN(I),PMSUM)
+ ENDIF
+ 100 CONTINUE
+ ELSEIF(KFLW.EQ.6) THEN
+ PMMN(I)=PMAS(24,1)+PMAS(5,1)
+ ENDIF
+ ENDIF
+ 110 CONTINUE
+ IF(NBW.GE.1) THEN
+ CKIN41=CKIN(41)
+ CKIN43=CKIN(43)
+ CKIN(41)=MAX(PMMN(1),CKIN(41))
+ CKIN(43)=MAX(PMMN(2),CKIN(43))
+ CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
+ CKIN(41)=CKIN41
+ CKIN(43)=CKIN43
+ IF(MINT(51).EQ.1) THEN
+ WRITE(MSTU(11),5100) ISUB
+ MSUB(ISUB)=0
+ GOTO 460
+ ENDIF
+ SQM3=PQM3**2
+ SQM4=PQM4**2
+ ENDIF
+ IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
+ IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
+ IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
+ IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
+ ENDIF
+ VINT(63)=SQM3
+ VINT(64)=SQM4
+
+C...Prepare for additional variable choices in 2 -> 3.
+ IF(ISTSB.EQ.5) THEN
+ VINT(201)=0D0
+ IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
+ VINT(206)=VINT(201)
+ VINT(204)=PMAS(23,1)
+ IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
+ IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
+ & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
+ VINT(209)=VINT(204)
+ ENDIF
+
+C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
+ NPTS(1)=2+2*MINT(72)
+ IF(MINT(47).EQ.1) THEN
+ IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
+ ELSEIF(MINT(47).EQ.5) THEN
+ IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
+ ENDIF
+ NPTS(2)=1
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ IF(MINT(47).GE.2) NPTS(2)=2
+ IF(MINT(47).EQ.5) NPTS(2)=3
+ ENDIF
+ NPTS(3)=1
+ IF(MINT(47).GE.4) NPTS(3)=3
+ IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
+ IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
+ NPTS(4)=1
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
+ NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
+
+C...Reset coefficients of cross-section weighting.
+ DO 120 J=1,20
+ COEF(ISUB,J)=0D0
+ 120 CONTINUE
+ COEF(ISUB,1)=1D0
+ COEF(ISUB,8)=0.5D0
+ COEF(ISUB,9)=0.5D0
+ COEF(ISUB,13)=1D0
+ COEF(ISUB,18)=1D0
+ MCTH=0
+ MTAUP=0
+ METAUP=0
+ VINT(23)=0D0
+ VINT(26)=0D0
+ SIGSAM=0D0
+
+C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
+C...in grid of phase space points.
+ CALL PYKLIM(1)
+ METAU=MINT(51)
+ NACC=0
+ DO 150 ITRY=1,NTRY
+ MINT(51)=0
+ IF(METAU.EQ.1) GOTO 150
+ IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
+ MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
+ IF(MTAU.GT.2+2*MINT(72)) MTAU=7
+ RTAU=0.5D0
+C...Special case when both resonances have same mass,
+C...as is often the case in process 194.
+ IF(MINT(72).EQ.2) THEN
+ IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
+ & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
+ IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
+ RTAU=0.4D0
+ ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
+ RTAU=0.6D0
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL PYKMAP(1,MTAU,RTAU)
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
+ METAUP=MINT(51)
+ ENDIF
+ IF(METAUP.EQ.1) GOTO 150
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
+ & .EQ.0) THEN
+ MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
+ CALL PYKMAP(4,MTAUP,0.5D0)
+ ENDIF
+ IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
+ CALL PYKLIM(2)
+ MEYST=MINT(51)
+ ENDIF
+ IF(MEYST.EQ.1) GOTO 150
+ IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
+ MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
+ IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
+ CALL PYKMAP(2,MYST,0.5D0)
+ CALL PYKLIM(3)
+ MECTH=MINT(51)
+ ENDIF
+ IF(MECTH.EQ.1) GOTO 150
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ MCTH=1+MOD(ITRY-1,NPTS(4))
+ CALL PYKMAP(3,MCTH,0.5D0)
+ ENDIF
+ IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
+
+C...Store position and limits.
+ MINT(51)=0
+ CALL PYKLIM(0)
+ IF(MINT(51).EQ.1) GOTO 150
+ NACC=NACC+1
+ MVARPT(NACC,1)=MTAU
+ MVARPT(NACC,2)=MTAUP
+ MVARPT(NACC,3)=MYST
+ MVARPT(NACC,4)=MCTH
+ DO 130 J=1,30
+ VINTPT(NACC,J)=VINT(10+J)
+ 130 CONTINUE
+
+C...Normal case: calculate cross-section.
+ IF(ISTSB.NE.5) THEN
+ CALL PYSIGH(NCHN,SIGS)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGS=WTXS*SIGS
+ ENDIF
+
+C..2 -> 3: find highest value out of a number of tries.
+ ELSE
+ SIGS=0D0
+ DO 140 IKIN3=1,MSTP(129)
+ CALL PYKMAP(5,0,0D0)
+ IF(MINT(51).EQ.1) GOTO 140
+ CALL PYSIGH(NCHN,SIGTMP)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGTMP=WTXS*SIGTMP
+ ENDIF
+ IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
+ 140 CONTINUE
+ ENDIF
+
+C...Store cross-section.
+ SIGSPT(NACC)=SIGS
+ IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
+ & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
+ 150 CONTINUE
+ IF(NACC.EQ.0) THEN
+ WRITE(MSTU(11),5100) ISUB
+ MSUB(ISUB)=0
+ GOTO 460
+ ELSEIF(SIGSAM.EQ.0D0) THEN
+ WRITE(MSTU(11),5300) ISUB
+ MSUB(ISUB)=0
+ GOTO 460
+ ENDIF
+ IF(ISUB.NE.96) NPOSI=NPOSI+1
+
+C...Calculate integrals in tau over maximal phase space limits.
+ TAUMIN=VINT(11)
+ TAUMAX=VINT(31)
+ ATAU1=LOG(TAUMAX/TAUMIN)
+ IF(NPTS(1).GE.2) THEN
+ ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
+ ENDIF
+ IF(NPTS(1).GE.4) THEN
+ ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
+ ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
+ & GAMR1
+ ENDIF
+ IF(NPTS(1).GE.6) THEN
+ ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
+ ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
+ & GAMR2
+ ENDIF
+ IF(NPTS(1).GT.2+2*MINT(72)) THEN
+ ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
+ ENDIF
+
+C...Reset. Sum up cross-sections in points calculated.
+ DO 320 IVAR=1,4
+ IF(NPTS(IVAR).EQ.1) GOTO 320
+ IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
+ NBIN=NPTS(IVAR)
+ DO 170 J1=1,NBIN
+ NAREL(J1)=0
+ WTREL(J1)=0D0
+ COEFU(J1)=0D0
+ DO 160 J2=1,NBIN
+ WTMAT(J1,J2)=0D0
+ 160 CONTINUE
+ 170 CONTINUE
+ DO 180 IACC=1,NACC
+ IBIN=MVARPT(IACC,IVAR)
+ IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
+ IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
+ NAREL(IBIN)=NAREL(IBIN)+1
+ WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
+
+C...Sum up tau cross-section pieces in points used.
+ IF(IVAR.EQ.1) THEN
+ TAU=VINTPT(IACC,11)
+ WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
+ WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
+ IF(NBIN.GE.4) THEN
+ WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
+ WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
+ & ((TAU-TAUR1)**2+GAMR1**2)
+ ENDIF
+ IF(NBIN.GE.6) THEN
+ WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
+ WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
+ & ((TAU-TAUR2)**2+GAMR2**2)
+ ENDIF
+ IF(NBIN.GT.2+2*MINT(72)) THEN
+ WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
+ & TAU/MAX(2D-6,1D0-TAU)
+ ENDIF
+
+C...Sum up tau' cross-section pieces in points used.
+ ELSEIF(IVAR.EQ.2) THEN
+ TAU=VINTPT(IACC,11)
+ TAUP=VINTPT(IACC,16)
+ TAUPMN=VINTPT(IACC,6)
+ TAUPMX=VINTPT(IACC,26)
+ ATAUP1=LOG(TAUPMX/TAUPMN)
+ ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
+ WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
+ WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
+ & (1D0-TAU/TAUP)**3/TAUP
+ IF(NBIN.GE.3) THEN
+ ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
+ WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
+ & TAUP/MAX(2D-6,1D0-TAUP)
+ ENDIF
+
+C...Sum up y* cross-section pieces in points used.
+ ELSEIF(IVAR.EQ.3) THEN
+ YST=VINTPT(IACC,12)
+ YSTMIN=VINTPT(IACC,2)
+ YSTMAX=VINTPT(IACC,22)
+ AYST0=YSTMAX-YSTMIN
+ AYST1=0.5D0*(YSTMAX-YSTMIN)**2
+ AYST2=AYST1
+ AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
+ WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
+ WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
+ WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
+ IF(MINT(45).EQ.3) THEN
+ TAUE=VINTPT(IACC,11)
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
+ YST0=-0.5D0*LOG(TAUE)
+ AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
+ & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
+ WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
+ & MAX(1D-6,1D0-EXP(YST-YST0))
+ ENDIF
+ IF(MINT(46).EQ.3) THEN
+ TAUE=VINTPT(IACC,11)
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
+ YST0=-0.5D0*LOG(TAUE)
+ AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
+ & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
+ WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
+ & MAX(1D-6,1D0-EXP(-YST-YST0))
+ ENDIF
+
+C...Sum up cos(theta-hat) cross-section pieces in points used.
+ ELSE
+ RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
+ RSQM=1D0+RM34
+ CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
+ CTHMIN=-CTHMAX
+ IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
+ & (TAUMAX*VINT(2)))
+ ACTH1=CTHMAX-CTHMIN
+ ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
+ ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
+ ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
+ ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
+ CTH=VINTPT(IACC,13)
+ WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
+ WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
+ & MAX(RM34,RSQM-CTH)
+ WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
+ & MAX(RM34,RSQM+CTH)
+ WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
+ & MAX(RM34,RSQM-CTH)**2
+ WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
+ & MAX(RM34,RSQM+CTH)**2
+ ENDIF
+ 180 CONTINUE
+
+C...Check that equation system solvable.
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
+ MSOLV=1
+ WTRELS=0D0
+ DO 190 IBIN=1,NBIN
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
+ & IRED=1,NBIN),WTREL(IBIN)
+ IF(NAREL(IBIN).EQ.0) MSOLV=0
+ WTRELS=WTRELS+WTREL(IBIN)
+ 190 CONTINUE
+ IF(ABS(WTRELS).LT.1D-20) MSOLV=0
+
+C...Solve to find relative importance of cross-section pieces.
+ IF(MSOLV.EQ.1) THEN
+ DO 200 IBIN=1,NBIN
+ WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
+ 200 CONTINUE
+ DO 230 IRED=1,NBIN-1
+ DO 220 IBIN=IRED+1,NBIN
+ IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
+ MSOLV=0
+ GOTO 260
+ ENDIF
+ RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
+ WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
+ DO 210 ICOE=IRED,NBIN
+ WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
+ 210 CONTINUE
+ 220 CONTINUE
+ 230 CONTINUE
+ DO 250 IRED=NBIN,1,-1
+ DO 240 ICOE=IRED+1,NBIN
+ WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
+ 240 CONTINUE
+ COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
+ 250 CONTINUE
+ ENDIF
+
+C...Share evenly if failure.
+ 260 IF(MSOLV.EQ.0) THEN
+ DO 270 IBIN=1,NBIN
+ COEFU(IBIN)=1D0
+ WTRELN(IBIN)=0.1D0
+ IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
+ & WTREL(IBIN)/WTRELS)
+ 270 CONTINUE
+ ENDIF
+
+C...Normalize coefficients, with piece shared democratically.
+ COEFSU=0D0
+ WTRELS=0D0
+ DO 280 IBIN=1,NBIN
+ COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
+ COEFSU=COEFSU+COEFU(IBIN)
+ WTRELS=WTRELS+WTRELN(IBIN)
+ 280 CONTINUE
+ IF(COEFSU.GT.0D0) THEN
+ DO 290 IBIN=1,NBIN
+ COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
+ & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
+ 290 CONTINUE
+ ELSE
+ DO 300 IBIN=1,NBIN
+ COEFO(IBIN)=1D0/NBIN
+ 300 CONTINUE
+ ENDIF
+ IF(IVAR.EQ.1) IOFF=0
+ IF(IVAR.EQ.2) IOFF=17
+ IF(IVAR.EQ.3) IOFF=7
+ IF(IVAR.EQ.4) IOFF=12
+ DO 310 IBIN=1,NBIN
+ ICOF=IOFF+IBIN
+ IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
+ IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
+ COEF(ISUB,ICOF)=COEFO(IBIN)
+ 310 CONTINUE
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
+ & (COEFO(IBIN),IBIN=1,NBIN)
+ 320 CONTINUE
+
+C...Find two most promising maxima among points previously determined.
+ DO 330 J=1,4
+ IACCMX(J)=0
+ SIGSMX(J)=0D0
+ 330 CONTINUE
+ NMAX=0
+ DO 390 IACC=1,NACC
+ DO 340 J=1,30
+ VINT(10+J)=VINTPT(IACC,J)
+ 340 CONTINUE
+ IF(ISTSB.NE.5) THEN
+ CALL PYSIGH(NCHN,SIGS)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGS=WTXS*SIGS
+ ENDIF
+ ELSE
+ SIGS=0D0
+ DO 350 IKIN3=1,MSTP(129)
+ CALL PYKMAP(5,0,0D0)
+ IF(MINT(51).EQ.1) GOTO 350
+ CALL PYSIGH(NCHN,SIGTMP)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGTMP=WTXS*SIGTMP
+ ENDIF
+ IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
+ 350 CONTINUE
+ ENDIF
+ IEQ=0
+ DO 360 IMV=1,NMAX
+ IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
+ 360 CONTINUE
+ IF(IEQ.EQ.0) THEN
+ DO 370 IMV=NMAX,1,-1
+ IIN=IMV+1
+ IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
+ IACCMX(IMV+1)=IACCMX(IMV)
+ SIGSMX(IMV+1)=SIGSMX(IMV)
+ 370 CONTINUE
+ IIN=1
+ 380 IACCMX(IIN)=IACC
+ SIGSMX(IIN)=SIGS
+ IF(NMAX.LE.1) NMAX=NMAX+1
+ ENDIF
+ 390 CONTINUE
+
+C...Read out starting position for search.
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
+ SIGSAM=SIGSMX(1)
+ DO 440 IMAX=1,NMAX
+ IACC=IACCMX(IMAX)
+ MTAU=MVARPT(IACC,1)
+ MTAUP=MVARPT(IACC,2)
+ MYST=MVARPT(IACC,3)
+ MCTH=MVARPT(IACC,4)
+ VTAU=0.5D0
+ VYST=0.5D0
+ VCTH=0.5D0
+ VTAUP=0.5D0
+
+C...Starting point and step size in parameter space.
+ DO 430 IRPT=1,2
+ DO 420 IVAR=1,4
+ IF(NPTS(IVAR).EQ.1) GOTO 420
+ IF(IVAR.EQ.1) VVAR=VTAU
+ IF(IVAR.EQ.2) VVAR=VTAUP
+ IF(IVAR.EQ.3) VVAR=VYST
+ IF(IVAR.EQ.4) VVAR=VCTH
+ IF(IVAR.EQ.1) MVAR=MTAU
+ IF(IVAR.EQ.2) MVAR=MTAUP
+ IF(IVAR.EQ.3) MVAR=MYST
+ IF(IVAR.EQ.4) MVAR=MCTH
+ IF(IRPT.EQ.1) VDEL=0.1D0
+ IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
+ & 0.98D0-VVAR))
+ IF(IRPT.EQ.1) VMAR=0.02D0
+ IF(IRPT.EQ.2) VMAR=0.002D0
+ IMOV0=1
+ IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
+ DO 410 IMOV=IMOV0,8
+
+C...Define new point in parameter space.
+ IF(IMOV.EQ.0) THEN
+ INEW=2
+ VNEW=VVAR
+ ELSEIF(IMOV.EQ.1) THEN
+ INEW=3
+ VNEW=VVAR+VDEL
+ ELSEIF(IMOV.EQ.2) THEN
+ INEW=1
+ VNEW=VVAR-VDEL
+ ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
+ & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
+ VVAR=VVAR+VDEL
+ SIGSSM(1)=SIGSSM(2)
+ SIGSSM(2)=SIGSSM(3)
+ INEW=3
+ VNEW=VVAR+VDEL
+ ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
+ & VVAR-2D0*VDEL.GT.VMAR) THEN
+ VVAR=VVAR-VDEL
+ SIGSSM(3)=SIGSSM(2)
+ SIGSSM(2)=SIGSSM(1)
+ INEW=1
+ VNEW=VVAR-VDEL
+ ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
+ VDEL=0.5D0*VDEL
+ VVAR=VVAR+VDEL
+ SIGSSM(1)=SIGSSM(2)
+ INEW=2
+ VNEW=VVAR
+ ELSE
+ VDEL=0.5D0*VDEL
+ VVAR=VVAR-VDEL
+ SIGSSM(3)=SIGSSM(2)
+ INEW=2
+ VNEW=VVAR
+ ENDIF
+
+C...Convert to relevant variables and find derived new limits.
+ ILERR=0
+ IF(IVAR.EQ.1) THEN
+ VTAU=VNEW
+ CALL PYKMAP(1,MTAU,VTAU)
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ CALL PYKLIM(4)
+ IF(MINT(51).EQ.1) ILERR=1
+ ENDIF
+ ENDIF
+ IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
+ & ILERR.EQ.0) THEN
+ IF(IVAR.EQ.2) VTAUP=VNEW
+ CALL PYKMAP(4,MTAUP,VTAUP)
+ ENDIF
+ IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
+ CALL PYKLIM(2)
+ IF(MINT(51).EQ.1) ILERR=1
+ ENDIF
+ IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
+ IF(IVAR.EQ.3) VYST=VNEW
+ CALL PYKMAP(2,MYST,VYST)
+ CALL PYKLIM(3)
+ IF(MINT(51).EQ.1) ILERR=1
+ ENDIF
+ IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
+ & ILERR.EQ.0) THEN
+ IF(IVAR.EQ.4) VCTH=VNEW
+ CALL PYKMAP(3,MCTH,VCTH)
+ ENDIF
+ IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
+
+C...Evaluate cross-section. Save new maximum. Final maximum.
+ IF(ILERR.NE.0) THEN
+ SIGS=0.
+ ELSEIF(ISTSB.NE.5) THEN
+ CALL PYSIGH(NCHN,SIGS)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGS=WTXS*SIGS
+ ENDIF
+ ELSE
+ SIGS=0D0
+ DO 400 IKIN3=1,MSTP(129)
+ CALL PYKMAP(5,0,0D0)
+ IF(MINT(51).EQ.1) GOTO 400
+ CALL PYSIGH(NCHN,SIGTMP)
+ IF(MWTXS.EQ.1) THEN
+ CALL PYEVWT(WTXS)
+ SIGTMP=WTXS*SIGTMP
+ ENDIF
+ IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
+ 400 CONTINUE
+ ENDIF
+ SIGSSM(INEW)=SIGS
+ IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
+ & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
+ 410 CONTINUE
+ 420 CONTINUE
+ 430 CONTINUE
+ 440 CONTINUE
+ IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
+ XSEC(ISUB,1)=1.05D0*SIGSAM
+ 450 CONTINUE
+ IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
+ & PARP(174)*XSEC(ISUB,1)
+ IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
+ 460 CONTINUE
+ MINT(51)=0
+
+C...Print summary table.
+ IF(NPOSI.EQ.0) THEN
+ WRITE(MSTU(11),5900)
+ STOP
+ ENDIF
+ IF(MSTP(122).GE.1) THEN
+ WRITE(MSTU(11),6000)
+ WRITE(MSTU(11),6100)
+ DO 470 ISUB=1,500
+ IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
+ IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
+ IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
+ IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
+ IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
+ & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
+ WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
+ 470 CONTINUE
+ WRITE(MSTU(11),6300)
+ ENDIF
+
+C...Format statements for maximization results.
+ 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
+ &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
+ &'cth',9X,'tau''',7X,'sigma')
+ 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
+ &'phase space.'/1X,'Process switched off!')
+ 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
+ 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
+ &'cross-section.'/1X,'Process switched off!')
+ 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
+ 5500 FORMAT(1X,1P,8D11.3)
+ 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
+ 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
+ &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
+ 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
+ 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
+ &'cross-section.'/1X,'Execution stopped!')
+ 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
+ &'cross-section maximum search',1X,8('*'))
+ 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
+ &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
+ &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
+ 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
+ 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPILE
+C...Initializes multiplicity distribution and selects mutliplicity
+C...of pileup events, i.e. several events occuring at the same
+C...beam crossing.
+
+ SUBROUTINE PYPILE(MPILE)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
+C...Local arrays and saved variables.
+ DIMENSION WTI(0:200)
+ SAVE IMIN,IMAX,WTI,WTS
+
+C...Sum of allowed cross-sections for pileup events.
+ IF(MPILE.EQ.1) THEN
+ VINT(131)=SIGT(0,0,5)
+ IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
+ IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
+ IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
+ IF(MSTP(133).LE.0) RETURN
+
+C...Initialize multiplicity distribution at maximum.
+ XNAVE=VINT(131)*PARP(131)
+ IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
+ INAVE=MAX(1,MIN(200,NINT(XNAVE)))
+ WTI(INAVE)=1D0
+ WTS=WTI(INAVE)
+ WTN=WTI(INAVE)*INAVE
+
+C...Find shape of multiplicity distribution below maximum.
+ IMIN=INAVE
+ DO 100 I=INAVE-1,1,-1
+ IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
+ IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
+ IF(WTI(I).LT.1D-6) GOTO 110
+ WTS=WTS+WTI(I)
+ WTN=WTN+WTI(I)*I
+ IMIN=I
+ 100 CONTINUE
+
+C...Find shape of multiplicity distribution above maximum.
+ 110 IMAX=INAVE
+ DO 120 I=INAVE+1,200
+ IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
+ IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
+ IF(WTI(I).LT.1D-6) GOTO 130
+ WTS=WTS+WTI(I)
+ WTN=WTN+WTI(I)*I
+ IMAX=I
+ 120 CONTINUE
+ 130 VINT(132)=XNAVE
+ VINT(133)=WTN/WTS
+ IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
+ & WTS/(WTS+WTI(1)/XNAVE)
+ IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
+ IF(MSTP(133).GE.2) VINT(134)=XNAVE
+
+C...Pick multiplicity of pileup events.
+ ELSE
+ IF(MSTP(133).LE.0) THEN
+ MINT(81)=MAX(1,MSTP(134))
+ ELSE
+ WTR=WTS*PYR(0)
+ DO 140 I=IMIN,IMAX
+ MINT(81)=I
+ WTR=WTR-WTI(I)
+ IF(WTR.LE.0D0) GOTO 150
+ 140 CONTINUE
+ 150 CONTINUE
+ ENDIF
+ ENDIF
+
+C...Format statement for error message.
+ 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
+ &'crossing too large, ',1P,D12.4)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSAVE
+C...Saves and restores parameter and cross section values for the
+C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
+C...choice between alternatives.
+
+ SUBROUTINE PYSAVE(ISAVE,IGA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
+C...Local arrays and saved variables.
+ DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
+ &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
+ SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
+
+C...Save list of subprocesses and cross-section information.
+ IF(ISAVE.EQ.1) THEN
+ ICP=0
+ DO 120 I=1,500
+ IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
+ ICP=ICP+1
+ NSUBCP(IGA,ICP)=I
+ MSUBCP(IGA,ICP)=MSUB(I)
+ DO 100 J=1,20
+ COEFCP(IGA,ICP,J)=COEF(I,J)
+ 100 CONTINUE
+ DO 110 J=1,3
+ NGENCP(IGA,ICP,J)=NGEN(I,J)
+ XSECCP(IGA,ICP,J)=XSEC(I,J)
+ 110 CONTINUE
+ 120 CONTINUE
+ NCP(IGA)=ICP
+ DO 130 J=1,3
+ NGENCP(IGA,0,J)=NGEN(0,J)
+ XSECCP(IGA,0,J)=XSEC(0,J)
+ 130 CONTINUE
+C...Save various common process variables.
+ DO 140 J=1,10
+ INTCP(IGA,J)=MINT(40+J)
+ 140 CONTINUE
+ INTCP(IGA,11)=MINT(101)
+ INTCP(IGA,12)=MINT(102)
+ INTCP(IGA,13)=MINT(107)
+ INTCP(IGA,14)=MINT(108)
+ INTCP(IGA,15)=MINT(123)
+ RECP(IGA,1)=CKIN(3)
+
+C...Save cross-section information only.
+ ELSEIF(ISAVE.EQ.2) THEN
+ DO 160 ICP=1,NCP(IGA)
+ I=NSUBCP(IGA,ICP)
+ DO 150 J=1,3
+ NGENCP(IGA,ICP,J)=NGEN(I,J)
+ XSECCP(IGA,ICP,J)=XSEC(I,J)
+ 150 CONTINUE
+ 160 CONTINUE
+ DO 170 J=1,3
+ NGENCP(IGA,0,J)=NGEN(0,J)
+ XSECCP(IGA,0,J)=XSEC(0,J)
+ 170 CONTINUE
+
+C...Choose between allowed alternatives.
+ ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
+ IF(ISAVE.EQ.4) THEN
+ XSUMCP=0D0
+ DO 180 IG=1,MINT(121)
+ XSUMCP=XSUMCP+XSECCP(IG,0,1)
+ 180 CONTINUE
+ XSUMCP=XSUMCP*PYR(0)
+ DO 190 IG=1,MINT(121)
+ IGA=IG
+ XSUMCP=XSUMCP-XSECCP(IG,0,1)
+ IF(XSUMCP.LE.0D0) GOTO 200
+ 190 CONTINUE
+ 200 CONTINUE
+ ENDIF
+
+C...Restore cross-section information.
+ DO 210 I=1,500
+ MSUB(I)=0
+ 210 CONTINUE
+ DO 240 ICP=1,NCP(IGA)
+ I=NSUBCP(IGA,ICP)
+ MSUB(I)=MSUBCP(IGA,ICP)
+ DO 220 J=1,20
+ COEF(I,J)=COEFCP(IGA,ICP,J)
+ 220 CONTINUE
+ DO 230 J=1,3
+ NGEN(I,J)=NGENCP(IGA,ICP,J)
+ XSEC(I,J)=XSECCP(IGA,ICP,J)
+ 230 CONTINUE
+ 240 CONTINUE
+ DO 250 J=1,3
+ NGEN(0,J)=NGENCP(IGA,0,J)
+ XSEC(0,J)=XSECCP(IGA,0,J)
+ 250 CONTINUE
+
+C...Restore various common process variables.
+ DO 260 J=1,10
+ MINT(40+J)=INTCP(IGA,J)
+ 260 CONTINUE
+ MINT(101)=INTCP(IGA,11)
+ MINT(102)=INTCP(IGA,12)
+ MINT(107)=INTCP(IGA,13)
+ MINT(108)=INTCP(IGA,14)
+ MINT(123)=INTCP(IGA,15)
+ CKIN(3)=RECP(IGA,1)
+ CKIN(1)=2D0*CKIN(3)
+
+C...Sum up cross-section info (for PYSTAT).
+ ELSEIF(ISAVE.EQ.5) THEN
+ DO 270 I=1,500
+ MSUB(I)=0
+ NGEN(I,1)=0
+ NGEN(I,3)=0
+ XSEC(I,3)=0D0
+ 270 CONTINUE
+ NGEN(0,1)=0
+ NGEN(0,2)=0
+ NGEN(0,3)=0
+ XSEC(0,3)=0
+ DO 290 IG=1,MINT(121)
+ DO 280 ICP=1,NCP(IG)
+ I=NSUBCP(IG,ICP)
+ IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
+ NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
+ NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
+ XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
+ 280 CONTINUE
+ NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
+ NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
+ NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
+ XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
+ 290 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRAND
+C...Generates quantities characterizing the high-pT scattering at the
+C...parton level according to the matrix elements. Chooses incoming,
+C...reacting partons, their momentum fractions and one of the possible
+C...subprocesses.
+
+ SUBROUTINE PYRAND
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
+C...Local arrays.
+ DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
+
+C...Parameters and data used in elastic/diffractive treatment.
+ DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
+ &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
+
+C...Initial values, specifically for (first) semihard interaction.
+ MINT(10)=0
+ MINT(17)=0
+ MINT(18)=0
+ VINT(143)=1D0
+ VINT(144)=1D0
+ MFAIL=0
+ IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
+ ISUB=0
+ LOOP=0
+ 100 LOOP=LOOP+1
+ MINT(51)=0
+
+C...Choice of process type - first event of pileup.
+ IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
+
+C...For gamma-p or gamma-gamma first pick between alternatives.
+ IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
+ MINT(122)=IGA
+
+C...For gamma + gamma with different nature, flip at random.
+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
+ & PYR(0).GT.0.5D0) THEN
+ MINTSV=MINT(41)
+ MINT(41)=MINT(42)
+ MINT(42)=MINTSV
+ MINTSV=MINT(45)
+ MINT(45)=MINT(46)
+ MINT(46)=MINTSV
+ MINTSV=MINT(107)
+ MINT(107)=MINT(108)
+ MINT(108)=MINTSV
+ IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
+ ENDIF
+
+C...Pick process type.
+ RSUB=XSEC(0,1)*PYR(0)
+ DO 110 I=1,500
+ IF(MSUB(I).NE.1) GOTO 110
+ ISUB=I
+ RSUB=RSUB-XSEC(I,1)
+ IF(RSUB.LE.0D0) GOTO 120
+ 110 CONTINUE
+ 120 IF(ISUB.EQ.95) ISUB=96
+ IF(ISUB.EQ.96) CALL PYMULT(2)
+
+C...Choice of inclusive process type - pileup events.
+ ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
+ RSUB=VINT(131)*PYR(0)
+ ISUB=96
+ IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
+ IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
+ IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
+ IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
+ & ISUB=91
+ IF(ISUB.EQ.96) CALL PYMULT(2)
+ ENDIF
+ IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
+ IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
+ IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
+ &NGEN(97,1)=NGEN(97,1)+1
+ MINT(1)=ISUB
+ ISTSB=ISET(ISUB)
+
+C...Random choice of flavour for some SUSY processes.
+ IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
+C...~e_L ~nu_e or ~mu_L ~nu_mu.
+ IF(ISUB.EQ.210) THEN
+ KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
+ KFPR(ISUB,2)=KFPR(ISUB,1)+1
+C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
+ ELSEIF(ISUB.EQ.213) THEN
+ KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
+ KFPR(ISUB,2)=KFPR(ISUB,1)
+C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
+ ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
+ IF(MOD(ISUB,2).EQ.0) THEN
+ KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
+ ELSE
+ KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
+ ENDIF
+C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
+ ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
+ IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
+ KSU1=KSUSY1
+ KSU2=KSUSY1
+ ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
+ KSU1=KSUSY2
+ KSU2=KSUSY2
+ ELSEIF(PYR(0).LT.0.5D0) THEN
+ KSU1=KSUSY1
+ KSU2=KSUSY2
+ ELSE
+ KSU1=KSUSY2
+ KSU2=KSUSY1
+ ENDIF
+ KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
+ KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
+C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
+ ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
+ KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
+ KFPR(ISUB,2)=KFPR(ISUB,1)
+ ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
+ KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
+ KFPR(ISUB,2)=KFPR(ISUB,1)
+ ENDIF
+ ENDIF
+
+C...Find resonances (explicit or implicit in cross-section).
+ MINT(72)=0
+ KFR1=0
+ IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
+ KFR1=KFPR(ISUB,1)
+ ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
+ & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
+ KFR1=23
+ ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
+ & ISUB.EQ.177) THEN
+ KFR1=24
+ ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
+ KFR1=25
+ IF(MSTP(46).EQ.5) THEN
+ KFR1=30
+ PMAS(30,1)=PARP(45)
+ PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
+ ENDIF
+ ELSEIF(ISUB.EQ.194) THEN
+ KFR1=54
+ ENDIF
+ CKMX=CKIN(2)
+ IF(CKMX.LE.0D0) CKMX=VINT(1)
+ KCR1=PYCOMP(KFR1)
+ IF(KFR1.NE.0) THEN
+ IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
+ & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
+ ENDIF
+ IF(KFR1.NE.0) THEN
+ TAUR1=PMAS(KCR1,1)**2/VINT(2)
+ GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
+ MINT(72)=1
+ MINT(73)=KFR1
+ VINT(73)=TAUR1
+ VINT(74)=GAMR1
+ ENDIF
+ IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
+ KFR2=23
+ IF(ISUB.EQ.194) KFR2=56
+ KCR2=PYCOMP(KFR2)
+ TAUR2=PMAS(KCR2,1)**2/VINT(2)
+ GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
+ IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
+ & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
+ IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
+ MINT(72)=2
+ MINT(74)=KFR2
+ VINT(75)=TAUR2
+ VINT(76)=GAMR2
+ ELSEIF(KFR2.NE.0) THEN
+ KFR1=KFR2
+ TAUR1=TAUR2
+ GAMR1=GAMR2
+ MINT(72)=1
+ MINT(73)=KFR1
+ VINT(73)=TAUR1
+ VINT(74)=GAMR1
+ ENDIF
+ ENDIF
+
+C...Find product masses and minimum pT of process,
+C...optionally with broadening according to a truncated Breit-Wigner.
+ VINT(63)=0D0
+ VINT(64)=0D0
+ MINT(71)=0
+ VINT(71)=CKIN(3)
+ IF(MINT(82).GE.2) VINT(71)=0D0
+ VINT(80)=1D0
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ NBW=0
+ DO 140 I=1,2
+ PMMN(I)=0D0
+ IF(KFPR(ISUB,I).EQ.0) THEN
+ ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
+ & PARP(41)) THEN
+ VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
+ ELSE
+ NBW=NBW+1
+C...This prevents SUSY/t particles from becoming too light.
+ KFLW=KFPR(ISUB,I)
+ IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
+ KCW=PYCOMP(KFLW)
+ PMMN(I)=PMAS(KCW,1)
+ DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
+ IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
+ PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
+ & PMAS(PYCOMP(KFDP(IDC,2)),1)
+ IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
+ & PMAS(PYCOMP(KFDP(IDC,3)),1)
+ PMMN(I)=MIN(PMMN(I),PMSUM)
+ ENDIF
+ 130 CONTINUE
+ ELSEIF(KFLW.EQ.6) THEN
+ PMMN(I)=PMAS(24,1)+PMAS(5,1)
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+ IF(NBW.GE.1) THEN
+ CKIN41=CKIN(41)
+ CKIN43=CKIN(43)
+ CKIN(41)=MAX(PMMN(1),CKIN(41))
+ CKIN(43)=MAX(PMMN(2),CKIN(43))
+ CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
+ CKIN(41)=CKIN41
+ CKIN(43)=CKIN43
+ IF(MINT(51).EQ.1) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ VINT(63)=PQM3**2
+ VINT(64)=PQM4**2
+ ENDIF
+ IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
+ IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
+ ENDIF
+
+C...Prepare for additional variable choices in 2 -> 3.
+ IF(ISTSB.EQ.5) THEN
+ VINT(201)=0D0
+ IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
+ VINT(206)=VINT(201)
+ VINT(204)=PMAS(23,1)
+ IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
+ IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
+ & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
+ VINT(209)=VINT(204)
+ ENDIF
+
+C...Select incoming VDM particle (rho/omega/phi/J/psi).
+ IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
+ &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
+ VRN=PYR(0)*SIGT(0,0,5)
+ IF(MINT(101).LE.1) THEN
+ I1MN=0
+ I1MX=0
+ ELSE
+ I1MN=1
+ I1MX=MINT(101)
+ ENDIF
+ IF(MINT(102).LE.1) THEN
+ I2MN=0
+ I2MX=0
+ ELSE
+ I2MN=1
+ I2MX=MINT(102)
+ ENDIF
+ DO 160 I1=I1MN,I1MX
+ KFV1=110*I1+3
+ DO 150 I2=I2MN,I2MX
+ KFV2=110*I2+3
+ VRN=VRN-SIGT(I1,I2,5)
+ IF(VRN.LE.0D0) GOTO 170
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 IF(MINT(101).GE.2) MINT(103)=KFV1
+ IF(MINT(102).GE.2) MINT(104)=KFV2
+ ENDIF
+
+ IF(ISTSB.EQ.0) THEN
+C...Elastic scattering or single or double diffractive scattering.
+
+C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
+ MINT(103)=MINT(11)
+ MINT(104)=MINT(12)
+ PMM(1)=VINT(3)
+ PMM(2)=VINT(4)
+ IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
+ JJ=ISUB-90
+ VRN=PYR(0)*SIGT(0,0,JJ)
+ IF(MINT(101).LE.1) THEN
+ I1MN=0
+ I1MX=0
+ ELSE
+ I1MN=1
+ I1MX=MINT(101)
+ ENDIF
+ IF(MINT(102).LE.1) THEN
+ I2MN=0
+ I2MX=0
+ ELSE
+ I2MN=1
+ I2MX=MINT(102)
+ ENDIF
+ DO 190 I1=I1MN,I1MX
+ KFV1=110*I1+3
+ DO 180 I2=I2MN,I2MX
+ KFV2=110*I2+3
+ VRN=VRN-SIGT(I1,I2,JJ)
+ IF(VRN.LE.0D0) GOTO 200
+ 180 CONTINUE
+ 190 CONTINUE
+ 200 IF(MINT(101).GE.2) THEN
+ MINT(103)=KFV1
+ PMM(1)=PYMASS(KFV1)
+ ENDIF
+ IF(MINT(102).GE.2) THEN
+ MINT(104)=KFV2
+ PMM(2)=PYMASS(KFV2)
+ ENDIF
+ ENDIF
+
+C...Side/sides of diffractive system.
+ MINT(17)=0
+ MINT(18)=0
+ IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
+ IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
+
+C...Find masses of particles and minimal masses of diffractive states.
+ DO 210 JT=1,2
+ PDIF(JT)=PMM(JT)
+ VINT(66+JT)=PDIF(JT)
+ IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
+ 210 CONTINUE
+ SH=VINT(2)
+ SQM1=PMM(1)**2
+ SQM2=PMM(2)**2
+ SQM3=PDIF(1)**2
+ SQM4=PDIF(2)**2
+ SMRES1=(PMM(1)+PMRC)**2
+ SMRES2=(PMM(2)+PMRC)**2
+
+C...Find elastic slope and lower limit diffractive slope.
+ IHA=MAX(2,IABS(MINT(103))/110)
+ IF(IHA.GE.5) IHA=1
+ IHB=MAX(2,IABS(MINT(104))/110)
+ IF(IHB.GE.5) IHB=1
+ IF(ISUB.EQ.91) THEN
+ BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
+ ELSEIF(ISUB.EQ.92) THEN
+ BMN=MAX(2D0,2D0*BHAD(IHB))
+ ELSEIF(ISUB.EQ.93) THEN
+ BMN=MAX(2D0,2D0*BHAD(IHA))
+ ELSEIF(ISUB.EQ.94) THEN
+ BMN=2D0*ALP*4D0
+ ENDIF
+
+C...Determine maximum possible t range and coefficient of generation.
+ SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
+ SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
+ THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
+ THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
+ THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
+ & (SQM1*SQM4-SQM2*SQM3)/SH
+ THL=-0.5D0*(THA+THB)
+ THU=THC/THL
+ THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
+
+C...Select diffractive mass/masses according to dm^2/m^2.
+ 220 DO 230 JT=1,2
+ IF(MINT(16+JT).EQ.0) THEN
+ PDIF(2+JT)=PDIF(JT)
+ ELSE
+ PMMIN=PDIF(JT)
+ PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
+ PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
+ ENDIF
+ 230 CONTINUE
+ SQM3=PDIF(3)**2
+ SQM4=PDIF(4)**2
+
+C..Additional mass factors, including resonance enhancement.
+ IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
+ IF(ISUB.EQ.92) THEN
+ FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
+ IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
+ ELSEIF(ISUB.EQ.93) THEN
+ FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
+ IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
+ ELSEIF(ISUB.EQ.94) THEN
+ FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
+ & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
+ & (1D0+CRES*SMRES2/(SMRES2+SQM4))
+ IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
+ ENDIF
+
+C...Select t according to exp(Bmn*t) and correct to right slope.
+ TH=THU+LOG(1D0+THRND*PYR(0))/BMN
+ IF(ISUB.GE.92) THEN
+ IF(ISUB.EQ.92) THEN
+ BADD=2D0*ALP*LOG(SH/SQM3)
+ IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
+ ELSEIF(ISUB.EQ.93) THEN
+ BADD=2D0*ALP*LOG(SH/SQM4)
+ IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
+ ELSEIF(ISUB.EQ.94) THEN
+ BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
+ ENDIF
+ IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
+ ENDIF
+
+C...Check whether m^2 and t choices are consistent.
+ SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
+ THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
+ THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
+ IF(THB.LE.1D-8) GOTO 220
+ THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
+ & (SQM1*SQM4-SQM2*SQM3)/SH
+ THLM=-0.5D0*(THA+THB)
+ THUM=THC/THLM
+ IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
+
+C...Information to output.
+ VINT(21)=1D0
+ VINT(22)=0D0
+ VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
+ VINT(45)=TH
+ VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
+ VINT(63)=PDIF(3)**2
+ VINT(64)=PDIF(4)**2
+
+C...Note: in the following, by In is meant the integral over the
+C...quantity multiplying coefficient cn.
+C...Choose tau according to h1(tau)/tau, where
+C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
+C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
+C...I1/I5*c5*1/(tau+tau_R') +
+C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
+C...I1/I7*c7*tau/(1.-tau), and
+C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
+ ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
+ CALL PYKLIM(1)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ RTAU=PYR(0)
+ MTAU=1
+ IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
+ IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
+ IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
+ IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
+ & MTAU=5
+ IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
+ & COEF(ISUB,5)) MTAU=6
+ IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
+ & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
+ CALL PYKMAP(1,MTAU,PYR(0))
+
+C...2 -> 3, 4 processes:
+C...Choose tau' according to h4(tau,tau')/tau', where
+C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
+C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ CALL PYKLIM(4)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ RTAUP=PYR(0)
+ MTAUP=1
+ IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
+ IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
+ CALL PYKMAP(4,MTAUP,PYR(0))
+ ENDIF
+
+C...Choose y* according to h2(y*), where
+C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
+C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
+C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
+C...and c1 + c2 + c3 + c4 + c5 = 1.
+ CALL PYKLIM(2)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ RYST=PYR(0)
+ MYST=1
+ IF(RYST.GT.COEF(ISUB,8)) MYST=2
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
+ & COEF(ISUB,11)) MYST=5
+ CALL PYKMAP(2,MYST,PYR(0))
+
+C...2 -> 2 processes:
+C...Choose cos(theta-hat) (cth) according to h3(cth), where
+C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
+C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
+C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
+C...and c0 + c1 + c2 + c3 + c4 = 1.
+ CALL PYKLIM(3)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ RCTH=PYR(0)
+ MCTH=1
+ IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
+ IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
+ IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
+ IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
+ & COEF(ISUB,16)) MCTH=5
+ CALL PYKMAP(3,MCTH,PYR(0))
+ ENDIF
+
+C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
+ IF(ISTSB.EQ.5) THEN
+ CALL PYKMAP(5,0,0D0)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+
+C...Low-pT or multiple interactions (first semihard interaction).
+ ELSEIF(ISTSB.EQ.9) THEN
+ CALL PYMULT(3)
+ ISUB=MINT(1)
+
+C...Generate user-defined process: kinematics plus weight.
+ ELSEIF(ISTSB.EQ.11) THEN
+ MSTI(51)=0
+ CALL PYUPEV(ISUB,SIGS)
+ IF(NUP.LE.0) THEN
+ MINT(51)=2
+ MSTI(51)=1
+ IF(MINT(82).EQ.1) THEN
+ NGEN(0,1)=NGEN(0,1)-1
+ NGEN(0,2)=NGEN(0,2)-1
+ NGEN(ISUB,1)=NGEN(ISUB,1)-1
+ ENDIF
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ RETURN
+ ENDIF
+
+C...Construct 'trivial' kinematical variables needed.
+ KFL1=KUP(1,2)
+ KFL2=KUP(2,2)
+ VINT(41)=2D0*PUP(1,4)/VINT(1)
+ VINT(42)=2D0*PUP(2,4)/VINT(1)
+ VINT(21)=VINT(41)*VINT(42)
+ VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
+ VINT(44)=VINT(21)*VINT(2)
+ VINT(43)=SQRT(MAX(0D0,VINT(44)))
+ VINT(56)=Q2UP(0)
+ VINT(55)=SQRT(MAX(0D0,VINT(56)))
+
+C...Construct other kinematical variables needed (approximately).
+ VINT(23)=0D0
+ VINT(26)=VINT(21)
+ VINT(45)=-0.5D0*VINT(44)
+ VINT(46)=-0.5D0*VINT(44)
+ VINT(49)=VINT(43)
+ VINT(50)=VINT(44)
+ VINT(51)=VINT(55)
+ VINT(52)=VINT(56)
+ VINT(53)=VINT(55)
+ VINT(54)=VINT(56)
+ VINT(25)=0D0
+ VINT(48)=0D0
+ DO 240 IUP=3,NUP
+ IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
+ & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
+ IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
+ & PUP(IUP,2)**2)
+ 240 CONTINUE
+ VINT(47)=SQRT(VINT(48))
+
+C...Calculate parton distribution weights.
+ IF(MINT(47).GE.2) THEN
+ DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
+ MINT(105)=MINT(102+I)
+ MINT(109)=MINT(106+I)
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
+ ELSE
+ CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
+ ENDIF
+ DO 250 KFL=-25,25
+ XSFX(I,KFL)=XPQ(KFL)
+ 250 CONTINUE
+ 260 CONTINUE
+ ENDIF
+ ENDIF
+
+C...Choose azimuthal angle.
+ VINT(24)=PARU(2)*PYR(0)
+
+C...Check against user cuts on kinematics at parton level.
+ MINT(51)=0
+ IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
+ IF(MINT(51).NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
+ MCUT=0
+ IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
+ & CALL PYKCUT(MCUT)
+ IF(MCUT.NE.0) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+
+C...Calculate differential cross-section for different subprocesses.
+ IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
+ SIGSOR=SIGS
+ SIGLPT=SIGT(0,0,5)
+
+C...Multiply cross-section by user-defined weights.
+ IF(MSTP(173).EQ.1) THEN
+ SIGS=PARP(173)*SIGS
+ DO 270 ICHN=1,NCHN
+ SIGH(ICHN)=PARP(173)*SIGH(ICHN)
+ 270 CONTINUE
+ SIGLPT=PARP(173)*SIGLPT
+ ENDIF
+ WTXS=1D0
+ SIGSWT=SIGS
+ VINT(99)=1D0
+ VINT(100)=1D0
+ IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
+ IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
+ & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
+ SIGSWT=WTXS*SIGS
+ VINT(99)=WTXS
+ IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
+ ENDIF
+
+C...Calculations for Monte Carlo estimate of all cross-sections.
+ IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
+ IF(MSTP(142).LE.1) THEN
+ XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
+ ELSE
+ XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
+ ENDIF
+ ELSEIF(MINT(82).EQ.1) THEN
+ XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
+ ENDIF
+ IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
+ &XSEC(97,2)=XSEC(97,2)+SIGLPT
+
+C...Multiple interactions: store results of cross-section calculation.
+ IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
+ VINT(153)=SIGSOR
+ CALL PYMULT(4)
+ ENDIF
+
+C...Check that weight not negative.
+ VIOL=SIGSWT/XSEC(ISUB,1)
+ IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
+ IF(MSTP(123).LE.0) THEN
+ IF(VIOL.LT.-1D-3) THEN
+ WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
+ & VINT(22),VINT(23),VINT(26)
+ STOP
+ ENDIF
+ ELSE
+ IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
+ VINT(109)=VIOL
+ WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
+ & VINT(22),VINT(23),VINT(26)
+ ENDIF
+ ENDIF
+
+C...Weighting using estimate of maximum of differential cross-section.
+ IF(MFAIL.EQ.0) THEN
+ IF(VIOL.LT.PYR(0)) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ GOTO 100
+ ENDIF
+ ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
+ IF(VIOL.LT.PYR(0)) THEN
+ MSTI(61)=1
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ RETURN
+ ENDIF
+ ELSE
+ RATND=SIGLPT/XSEC(95,1)
+ IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
+ MSTI(61)=1
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ RETURN
+ ENDIF
+ VIOL=VIOL/RATND
+ IF(VIOL.LT.PYR(0)) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ GOTO 100
+ ENDIF
+ ENDIF
+
+C...Check for possible violation of estimated maximum of differential
+C...cross-section used in weighting.
+ IF(MSTP(123).LE.0) THEN
+ IF(VIOL.GT.1D0) THEN
+ WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
+ & VINT(22),VINT(23),VINT(26)
+ STOP
+ ENDIF
+ ELSEIF(MSTP(123).EQ.1) THEN
+ IF(VIOL.GT.VINT(108)) THEN
+ VINT(108)=VIOL
+ IF(VIOL.GT.1D0) THEN
+ MINT(10)=1
+ WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
+ & VINT(22),VINT(23),VINT(26)
+ ENDIF
+ ENDIF
+ ELSEIF(VIOL.GT.VINT(108)) THEN
+ VINT(108)=VIOL
+ IF(VIOL.GT.1D0) THEN
+ MINT(10)=1
+ XDIF=XSEC(ISUB,1)*(VIOL-1D0)
+ XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
+ IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
+ & XSEC(0,1)=XSEC(0,1)+XDIF
+ WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
+ & VINT(22),VINT(23),VINT(26)
+ IF(ISUB.LE.9) THEN
+ WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
+ ELSEIF(ISUB.LE.99) THEN
+ WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
+ ELSE
+ WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
+ ENDIF
+ VINT(108)=1D0
+ ENDIF
+ ENDIF
+
+C...Multiple interactions: choose impact parameter.
+ VINT(148)=1D0
+ IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
+ &MSTP(82).GE.3) THEN
+ CALL PYMULT(5)
+ IF(VINT(150).LT.PYR(0)) THEN
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+ IF(MFAIL.EQ.1) THEN
+ MSTI(61)=1
+ RETURN
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
+ IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
+ IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
+ IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
+ ENDIF
+ IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
+
+C...Choose flavour of reacting partons (and subprocess).
+ IF(ISTSB.GE.11) GOTO 290
+ RSIGS=SIGS*PYR(0)
+ QT2=VINT(48)
+ RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
+ IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
+ &PYR(0).GT.RQQBAR)) THEN
+ DO 280 ICHN=1,NCHN
+ KFL1=ISIG(ICHN,1)
+ KFL2=ISIG(ICHN,2)
+ MINT(2)=ISIG(ICHN,3)
+ RSIGS=RSIGS-SIGH(ICHN)
+ IF(RSIGS.LE.0D0) GOTO 290
+ 280 CONTINUE
+
+C...Multiple interactions: choose qqbar preferentially at small pT.
+ ELSEIF(ISUB.EQ.96) THEN
+ MINT(105)=MINT(103)
+ MINT(109)=MINT(107)
+ CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
+ MINT(105)=MINT(104)
+ MINT(109)=MINT(108)
+ CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
+ MINT(1)=11
+ MINT(2)=1
+ IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
+
+C...Low-pT: choose string drawing configuration.
+ ELSE
+ KFL1=21
+ KFL2=21
+ RSIGS=6D0*PYR(0)
+ MINT(2)=1
+ IF(RSIGS.GT.1D0) MINT(2)=2
+ IF(RSIGS.GT.2D0) MINT(2)=3
+ ENDIF
+
+C...Reassign QCD process. Partons before initial state radiation.
+ 290 IF(MINT(2).GT.10) THEN
+ MINT(1)=MINT(2)/10
+ MINT(2)=MOD(MINT(2),10)
+ ENDIF
+ IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
+ &NGEN(MINT(1),2)+1
+ MINT(15)=KFL1
+ MINT(16)=KFL2
+ MINT(13)=MINT(15)
+ MINT(14)=MINT(16)
+ VINT(141)=VINT(41)
+ VINT(142)=VINT(42)
+ VINT(151)=0D0
+ VINT(152)=0D0
+
+C...Calculate x value of photon for parton inside photon inside e.
+ DO 320 JT=1,2
+ MINT(18+JT)=0
+ VINT(154+JT)=0D0
+ MSPLI=0
+ IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
+ IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
+ IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
+ IF(MSPLI.EQ.2) THEN
+ KFLH=MINT(14+JT)
+ XHRD=VINT(140+JT)
+ Q2HRD=VINT(54)
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
+ ELSE
+ CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
+ ENDIF
+ WTMX=4D0*XPQ(KFLH)
+ IF(MSTP(13).EQ.2) THEN
+ Q2PMS=Q2HRD/PMAS(11,1)**2
+ WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
+ ENDIF
+ 300 XE=XHRD**PYR(0)
+ XG=MIN(0.999999D0,XHRD/XE)
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(22,XG,Q2HRD,XPQ)
+ ELSE
+ CALL PYPDFL(22,XG,Q2HRD,XPQ)
+ ENDIF
+ WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
+ IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
+ IF(WT.LT.PYR(0)*WTMX) GOTO 300
+ MINT(18+JT)=1
+ VINT(154+JT)=XE
+ DO 310 KFLS=-25,25
+ XSFX(JT,KFLS)=XPQ(KFLS)
+ 310 CONTINUE
+ ENDIF
+ 320 CONTINUE
+
+C...Pick scale where photon is resolved.
+ IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
+ &(VINT(54)/PARP(15)**2)**PYR(0)
+ IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
+ &(VINT(54)/PARP(15)**2)**PYR(0)
+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
+
+C...Format statements for differential cross-section maximum violations.
+ 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
+ &'in event',1X,I7,'D0'/1X,'Execution stopped!')
+ 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
+ &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
+ 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
+ &'in event',1X,I7)
+ 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
+ &'in event',1X,I7,'D0'/1X,'Execution stopped!')
+ 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
+ &'in event',1X,I7)
+ 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
+ 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
+ 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSCAT
+C...Finds outgoing flavours and event type; sets up the kinematics
+C...and colour flow of the hard scattering
+
+ SUBROUTINE PYSCAT
+
+C...Double precision and integer declarations
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
+C...Local arrays and saved variables
+ DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
+ &PHI(2),KUPPO(20),VINTSV(41:66)
+ SAVE VINTSV
+
+C...Read out process
+ ISUB=MINT(1)
+ ISUBSV=ISUB
+
+C...Restore information for low-pT processes
+ IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
+ DO 100 J=41,66
+ 100 VINT(J)=VINTSV(J)
+ ENDIF
+
+C...Convert H' or A process into equivalent H one
+ IHIGG=1
+ KFHIGG=25
+ IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
+ &ISUB.LE.190)) THEN
+ IHIGG=2
+ IF(MOD(ISUB-1,10).GE.5) IHIGG=3
+ KFHIGG=33+IHIGG
+ IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
+ IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
+ IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
+ IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
+ IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
+ IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
+ IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
+ IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
+ IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
+ ENDIF
+
+C...Choice of subprocess, number of documentation lines
+ IDOC=6+ISET(ISUB)
+ IF(ISUB.EQ.95) IDOC=8
+ IF(ISET(ISUB).EQ.5) IDOC=9
+ IF(ISET(ISUB).EQ.11) IDOC=4+NUP
+ MINT(3)=IDOC-6
+ IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
+ MINT(4)=IDOC
+ IPU1=MINT(84)+1
+ IPU2=MINT(84)+2
+ IPU3=MINT(84)+3
+ IPU4=MINT(84)+4
+ IPU5=MINT(84)+5
+ IPU6=MINT(84)+6
+
+C...Reset K, P and V vectors. Store incoming particles
+ DO 120 JT=1,MSTP(126)+20
+ I=MINT(83)+JT
+ DO 110 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 140 JT=1,2
+ I=MINT(83)+JT
+ K(I,1)=21
+ K(I,2)=MINT(10+JT)
+ DO 130 J=1,5
+ P(I,J)=VINT(285+5*JT+J)
+ 130 CONTINUE
+ 140 CONTINUE
+ MINT(6)=2
+ KFRES=0
+
+C...Store incoming partons in their CM-frame
+ SH=VINT(44)
+ SHR=SQRT(SH)
+ SHP=VINT(26)*VINT(2)
+ SHPR=SQRT(SHP)
+ SHUSER=SHR
+ IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
+ DO 150 JT=1,2
+ I=MINT(84)+JT
+ K(I,1)=14
+ K(I,2)=MINT(14+JT)
+ K(I,3)=MINT(83)+2+JT
+ P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
+ P(I,4)=0.5D0*SHUSER
+ 150 CONTINUE
+
+C...Copy incoming partons to documentation lines
+ DO 170 JT=1,2
+ I1=MINT(83)+4+JT
+ I2=MINT(84)+JT
+ K(I1,1)=21
+ K(I1,2)=K(I2,2)
+ K(I1,3)=I1-2
+ DO 160 J=1,5
+ P(I1,J)=P(I2,J)
+ 160 CONTINUE
+ 170 CONTINUE
+
+C...Choose new quark/lepton flavour for relevant annihilation graphs
+ IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
+ IGLGA=21
+ IF(ISUB.EQ.58) IGLGA=22
+ CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
+ 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
+ DO 190 I=1,MDCY(IGLGA,3)
+ KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
+ RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
+ IF(RKFL.LE.0D0) GOTO 200
+ 190 CONTINUE
+ 200 CONTINUE
+ IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
+ & IABS(KFLF).GE.3) THEN
+ FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
+ & VINT(44)**2
+ FACCIB=VINT(46)**2/PARU(155)**4
+ IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
+ ELSEIF(ISUB.EQ.54) THEN
+ IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
+ ELSEIF(ISUB.EQ.58) THEN
+ IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
+ ENDIF
+ ENDIF
+
+C...Final state flavours and colour flow: default values
+ JS=1
+ MINT(21)=MINT(15)
+ MINT(22)=MINT(16)
+ MINT(23)=0
+ MINT(24)=0
+ KCC=20
+ KCS=ISIGN(1,MINT(15))
+
+ IF(ISET(ISUB).EQ.11) THEN
+C...User-defined processes: find products
+ IRUP=0
+ DO 210 IUP=3,NUP
+ IF(KUP(IUP,1).NE.1) THEN
+ ELSEIF(IRUP.LE.5) THEN
+ IRUP=IRUP+1
+ MINT(20+IRUP)=KUP(IUP,2)
+ ENDIF
+ 210 CONTINUE
+
+ ELSEIF(ISUB.LE.10) THEN
+ IF(ISUB.EQ.1) THEN
+C...f + fbar -> gamma*/Z0
+ KFRES=23
+
+ ELSEIF(ISUB.EQ.2) THEN
+C...f + fbar' -> W+/-
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ KFRES=ISIGN(24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.3) THEN
+C...f + fbar -> h0 (or H0, or A0)
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.4) THEN
+C...gamma + W+/- -> W+/-
+
+ ELSEIF(ISUB.EQ.5) THEN
+C...Z0 + Z0 -> h0
+ XH=SH/SHP
+ MINT(21)=MINT(15)
+ MINT(22)=MINT(16)
+ PMQ(1)=PYMASS(MINT(21))
+ PMQ(2)=PYMASS(MINT(22))
+ 220 JT=INT(1.5D0+PYR(0))
+ ZMIN=2D0*PMQ(JT)/SHPR
+ ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
+ & (SHPR*(SHPR-PMQ(3-JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
+ IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
+ & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
+ SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 220
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
+ CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
+ SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 220
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
+ CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
+ PHIR=PARU(2)*PYR(0)
+ CPHI=COS(PHIR)
+ ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
+ & SQRT(1D0-CTHE(2)**2)*CPHI
+ Z1=2D0-Z(JT)
+ Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
+ Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
+ Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
+ & PMQ(3-JT)**2/SHP))
+ ZMIN=2D0*PMQ(3-JT)/SHPR
+ ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
+ KCC=22
+ KFRES=25
+
+ ELSEIF(ISUB.EQ.6) THEN
+C...Z0 + W+/- -> W+/-
+
+ ELSEIF(ISUB.EQ.7) THEN
+C...W+ + W- -> Z0
+
+ ELSEIF(ISUB.EQ.8) THEN
+C...W+ + W- -> h0
+ XH=SH/SHP
+ 230 DO 260 JT=1,2
+ I=MINT(14+JT)
+ IA=IABS(I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 240 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
+ MINT(20+JT)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 250
+ 240 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JT)=ISIGN(IB,I)
+ ENDIF
+ 250 PMQ(JT)=PYMASS(MINT(20+JT))
+ 260 CONTINUE
+ JT=INT(1.5D0+PYR(0))
+ ZMIN=2D0*PMQ(JT)/SHPR
+ ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
+ & (SHPR*(SHPR-PMQ(3-JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(ZMIN.GE.ZMAX) GOTO 230
+ Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
+ IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
+ & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
+ SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 230
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
+ CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
+ SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 230
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
+ CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
+ PHIR=PARU(2)*PYR(0)
+ CPHI=COS(PHIR)
+ ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
+ & SQRT(1D0-CTHE(2)**2)*CPHI
+ Z1=2D0-Z(JT)
+ Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
+ Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
+ Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
+ & PMQ(3-JT)**2/SHP))
+ ZMIN=2D0*PMQ(3-JT)/SHPR
+ ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
+ KCC=22
+ KFRES=25
+
+ ELSEIF(ISUB.EQ.10) THEN
+C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
+ IF(MINT(2).EQ.1) THEN
+ KCC=22
+ ELSE
+C...W exchange: need to mix flavours according to CKM matrix
+ DO 280 JT=1,2
+ I=MINT(14+JT)
+ IA=IABS(I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 270 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
+ MINT(20+JT)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 280
+ 270 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JT)=ISIGN(IB,I)
+ ENDIF
+ 280 CONTINUE
+ KCC=22
+ ENDIF
+ ENDIF
+
+ ELSEIF(ISUB.LE.20) THEN
+ IF(ISUB.EQ.11) THEN
+C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+
+ ELSEIF(ISUB.EQ.12) THEN
+C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
+ MINT(21)=ISIGN(KFLF,MINT(15))
+ MINT(22)=-MINT(21)
+ KCC=4
+
+ ELSEIF(ISUB.EQ.13) THEN
+C...f + fbar -> g + g; th arbitrary
+ MINT(21)=21
+ MINT(22)=21
+ KCC=MINT(2)+4
+
+ ELSEIF(ISUB.EQ.14) THEN
+C...f + fbar -> g + gamma; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=21
+ MINT(23-JS)=22
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.15) THEN
+C...f + fbar -> g + Z0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=21
+ MINT(23-JS)=23
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.16) THEN
+C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
+ MINT(20+JS)=21
+ MINT(23-JS)=ISIGN(24,KCH1+KCH2)
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.17) THEN
+C...f + fbar -> g + h0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=21
+ MINT(23-JS)=25
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.18) THEN
+C...f + fbar -> gamma + gamma; th arbitrary
+ MINT(21)=22
+ MINT(22)=22
+
+ ELSEIF(ISUB.EQ.19) THEN
+C...f + fbar -> gamma + Z0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=22
+ MINT(23-JS)=23
+
+ ELSEIF(ISUB.EQ.20) THEN
+C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
+C...(p(fbar')-p(W+))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
+ MINT(20+JS)=22
+ MINT(23-JS)=ISIGN(24,KCH1+KCH2)
+ ENDIF
+
+ ELSEIF(ISUB.LE.30) THEN
+ IF(ISUB.EQ.21) THEN
+C...f + fbar -> gamma + h0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=22
+ MINT(23-JS)=25
+
+ ELSEIF(ISUB.EQ.22) THEN
+C...f + fbar -> Z0 + Z0; th arbitrary
+ MINT(21)=23
+ MINT(22)=23
+
+ ELSEIF(ISUB.EQ.23) THEN
+C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
+ MINT(20+JS)=23
+ MINT(23-JS)=ISIGN(24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.24) THEN
+C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=23
+ MINT(23-JS)=KFHIGG
+
+ ELSEIF(ISUB.EQ.25) THEN
+C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
+ MINT(21)=-ISIGN(24,MINT(15))
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.26) THEN
+C...f + fbar' -> W+/- + h0 (or H0, or A0);
+C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
+ MINT(20+JS)=ISIGN(24,KCH1+KCH2)
+ MINT(23-JS)=KFHIGG
+
+ ELSEIF(ISUB.EQ.27) THEN
+C...f + fbar -> h0 + h0
+
+ ELSEIF(ISUB.EQ.28) THEN
+C...f + g -> f + g; th = (p(f)-p(f))**2
+ KCC=MINT(2)+6
+ IF(MINT(15).EQ.21) KCC=KCC+2
+ IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
+ IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
+
+ ELSEIF(ISUB.EQ.29) THEN
+C...f + g -> f + gamma; th = (p(f)-p(f))**2
+ IF(MINT(15).EQ.21) JS=2
+ MINT(23-JS)=22
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.30) THEN
+C...f + g -> f + Z0; th = (p(f)-p(f))**2
+ IF(MINT(15).EQ.21) JS=2
+ MINT(23-JS)=23
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+ ENDIF
+
+ ELSEIF(ISUB.LE.40) THEN
+ IF(ISUB.EQ.31) THEN
+C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 290 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
+ MINT(20+JS)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 300
+ 290 CONTINUE
+ 300 KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.32) THEN
+C...f + g -> f + h0; th = (p(f)-p(f))**2
+ IF(MINT(15).EQ.21) JS=2
+ MINT(23-JS)=25
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.33) THEN
+C...f + gamma -> f + g; th=(p(f)-p(f))**2
+ IF(MINT(15).EQ.22) JS=2
+ MINT(23-JS)=21
+ KCC=24+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.34) THEN
+C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
+ IF(MINT(15).EQ.22) JS=2
+ KCC=22
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.35) THEN
+C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
+ IF(MINT(15).EQ.22) JS=2
+ MINT(23-JS)=23
+ KCC=22
+
+ ELSEIF(ISUB.EQ.36) THEN
+C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
+ IF(MINT(15).EQ.22) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 310 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
+ MINT(20+JS)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 320
+ 310 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JS)=ISIGN(IB,I)
+ ENDIF
+ 320 KCC=22
+
+ ELSEIF(ISUB.EQ.37) THEN
+C...f + gamma -> f + h0
+
+ ELSEIF(ISUB.EQ.38) THEN
+C...f + Z0 -> f + g
+
+ ELSEIF(ISUB.EQ.39) THEN
+C...f + Z0 -> f + gamma
+
+ ELSEIF(ISUB.EQ.40) THEN
+C...f + Z0 -> f + Z0
+ ENDIF
+
+ ELSEIF(ISUB.LE.50) THEN
+ IF(ISUB.EQ.41) THEN
+C...f + Z0 -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.42) THEN
+C...f + Z0 -> f + h0
+
+ ELSEIF(ISUB.EQ.43) THEN
+C...f + W+/- -> f' + g
+
+ ELSEIF(ISUB.EQ.44) THEN
+C...f + W+/- -> f' + gamma
+
+ ELSEIF(ISUB.EQ.45) THEN
+C...f + W+/- -> f' + Z0
+
+ ELSEIF(ISUB.EQ.46) THEN
+C...f + W+/- -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.47) THEN
+C...f + W+/- -> f' + h0
+
+ ELSEIF(ISUB.EQ.48) THEN
+C...f + h0 -> f + g
+
+ ELSEIF(ISUB.EQ.49) THEN
+C...f + h0 -> f + gamma
+
+ ELSEIF(ISUB.EQ.50) THEN
+C...f + h0 -> f + Z0
+ ENDIF
+
+ ELSEIF(ISUB.LE.60) THEN
+ IF(ISUB.EQ.51) THEN
+C...f + h0 -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.52) THEN
+C...f + h0 -> f + h0
+
+ ELSEIF(ISUB.EQ.53) THEN
+C...g + g -> f + fbar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFLF,KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+
+ ELSEIF(ISUB.EQ.54) THEN
+C...g + gamma -> f + fbar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFLF,KCS)
+ MINT(22)=-MINT(21)
+ KCC=27
+ IF(MINT(16).EQ.21) KCC=28
+
+ ELSEIF(ISUB.EQ.55) THEN
+C...g + Z0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.56) THEN
+C...g + W+/- -> f + fbar'
+
+ ELSEIF(ISUB.EQ.57) THEN
+C...g + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.58) THEN
+C...gamma + gamma -> f + fbar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFLF,KCS)
+ MINT(22)=-MINT(21)
+ KCC=21
+
+ ELSEIF(ISUB.EQ.59) THEN
+C...gamma + Z0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.60) THEN
+C...gamma + W+/- -> f + fbar'
+ ENDIF
+
+ ELSEIF(ISUB.LE.70) THEN
+ IF(ISUB.EQ.61) THEN
+C...gamma + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.62) THEN
+C...Z0 + Z0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.63) THEN
+C...Z0 + W+/- -> f + fbar'
+
+ ELSEIF(ISUB.EQ.64) THEN
+C...Z0 + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.65) THEN
+C...W+ + W- -> f + fbar
+
+ ELSEIF(ISUB.EQ.66) THEN
+C...W+/- + h0 -> f + fbar'
+
+ ELSEIF(ISUB.EQ.67) THEN
+C...h0 + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.68) THEN
+C...g + g -> g + g; th arbitrary
+ KCC=MINT(2)+12
+ KCS=(-1)**INT(1.5D0+PYR(0))
+
+ ELSEIF(ISUB.EQ.69) THEN
+C...gamma + gamma -> W+ + W-; th arbitrary
+ MINT(21)=24
+ MINT(22)=-24
+ KCC=21
+
+ ELSEIF(ISUB.EQ.70) THEN
+C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
+ IF(MINT(15).EQ.22) MINT(21)=23
+ IF(MINT(16).EQ.22) MINT(22)=23
+ KCC=21
+ ENDIF
+
+ ELSEIF(ISUB.LE.80) THEN
+ IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
+C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
+ XH=SH/SHP
+ MINT(21)=MINT(15)
+ MINT(22)=MINT(16)
+ PMQ(1)=PYMASS(MINT(21))
+ PMQ(2)=PYMASS(MINT(22))
+ 330 JT=INT(1.5D0+PYR(0))
+ ZMIN=2D0*PMQ(JT)/SHPR
+ ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
+ & (SHPR*(SHPR-PMQ(3-JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
+ IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
+ & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
+ SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 330
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
+ CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
+ SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 330
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
+ CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
+ PHIR=PARU(2)*PYR(0)
+ CPHI=COS(PHIR)
+ ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
+ & SQRT(1D0-CTHE(2)**2)*CPHI
+ Z1=2D0-Z(JT)
+ Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
+ Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
+ Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
+ & PMQ(3-JT)**2/SHP))
+ ZMIN=2D0*PMQ(3-JT)/SHPR
+ ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
+ KCC=22
+
+ ELSEIF(ISUB.EQ.73) THEN
+C...Z0 + W+/- -> Z0 + W+/-
+ JS=MINT(2)
+ XH=SH/SHP
+ 340 JT=3-MINT(2)
+ I=MINT(14+JT)
+ IA=IABS(I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 350 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
+ MINT(20+JT)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 360
+ 350 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JT)=ISIGN(IB,I)
+ ENDIF
+ 360 PMQ(JT)=PYMASS(MINT(20+JT))
+ MINT(23-JT)=MINT(17-JT)
+ PMQ(3-JT)=PYMASS(MINT(23-JT))
+ JT=INT(1.5D0+PYR(0))
+ ZMIN=2D0*PMQ(JT)/SHPR
+ ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
+ & (SHPR*(SHPR-PMQ(3-JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(ZMIN.GE.ZMAX) GOTO 340
+ Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
+ IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
+ & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
+ SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 340
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
+ CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
+ SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 340
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
+ CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
+ PHIR=PARU(2)*PYR(0)
+ CPHI=COS(PHIR)
+ ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
+ & SQRT(1D0-CTHE(2)**2)*CPHI
+ Z1=2D0-Z(JT)
+ Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
+ Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
+ Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
+ & PMQ(3-JT)**2/SHP))
+ ZMIN=2D0*PMQ(3-JT)/SHPR
+ ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
+ KCC=22
+
+ ELSEIF(ISUB.EQ.74) THEN
+C...Z0 + h0 -> Z0 + h0
+
+ ELSEIF(ISUB.EQ.75) THEN
+C...W+ + W- -> gamma + gamma
+
+ ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
+C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
+ XH=SH/SHP
+ 370 DO 400 JT=1,2
+ I=MINT(14+JT)
+ IA=IABS(I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 380 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
+ MINT(20+JT)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 390
+ 380 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JT)=ISIGN(IB,I)
+ ENDIF
+ 390 PMQ(JT)=PYMASS(MINT(20+JT))
+ 400 CONTINUE
+ JT=INT(1.5D0+PYR(0))
+ ZMIN=2D0*PMQ(JT)/SHPR
+ ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
+ & (SHPR*(SHPR-PMQ(3-JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(ZMIN.GE.ZMAX) GOTO 370
+ Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
+ IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
+ & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
+ SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 370
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
+ CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
+ SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
+ IF(SQC1.LT.1.D-8) GOTO 370
+ C1=SQRT(SQC1)
+ C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
+ CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
+ CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
+ PHIR=PARU(2)*PYR(0)
+ CPHI=COS(PHIR)
+ ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
+ & SQRT(1D0-CTHE(2)**2)*CPHI
+ Z1=2D0-Z(JT)
+ Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
+ Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
+ Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
+ & PMQ(3-JT)**2/SHP))
+ ZMIN=2D0*PMQ(3-JT)/SHPR
+ ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
+ ZMAX=MIN(1D0-XH,ZMAX)
+ IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
+ KCC=22
+
+ ELSEIF(ISUB.EQ.78) THEN
+C...W+/- + h0 -> W+/- + h0
+
+ ELSEIF(ISUB.EQ.79) THEN
+C...h0 + h0 -> h0 + h0
+
+ ELSEIF(ISUB.EQ.80) THEN
+C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
+ IF(MINT(15).EQ.22) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
+ IB=3-IA
+ MINT(20+JS)=ISIGN(IB,I)
+ KCC=22
+ ENDIF
+
+ ELSEIF(ISUB.LE.90) THEN
+ IF(ISUB.EQ.81) THEN
+C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
+ MINT(21)=ISIGN(MINT(55),MINT(15))
+ MINT(22)=-MINT(21)
+ KCC=4
+
+ ELSEIF(ISUB.EQ.82) THEN
+C...g + g -> Q + Qbar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(MINT(55),KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+
+ ELSEIF(ISUB.EQ.83) THEN
+C...f + q -> f' + Q; th = (p(f) - p(f'))**2
+ KFOLD=MINT(16)
+ IF(MINT(2).EQ.2) KFOLD=MINT(15)
+ KFAOLD=IABS(KFOLD)
+ IF(KFAOLD.GT.10) THEN
+ KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
+ ELSE
+ RCKM=VINT(180+KFOLD)*PYR(0)
+ IPM=(5-ISIGN(1,KFOLD))/2
+ KFANEW=-MOD(KFAOLD+1,2)
+ 410 KFANEW=KFANEW+2
+ IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
+ IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
+ & VCKM(KFAOLD/2,(KFANEW+1)/2)
+ IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
+ & VCKM(KFANEW/2,(KFAOLD+1)/2)
+ ENDIF
+ IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
+ ENDIF
+ IF(MINT(2).EQ.1) THEN
+ MINT(21)=ISIGN(MINT(55),MINT(15))
+ MINT(22)=ISIGN(KFANEW,MINT(16))
+ ELSE
+ MINT(21)=ISIGN(KFANEW,MINT(15))
+ MINT(22)=ISIGN(MINT(55),MINT(16))
+ JS=2
+ ENDIF
+ KCC=22
+
+ ELSEIF(ISUB.EQ.84) THEN
+C...g + gamma -> Q + Qbar; th arbitary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(MINT(55),KCS)
+ MINT(22)=-MINT(21)
+ KCC=27
+ IF(MINT(16).EQ.21) KCC=28
+
+ ELSEIF(ISUB.EQ.85) THEN
+C...gamma + gamma -> F + Fbar; th arbitary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(MINT(56),KCS)
+ MINT(22)=-MINT(21)
+ KCC=21
+
+ ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
+C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
+ MINT(21)=KFPR(ISUB,1)
+ MINT(22)=KFPR(ISUB,2)
+ KCC=24
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ ENDIF
+
+ ELSEIF(ISUB.LE.100) THEN
+ IF(ISUB.EQ.95) THEN
+C...Low-pT ( = energyless g + g -> g + g)
+ KCC=MINT(2)+12
+ KCS=(-1)**INT(1.5D0+PYR(0))
+
+ ELSEIF(ISUB.EQ.96) THEN
+C...Multiple interactions (should be reassigned to QCD process)
+ ENDIF
+
+ ELSEIF(ISUB.LE.110) THEN
+ IF(ISUB.EQ.101) THEN
+C...g + g -> gamma*/Z0
+ KCC=21
+ KFRES=22
+
+ ELSEIF(ISUB.EQ.102) THEN
+C...g + g -> h0 (or H0, or A0)
+ KCC=21
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.103) THEN
+C...gamma + gamma -> h0 (or H0, or A0)
+ KCC=21
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.106) THEN
+C...g + g -> J/Psi + gamma
+ MINT(21)=KFPR(ISUB,1)
+ MINT(22)=KFPR(ISUB,2)
+ KCC=21
+
+ ELSEIF(ISUB.EQ.107) THEN
+C...g + gamma -> J/Psi + g
+ MINT(21)=KFPR(ISUB,1)
+ MINT(22)=KFPR(ISUB,2)
+ KCC=22
+ IF(MINT(16).EQ.22) KCC=33
+
+ ELSEIF(ISUB.EQ.108) THEN
+C...gamma + gamma -> J/Psi + gamma
+ MINT(21)=KFPR(ISUB,1)
+ MINT(22)=KFPR(ISUB,2)
+
+ ELSEIF(ISUB.EQ.110) THEN
+C...f + fbar -> gamma + h0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=22
+ MINT(23-JS)=KFHIGG
+ ENDIF
+
+ ELSEIF(ISUB.LE.120) THEN
+ IF(ISUB.EQ.111) THEN
+C...f + fbar -> g + h0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=21
+ MINT(23-JS)=25
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.112) THEN
+C...f + g -> f + h0; th = (p(f) - p(f))**2
+ IF(MINT(15).EQ.21) JS=2
+ MINT(23-JS)=25
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.113) THEN
+C...g + g -> g + h0; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(23-JS)=25
+ KCC=22+JS
+ KCS=(-1)**INT(1.5D0+PYR(0))
+
+ ELSEIF(ISUB.EQ.114) THEN
+C...g + g -> gamma + gamma; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(21)=22
+ MINT(22)=22
+ KCC=21
+
+ ELSEIF(ISUB.EQ.115) THEN
+C...g + g -> g + gamma; th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(23-JS)=22
+ KCC=22+JS
+ KCS=(-1)**INT(1.5D0+PYR(0))
+
+ ELSEIF(ISUB.EQ.116) THEN
+C...g + g -> gamma + Z0
+
+ ELSEIF(ISUB.EQ.117) THEN
+C...g + g -> Z0 + Z0
+
+ ELSEIF(ISUB.EQ.118) THEN
+C...g + g -> W+ + W-
+ ENDIF
+
+ ELSEIF(ISUB.LE.140) THEN
+ IF(ISUB.EQ.121) THEN
+C...g + g -> Q + Qbar + h0
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
+ MINT(22)=-MINT(21)
+ KCC=11+INT(0.5D0+PYR(0))
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.122) THEN
+C...q + qbar -> Q + Qbar + h0
+ MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
+ MINT(22)=-MINT(21)
+ KCC=4
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.123) THEN
+C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
+C...inner process)
+ KCC=22
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.124) THEN
+C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
+C...inner process)
+ DO 430 JT=1,2
+ I=MINT(14+JT)
+ IA=IABS(I)
+ IF(IA.LE.10) THEN
+ RVCKM=VINT(180+I)*PYR(0)
+ DO 420 J=1,MSTP(1)
+ IB=2*J-1+MOD(IA,2)
+ IPM=(5-ISIGN(1,I))/2
+ IDC=J+MDCY(IA,2)+2
+ IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
+ MINT(20+JT)=ISIGN(IB,I)
+ RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
+ IF(RVCKM.LE.0D0) GOTO 430
+ 420 CONTINUE
+ ELSE
+ IB=2*((IA+1)/2)-1+MOD(IA,2)
+ MINT(20+JT)=ISIGN(IB,I)
+ ENDIF
+ 430 CONTINUE
+ KCC=22
+ KFRES=KFHIGG
+
+ ELSEIF(ISUB.EQ.131) THEN
+C...g + g -> Z0 + q + qbar
+ ENDIF
+
+ ELSEIF(ISUB.LE.160) THEN
+ IF(ISUB.EQ.141) THEN
+C...f + fbar -> gamma*/Z0/Z'0
+ KFRES=32
+
+ ELSEIF(ISUB.EQ.142) THEN
+C...f + fbar' -> W'+/-
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ KFRES=ISIGN(34,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.143) THEN
+C...f + fbar' -> H+/-
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ KFRES=ISIGN(37,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.144) THEN
+C...f + fbar' -> R
+ KFRES=ISIGN(40,MINT(15)+MINT(16))
+
+ ELSEIF(ISUB.EQ.145) THEN
+C...q + l -> LQ (leptoquark)
+ IF(IABS(MINT(16)).LE.8) JS=2
+ KFRES=ISIGN(39,MINT(14+JS))
+ KCC=28+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
+C...q + g -> q* (excited quark)
+ IF(MINT(15).EQ.21) JS=2
+ KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
+ KCC=30+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.149) THEN
+C...g + g -> eta_techni
+ KFRES=38
+ KCC=23
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ ENDIF
+
+ ELSEIF(ISUB.LE.200) THEN
+ IF(ISUB.EQ.161) THEN
+C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
+ IB=IA+MOD(IA,2)-MOD(IA+1,2)
+ MINT(20+JS)=ISIGN(IB,I)
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.162) THEN
+C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
+ IF(MINT(15).EQ.21) JS=2
+ MINT(20+JS)=ISIGN(39,MINT(14+JS))
+ KFLQL=KFDP(MDCY(39,2),2)
+ MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.163) THEN
+C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(39,KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+
+ ELSEIF(ISUB.EQ.164) THEN
+C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
+ MINT(21)=ISIGN(39,MINT(15))
+ MINT(22)=-MINT(21)
+ KCC=4
+
+ ELSEIF(ISUB.EQ.165) THEN
+C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
+ MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.166) THEN
+C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
+ IF(MOD(MINT(15),2).EQ.0) THEN
+ MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
+ MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
+ ELSE
+ MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
+ MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
+ ENDIF
+
+ ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
+C...q + q' -> q" + q* (excited quark)
+ KFQSTR=KFPR(ISUB,2)
+ KFQEXC=MOD(KFQSTR,KEXCIT)
+ JS=MINT(2)
+ MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
+ IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
+ & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
+ KCC=22
+
+ ELSEIF(ISUB.EQ.191) THEN
+C...f + fbar -> rho_tech0.
+ KFRES=54
+
+ ELSEIF(ISUB.EQ.192) THEN
+C...f + fbar' -> rho_tech+/-
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ KFRES=ISIGN(55,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.193) THEN
+C...f + fbar -> omega_tech0.
+ KFRES=56
+
+ ELSEIF(ISUB.EQ.194) THEN
+C...f + fbar -> f' + fbar' via mixture of s-channel
+C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
+ MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
+ MINT(22)=-MINT(21)
+ ENDIF
+
+CMRENNA++
+ ELSEIF(ISUB.LE.215) THEN
+ IF(ISUB.EQ.201) THEN
+C...f + fbar -> ~e_L + ~e_Lbar
+ MINT(21)=ISIGN(KSUSY1+11,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.202) THEN
+C...f + fbar -> ~e_R + ~e_Rbar
+ MINT(21)=ISIGN(KSUSY2+11,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.203) THEN
+C...f + fbar -> ~e_R + ~e_Lbar
+ KCS=1
+ IF(MINT(2).EQ.2) KCS=-1
+ MINT(21)=ISIGN(KSUSY1+11,KCS)
+ MINT(22)=-ISIGN(KSUSY2+11,KCS)
+
+ ELSEIF(ISUB.EQ.204) THEN
+C...f + fbar -> ~mu_L + ~mu_Lbar
+ MINT(21)=ISIGN(KSUSY1+13,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.205) THEN
+C...f + fbar -> ~mu_R + ~mu_Rbar
+ MINT(21)=ISIGN(KSUSY2+13,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.206) THEN
+C...f + fbar -> ~mu_L + ~mu_Rbar
+ KCS=1
+ IF(MINT(2).EQ.2) KCS=-1
+ MINT(21)=ISIGN(KSUSY1+13,KCS)
+ MINT(22)=-ISIGN(KSUSY2+13,KCS)
+
+ ELSEIF(ISUB.EQ.207) THEN
+C...f + fbar -> ~tau_1 + ~tau_1bar
+ MINT(21)=ISIGN(KSUSY1+15,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.208) THEN
+C...f + fbar -> ~tau_2 + ~tau_2bar
+ MINT(21)=ISIGN(KSUSY2+15,KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.209) THEN
+C...f + fbar -> ~tau_1 + ~tau_2bar
+ KCS=1
+ IF(MINT(2).EQ.2) KCS=-1
+ MINT(21)=ISIGN(KSUSY1+15,KCS)
+ MINT(22)=-ISIGN(KSUSY2+15,KCS)
+
+ ELSEIF(ISUB.EQ.210) THEN
+C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
+ MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.211) THEN
+C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
+ MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.212) THEN
+C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
+ MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.213) THEN
+C...f + fbar -> ~nul + ~nulbar
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.214) THEN
+C...f + fbar -> ~nutau + ~nutaubar
+ MINT(21)=ISIGN(KSUSY1+16,KCS)
+ MINT(22)=-MINT(21)
+ ENDIF
+
+ ELSEIF(ISUB.LE.225) THEN
+ IF(ISUB.EQ.216) THEN
+C...f + fbar -> ~chi01 + ~chi01
+ MINT(21)=KSUSY1+22
+ MINT(22)=KSUSY1+22
+
+ ELSEIF(ISUB.EQ.217) THEN
+C...f + fbar -> ~chi02 + ~chi02
+ MINT(21)=KSUSY1+23
+ MINT(22)=KSUSY1+23
+
+ ELSEIF(ISUB.EQ.218 ) THEN
+C...f + fbar -> ~chi03 + ~chi03
+ MINT(21)=KSUSY1+25
+ MINT(22)=KSUSY1+25
+
+ ELSEIF(ISUB.EQ.219 ) THEN
+C...f + fbar -> ~chi04 + ~chi04
+ MINT(21)=KSUSY1+35
+ MINT(22)=KSUSY1+35
+
+ ELSEIF(ISUB.EQ.220 ) THEN
+C...f + fbar -> ~chi01 + ~chi02
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+22
+ MINT(23-JS)=KSUSY1+23
+
+ ELSEIF(ISUB.EQ.221 ) THEN
+C...f + fbar -> ~chi01 + ~chi03
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+22
+ MINT(23-JS)=KSUSY1+25
+
+ ELSEIF(ISUB.EQ.222) THEN
+C...f + fbar -> ~chi01 + ~chi04
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+22
+ MINT(23-JS)=KSUSY1+35
+
+ ELSEIF(ISUB.EQ.223) THEN
+C...f + fbar -> ~chi02 + ~chi03
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+23
+ MINT(23-JS)=KSUSY1+25
+
+ ELSEIF(ISUB.EQ.224) THEN
+C...f + fbar -> ~chi02 + ~chi04
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+23
+ MINT(23-JS)=KSUSY1+35
+
+ ELSEIF(ISUB.EQ.225) THEN
+C...f + fbar -> ~chi03 + ~chi04
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+25
+ MINT(23-JS)=KSUSY1+35
+ ENDIF
+
+ ELSEIF(ISUB.LE.236) THEN
+ IF(ISUB.EQ.226) THEN
+C...f + fbar -> ~chi+-1 + ~chi-+1
+C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
+ MINT(21)=ISIGN(KSUSY1+24,MINT(15))
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.227) THEN
+C...f + fbar -> ~chi+-2 + ~chi-+2
+ MINT(21)=ISIGN(KSUSY1+37,MINT(15))
+ MINT(22)=-MINT(21)
+
+ ELSEIF(ISUB.EQ.228) THEN
+C...f + fbar -> ~chi+-1 + ~chi-+2
+C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
+C...js=1 if pyr<.5, js=2 if pyr>.5
+C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
+C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
+C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
+C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
+ KCH1=ISIGN(1,MINT(15))
+ KCH2=INT(1-KCH1)/2
+ IF(MINT(2).EQ.1) THEN
+ MINT(22-KCH2)= -(KSUSY1+24)
+ MINT(21+KCH2)= KSUSY1+37
+ IF(KCH2.EQ.0) JS=2
+ ELSE
+ MINT(21+KCH2)= KSUSY1+24
+ MINT(22-KCH2)= -(KSUSY1+37)
+ IF(KCH2.EQ.1) JS=2
+ ENDIF
+
+ ELSEIF(ISUB.EQ.229) THEN
+C...q + qbar' -> ~chi01 + ~chi+-1
+C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+C...CHECK THIS
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+22
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.230) THEN
+C...q + qbar' -> ~chi02 + ~chi+-1
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+23
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.231) THEN
+C...q + qbar' -> ~chi03 + ~chi+-1
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+25
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.232) THEN
+C...q + qbar' -> ~chi04 + ~chi+-1
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+35
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.233) THEN
+C...q + qbar' -> ~chi01 + ~chi+-2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+22
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.234) THEN
+C...q + qbar' -> ~chi02 + ~chi+-2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+23
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.235) THEN
+C...q + qbar' -> ~chi03 + ~chi+-2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+25
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
+
+ ELSEIF(ISUB.EQ.236) THEN
+C...q + qbar' -> ~chi04 + ~chi+-2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ IF(MOD(MINT(15),2).NE.0) JS=2
+ MINT(20+JS)=KSUSY1+35
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
+ ENDIF
+
+ ELSEIF(ISUB.LE.245) THEN
+ IF(ISUB.EQ.237) THEN
+C...q + qbar -> ~chi01 + ~g
+C...th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=KSUSY1+22
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.238) THEN
+C...q + qbar -> ~chi02 + ~g
+C...th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=KSUSY1+23
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.239) THEN
+C...q + qbar -> ~chi03 + ~g
+C...th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=KSUSY1+25
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.240) THEN
+C...q + qbar -> ~chi04 + ~g
+C...th arbitrary
+ IF(PYR(0).GT.0.5D0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=KSUSY1+35
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.241) THEN
+C...q + qbar' -> ~chi+-1 + ~g
+C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
+C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
+C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
+C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
+C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ JS=1
+ IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.242) THEN
+C...q + qbar' -> ~chi+-2 + ~g
+C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
+C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
+C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
+C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
+C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
+ KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
+ KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
+ JS=1
+ IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
+ MINT(20+JS)=KSUSY1+21
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
+ KCC=17+JS
+
+ ELSEIF(ISUB.EQ.243) THEN
+C...q + qbar -> ~g + ~g ; th arbitrary
+ MINT(21)=KSUSY1+21
+ MINT(22)=KSUSY1+21
+ KCC=MINT(2)+4
+
+ ELSEIF(ISUB.EQ.244) THEN
+C...g + g -> ~g + ~g ; th arbitrary
+ KCC=MINT(2)+12
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=KSUSY1+21
+ MINT(22)=KSUSY1+21
+ ENDIF
+
+ ELSEIF(ISUB.LE.260) THEN
+ IF(ISUB.EQ.246) THEN
+C...qj + g -> ~qj_L + ~chi01
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY1+IA,I)
+ MINT(23-JS)=KSUSY1+22
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.247) THEN
+C...qj + g -> ~qj_R + ~chi01
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY2+IA,I)
+ MINT(23-JS)=KSUSY1+22
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.248) THEN
+C...qj + g -> ~qj_L + ~chi02
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY1+IA,I)
+ MINT(23-JS)=KSUSY1+23
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.249) THEN
+C...qj + g -> ~qj_R + ~chi02
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY2+IA,I)
+ MINT(23-JS)=KSUSY1+23
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.250) THEN
+C...qj + g -> ~qj_L + ~chi03
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY1+IA,I)
+ MINT(23-JS)=KSUSY1+25
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.251) THEN
+C...qj + g -> ~qj_R + ~chi03
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY2+IA,I)
+ MINT(23-JS)=KSUSY1+25
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.252) THEN
+C...qj + g -> ~qj_L + ~chi04
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY1+IA,I)
+ MINT(23-JS)=KSUSY1+35
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.253) THEN
+C...qj + g -> ~qj_R + ~chi04
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY2+IA,I)
+ MINT(23-JS)=KSUSY1+35
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.254) THEN
+C...qj + g -> ~qk_L + ~chi+-1
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
+ IB=-IA+INT((IA+1)/2)*4-1
+ MINT(20+JS)=ISIGN(KSUSY1+IB,I)
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.255) THEN
+C...qj + g -> ~qk_L + ~chi+-1
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
+ IB=-IA+INT((IA+1)/2)*4-1
+ MINT(20+JS)=ISIGN(KSUSY2+IB,I)
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.256) THEN
+C...qj + g -> ~qk_L + ~chi+-2
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ IB=-IA+INT((IA+1)/2)*4-1
+ MINT(20+JS)=ISIGN(KSUSY1+IB,I)
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.257) THEN
+C...qj + g -> ~qk_R + ~chi+-2
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ IB=-IA+INT((IA+1)/2)*4-1
+ MINT(20+JS)=ISIGN(KSUSY2+IB,I)
+ MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
+ KCC=15+JS
+ KCS=ISIGN(1,MINT(14+JS))
+
+ ELSEIF(ISUB.EQ.258) THEN
+C...qj + g -> ~qj_L + ~g
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY1+IA,I)
+ MINT(23-JS)=KSUSY1+21
+ KCC=MINT(2)+6
+ IF(JS.EQ.2) KCC=KCC+2
+ KCS=ISIGN(1,I)
+
+ ELSEIF(ISUB.EQ.259) THEN
+C...qj + g -> ~qj_R + ~g
+ IF(MINT(15).EQ.21) JS=2
+ I=MINT(14+JS)
+ IA=IABS(I)
+ MINT(20+JS)=ISIGN(KSUSY2+IA,I)
+ MINT(23-JS)=KSUSY1+21
+ KCC=MINT(2)+6
+ IF(JS.EQ.2) KCC=KCC+2
+ KCS=ISIGN(1,I)
+ ENDIF
+
+ ELSEIF(ISUB.LE.270) THEN
+ IF(ISUB.EQ.261) THEN
+C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+C...Correct color combination
+ IF(MINT(43).EQ.4) KCC=4
+
+ ELSEIF(ISUB.EQ.262) THEN
+C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+C...Correct color combination
+ IF(MINT(43).EQ.4) KCC=4
+
+ ELSEIF(ISUB.EQ.263) THEN
+C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
+ IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
+ & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
+ ELSE
+ JS=2
+ MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
+ MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
+ ENDIF
+C...Correct color combination
+ IF(MINT(43).EQ.4) KCC=4
+
+ ELSEIF(ISUB.EQ.264) THEN
+C...g + g -> ~t_1 + ~t_1bar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+
+ ELSEIF(ISUB.EQ.265) THEN
+C...g + g -> ~t_2 + ~t_2bar; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+ ENDIF
+
+ ELSEIF(ISUB.LE.280) THEN
+ IF(ISUB.EQ.271) THEN
+C...qi + qj -> ~qi_L + ~qj_L
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+ MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
+ MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
+
+ ELSEIF(ISUB.EQ.272) THEN
+C...qi + qj -> ~qi_R + ~qj_R
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+ MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
+ MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
+
+ ELSEIF(ISUB.EQ.273) THEN
+C...qi + qj -> ~qi_L + ~qj_R
+ MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
+ MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+
+ ELSEIF(ISUB.EQ.274) THEN
+C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
+ MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
+ MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+
+ ELSEIF(ISUB.EQ.275) THEN
+C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
+ MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
+ MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+
+ ELSEIF(ISUB.EQ.276) THEN
+C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
+ MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
+ MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
+ KCC=MINT(2)
+ IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
+
+ ELSEIF(ISUB.EQ.277) THEN
+C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
+ ISGN=1
+ IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
+ MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ IF(MINT(43).EQ.4) KCC=4
+
+ ELSEIF(ISUB.EQ.278) THEN
+C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
+ ISGN=1
+ IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
+ MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ IF(MINT(43).EQ.4) KCC=4
+
+ ELSEIF(ISUB.EQ.279) THEN
+C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
+C...pure LL + RR
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+
+ ELSEIF(ISUB.EQ.280) THEN
+C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
+ KCS=(-1)**INT(1.5D0+PYR(0))
+ MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
+ MINT(22)=-MINT(21)
+ KCC=MINT(2)+10
+ ENDIF
+
+CMRENNA--
+ ENDIF
+
+ IF(ISET(ISUB).EQ.11) THEN
+C...Store documentation for user-defined processes
+ BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
+ KUPPO(1)=MINT(83)+5
+ KUPPO(2)=MINT(83)+6
+ I=MINT(83)+6
+ DO 450 IUP=3,NUP
+ KUPPO(IUP)=0
+ IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
+ IDOC=IDOC-1
+ MINT(4)=MINT(4)-1
+ GOTO 450
+ ENDIF
+ I=I+1
+ KUPPO(IUP)=I
+ K(I,1)=21
+ K(I,2)=KUP(IUP,2)
+ K(I,3)=0
+ IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
+ K(I,4)=0
+ K(I,5)=0
+ DO 440 J=1,5
+ P(I,J)=PUP(IUP,J)
+ 440 CONTINUE
+ 450 CONTINUE
+ CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
+ & -BEZUP)
+
+C...Store final state partons for user-defined processes
+ N=IPU2
+ DO 470 IUP=3,NUP
+ N=N+1
+ K(N,1)=1
+ IF(KUP(IUP,1).NE.1) K(N,1)=11
+ K(N,2)=KUP(IUP,2)
+ IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
+ K(N,3)=KUPPO(IUP)
+ ELSE
+ K(N,3)=MINT(84)+KUP(IUP,3)
+ ENDIF
+ K(N,4)=0
+ K(N,5)=0
+ DO 460 J=1,5
+ P(N,J)=PUP(IUP,J)
+ 460 CONTINUE
+ 470 CONTINUE
+ CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
+
+C...Arrange colour flow for user-defined processes
+ N=MINT(84)
+ DO 480 IUP=1,NUP
+ N=N+1
+ IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
+ IF(K(N,1).EQ.1) K(N,1)=3
+ IF(K(N,1).EQ.11) K(N,1)=14
+ IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
+ & MINT(84))
+ IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
+ & MINT(84))
+ IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
+ IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
+ 480 CONTINUE
+
+ ELSEIF(IDOC.EQ.7) THEN
+C...Resonance not decaying; store kinematics
+ I=MINT(83)+7
+ K(IPU3,1)=1
+ K(IPU3,2)=KFRES
+ K(IPU3,3)=I
+ P(IPU3,4)=SHUSER
+ P(IPU3,5)=SHUSER
+ K(I,1)=21
+ K(I,2)=KFRES
+ P(I,4)=SHUSER
+ P(I,5)=SHUSER
+ N=IPU3
+ MINT(21)=KFRES
+ MINT(22)=0
+
+C...Special cases: colour flow in coloured resonances
+ KCRES=PYCOMP(KFRES)
+ IF(KCHG(KCRES,2).NE.0) THEN
+ K(IPU3,1)=3
+ DO 490 J=1,2
+ JC=J
+ IF(KCS.EQ.-1) JC=3-J
+ IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
+ & MINT(84)+ICOL(KCC,1,JC)
+ IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
+ & MINT(84)+ICOL(KCC,2,JC)
+ IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
+ & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
+ 490 CONTINUE
+ ELSE
+ K(IPU1,4)=IPU2
+ K(IPU1,5)=IPU2
+ K(IPU2,4)=IPU1
+ K(IPU2,5)=IPU1
+ ENDIF
+
+ ELSEIF(IDOC.EQ.8) THEN
+C...2 -> 2 processes: store outgoing partons in their CM-frame
+ DO 500 JT=1,2
+ I=MINT(84)+2+JT
+ KCA=PYCOMP(MINT(20+JT))
+ K(I,1)=1
+ IF(KCHG(KCA,2).NE.0) K(I,1)=3
+ K(I,2)=MINT(20+JT)
+ K(I,3)=MINT(83)+IDOC+JT-2
+ KFAA=IABS(K(I,2))
+ IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
+ P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
+ ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
+ P(I,5)=SQRT(VINT(64))
+ ELSE
+ P(I,5)=PYMASS(K(I,2))
+ ENDIF
+ IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
+ & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
+ 500 CONTINUE
+ IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
+ KFA1=IABS(MINT(21))
+ KFA2=IABS(MINT(22))
+ IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
+ & THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ P(IPU3,5)=0D0
+ P(IPU4,5)=0D0
+ ENDIF
+ P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
+ P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
+ P(IPU4,4)=SHR-P(IPU3,4)
+ P(IPU4,3)=-P(IPU3,3)
+ N=IPU4
+ MINT(7)=MINT(83)+7
+ MINT(8)=MINT(83)+8
+
+C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
+ CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
+
+ ELSEIF(IDOC.EQ.9) THEN
+C...2 -> 3 processes: store outgoing partons in their CM frame
+ DO 510 JT=1,2
+ I=MINT(84)+2+JT
+ KCA=PYCOMP(MINT(20+JT))
+ K(I,1)=1
+ IF(KCHG(KCA,2).NE.0) K(I,1)=3
+ K(I,2)=MINT(20+JT)
+ K(I,3)=MINT(83)+IDOC+JT-3
+ IF(IABS(K(I,2)).LE.22) THEN
+ P(I,5)=PYMASS(K(I,2))
+ ELSE
+ P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
+ ENDIF
+ PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
+ P(I,1)=PT*COS(VINT(198+5*JT))
+ P(I,2)=PT*SIN(VINT(198+5*JT))
+ 510 CONTINUE
+ K(IPU5,1)=1
+ K(IPU5,2)=KFRES
+ K(IPU5,3)=MINT(83)+IDOC
+ P(IPU5,5)=SHR
+ P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
+ P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
+ PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
+ PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
+ PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
+ PMT3=SQRT(PMS3)
+ P(IPU5,3)=PMT3*SINH(VINT(211))
+ P(IPU5,4)=PMT3*COSH(VINT(211))
+ PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
+ SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
+ IF(SQL12.LE.0D0) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
+ & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
+ P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
+ P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
+ P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
+ MINT(23)=KFRES
+ N=IPU5
+ MINT(7)=MINT(83)+7
+ MINT(8)=MINT(83)+8
+
+ ELSEIF(IDOC.EQ.11) THEN
+C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
+ PHI(1)=PARU(2)*PYR(0)
+ PHI(2)=PHI(1)-PHIR
+ DO 520 JT=1,2
+ I=MINT(84)+2+JT
+ K(I,1)=1
+ IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
+ K(I,2)=MINT(20+JT)
+ K(I,3)=MINT(83)+IDOC+JT-2
+ P(I,5)=PYMASS(K(I,2))
+ IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
+ PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
+ P(I,1)=PTABS*COS(PHI(JT))
+ P(I,2)=PTABS*SIN(PHI(JT))
+ P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
+ P(I,4)=0.5D0*SHPR*Z(JT)
+ IZW=MINT(83)+6+JT
+ K(IZW,1)=21
+ K(IZW,2)=23
+ IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
+ K(IZW,3)=IZW-2
+ P(IZW,1)=-P(I,1)
+ P(IZW,2)=-P(I,2)
+ P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
+ P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
+ P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
+ 520 CONTINUE
+ I=MINT(83)+9
+ K(IPU5,1)=1
+ K(IPU5,2)=KFRES
+ K(IPU5,3)=I
+ P(IPU5,5)=SHR
+ P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
+ P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
+ P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
+ P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
+ K(I,1)=21
+ K(I,2)=KFRES
+ DO 530 J=1,5
+ P(I,J)=P(IPU5,J)
+ 530 CONTINUE
+ N=IPU5
+ MINT(23)=KFRES
+
+ ELSEIF(IDOC.EQ.12) THEN
+C...Z0 and W+/- scattering: store bosons and outgoing partons
+ PHI(1)=PARU(2)*PYR(0)
+ PHI(2)=PHI(1)-PHIR
+ JTRAN=INT(1.5D0+PYR(0))
+ DO 540 JT=1,2
+ I=MINT(84)+2+JT
+ K(I,1)=1
+ IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
+ K(I,2)=MINT(20+JT)
+ K(I,3)=MINT(83)+IDOC+JT-2
+ P(I,5)=PYMASS(K(I,2))
+ IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
+ PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
+ PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
+ P(I,1)=PTABS*COS(PHI(JT))
+ P(I,2)=PTABS*SIN(PHI(JT))
+ P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
+ P(I,4)=0.5D0*SHPR*Z(JT)
+ IZW=MINT(83)+6+JT
+ K(IZW,1)=21
+ IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
+ K(IZW,2)=23
+ ELSE
+ K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
+ ENDIF
+ K(IZW,3)=IZW-2
+ P(IZW,1)=-P(I,1)
+ P(IZW,2)=-P(I,2)
+ P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
+ P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
+ P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
+ IPU=MINT(84)+4+JT
+ K(IPU,1)=3
+ K(IPU,2)=KFPR(ISUB,JT)
+ IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
+ IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
+ K(IPU,3)=MINT(83)+8+JT
+ IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
+ P(IPU,5)=PYMASS(K(IPU,2))
+ ELSE
+ P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
+ ENDIF
+ MINT(22+JT)=K(IPU,2)
+ 540 CONTINUE
+C...Find rotation and boost for hard scattering subsystem
+ I1=MINT(83)+7
+ I2=MINT(83)+8
+ BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
+ BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
+ BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
+ GAMCM=(P(I1,4)+P(I2,4))/SHR
+ BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
+ PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
+ PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
+ PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
+ THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
+ PHICM=PYANGL(PX,PY)
+C...Store hard scattering subsystem. Rotate and boost it
+ SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
+ & P(IPU6,5)**2
+ PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
+ CTHWZ=VINT(23)
+ STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
+ PHIWZ=VINT(24)-PHICM
+ P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
+ P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
+ P(IPU5,3)=PABS*CTHWZ
+ P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
+ P(IPU6,1)=-P(IPU5,1)
+ P(IPU6,2)=-P(IPU5,2)
+ P(IPU6,3)=-P(IPU5,3)
+ P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
+ CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
+ DO 560 JT=1,2
+ I1=MINT(83)+8+JT
+ I2=MINT(84)+4+JT
+ K(I1,1)=21
+ K(I1,2)=K(I2,2)
+ DO 550 J=1,5
+ P(I1,J)=P(I2,J)
+ 550 CONTINUE
+ 560 CONTINUE
+ N=IPU6
+ MINT(7)=MINT(83)+9
+ MINT(8)=MINT(83)+10
+ ENDIF
+
+ IF(ISET(ISUB).EQ.11) THEN
+ ELSEIF(IDOC.GE.8) THEN
+C...Store colour connection indices
+ DO 570 J=1,2
+ JC=J
+ IF(KCS.EQ.-1) JC=3-J
+ IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
+ & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
+ IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
+ & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
+ IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
+ & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
+ IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
+ & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
+ 570 CONTINUE
+
+C...Copy outgoing partons to documentation lines
+ IMAX=2
+ IF(IDOC.EQ.9) IMAX=3
+ DO 590 I=1,IMAX
+ I1=MINT(83)+IDOC-IMAX+I
+ I2=MINT(84)+2+I
+ K(I1,1)=21
+ K(I1,2)=K(I2,2)
+ IF(IDOC.LE.9) K(I1,3)=0
+ IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
+ DO 580 J=1,5
+ P(I1,J)=P(I2,J)
+ 580 CONTINUE
+ 590 CONTINUE
+
+ ELSEIF(IDOC.EQ.9) THEN
+C...Store colour connection indices
+ DO 600 J=1,2
+ JC=J
+ IF(KCS.EQ.-1) JC=3-J
+ IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
+ & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
+ & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
+ IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
+ & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
+ & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
+ IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
+ & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
+ IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
+ & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
+ 600 CONTINUE
+
+C...Copy outgoing partons to documentation lines
+ DO 620 I=1,3
+ I1=MINT(83)+IDOC-3+I
+ I2=MINT(84)+2+I
+ K(I1,1)=21
+ K(I1,2)=K(I2,2)
+ K(I1,3)=0
+ DO 610 J=1,5
+ P(I1,J)=P(I2,J)
+ 610 CONTINUE
+ 620 CONTINUE
+ ENDIF
+
+C...Low-pT events: remove gluons used for string drawing purposes
+ IF(ISUB.EQ.95) THEN
+ K(IPU3,1)=K(IPU3,1)+10
+ K(IPU4,1)=K(IPU4,1)+10
+ DO 630 J=41,66
+ VINTSV(J)=VINT(J)
+ VINT(J)=0D0
+ 630 CONTINUE
+ DO 650 I=MINT(83)+5,MINT(83)+8
+ DO 640 J=1,5
+ P(I,J)=0D0
+ 640 CONTINUE
+ 650 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSSPA
+C...Generates spacelike parton showers.
+
+ SUBROUTINE PYSSPA(IPU1,IPU2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT3/
+C...Local arrays and data.
+ DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
+ &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
+ &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
+ &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
+ &THEFIS(2,2),ISFI(2)
+ DATA IS/2*0/
+
+C...Read out basic information; set global Q^2 scale.
+ IPUS1=IPU1
+ IPUS2=IPU2
+ ISUB=MINT(1)
+ Q2MX=VINT(56)
+ IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
+
+C...Initialize QCD evolution and check phase space.
+ Q2MNC=PARP(62)**2
+ Q2MNCS(1)=Q2MNC
+ IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
+ &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
+ Q2MNCS(2)=Q2MNC
+ IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
+ &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
+ MCEV=0
+ XEC0=2D0*PARP(65)/VINT(1)
+ ALAMS=PARU(112)
+ PARU(112)=PARP(61)
+ FQ2C=1D0
+ TCMX=0D0
+ IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
+ MCEV=1
+ IF(MSTP(64).EQ.1) FQ2C=PARP(63)
+ IF(MSTP(64).EQ.2) FQ2C=PARP(64)
+ TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
+ IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
+ & MCEV=0
+ ENDIF
+
+C...Initialize QED evolution and check phase space.
+ Q2MNE=PARP(68)**2
+ MEEV=0
+ XEE=1D-6
+ SPME=PMAS(11,1)**2
+ TEMX=0D0
+ FWTE=10D0
+ IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
+ MEEV=1
+ TEMX=LOG(Q2MX/SPME)
+ IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
+ ENDIF
+ IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
+
+C...Initial values: flavours, momenta, virtualities.
+ NS=N
+ 100 N=NS
+ DO 120 JT=1,2
+ MORE(JT)=1
+ KFBEAM(JT)=MINT(10+JT)
+ IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
+ KFLS(JT)=MINT(14+JT)
+ KFLS(JT+2)=KFLS(JT)
+ XS(JT)=VINT(40+JT)
+ IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
+ ZS(JT)=1D0
+ Q2S(JT)=Q2MX
+ TEVCSV(JT)=TCMX
+ ALAM(JT)=PARP(61)
+ THE2(JT)=100D0
+ TEVESV(JT)=TEMX
+ DO 110 KFL=-25,25
+ XFS(JT,KFL)=XSFX(JT,KFL)
+ 110 CONTINUE
+ 120 CONTINUE
+ DSH=VINT(44)
+ IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
+
+C...Find if interference with final state partons.
+ MFIS=0
+ IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
+ IF(MFIS.NE.0) THEN
+ DO 140 I=1,2
+ KCFI(I)=0
+ KCA=PYCOMP(IABS(KFLS(I)))
+ IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
+ NFIS(I)=0
+ IF(KCFI(I).NE.0) THEN
+ IF(I.EQ.1) IPFS=IPUS1
+ IF(I.EQ.2) IPFS=IPUS2
+ DO 130 J=1,2
+ ICSI=MOD(K(IPFS,3+J),MSTU(5))
+ IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
+ & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
+ NFIS(I)=NFIS(I)+1
+ THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
+ & P(ICSI,2)**2))
+ IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
+ ENDIF
+ 130 CONTINUE
+ ENDIF
+ 140 CONTINUE
+ IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
+ ENDIF
+
+C...Pick up leg with highest virtuality.
+ 150 N=N+1
+ JT=1
+ IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
+ IF(MORE(JT).EQ.0) JT=3-JT
+ KFLB=KFLS(JT)
+ XB=XS(JT)
+ DO 160 KFL=-25,25
+ XFB(KFL)=XFS(JT,KFL)
+ 160 CONTINUE
+ DSHR=2D0*SQRT(DSH)
+ DSHZ=DSH/ZS(JT)
+
+C...Check if allowed to branch.
+ MCEV=0
+ IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
+ MCEV=1
+ XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
+ IF(XB.GE.1D0-2D0*XEC) MCEV=0
+ ENDIF
+ MEEV=0
+ IF(MINT(44+JT).EQ.3) THEN
+ MEEV=1
+ IF(XB.GE.1D0-2D0*XEE) MEEV=0
+ IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
+ & MEEV=0
+C***Currently kill QED shower for resolved photoproduction.
+ IF(MINT(18+JT).EQ.1) MEEV=0
+C***Currently kill shower for W inside electron.
+ IF(IABS(KFLB).EQ.24) THEN
+ MCEV=0
+ MEEV=0
+ ENDIF
+ ENDIF
+ IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
+ Q2B=0D0
+ GOTO 250
+ ENDIF
+
+C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
+ Q2B=Q2S(JT)
+ TEVCB=TEVCSV(JT)
+ TEVEB=TEVESV(JT)
+ IF(MSTP(62).LE.1) THEN
+ IF(ZS(JT).GT.0.99999D0) THEN
+ Q2B=Q2S(JT)
+ ELSE
+ Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
+ & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
+ & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
+ ENDIF
+ IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
+ IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
+ ENDIF
+ IF(MCEV.EQ.1) THEN
+ ALSDUM=PYALPS(FQ2C*Q2B)
+ TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
+ ALAM(JT)=PARU(117)
+ B0=(33D0-2D0*MSTU(118))/6D0
+ ENDIF
+ TEVCBS=TEVCB
+ TEVEBS=TEVEB
+
+C...Select side for interference with final state partons.
+ IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
+ IFI=N-NS
+ ISFI(IFI)=0
+ IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
+ ISFI(IFI)=1
+ ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
+ IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
+ ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
+ ISFI(IFI)=1
+ IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
+ ENDIF
+ ENDIF
+
+C...Calculate Altarelli-Parisi weights.
+ DO 170 KFL=-25,25
+ WTAPC(KFL)=0D0
+ WTAPE(KFL)=0D0
+ WTSF(KFL)=0D0
+ 170 CONTINUE
+C...q -> q, g -> q.
+ IF(IABS(KFLB).LE.10) THEN
+ WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
+ WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
+C...f -> f, gamma -> f.
+ ELSEIF(IABS(KFLB).LE.20) THEN
+ WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
+ WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
+ WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
+ IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
+C...f -> g, g -> g.
+ ELSEIF(KFLB.EQ.21) THEN
+ WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
+ DO 180 KFL=1,MSTP(58)
+ WTAPC(KFL)=WTAPQ
+ WTAPC(-KFL)=WTAPQ
+ 180 CONTINUE
+ WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
+C...f -> gamma, W+, W-.
+ ELSEIF(KFLB.EQ.22) THEN
+ WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
+ WTAPE(11)=WTAPF
+ WTAPE(-11)=WTAPF
+ ELSEIF(KFLB.EQ.24) THEN
+ WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
+ & (XEE*(XB+XEE)))/XB
+ ELSEIF(KFLB.EQ.-24) THEN
+ WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
+ & (XEE*(XB+XEE)))/XB
+ ENDIF
+
+C...Calculate parton distribution weights and sum.
+ NTRY=0
+ 190 NTRY=NTRY+1
+ IF(NTRY.GT.500) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ WTSUMC=0D0
+ WTSUME=0D0
+ XFBO=MAX(1D-10,XFB(KFLB))
+ DO 200 KFL=-25,25
+ WTSF(KFL)=XFB(KFL)/XFBO
+ WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
+ WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
+ 200 CONTINUE
+ WTSUMC=MAX(0.0001D0,WTSUMC)
+ WTSUME=MAX(0.0001D0/FWTE,WTSUME)
+
+C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
+ NTRY2=0
+ 210 NTRY2=NTRY2+1
+ IF(NTRY2.GT.500) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ IF(MCEV.EQ.1) THEN
+ IF(MSTP(64).LE.0) THEN
+ TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
+ ELSEIF(MSTP(64).EQ.1) THEN
+ TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
+ ELSE
+ TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
+ ENDIF
+ ENDIF
+ IF(MEEV.EQ.1) THEN
+ TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
+ & (PARU(101)*FWTE*WTSUME*TEMX)))
+ ENDIF
+
+C...Translate t into Q2 scale; choose between QCD and QED evolution.
+ 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
+ IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
+ MCE=0
+ IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
+ ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
+ IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
+ ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
+ IF(Q2EB.GT.Q2MNE) MCE=2
+ ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
+ MCE=1
+ IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
+ IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
+ ELSE
+ MCE=2
+ IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
+ IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
+ ENDIF
+
+C...Evolution possibly ended. Update t values.
+ IF(MCE.EQ.0) THEN
+ Q2B=0D0
+ GOTO 250
+ ELSEIF(MCE.EQ.1) THEN
+ Q2B=Q2CB
+ Q2REF=FQ2C*Q2B
+ IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
+ ELSE
+ Q2B=Q2EB
+ Q2REF=Q2B
+ IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
+ ENDIF
+
+C...Select flavour for branching parton.
+ IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
+ IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
+ KFLA=-25
+ 230 KFLA=KFLA+1
+ IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
+ IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
+ IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
+ IF(KFLA.EQ.25) THEN
+ Q2B=0D0
+ GOTO 250
+ ENDIF
+
+C...Choose z value and corrective weight.
+ WTZ=0D0
+C...q -> q + g.
+ IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
+ Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
+ & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
+ WTZ=0.5D0*(1D0+Z**2)
+C...q -> g + q.
+ ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
+ Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
+ WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
+C...f -> f + gamma.
+ ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
+ IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
+ Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
+ & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
+ ELSE
+ Z=XB+XB*(XEE/(1D0-XEE))*
+ & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
+ ENDIF
+ WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
+C...f -> gamma + f.
+ ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
+ Z=XB+XB*(XEE/(1D0-XEE))*
+ & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
+ WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
+C...f -> W+- + f'.
+ ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
+ Z=XB+XB*(XEE/(1D0-XEE))*
+ & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
+ WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
+ & (Q2B/(Q2B+PMAS(24,1)**2))
+C...g -> q + qbar.
+ ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
+ Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
+ WTZ=1D0-2D0*Z*(1D0-Z)
+C...g -> g + g.
+ ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
+ Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
+ WTZ=(1D0-Z*(1D0-Z))**2
+C...gamma -> f + fbar.
+ ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
+ Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
+ WTZ=1D0-2D0*Z*(1D0-Z)
+ ENDIF
+ IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
+
+C...Option with resummation of soft gluon emission as effective z shift.
+ IF(MCE.EQ.1) THEN
+ IF(MSTP(65).GE.1) THEN
+ RSOFT=6D0
+ IF(KFLB.NE.21) RSOFT=8D0/3D0
+ Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
+ IF(Z.LE.XB) GOTO 210
+ ENDIF
+
+C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
+ IF(MSTP(64).GE.2) THEN
+ IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
+ ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
+ IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
+ IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
+ ENDIF
+
+C...Impose angular constraint in first branching from interference
+C...with final state partons.
+ IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
+ THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
+ IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
+ IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
+ ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
+ IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
+ ENDIF
+ ENDIF
+
+C...Option with angular ordering requirement.
+ IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
+ THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
+ IF(THE2T.GT.THE2(JT)) GOTO 210
+ ENDIF
+ ENDIF
+
+C...Weighting with new parton distributions.
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
+ ELSE
+ CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
+ ENDIF
+ XFBN=XFN(KFLB)
+ IF(XFBN.LT.1D-20) THEN
+ IF(KFLA.EQ.KFLB) THEN
+ TEVCB=TEVCBS
+ TEVEB=TEVEBS
+ WTAPC(KFLB)=0D0
+ WTAPE(KFLB)=0D0
+ GOTO 190
+ ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
+ TEVCB=0.5D0*(TEVCBS+TEVCB)
+ GOTO 220
+ ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
+ TEVEB=0.5D0*(TEVEBS+TEVEB)
+ GOTO 220
+ ELSE
+ XFBN=1D-10
+ XFN(KFLB)=XFBN
+ ENDIF
+ ENDIF
+ DO 240 KFL=-25,25
+ XFB(KFL)=XFN(KFL)
+ 240 CONTINUE
+ XA=XB/Z
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
+ ELSE
+ CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
+ ENDIF
+ XFAN=XFA(KFLA)
+ IF(XFAN.LT.1D-20) GOTO 190
+ WTSFA=WTSF(KFLA)
+ IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
+
+C...Define two hard scatterers in their CM-frame.
+ 250 IF(N.EQ.NS+2) THEN
+ DQ2(JT)=Q2B
+ DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
+ DO 270 JR=1,2
+ I=NS+JR
+ IF(JR.EQ.1) IPO=IPUS1
+ IF(JR.EQ.2) IPO=IPUS2
+ DO 260 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 260 CONTINUE
+ K(I,1)=14
+ K(I,2)=KFLS(JR+2)
+ K(I,4)=IPO
+ K(I,5)=IPO
+ P(I,3)=DPLCM*(-1)**(JR+1)
+ P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
+ P(I,5)=-SQRT(DQ2(JR))
+ K(IPO,1)=14
+ K(IPO,3)=I
+ K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
+ K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
+ 270 CONTINUE
+
+C...Find maximum allowed mass of timelike parton.
+ ELSEIF(N.GT.NS+2) THEN
+ JR=3-JT
+ DQ2(3)=Q2B
+ DPC(1)=P(IS(1),4)
+ DPC(2)=P(IS(2),4)
+ DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
+ DPD(1)=DSH+DQ2(JR)+DQ2(JT)
+ DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
+ DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
+ DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
+ IKIN=0
+ IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
+ & 1D-10*DPD(1)) IKIN=1
+ IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
+ & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
+ IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
+ & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
+
+C...Generate timelike parton shower (if required).
+ IT=N
+ DO 280 J=1,5
+ K(IT,J)=0
+ P(IT,J)=0D0
+ V(IT,J)=0D0
+ 280 CONTINUE
+ K(IT,1)=3
+C...f -> f + g (gamma).
+ IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
+ K(IT,2)=21
+ IF(IABS(KFLB).GE.11) K(IT,2)=22
+C...f -> g (gamma, W+-) + f.
+ ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
+ K(IT,2)=KFLB
+ IF(KFLS(JT+2).EQ.24) THEN
+ K(IT,2)=-12
+ ELSEIF(KFLS(JT+2).EQ.-24) THEN
+ K(IT,2)=12
+ ENDIF
+C...g (gamma) -> f + fbar, g + g.
+ ELSE
+ K(IT,2)=-KFLS(JT+2)
+ IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
+ ENDIF
+ P(IT,5)=PYMASS(K(IT,2))
+ IF(DMSMA.LE.P(IT,5)**2) GOTO 100
+ IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
+ MSTJ48=MSTJ(48)
+ PARJ85=PARJ(85)
+ P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
+ P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
+ IF(MSTP(63).EQ.1) THEN
+ Q2TIM=DMSMA
+ ELSEIF(MSTP(63).EQ.2) THEN
+ Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
+ ELSE
+ Q2TIM=DMSMA
+ MSTJ(48)=1
+ IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
+ IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
+ & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
+ PARJ(85)=SQRT(MAX(0D0,DPT2))*
+ & (1D0/P(IT,4)+1D0/P(IS(JT),4))
+ ENDIF
+ CALL PYSHOW(IT,0,SQRT(Q2TIM))
+ MSTJ(48)=MSTJ48
+ PARJ(85)=PARJ85
+ IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
+ ENDIF
+
+C...Reconstruct kinematics of branching: timelike parton shower.
+ DMS=P(IT,5)**2
+ IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
+ IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
+ & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
+ & (4D0*DSH*DPC(3)**2)
+ IF(DPT2.LT.0D0) GOTO 100
+ DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
+ & DSHR)/DPC(3)-DPC(3)
+ P(IT,1)=SQRT(DPT2)
+ P(IT,3)=DPB(1)*(-1)**(JT+1)
+ P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
+ IF(N.GE.IT+1) THEN
+ DPB(1)=SQRT(DPB(1)**2+DPT2)
+ DPB(2)=SQRT(DPB(1)**2+DMS)
+ DPB(3)=P(IT+1,3)
+ DPB(4)=SQRT(DPB(3)**2+DMS)
+ DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
+ & DPB(1))
+ CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
+ THE=PYANGL(P(IT,3),P(IT,1))
+ CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
+ ENDIF
+
+C...Reconstruct kinematics of branching: spacelike parton.
+ DO 290 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 290 CONTINUE
+ K(N+1,1)=14
+ K(N+1,2)=KFLB
+ P(N+1,1)=P(IT,1)
+ P(N+1,3)=P(IT,3)+P(IS(JT),3)
+ P(N+1,4)=P(IT,4)+P(IS(JT),4)
+ P(N+1,5)=-SQRT(DQ2(3))
+
+C...Define colour flow of branching.
+ K(IS(JT),3)=N+1
+ K(IT,3)=N+1
+ IM1=N+1
+ IM2=N+1
+C...f -> f + gamma (Z, W).
+ IF(IABS(K(IT,2)).GE.22) THEN
+ K(IT,1)=1
+ ID1=IS(JT)
+ ID2=IS(JT)
+C...f -> gamma (Z, W) + f.
+ ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
+ ID1=IT
+ ID2=IT
+C...gamma -> q + qbar, g + g.
+ ELSEIF(K(N+1,2).EQ.22) THEN
+ ID1=IS(JT)
+ ID2=IT
+ IM1=ID2
+ IM2=ID1
+C...q -> q + g.
+ ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
+ ID1=IT
+ ID2=IS(JT)
+C...q -> g + q.
+ ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
+ ID1=IS(JT)
+ ID2=IT
+C...qbar -> qbar + g.
+ ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
+ ID1=IS(JT)
+ ID2=IT
+C...qbar -> g + qbar.
+ ELSEIF(K(N+1,2).LT.0) THEN
+ ID1=IT
+ ID2=IS(JT)
+C...g -> g + g; g -> q + qbar.
+ ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
+ ID1=IS(JT)
+ ID2=IT
+ ELSE
+ ID1=IT
+ ID2=IS(JT)
+ ENDIF
+ IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
+ IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
+ K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
+ K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
+ IF(ID1.NE.ID2) THEN
+ K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
+ K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
+ ENDIF
+ N=N+1
+
+C...Boost to new CM-frame.
+ DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
+ DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
+ IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
+ CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
+ IR=N+(JT-1)*(IS(1)-N)
+ CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
+ & 0D0,0D0,0D0)
+ ENDIF
+
+C...Update kinematics variables.
+ IS(JT)=N
+ DQ2(JT)=Q2B
+ IF(MSTP(62).GE.3) THE2(JT)=THE2T
+ DSH=DSHZ
+
+C...Save quantities; loop back.
+ Q2S(JT)=Q2B
+ IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
+ &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
+ KFLS(JT+2)=KFLS(JT)
+ KFLS(JT)=KFLA
+ XS(JT)=XA
+ ZS(JT)=Z
+ DO 300 KFL=-25,25
+ XFS(JT,KFL)=XFA(KFL)
+ 300 CONTINUE
+ TEVCSV(JT)=TEVCB
+ TEVESV(JT)=TEVEB
+ ELSE
+ MORE(JT)=0
+ IF(JT.EQ.1) IPU1=N
+ IF(JT.EQ.2) IPU2=N
+ ENDIF
+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
+ CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) N=NS
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
+
+C...Boost hard scattering partons to frame of shower initiators.
+ DO 310 J=1,3
+ ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
+ 310 CONTINUE
+ K(N+2,1)=1
+ DO 320 J=1,5
+ P(N+2,J)=P(NS+1,J)
+ 320 CONTINUE
+ ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
+ IF(ROBOT.GE.0.999999D0) THEN
+ ROBOT=1.00001D0*SQRT(ROBOT)
+ ROBO(3)=ROBO(3)/ROBOT
+ ROBO(4)=ROBO(4)/ROBOT
+ ROBO(5)=ROBO(5)/ROBOT
+ ENDIF
+ CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
+ ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
+ ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
+ CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
+ &ROBO(5))
+
+C...Store user information. Reset Lambda value.
+ K(IPU1,3)=MINT(83)+3
+ K(IPU2,3)=MINT(83)+4
+ DO 330 JT=1,2
+ MINT(12+JT)=KFLS(JT)
+ VINT(140+JT)=XS(JT)
+ IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
+ 330 CONTINUE
+ PARU(112)=ALAMS
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRESD
+C...Allows resonances to decay (including parton showers for hadronic
+C...channels).
+
+ SUBROUTINE PYRESD(IRES)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/,/PYINT4/
+C...Local arrays and complex and character variables.
+ DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
+ &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
+ &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
+ &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
+ COMPLEX FGK,HA(6,6),HC(6,6)
+ REAL TIR,UIR
+ CHARACTER CODE*9,MASS*9
+
+C...The F, Xi and Xj functions of Gunion and Kunszt
+C...(Phys. Rev. D33, 665, plus errata from the authors).
+ FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
+ &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
+ DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
+ &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
+ DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
+ &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
+ &2D0*(D34/D56+D56/D34))
+
+C...Some general constants.
+ XW=PARU(102)
+ XWV=XW
+ IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
+ XW1=1D0-XW
+ SQMZ=PMAS(23,1)**2
+ GMMZ=PMAS(23,1)*PMAS(23,2)
+ SQMW=PMAS(24,1)**2
+ GMMW=PMAS(24,1)*PMAS(24,2)
+ SH=VINT(44)
+
+C...Reset original resonance configuration.
+ DO 100 JT=1,8
+ IREF(1,JT)=0
+ 100 CONTINUE
+
+C...Define initial one, two or three objects for subprocess.
+ IF(IRES.EQ.0) THEN
+ ISUB=MINT(1)
+ IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
+ IREF(1,1)=MINT(84)+2+ISET(ISUB)
+ IREF(1,4)=MINT(83)+6+ISET(ISUB)
+ ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
+ IREF(1,1)=MINT(84)+1+ISET(ISUB)
+ IREF(1,2)=MINT(84)+2+ISET(ISUB)
+ IREF(1,4)=MINT(83)+5+ISET(ISUB)
+ IREF(1,5)=MINT(83)+6+ISET(ISUB)
+ ELSEIF(ISET(ISUB).EQ.5) THEN
+ IREF(1,1)=MINT(84)+3
+ IREF(1,2)=MINT(84)+4
+ IREF(1,3)=MINT(84)+5
+ IREF(1,4)=MINT(83)+7
+ IREF(1,5)=MINT(83)+8
+ IREF(1,6)=MINT(83)+9
+ ENDIF
+
+C...Define original resonance for odd cases.
+ ELSE
+ ISUB=0
+ IREF(1,1)=IRES
+ ENDIF
+
+C...Check if initial resonance has been moved (in resonance + jet).
+ DO 120 JT=1,3
+ IF(IREF(1,JT).GT.0) THEN
+ IF(K(IREF(1,JT),1).GT.10) THEN
+ KFA=IABS(K(IREF(1,JT),2))
+ IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
+ DO 110 I=IREF(1,JT)+1,N
+ IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
+ & IREF(1,JT)=I
+ 110 CONTINUE
+ ELSE
+ KDA=MOD(K(IREF(1,JT),4),MSTU(4))
+ IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
+ ENDIF
+ ENDIF
+ ENDIF
+ 120 CONTINUE
+
+C...Loop over decay history.
+ NP=1
+ IP=0
+ 130 IP=IP+1
+ NINH=0
+ JTMAX=2
+ IF(IREF(IP,2).EQ.0) JTMAX=1
+ IF(IREF(IP,3).NE.0) JTMAX=3
+ IT4=0
+ NSAV=N
+
+C...Start treatment of one, two or three resonances in parallel.
+ 140 N=NSAV
+ DO 220 JT=1,JTMAX
+ ID=IREF(IP,JT)
+ KDCY(JT)=0
+ KFL1(JT)=0
+ KFL2(JT)=0
+ KFL3(JT)=0
+ KEQL(JT)=0
+ NSD(JT)=ID
+
+C...Check whether particle can/is allowed to decay.
+ IF(ID.EQ.0) GOTO 210
+ KFA=IABS(K(ID,2))
+ KCA=PYCOMP(KFA)
+ IF(MWID(KCA).EQ.0) GOTO 210
+ IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
+ IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
+ & KFA.EQ.18) IT4=IT4+1
+ K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
+ K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
+
+C...Info for selection of decay channel: sign, pairings.
+ IF(KCHG(KCA,3).EQ.0) THEN
+ IPM=2
+ ELSE
+ IPM=(5-ISIGN(1,K(ID,2)))/2
+ ENDIF
+ KFB=0
+ IF(JTMAX.EQ.2) THEN
+ KFB=IABS(K(IREF(IP,3-JT),2))
+ ELSEIF(JTMAX.EQ.3) THEN
+ JT2=JT+1-3*(JT/3)
+ KFB=IABS(K(IREF(IP,JT2),2))
+ IF(KFB.NE.KFA) THEN
+ JT2=JT+2-3*((JT+1)/3)
+ KFB=IABS(K(IREF(IP,JT2),2))
+ ENDIF
+ ENDIF
+
+C...Select decay channel.
+ IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
+ & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
+ CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
+ WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
+ IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
+ IF(WDTE0S.LE.0D0) GOTO 210
+ RKFL=WDTE0S*PYR(0)
+ IDL=0
+ 150 IDL=IDL+1
+ IDC=IDL+MDCY(KCA,2)-1
+ RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
+ IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
+ IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
+
+C...Read out flavours and colour charges of decay channel chosen.
+ KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
+ IF(KCQM(JT).EQ.-2) KCQM(JT)=2
+ KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
+ KFC1A=PYCOMP(IABS(KFL1(JT)))
+ IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
+ KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
+ IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
+ KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
+ KFC2A=PYCOMP(IABS(KFL2(JT)))
+ IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
+ KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
+ IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
+ KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
+ IF(KFL3(JT).NE.0) THEN
+ KFC3A=PYCOMP(IABS(KFL3(JT)))
+ IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
+ KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
+ IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
+ ENDIF
+
+C...Set/save further info on channel.
+ KDCY(JT)=1
+ IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
+ NSD(JT)=N
+ HGZ(JT,1)=VINT(111)
+ HGZ(JT,2)=VINT(112)
+ HGZ(JT,3)=VINT(114)
+
+C...Select masses; to begin with assume resonances narrow.
+ DO 170 I=1,3
+ P(N+I,5)=0D0
+ PMMN(I)=0D0
+ IF(I.EQ.1) THEN
+ KFLW=IABS(KFL1(JT))
+ KCW=KFC1A
+ ELSEIF(I.EQ.2) THEN
+ KFLW=IABS(KFL2(JT))
+ KCW=KFC2A
+ ELSEIF(I.EQ.3) THEN
+ IF(KFL3(JT).EQ.0) GOTO 170
+ KFLW=IABS(KFL3(JT))
+ KCW=KFC3A
+ ENDIF
+ P(N+I,5)=PMAS(KCW,1)
+CMRENNA++
+C...This prevents SUSY/t particles from becoming too light.
+ IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
+ PMMN(I)=PMAS(KCW,1)
+ DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
+ IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
+ PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
+ & PMAS(PYCOMP(KFDP(IDC,2)),1)
+ IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
+ & PMAS(PYCOMP(KFDP(IDC,3)),1)
+ PMMN(I)=MIN(PMMN(I),PMSUM)
+ ENDIF
+ 160 CONTINUE
+CMRENNA--
+ ELSEIF(KFLW.EQ.6) THEN
+ PMMN(I)=PMAS(24,1)+PMAS(5,1)
+ ENDIF
+ 170 CONTINUE
+
+C...Check which two out of three are widest.
+ IWID1=1
+ IWID2=2
+ PWID1=PMAS(KFC1A,2)
+ PWID2=PMAS(KFC2A,2)
+ KFLW1=IABS(KFL1(JT))
+ KFLW2=IABS(KFL2(JT))
+ IF(KFL3(JT).NE.0) THEN
+ PWID3=PMAS(KFC3A,2)
+ IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
+ IWID1=3
+ PWID1=PWID3
+ KFLW1=IABS(KFL3(JT))
+ ELSEIF(PWID3.GT.PWID2) THEN
+ IWID2=3
+ PWID2=PWID3
+ KFLW2=IABS(KFL3(JT))
+ ENDIF
+ ENDIF
+
+C...If all narrow then only check that masses consistent.
+ IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
+ & PWID2.LT.PARP(41))) THEN
+CMRENNA++
+C....Handle near degeneracy cases.
+ IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
+ IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
+ P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
+ IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
+ ENDIF
+ ENDIF
+CMRENNA--
+ IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
+ CALL PYERRM(13,'(PYRESD:) daughter masses too large')
+ MINT(51)=1
+ RETURN
+ ENDIF
+
+C...For three wide resonances select narrower of three
+C...according to BW decoupled from rest.
+ ELSE
+ PMTOT=P(ID,5)
+ IF(KFL3(JT).NE.0) THEN
+ IWID3=6-IWID1-IWID2
+ KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
+ & KFLW1-KFLW2
+ LOOP=0
+ 180 LOOP=LOOP+1
+ P(N+IWID3,5)=PYMASS(KFLW3)
+ IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
+ PMTOT=PMTOT-P(N+IWID3,5)
+ ENDIF
+C...Select other two correlated within remaining phase space.
+ IF(IP.EQ.1) THEN
+ CKIN45=CKIN(45)
+ CKIN47=CKIN(47)
+ CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
+ CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
+ CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
+ & P(N+IWID2,5))
+ CKIN(45)=CKIN45
+ CKIN(47)=CKIN47
+ ELSE
+ CKIN(49)=PMMN(IWID1)
+ CKIN(50)=PMMN(IWID2)
+ CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
+ & P(N+IWID2,5))
+ CKIN(49)=0D0
+ CKIN(50)=0D0
+ ENDIF
+ IF(MINT(51).EQ.1) RETURN
+ ENDIF
+
+C...Begin fill decay products, with colour flow for coloured objects.
+ MSTU10=MSTU(10)
+ MSTU(10)=1
+ MSTU(19)=1
+
+CMRENNA++
+C...1) Three-body decays of SUSY particles (plus special case top).
+ IF(KFL3(JT).NE.0) THEN
+ DO 200 I=N+1,N+3
+ DO 190 J=1,5
+ K(I,J)=0
+ V(I,J)=0D0
+ 190 CONTINUE
+ 200 CONTINUE
+ XM(1)=P(N+1,5)
+ XM(2)=P(N+2,5)
+ XM(3)=P(N+3,5)
+ XM(5)=P(ID,5)
+ CALL PYTBDY(XM)
+ K(N+1,1)=1
+ K(N+1,2)=KFL1(JT)
+ K(N+2,1)=1
+ K(N+2,2)=KFL2(JT)
+ K(N+3,1)=1
+ K(N+3,2)=KFL3(JT)
+
+C...Set colour flow for t -> W + b + Z.
+ IF(KFA.EQ.6) THEN
+ K(N+2,1)=3
+ ISID=4
+ IF(KCQM(JT).EQ.-1) ISID=5
+ IDAU=N+2
+ K(ID,ISID)=K(ID,ISID)+IDAU
+ K(IDAU,ISID)=MSTU(5)*ID
+
+C...Set colour flow in three-body decays - programmed as special cases.
+ ELSEIF(KFC2A.LE.6) THEN
+ K(N+2,1)=3
+ K(N+3,1)=3
+ ISID=4
+ IF(KFL2(JT).LT.0) ISID=5
+ K(N+2,ISID)=MSTU(5)*(N+3)
+ K(N+3,9-ISID)=MSTU(5)*(N+2)
+ ENDIF
+ IF(KFL1(JT).EQ.KSUSY1+21) THEN
+ K(N+1,1)=3
+ K(N+2,1)=3
+ K(N+3,1)=3
+ ISID=4
+ IF(KFL2(JT).LT.0) ISID=5
+ K(N+1,ISID)=MSTU(5)*(N+2)
+ K(N+1,9-ISID)=MSTU(5)*(N+3)
+ K(N+2,ISID)=MSTU(5)*(N+1)
+ K(N+3,9-ISID)=MSTU(5)*(N+1)
+ ENDIF
+ IF(KFA.EQ.KSUSY1+21) THEN
+ K(N+2,1)=3
+ K(N+3,1)=3
+ ISID=4
+ IF(KFL2(JT).LT.0) ISID=5
+ K(ID,ISID)=K(ID,ISID)+(N+2)
+ K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
+ K(N+2,ISID)=MSTU(5)*ID
+ K(N+3,9-ISID)=MSTU(5)*ID
+ ENDIF
+ N=N+3
+CMRENNA--
+
+C...2) Everything else two-body decay.
+ ELSE
+ CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
+C...First set colour flow as if mother colour singlet.
+ IF(KCQ1(JT).NE.0) THEN
+ K(N-1,1)=3
+ IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
+ IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
+ ENDIF
+ IF(KCQ2(JT).NE.0) THEN
+ K(N,1)=3
+ IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
+ IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
+ ENDIF
+C...Then redirect colour flow if mother (anti)triplet.
+ IF(KCQM(JT).EQ.0) THEN
+ ELSEIF(KCQM(JT).NE.2) THEN
+ ISID=4
+ IF(KCQM(JT).EQ.-1) ISID=5
+ IDAU=N-1
+ IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
+ K(ID,ISID)=K(ID,ISID)+IDAU
+ K(IDAU,ISID)=MSTU(5)*ID
+C...Then redirect colour flow if mother octet.
+ ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
+ IDAU=N-1
+ IF(KCQ1(JT).EQ.0) IDAU=N
+ K(ID,4)=K(ID,4)+IDAU
+ K(ID,5)=K(ID,5)+IDAU
+ K(IDAU,4)=MSTU(5)*ID
+ K(IDAU,5)=MSTU(5)*ID
+ ELSE
+ ISID=4
+ IF(KCQ1(JT).EQ.-1) ISID=5
+ IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
+ K(ID,ISID)=K(ID,ISID)+(N-1)
+ K(ID,9-ISID)=K(ID,9-ISID)+N
+ K(N-1,ISID)=MSTU(5)*ID
+ K(N,9-ISID)=MSTU(5)*ID
+ ENDIF
+ ENDIF
+
+C...End loop over resonances for daughter flavour and mass selection.
+ MSTU(10)=MSTU10
+ 210 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
+ & NINH=NINH+1
+ IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
+ WRITE(CODE,'(I9)') K(ID,2)
+ WRITE(MASS,'(F9.3)') P(ID,5)
+ CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
+ & CODE//' with mass'//MASS)
+ MINT(51)=1
+ RETURN
+ ENDIF
+ 220 CONTINUE
+
+C...Check for allowed combinations. Skip if no decays.
+ IF(JTMAX.EQ.1) THEN
+ IF(KDCY(1).EQ.0) GOTO 560
+ ELSEIF(JTMAX.EQ.2) THEN
+ IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
+ IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
+ IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
+ ELSEIF(JTMAX.EQ.3) THEN
+ IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
+ IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
+ IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
+ IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
+ IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
+ IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
+ IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
+ ENDIF
+
+C...Special case: matrix element option for Z0 decay to quarks.
+ IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
+ &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
+
+C...Check consistency of MSTJ options set.
+ IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
+ CALL PYERRM(6,
+ & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
+ MSTJ(110)=1
+ ENDIF
+ IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
+ CALL PYERRM(6,
+ & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
+ MSTJ(111)=0
+ ENDIF
+
+C...Select alpha_strong behaviour.
+ MST111=MSTU(111)
+ PAR112=PARU(112)
+ MSTU(111)=MSTJ(108)
+ IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
+ & MSTU(111)=1
+ PARU(112)=PARJ(121)
+ IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
+
+C...Find axial fraction in total cross section for scalar gluon model.
+ PARJ(171)=0D0
+ IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
+ & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
+ POLL=1D0-PARJ(131)*PARJ(132)
+ SFF=1D0/(16D0*XW*XW1)
+ SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
+ & (PARJ(123)*PARJ(124))**2)
+ SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
+ VE=4D0*XW-1D0
+ HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
+ HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
+ & (PARJ(132)-PARJ(131)))
+ KFLC=IABS(KFL1(1))
+ PMQ=PYMASS(KFLC)
+ QF=KCHG(KFLC,1)/3D0
+ VQ=1D0
+ IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
+ & 1D0-(2D0*PMQ/P(ID,5))**2))
+ VF=SIGN(1D0,QF)-4D0*QF*XW
+ RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
+ & VF**2*HF1W)+VQ**3*HF1W
+ IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
+ ENDIF
+
+C...Choice of jet configuration.
+ CALL PYXJET(P(ID,5),NJET,CUT)
+ KFLC=IABS(KFL1(1))
+ KFLN=21
+ IF(NJET.EQ.4) THEN
+ CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
+ ELSEIF(NJET.EQ.3) THEN
+ CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
+ ELSE
+ MSTJ(120)=1
+ ENDIF
+
+C...Fill jet configuration; return if incorrect kinematics.
+ NC=N-2
+ IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
+ CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
+ ELSEIF(NJET.EQ.2) THEN
+ CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
+ ELSEIF(NJET.EQ.3) THEN
+ CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
+ ELSEIF(KFLN.EQ.21) THEN
+ CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
+ & X12,X14)
+ ELSE
+ CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
+ & X12,X14)
+ ENDIF
+ IF(MSTU(24).NE.0) THEN
+ MINT(51)=1
+ MSTU(111)=MST111
+ PARU(112)=PAR112
+ RETURN
+ ENDIF
+
+C...Angular orientation according to matrix element.
+ IF(MSTJ(106).EQ.1) THEN
+ CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
+ IF(MINT(11).LT.0) THE=PARU(1)-THE
+ CTHE(1)=COS(THE)
+ CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
+ CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
+ ENDIF
+
+C...Boost partons to Z0 rest frame.
+ CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
+ & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
+
+C...Mark decayed resonance and add documentation lines,
+ K(ID,1)=K(ID,1)+10
+ IDOC=MINT(83)+MINT(4)
+ DO 240 I=NC+1,N
+ I1=MINT(83)+MINT(4)+1
+ K(I,3)=I1
+ IF(MSTP(128).GE.1) K(I,3)=ID
+ IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
+ MINT(4)=MINT(4)+1
+ K(I1,1)=21
+ K(I1,2)=K(I,2)
+ K(I1,3)=IREF(IP,4)
+ DO 230 J=1,5
+ P(I1,J)=P(I,J)
+ 230 CONTINUE
+ ENDIF
+ 240 CONTINUE
+
+C...Generate parton shower.
+ IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
+
+C... End special case for Z0: skip ahead.
+ MSTU(111)=MST111
+ PARU(112)=PAR112
+ GOTO 550
+ ENDIF
+
+C...Order incoming partons and outgoing resonances.
+ IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
+ ILIN(1)=MINT(84)+1
+ IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
+ IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
+ ILIN(2)=2*MINT(84)+3-ILIN(1)
+ IMIN=1
+ IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
+ & .EQ.36) IMIN=3
+ IMAX=2
+ IORD=1
+ IF(K(IREF(IP,1),2).EQ.23) IORD=2
+ IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
+ IAKIPD=IABS(K(IREF(IP,IORD),2))
+ IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
+ IF(KDCY(IORD).EQ.0) IORD=3-IORD
+
+C...Order decay products of resonances.
+ DO 250 JT=IORD,3-IORD,3-2*IORD
+ IF(KDCY(JT).EQ.0) THEN
+ ILIN(IMAX+1)=NSD(JT)
+ IMAX=IMAX+1
+ ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
+ ILIN(IMAX+1)=N+2*JT-1
+ ILIN(IMAX+2)=N+2*JT
+ IMAX=IMAX+2
+ K(N+2*JT-1,2)=K(NSD(JT)+1,2)
+ K(N+2*JT,2)=K(NSD(JT)+2,2)
+ ELSE
+ ILIN(IMAX+1)=N+2*JT
+ ILIN(IMAX+2)=N+2*JT-1
+ IMAX=IMAX+2
+ K(N+2*JT-1,2)=K(NSD(JT)+1,2)
+ K(N+2*JT,2)=K(NSD(JT)+2,2)
+ ENDIF
+ 250 CONTINUE
+
+C...Find charge, isospin, left- and righthanded couplings.
+ DO 270 I=IMIN,IMAX
+ DO 260 J=1,4
+ COUP(I,J)=0D0
+ 260 CONTINUE
+ KFA=IABS(K(ILIN(I),2))
+ IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
+ COUP(I,1)=KCHG(KFA,1)/3D0
+ COUP(I,2)=(-1)**MOD(KFA,2)
+ COUP(I,4)=-2D0*COUP(I,1)*XWV
+ COUP(I,3)=COUP(I,2)+COUP(I,4)
+ 270 CONTINUE
+
+C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
+ IF(ISUB.EQ.22) THEN
+ DO 300 I=3,5,2
+ I1=IORD
+ IF(I.EQ.5) I1=3-IORD
+ DO 290 J1=1,2
+ DO 280 J2=1,2
+ CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
+ & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
+ & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
+ & COUP(I,J2+2)**2
+ 280 CONTINUE
+ 290 CONTINUE
+ 300 CONTINUE
+ COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
+ & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
+ COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
+ & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
+ IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
+ ENDIF
+ ENDIF
+
+C...Select angular orientation type - Z'/W' only.
+ MZPWP=0
+ IF(ISUB.EQ.141) THEN
+ IF(PYR(0).LT.PARU(130)) MZPWP=1
+ IF(IP.EQ.2) THEN
+ IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
+ IAKIR=IABS(K(IREF(2,2),2))
+ IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
+ ENDIF
+ IF(IP.GE.3) MZPWP=2
+ ELSEIF(ISUB.EQ.142) THEN
+ IF(PYR(0).LT.PARU(136)) MZPWP=1
+ IF(IP.EQ.2) THEN
+ IAKIR=IABS(K(IREF(2,2),2))
+ IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
+ ENDIF
+ IF(IP.GE.3) MZPWP=2
+ ENDIF
+
+C...Select random angles (begin of weighting procedure).
+ 310 DO 320 JT=1,JTMAX
+ IF(KDCY(JT).EQ.0) GOTO 320
+ IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
+ CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
+ IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
+ PHI(JT)=VINT(24)
+ ELSE
+ CTHE(JT)=2D0*PYR(0)-1D0
+ PHI(JT)=PARU(2)*PYR(0)
+ ENDIF
+ 320 CONTINUE
+
+ IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
+C...Construct massless four-vectors.
+ DO 340 I=N+1,N+4
+ K(I,1)=1
+ DO 330 J=1,5
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 330 CONTINUE
+ 340 CONTINUE
+ DO 350 JT=1,JTMAX
+ IF(KDCY(JT).EQ.0) GOTO 350
+ ID=IREF(IP,JT)
+ P(N+2*JT-1,3)=0.5D0*P(ID,5)
+ P(N+2*JT-1,4)=0.5D0*P(ID,5)
+ P(N+2*JT,3)=-0.5D0*P(ID,5)
+ P(N+2*JT,4)=0.5D0*P(ID,5)
+ CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
+ & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
+ 350 CONTINUE
+
+C...Store incoming and outgoing momenta, with random rotation to
+C...avoid accidental zeroes in HA expressions.
+ DO 370 I=1,IMAX
+ K(N+4+I,1)=1
+ P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
+ & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
+ P(N+4+I,5)=P(ILIN(I),5)
+ DO 360 J=1,3
+ P(N+4+I,J)=P(ILIN(I),J)
+ 360 CONTINUE
+ 370 CONTINUE
+ 380 THERR=ACOS(2D0*PYR(0)-1D0)
+ PHIRR=PARU(2)*PYR(0)
+ CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
+ DO 400 I=1,IMAX
+ IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
+ DO 390 J=1,4
+ PK(I,J)=P(N+4+I,J)
+ 390 CONTINUE
+ 400 CONTINUE
+
+C...Calculate internal products.
+ IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
+ & ISUB.EQ.142) THEN
+ DO 420 I1=IMIN,IMAX-1
+ DO 410 I2=I1+1,IMAX
+ HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
+ & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
+ & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
+ & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
+ & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
+ & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
+ HC(I1,I2)=CONJG(HA(I1,I2))
+ IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
+ IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
+ HA(I2,I1)=-HA(I1,I2)
+ HC(I2,I1)=-HC(I1,I2)
+ 410 CONTINUE
+ 420 CONTINUE
+ ENDIF
+ DO 440 I=1,2
+ DO 430 J=1,4
+ PK(I,J)=-PK(I,J)
+ 430 CONTINUE
+ 440 CONTINUE
+ DO 460 I1=IMIN,IMAX-1
+ DO 450 I2=I1+1,IMAX
+ PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
+ & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
+ PKK(I2,I1)=PKK(I1,I2)
+ 450 CONTINUE
+ 460 CONTINUE
+ ENDIF
+
+ KFAGM=IABS(IREF(IP,7))
+ IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
+C...Isotropic decay selected by user.
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(JTMAX.EQ.3) THEN
+C...Isotropic decay when three mother particles.
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(IT4.GE.1) THEN
+C... Isotropic decay t -> b + W etc for 4th generation q and l.
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
+ & IREF(IP,7).EQ.36) THEN
+C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
+ IF(IP.EQ.1) WTMAX=SH**2
+ IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
+ KFA=IABS(K(IREF(IP,1),2))
+ IF(KFA.EQ.23) THEN
+ KFLF1A=IABS(KFL1(1))
+ EF1=KCHG(KFLF1A,1)/3D0
+ AF1=SIGN(1D0,EF1+0.1D0)
+ VF1=AF1-4D0*EF1*XWV
+ KFLF2A=IABS(KFL1(2))
+ EF2=KCHG(KFLF2A,1)/3D0
+ AF2=SIGN(1D0,EF2+0.1D0)
+ VF2=AF2-4D0*EF2*XWV
+ VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
+ WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
+ & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
+ ELSEIF(KFA.EQ.24) THEN
+ WT=16D0*PKK(3,5)*PKK(4,6)
+ ELSE
+ WT=WTMAX
+ ENDIF
+
+ ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
+ & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
+ & THEN
+C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
+ I1=IREF(IP,8)
+ IF(MOD(KFAGM,2).EQ.0) THEN
+ I2=N+1
+ I3=N+2
+ ELSE
+ I2=N+2
+ I3=N+1
+ ENDIF
+ I4=IREF(IP,2)
+ WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
+ & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
+ & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
+ WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
+
+ ELSEIF(ISUB.EQ.1) THEN
+C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
+ EI=KCHG(IABS(MINT(15)),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ EF=KCHG(IABS(KFL1(1)),1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
+ WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
+ & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
+ WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
+ & (VI**2+AI**2)*VINT(114)*VF**2)
+ WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
+ & 4D0*VI*AI*VINT(114)*VF*AF)
+ WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
+ & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
+ WTMAX=2D0*(WT1+ABS(WT3))
+
+ ELSEIF(ISUB.EQ.2) THEN
+C...Angular weight for W+/- -> 2 quarks/leptons.
+ WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
+ WTMAX=4D0
+
+ ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
+C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
+C...-> gluon/gamma + 2 quarks/leptons.
+ CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
+ CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
+ CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
+ CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
+ WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
+ & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
+ WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
+ & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
+
+ ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
+C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
+C...-> gluon/gamma + 2 quarks/leptons.
+ WT=PKK(1,3)**2+PKK(2,4)**2
+ WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
+
+ ELSEIF(ISUB.EQ.22) THEN
+C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
+ S34=P(IREF(IP,IORD),5)**2
+ S56=P(IREF(IP,3-IORD),5)**2
+ TI=PKK(1,3)+PKK(1,4)+S34
+ UI=PKK(1,5)+PKK(1,6)+S56
+ TIR=REAL(TI)
+ UIR=REAL(UI)
+ FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
+ FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
+ FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
+ FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
+ FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
+ FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
+ FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
+ FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
+ WT=
+ & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
+ & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
+ & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
+ & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
+ WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
+ & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
+ & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
+ & 1D0/UI**2))
+
+ ELSEIF(ISUB.EQ.23) THEN
+C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
+ D34=P(IREF(IP,IORD),5)**2
+ D56=P(IREF(IP,3-IORD),5)**2
+ DT=PKK(1,3)+PKK(1,4)+D34
+ DU=PKK(1,5)+PKK(1,6)+D56
+ FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
+ CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
+ CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
+ FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
+ & REAL(CBWZ)*FGK(1,2,5,6,3,4))
+ FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
+ & REAL(CBWZ)*FGK(1,2,6,5,3,4))
+ WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
+ WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
+ & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
+
+ ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
+C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
+C...(or H0, or A0).
+ WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
+ & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
+ & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
+ WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
+ & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
+
+ ELSEIF(ISUB.EQ.25) THEN
+C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
+ D34=P(IREF(IP,IORD),5)**2
+ D56=P(IREF(IP,3-IORD),5)**2
+ DT=PKK(1,3)+PKK(1,4)+D34
+ DU=PKK(1,5)+PKK(1,6)+D56
+ FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
+ CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
+ CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
+ CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
+ CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
+ FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
+ & REAL(CBWW)*FGK(1,2,5,6,3,4))
+ FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
+ WT=FGK135**2+(CCWW*FGK253)**2
+ WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
+ & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
+
+ ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
+C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
+C...(or H0, or A0).
+ WT=PKK(1,3)*PKK(2,4)
+ WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
+
+ ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
+C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
+C...-> f + 2 quarks/leptons.
+ CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
+ CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
+ CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
+ CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
+ IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
+ & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
+ IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
+ & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
+ WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
+ & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
+
+ ELSEIF(ISUB.EQ.31) THEN
+C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
+ IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
+ IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
+ WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
+
+ ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
+ & ISUB.EQ.77) THEN
+C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
+ WT=16D0*PKK(3,5)*PKK(4,6)
+ WTMAX=SH**2
+
+ ELSEIF(ISUB.EQ.110) THEN
+C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(ISUB.EQ.141) THEN
+ IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
+C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
+C...Couplings of incoming flavour.
+ KFAI=IABS(MINT(15))
+ EI=KCHG(KFAI,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ KFAIC=1
+ IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
+ IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
+ IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
+ VPI=PARU(119+2*KFAIC)
+ API=PARU(120+2*KFAIC)
+C...Couplings of final flavour.
+ KFAF=IABS(KFL1(1))
+ EF=KCHG(KFAF,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ KFAFC=1
+ IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
+ IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
+ IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
+ VPF=PARU(119+2*KFAFC)
+ APF=PARU(120+2*KFAFC)
+C...Asymmetry and weight.
+ ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
+ & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
+ & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
+ & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
+ & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
+ & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
+ & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
+ WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
+ WTMAX=2D0+ABS(ASYM)
+ ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
+C...Angular weight for f + fbar -> Z' -> W+ + W-.
+ RM1=P(NSD(1)+1,5)**2/SH
+ RM2=P(NSD(1)+2,5)**2/SH
+ CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
+ & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
+ CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
+ & (RM2-RM1)**2)
+ WT=CFLAT+CCOS2*CTHE(1)**2
+ WTMAX=CFLAT+MAX(0D0,CCOS2)
+ ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
+ & IABS(KFL1(1)).EQ.37)) THEN
+C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
+ WT=1D0-CTHE(1)**2
+ WTMAX=1D0
+ ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
+C...Angular weight for f + fbar -> Z' -> Z0 + h0.
+ RM1=P(NSD(1)+1,5)**2/SH
+ RM2=P(NSD(1)+2,5)**2/SH
+ FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
+ WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
+ WTMAX=1D0+FLAM2/(8D0*RM1)
+ ELSEIF(MZPWP.EQ.0) THEN
+C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
+C...(W:s like if intermediate Z).
+ D34=P(IREF(IP,IORD),5)**2
+ D56=P(IREF(IP,3-IORD),5)**2
+ DT=PKK(1,3)+PKK(1,4)+D34
+ DU=PKK(1,5)+PKK(1,6)+D56
+ FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
+ FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
+ WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
+ WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
+ & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
+ ELSEIF(MZPWP.EQ.1) THEN
+C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
+C...(W:s approximately longitudinal, like if intermediate H).
+ WT=16D0*PKK(3,5)*PKK(4,6)
+ WTMAX=SH**2
+ ELSE
+C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
+C...H0 + A0 -> 4 quarks/leptons.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+ ELSEIF(ISUB.EQ.142) THEN
+ IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
+C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
+ KFAI=IABS(MINT(15))
+ KFAIC=1
+ IF(KFAI.GT.10) KFAIC=2
+ VI=PARU(129+2*KFAIC)
+ AI=PARU(130+2*KFAIC)
+ KFAF=IABS(KFL1(1))
+ KFAFC=1
+ IF(KFAF.GT.10) KFAFC=2
+ VF=PARU(129+2*KFAFC)
+ AF=PARU(130+2*KFAFC)
+ ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
+ WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
+ WTMAX=2D0+ABS(ASYM)
+ ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
+C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
+ RM1=P(NSD(1)+1,5)**2/SH
+ RM2=P(NSD(1)+2,5)**2/SH
+ CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
+ & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
+ CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
+ & (RM2-RM1)**2)
+ WT=CFLAT+CCOS2*CTHE(1)**2
+ WTMAX=CFLAT+MAX(0D0,CCOS2)
+ ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
+C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
+ RM1=P(NSD(1)+1,5)**2/SH
+ RM2=P(NSD(1)+2,5)**2/SH
+ FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
+ WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
+ WTMAX=1D0+FLAM2/(8D0*RM1)
+ ELSEIF(MZPWP.EQ.0) THEN
+C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
+C...(W/Z like if intermediate W).
+ D34=P(IREF(IP,IORD),5)**2
+ D56=P(IREF(IP,3-IORD),5)**2
+ DT=PKK(1,3)+PKK(1,4)+D34
+ DU=PKK(1,5)+PKK(1,6)+D56
+ FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
+ FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
+ WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
+ WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
+ & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
+ ELSEIF(MZPWP.EQ.1) THEN
+C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
+C...(W/Z approximately longitudinal, like if intermediate H).
+ WT=16D0*PKK(3,5)*PKK(4,6)
+ WTMAX=SH**2
+ ELSE
+C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+ ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
+ & THEN
+C...Isotropic decay of leptoquarks (assumed spin 0).
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
+C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
+ SIDE=1D0
+ IF(MINT(16).EQ.21) SIDE=-1D0
+ IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
+ WT=1D0+SIDE*CTHE(1)
+ WTMAX=2D0
+ ELSEIF(IP.EQ.1) THEN
+ RM1=P(NSD(1)+1,5)**2/SH
+ WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
+ WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
+ ELSE
+C...W/Z decay assumed isotropic, since not known.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+ ELSEIF(ISUB.EQ.149) THEN
+C...Isotropic decay of techni-eta.
+ WT=1D0
+ WTMAX=1D0
+
+ ELSEIF(ISUB.EQ.191) THEN
+ IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
+C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
+C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
+ WT=1D0-CTHE(1)**2
+ WTMAX=1D0
+ ELSEIF(IP.EQ.1) THEN
+C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
+ CTHESG=CTHE(1)*ISIGN(1,MINT(15))
+ XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
+ BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ KFAI=IABS(MINT(15))
+ EI=KCHG(KFAI,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
+ ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
+ KFAF=IABS(KFL1(1))
+ EF=KCHG(KFAF,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VALF=0.5D0*(VF+AF)
+ VARF=0.5D0*(VF-AF)
+ ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
+ ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
+ ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
+ AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
+ WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
+ WTMAX=4D0*MAX(ASAME,AFLIP)
+ ELSE
+C...Isotropic decay of W/pi_tech produced in rho_tech decay.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+ ELSEIF(ISUB.EQ.192) THEN
+ IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
+C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
+C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
+ WT=1D0-CTHE(1)**2
+ WTMAX=1D0
+ ELSEIF(IP.EQ.1) THEN
+C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
+ CTHESG=CTHE(1)*ISIGN(1,MINT(15))
+ WT=(1D0+CTHESG)**2
+ WTMAX=4D0
+ ELSE
+C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+ ELSEIF(ISUB.EQ.193) THEN
+ IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
+C...Angular weight for f + fbar -> omega_tech0 ->
+C...gamma pi_tech0 or Z0 pi_tech0.
+ WT=1D0+CTHE(1)**2
+ WTMAX=2D0
+ ELSEIF(IP.EQ.1) THEN
+C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
+ CTHESG=CTHE(1)*ISIGN(1,MINT(15))
+ BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ KFAI=IABS(MINT(15))
+ EI=KCHG(KFAI,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
+ BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
+ KFAF=IABS(KFL1(1))
+ EF=KCHG(KFAF,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VALF=0.5D0*(VF+AF)
+ VARF=0.5D0*(VF-AF)
+ BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
+ BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
+ BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
+ BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
+ WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
+ WTMAX=4D0*MAX(BSAME,BFLIP)
+ ELSE
+C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+
+C...Obtain correct angular distribution by rejection techniques.
+ ELSE
+ WT=1D0
+ WTMAX=1D0
+ ENDIF
+ IF(WT.LT.PYR(0)*WTMAX) GOTO 310
+
+C...Construct massive four-vectors using angles chosen.
+ 470 DO 540 JT=1,JTMAX
+ IF(KDCY(JT).EQ.0) GOTO 540
+ ID=IREF(IP,JT)
+ DO 480 J=1,5
+ DPMO(J)=P(ID,J)
+ 480 CONTINUE
+ DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
+CMRENNA++
+ IF(KFL3(JT).EQ.0) THEN
+ CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
+ & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
+ ELSE
+ CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
+ & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
+ ENDIF
+CMRENNA--
+
+C...Mark decayed resonances; trace history.
+ K(ID,1)=K(ID,1)+10
+ KFA=IABS(K(ID,2))
+ KCA=PYCOMP(KFA)
+ IF(KCQM(JT).NE.0) THEN
+C...Do not kill colour flow through coloured resonance!
+ ELSE
+ K(ID,4)=NSD(JT)+1
+ K(ID,5)=NSD(JT)+2
+ IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
+ ENDIF
+
+C...Add documentation lines.
+ IF(ISUB.NE.0) THEN
+ IDOC=MINT(83)+MINT(4)
+CMRENNA+++
+ IHI=NSD(JT)+2
+ IF(KFL3(JT).NE.0) IHI=IHI+1
+ DO 500 I=NSD(JT)+1,IHI
+CMRENNA---
+ I1=MINT(83)+MINT(4)+1
+ K(I,3)=I1
+ IF(MSTP(128).GE.1) K(I,3)=ID
+ IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
+ MINT(4)=MINT(4)+1
+ K(I1,1)=21
+ K(I1,2)=K(I,2)
+ K(I1,3)=IREF(IP,JT+3)
+ DO 490 J=1,5
+ P(I1,J)=P(I,J)
+ 490 CONTINUE
+ ENDIF
+ 500 CONTINUE
+ ELSE
+ K(NSD(JT)+1,3)=ID
+ K(NSD(JT)+2,3)=ID
+ IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
+ ENDIF
+
+C...Do showering if any of the two/three products can shower.
+ NSHBEF=N
+ IF(MSTP(71).GE.1) THEN
+ ISHOW1=0
+ KFL1A=IABS(KFL1(JT))
+ IF(KFL1A.LE.22) ISHOW1=1
+ ISHOW2=0
+ KFL2A=IABS(KFL2(JT))
+ IF(KFL2A.LE.22) ISHOW2=1
+ ISHOW3=0
+ IF(KFL3(JT).NE.0) THEN
+ KFL3A=IABS(KFL3(JT))
+ IF(KFL3A.LE.22) ISHOW3=1
+ ENDIF
+ IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
+ ELSEIF(KFL3(JT).EQ.0) THEN
+ CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
+ ELSE
+ NSD1=NSD(JT)+1
+ NSD2=NSD(JT)+2
+ IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
+ NSD1=NSD(JT)+3
+ ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
+ NSD2=NSD(JT)+3
+ ENDIF
+ PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
+ & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
+ & (P(NSD1,3)+P(NSD2,3))**2))
+ CALL PYSHOW(NSD1,NSD2,PMSHOW)
+ ENDIF
+ ENDIF
+ NSHAFT=N
+ IF(JT.EQ.1) NAFT1=N
+
+C...Check if decay products moved by shower.
+ NSD1=NSD(JT)+1
+ NSD2=NSD(JT)+2
+ NSD3=NSD(JT)+3
+ IF(NSHAFT.GT.NSHBEF) THEN
+ IF(K(NSD1,1).GT.10) THEN
+ DO 510 I=NSHBEF+1,NSHAFT
+ IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
+ 510 CONTINUE
+ ENDIF
+ IF(K(NSD2,1).GT.10) THEN
+ DO 520 I=NSHBEF+1,NSHAFT
+ IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
+ & I.NE.NSD1) NSD2=I
+ 520 CONTINUE
+ ENDIF
+ IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
+ DO 530 I=NSHBEF+1,NSHAFT
+ IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
+ & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
+ 530 CONTINUE
+ ENDIF
+ ENDIF
+
+C...Store decay products for further treatment.
+ NP=NP+1
+ IREF(NP,1)=NSD1
+ IREF(NP,2)=NSD2
+ IREF(NP,3)=0
+ IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
+ IREF(NP,4)=IDOC+1
+ IREF(NP,5)=IDOC+2
+ IREF(NP,6)=0
+ IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
+ IREF(NP,7)=K(IREF(IP,JT),2)
+ IREF(NP,8)=IREF(IP,JT)
+ 540 CONTINUE
+
+C...Fill information for 2 -> 1 -> 2.
+ 550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
+ MINT(7)=MINT(83)+6+2*ISET(ISUB)
+ MINT(8)=MINT(83)+7+2*ISET(ISUB)
+ MINT(25)=KFL1(1)
+ MINT(26)=KFL2(1)
+ VINT(23)=CTHE(1)
+ RM3=P(N-1,5)**2/SH
+ RM4=P(N,5)**2/SH
+ BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
+ VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
+ VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
+ VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
+ VINT(47)=SQRT(VINT(48))
+ ENDIF
+
+C...Possibility of colour rearrangement in W+W- events.
+ IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
+ IAKF1=IABS(KFL1(1))
+ IAKF2=IABS(KFL1(2))
+ IAKF3=IABS(KFL2(1))
+ IAKF4=IABS(KFL2(2))
+ IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
+ & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
+ & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
+ ENDIF
+
+C...Loop back if needed.
+ 560 IF(IP.LT.NP) GOTO 130
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYMULT
+C...Initializes treatment of multiple interactions, selects kinematics
+C...of hardest interaction if low-pT physics included in run, and
+C...generates all non-hardest interactions.
+
+ SUBROUTINE PYMULT(MMUL)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
+C...Local arrays and saved variables.
+ DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
+ SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
+
+C...Initialization of multiple interaction treatment.
+ IF(MMUL.EQ.1) THEN
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
+ ISUB=96
+ MINT(1)=96
+ VINT(63)=0D0
+ VINT(64)=0D0
+ VINT(143)=1D0
+ VINT(144)=1D0
+
+C...Loop over phase space points: xT2 choice in 20 bins.
+ 100 SIGSUM=0D0
+ DO 120 IXT2=1,20
+ NMUL(IXT2)=MSTP(83)
+ SIGM(IXT2)=0D0
+ DO 110 ITRY=1,MSTP(83)
+ RSCA=0.05D0*((21-IXT2)-PYR(0))
+ XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
+ XT2=MAX(0.01D0*VINT(149),XT2)
+ VINT(25)=XT2
+
+C...Choose tau and y*. Calculate cos(theta-hat).
+ IF(PYR(0).LE.COEF(ISUB,1)) THEN
+ TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
+ TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
+ ELSE
+ TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
+ ENDIF
+ VINT(21)=TAU
+ CALL PYKLIM(2)
+ RYST=PYR(0)
+ MYST=1
+ IF(RYST.GT.COEF(ISUB,8)) MYST=2
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
+ CALL PYKMAP(2,MYST,PYR(0))
+ VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
+
+C...Calculate differential cross-section.
+ VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
+ CALL PYSIGH(NCHN,SIGS)
+ SIGM(IXT2)=SIGM(IXT2)+SIGS
+ 110 CONTINUE
+ SIGSUM=SIGSUM+SIGM(IXT2)
+ 120 CONTINUE
+ SIGSUM=SIGSUM/(20D0*MSTP(83))
+
+C...Reject result if sigma(parton-parton) is smaller than hadronic one.
+ IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
+ PARP(82)=0.9D0*PARP(82)
+ VINT(149)=4D0*PARP(82)**2/VINT(2)
+ GOTO 100
+ ENDIF
+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
+
+C...Start iteration to find k factor.
+ YKE=SIGSUM/SIGT(0,0,5)
+ SO=0.5D0
+ XI=0D0
+ YI=0D0
+ XF=0D0
+ YF=0D0
+ XK=0.5D0
+ IIT=0
+ 130 IF(IIT.EQ.0) THEN
+ XK=2D0*XK
+ ELSEIF(IIT.EQ.1) THEN
+ XK=0.5D0*XK
+ ELSE
+ XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
+ ENDIF
+
+C...Evaluate overlap integrals.
+ IF(MSTP(82).EQ.2) THEN
+ SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
+ SOP=SP/PARU(1)
+ ELSE
+ IF(MSTP(82).EQ.3) DELTAB=0.02D0
+ IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
+ SP=0D0
+ SOP=0D0
+ B=-0.5D0*DELTAB
+ 140 B=B+DELTAB
+ IF(MSTP(82).EQ.3) THEN
+ OV=EXP(-B**2)/PARU(2)
+ ELSE
+ CQ2=PARP(84)**2
+ OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
+ & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
+ & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
+ ENDIF
+ PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
+ SP=SP+PARU(2)*B*DELTAB*PACC
+ SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
+ IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
+ ENDIF
+ YK=PARU(1)*XK*SO/SP
+
+C...Continue iteration until convergence.
+ IF(YK.LT.YKE) THEN
+ XI=XK
+ YI=YK
+ IF(IIT.EQ.1) IIT=2
+ ELSE
+ XF=XK
+ YF=YK
+ IF(IIT.EQ.0) IIT=1
+ ENDIF
+ IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
+
+C...Store some results for subsequent use.
+ VINT(145)=SIGSUM
+ VINT(146)=SOP/SO
+ VINT(147)=SOP/SP
+
+C...Initialize iteration in xT2 for hardest interaction.
+ ELSEIF(MMUL.EQ.2) THEN
+ IF(MSTP(82).LE.0) THEN
+ ELSEIF(MSTP(82).EQ.1) THEN
+ XT2=1D0
+ XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
+ ELSEIF(MSTP(82).EQ.2) THEN
+ XT2=1D0
+ XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
+ & (1D0+VINT(149))
+ ELSE
+ XC2=4D0*CKIN(3)**2/VINT(2)
+ IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
+ ENDIF
+
+ ELSEIF(MMUL.EQ.3) THEN
+C...Low-pT or multiple interactions (first semihard interaction):
+C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
+C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
+ ISUB=MINT(1)
+ IF(MSTP(82).LE.0) THEN
+ XT2=0D0
+ ELSEIF(MSTP(82).EQ.1) THEN
+ XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
+ ELSEIF(MSTP(82).EQ.2) THEN
+ IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
+ & VINT(149)))).GT.PYR(0)) XT2=1D0
+ IF(XT2.GE.1D0) THEN
+ XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
+ & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
+ & VINT(149)
+ ELSE
+ XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
+ & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
+ & VINT(149)
+ ENDIF
+ XT2=MAX(0.01D0*VINT(149),XT2)
+ ELSE
+ XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
+ & PYR(0)*(1D0-XC2))-VINT(149)
+ XT2=MAX(0.01D0*VINT(149),XT2)
+ ENDIF
+ VINT(25)=XT2
+
+C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
+ IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
+ IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
+ IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
+ ISUB=95
+ MINT(1)=ISUB
+ VINT(21)=0.01D0*VINT(149)
+ VINT(22)=0D0
+ VINT(23)=0D0
+ VINT(25)=0.01D0*VINT(149)
+
+ ELSE
+C...Multiple interactions (first semihard interaction).
+C...Choose tau and y*. Calculate cos(theta-hat).
+ IF(PYR(0).LE.COEF(ISUB,1)) THEN
+ TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
+ TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
+ ELSE
+ TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
+ ENDIF
+ VINT(21)=TAU
+ CALL PYKLIM(2)
+ RYST=PYR(0)
+ MYST=1
+ IF(RYST.GT.COEF(ISUB,8)) MYST=2
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
+ CALL PYKMAP(2,MYST,PYR(0))
+ VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
+ ENDIF
+ VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
+
+C...Store results of cross-section calculation.
+ ELSEIF(MMUL.EQ.4) THEN
+ ISUB=MINT(1)
+ XTS=VINT(25)
+ IF(ISET(ISUB).EQ.1) XTS=VINT(21)
+ IF(ISET(ISUB).EQ.2)
+ & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
+ IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
+ RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
+ & (XTS+VINT(149))))
+ IRBIN=INT(1D0+20D0*RBIN)
+ IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
+ NMUL(IRBIN)=NMUL(IRBIN)+1
+ SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
+ ENDIF
+
+C...Choose impact parameter.
+ ELSEIF(MMUL.EQ.5) THEN
+ IF(MSTP(82).EQ.3) THEN
+ VINT(148)=PYR(0)/(PARU(2)*VINT(147))
+ ELSE
+ RTYPE=PYR(0)
+ CQ2=PARP(84)**2
+ IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
+ B2=-LOG(PYR(0))
+ ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
+ B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
+ ELSE
+ B2=-CQ2*LOG(PYR(0))
+ ENDIF
+ VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
+ & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
+ ENDIF
+
+C...Multiple interactions (variable impact parameter) : reject with
+C...probability exp(-overlap*cross-section above pT/normalization).
+ RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
+ SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
+ DO 150 IBIN=IRBIN+1,20
+ RNCOR=RNCOR+NMUL(IBIN)
+ SIGCOR=SIGCOR+SIGM(IBIN)
+ 150 CONTINUE
+ SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
+ IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
+ VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
+ & SIGABV/SIGT(0,0,5)))
+
+C...Generate additional multiple semihard interactions.
+ ELSEIF(MMUL.EQ.6) THEN
+ ISUBSV=MINT(1)
+ DO 160 J=11,80
+ VINTSV(J)=VINT(J)
+ 160 CONTINUE
+ ISUB=96
+ MINT(1)=96
+
+C...Reconstruct strings in hard scattering.
+ NMAX=MINT(84)+4
+ IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
+ IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
+ NSTR=0
+ DO 180 I=MINT(84)+1,NMAX
+ KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
+ IF(KCS.EQ.0) GOTO 180
+
+ DO 170 J=1,4
+ IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
+ IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
+ IF(J.LE.2) THEN
+ IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
+ ELSE
+ IST=MOD(K(I,J+1),MSTU(5))
+ ENDIF
+ IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
+ IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
+ NSTR=NSTR+1
+ IF(J.EQ.1.OR.J.EQ.4) THEN
+ KSTR(NSTR,1)=I
+ KSTR(NSTR,2)=IST
+ ELSE
+ KSTR(NSTR,1)=IST
+ KSTR(NSTR,2)=I
+ ENDIF
+ 170 CONTINUE
+ 180 CONTINUE
+
+C...Set up starting values for iteration in xT2.
+ XT2=VINT(25)
+ IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
+ IF(ISET(ISUBSV).EQ.2)
+ & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
+ IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
+ IF(MSTP(82).LE.1) THEN
+ XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
+ ELSE
+ XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
+ & VINT(149)*(1D0+VINT(149))
+ ENDIF
+ VINT(63)=0D0
+ VINT(64)=0D0
+ VINT(143)=1D0-VINT(141)
+ VINT(144)=1D0-VINT(142)
+
+C...Iterate downwards in xT2.
+ 190 IF(MSTP(82).LE.1) THEN
+ XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
+ IF(XT2.LT.VINT(149)) GOTO 240
+ ELSE
+ IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
+ XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
+ & LOG(PYR(0)))-VINT(149)
+ IF(XT2.LE.0D0) GOTO 240
+ XT2=MAX(0.01D0*VINT(149),XT2)
+ ENDIF
+ VINT(25)=XT2
+
+C...Choose tau and y*. Calculate cos(theta-hat).
+ IF(PYR(0).LE.COEF(ISUB,1)) THEN
+ TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
+ TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
+ ELSE
+ TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
+ ENDIF
+ VINT(21)=TAU
+ CALL PYKLIM(2)
+ RYST=PYR(0)
+ MYST=1
+ IF(RYST.GT.COEF(ISUB,8)) MYST=2
+ IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
+ CALL PYKMAP(2,MYST,PYR(0))
+ VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
+
+C...Check that x not used up. Accept or reject kinematical variables.
+ X1M=SQRT(TAU)*EXP(VINT(22))
+ X2M=SQRT(TAU)*EXP(-VINT(22))
+ IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
+ VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
+ CALL PYSIGH(NCHN,SIGS)
+ IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
+
+C...Reset K, P and V vectors. Select some variables.
+ DO 210 I=N+1,N+2
+ DO 200 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 200 CONTINUE
+ 210 CONTINUE
+ RFLAV=PYR(0)
+ PT=0.5D0*VINT(1)*SQRT(XT2)
+ PHI=PARU(2)*PYR(0)
+ CTH=VINT(23)
+
+C...Add first parton to event record.
+ K(N+1,1)=3
+ K(N+1,2)=21
+ IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
+ & 1+INT((2D0+PARJ(2))*PYR(0))
+ P(N+1,1)=PT*COS(PHI)
+ P(N+1,2)=PT*SIN(PHI)
+ P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
+ P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
+ P(N+1,5)=0D0
+
+C...Add second parton to event record.
+ K(N+2,1)=3
+ K(N+2,2)=21
+ IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
+ P(N+2,1)=-P(N+1,1)
+ P(N+2,2)=-P(N+1,2)
+ P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
+ P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
+ P(N+2,5)=0D0
+
+ IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
+C....Choose relevant string pieces to place gluons on.
+ DO 230 I=N+1,N+2
+ DMIN=1D8
+ DO 220 ISTR=1,NSTR
+ I1=KSTR(ISTR,1)
+ I2=KSTR(ISTR,2)
+ DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
+ & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
+ & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
+ & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
+ IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
+ DMIN=DIST
+ IST1=I1
+ IST2=I2
+ ISTM=ISTR
+ ENDIF
+ 220 CONTINUE
+
+C....Colour flow adjustments, new string pieces.
+ IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
+ & MOD(K(IST1,4),MSTU(5))
+ IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
+ & MSTU(5)*(K(IST1,5)/MSTU(5))+I
+ K(I,5)=MSTU(5)*IST1
+ K(I,4)=MSTU(5)*IST2
+ IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
+ & MOD(K(IST2,5),MSTU(5))
+ IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
+ & MSTU(5)*(K(IST2,4)/MSTU(5))+I
+ KSTR(ISTM,2)=I
+ KSTR(NSTR+1,1)=I
+ KSTR(NSTR+1,2)=IST2
+ NSTR=NSTR+1
+ 230 CONTINUE
+
+C...String drawing and colour flow for gluon loop.
+ ELSEIF(K(N+1,2).EQ.21) THEN
+ K(N+1,4)=MSTU(5)*(N+2)
+ K(N+1,5)=MSTU(5)*(N+2)
+ K(N+2,4)=MSTU(5)*(N+1)
+ K(N+2,5)=MSTU(5)*(N+1)
+ KSTR(NSTR+1,1)=N+1
+ KSTR(NSTR+1,2)=N+2
+ KSTR(NSTR+2,1)=N+2
+ KSTR(NSTR+2,2)=N+1
+ NSTR=NSTR+2
+
+C...String drawing and colour flow for qqbar pair.
+ ELSE
+ K(N+1,4)=MSTU(5)*(N+2)
+ K(N+2,5)=MSTU(5)*(N+1)
+ KSTR(NSTR+1,1)=N+1
+ KSTR(NSTR+1,2)=N+2
+ NSTR=NSTR+1
+ ENDIF
+
+C...Update remaining energy; iterate.
+ N=N+2
+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
+ CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ MINT(31)=MINT(31)+1
+ VINT(151)=VINT(151)+VINT(41)
+ VINT(152)=VINT(152)+VINT(42)
+ VINT(143)=VINT(143)-VINT(41)
+ VINT(144)=VINT(144)-VINT(42)
+ IF(MINT(31).LT.240) GOTO 190
+ 240 CONTINUE
+ MINT(1)=ISUBSV
+ DO 250 J=11,80
+ VINT(J)=VINTSV(J)
+ 250 CONTINUE
+ ENDIF
+
+C...Format statements for printout.
+ 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
+ &'actions for MSTP(82) =',I2,' ******')
+ 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
+ &D9.2,' mb: rejected')
+ 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
+ &D9.2,' mb: accepted')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYREMN
+C...Adds on target remnants (one or two from each side) and
+C...includes primordial kT for hadron beams.
+
+ SUBROUTINE PYREMN(IPU1,IPU2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
+ &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
+
+C...Find event type and remaining energy.
+ ISUB=MINT(1)
+ NS=N
+ IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
+ VINT(143)=1D0-VINT(141)
+ VINT(144)=1D0-VINT(142)
+ ENDIF
+
+C...Define initial partons.
+ NTRY=0
+ 100 NTRY=NTRY+1
+ DO 130 JT=1,2
+ I=MINT(83)+JT+2
+ IF(JT.EQ.1) IPU=IPU1
+ IF(JT.EQ.2) IPU=IPU2
+ K(I,1)=21
+ K(I,2)=K(IPU,2)
+ K(I,3)=I-2
+ PMS(JT)=0D0
+ VINT(156+JT)=0D0
+ VINT(158+JT)=0D0
+ IF(MINT(47).EQ.1) THEN
+ DO 110 J=1,5
+ P(I,J)=P(I-2,J)
+ 110 CONTINUE
+ ELSEIF(ISUB.EQ.95) THEN
+ K(I,2)=21
+ ELSE
+ P(I,5)=P(IPU,5)
+
+C...No primordial kT, or chosen according to truncated Gaussian or
+C...exponential, or (for photon) predetermined or power law.
+ 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
+ IF(MSTP(91).LE.0) THEN
+ PT=0D0
+ ELSEIF(MSTP(91).EQ.1) THEN
+ PT=PARP(91)*SQRT(-LOG(PYR(0)))
+ ELSE
+ RPT1=PYR(0)
+ RPT2=PYR(0)
+ PT=-PARP(92)*LOG(RPT1*RPT2)
+ ENDIF
+ IF(PT.GT.PARP(93)) GOTO 120
+ ELSEIF(MINT(106+JT).EQ.3) THEN
+ PT=SQRT(VINT(282+JT))
+ PT=PT*0.8D0**MINT(57)
+ IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
+ ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
+ IF(MSTP(93).LE.0) THEN
+ PT=0D0
+ ELSEIF(MSTP(93).EQ.1) THEN
+ PT=PARP(99)*SQRT(-LOG(PYR(0)))
+ ELSEIF(MSTP(93).EQ.2) THEN
+ RPT1=PYR(0)
+ RPT2=PYR(0)
+ PT=-PARP(99)*LOG(RPT1*RPT2)
+ ELSEIF(MSTP(93).EQ.3) THEN
+ HA=PARP(99)**2
+ HB=PARP(100)**2
+ PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
+ ELSE
+ HA=PARP(99)**2
+ HB=PARP(100)**2
+ IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
+ PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
+ ENDIF
+ IF(PT.GT.PARP(100)) GOTO 120
+ ELSE
+ PT=0D0
+ ENDIF
+ VINT(156+JT)=PT
+ PHI=PARU(2)*PYR(0)
+ P(I,1)=PT*COS(PHI)
+ P(I,2)=PT*SIN(PHI)
+ PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
+ ENDIF
+ 130 CONTINUE
+ IF(MINT(47).EQ.1) RETURN
+
+C...Kinematics construction for initial partons.
+ I1=MINT(83)+3
+ I2=MINT(83)+4
+ IF(ISUB.EQ.95) THEN
+ SHS=0D0
+ SHR=0D0
+ ELSE
+ SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
+ & (P(I1,2)+P(I2,2))**2
+ SHR=SQRT(MAX(0D0,SHS))
+ IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
+ P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
+ P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
+ P(I2,4)=SHR-P(I1,4)
+ P(I2,3)=-P(I1,3)
+
+C...Transform partons to overall CM-frame.
+ ROBO(3)=(P(I1,1)+P(I2,1))/SHR
+ ROBO(4)=(P(I1,2)+P(I2,2))/SHR
+ CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
+ ROBO(2)=PYANGL(P(I1,1),P(I1,2))
+ CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
+ ROBO(1)=PYANGL(P(I1,3),P(I1,1))
+ CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
+ CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
+ ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
+ & (VINT(141)+VINT(142))))
+ CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
+ ENDIF
+
+C...Optionally fix up x and Q2 definitions for leptoproduction.
+ IDISXQ=0
+ IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
+ &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
+ IF(IDISXQ.EQ.1) THEN
+
+C...Find where incoming and outgoing leptons/partons are sitting.
+ LESD=1
+ IF(MINT(42).EQ.1) LESD=2
+ LPIN=MINT(83)+3-LESD
+ LEIN=MINT(84)+LESD
+ LQIN=MINT(84)+3-LESD
+ LEOUT=MINT(84)+2+LESD
+ LQOUT=MINT(84)+5-LESD
+ IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
+ IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
+ LSCMS=0
+ DO 140 I=MINT(84)+5,N
+ IF(K(I,2).EQ.94) THEN
+ LSCMS=I
+ LEOUT=I+LESD
+ LQOUT=I+3-LESD
+ ENDIF
+ 140 CONTINUE
+ LQBG=IPU1
+ IF(LESD.EQ.1) LQBG=IPU2
+
+C...Calculate actual and wanted momentum transfer.
+ XNOM=VINT(43-LESD)
+ Q2NOM=-VINT(45)
+ HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
+ & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
+ & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
+ HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
+ FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
+ P(N+1,1)=FAC*P(LEOUT,1)
+ P(N+1,2)=FAC*P(LEOUT,2)
+ P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
+ & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
+ P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
+ & P(N+1,3)**2)
+ DO 150 J=1,4
+ QOLD(J)=P(LEIN,J)-P(LEOUT,J)
+ QNEW(J)=P(LEIN,J)-P(N+1,J)
+ 150 CONTINUE
+
+C...Boost outgoing electron and daughters.
+ IF(LSCMS.EQ.0) THEN
+ DO 160 J=1,4
+ P(LEOUT,J)=P(N+1,J)
+ 160 CONTINUE
+ ELSE
+ DO 170 J=1,3
+ P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
+ 170 CONTINUE
+ PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
+ DO 180 J=1,3
+ DBE(J)=PINV*P(N+2,J)
+ 180 CONTINUE
+ DO 200 I=LSCMS+1,N
+ IORIG=I
+ 190 IORIG=K(IORIG,3)
+ IF(IORIG.GT.LEOUT) GOTO 190
+ IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
+ & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
+ 200 CONTINUE
+ ENDIF
+
+C...Copy shower initiator and all outgoing partons.
+ NCOP=N+1
+ K(NCOP,3)=LQBG
+ DO 210 J=1,5
+ P(NCOP,J)=P(LQBG,J)
+ 210 CONTINUE
+ DO 240 I=MINT(84)+1,N
+ ICOP=0
+ IF(K(I,1).GT.10) GOTO 240
+ IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
+ ICOP=I
+ ELSE
+ IORIG=I
+ 220 IORIG=K(IORIG,3)
+ IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
+ ICOP=IORIG
+ ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
+ GOTO 220
+ ENDIF
+ ENDIF
+ IF(ICOP.NE.0) THEN
+ NCOP=NCOP+1
+ K(NCOP,3)=I
+ DO 230 J=1,5
+ P(NCOP,J)=P(I,J)
+ 230 CONTINUE
+ ENDIF
+ 240 CONTINUE
+
+C...Calculate relative rescaling factors.
+ SLC=3-2*LESD
+ PLCSUM=0D0
+ DO 250 I=N+2,NCOP
+ PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
+ 250 CONTINUE
+ DO 260 I=N+2,NCOP
+ V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
+ 260 CONTINUE
+
+C...Transfer extra three-momentum of current.
+ DO 280 I=N+2,NCOP
+ DO 270 J=1,3
+ P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
+ 270 CONTINUE
+ P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ 280 CONTINUE
+
+C...Iterate change of initiator momentum to get energy right.
+ ITER=0
+ 290 ITER=ITER+1
+ PEEX=-P(N+1,4)-QNEW(4)
+ PEMV=-P(N+1,3)/P(N+1,4)
+ DO 300 I=N+2,NCOP
+ PEEX=PEEX+P(I,4)
+ PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
+ 300 CONTINUE
+ IF(ABS(PEMV).LT.1D-10) THEN
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+ PZCH=-PEEX/PEMV
+ P(N+1,3)=P(N+1,3)+PZCH
+ P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
+ DO 310 I=N+2,NCOP
+ P(I,3)=P(I,3)+V(I,1)*PZCH
+ P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ 310 CONTINUE
+ IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
+
+C...Modify momenta in event record.
+ HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
+ & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
+ IF(ABS(HBE).GT.0.999999D0) THEN
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+ I=MINT(83)+5-LESD
+ CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
+ DO 330 I=N+1,NCOP
+ ICOP=K(I,3)
+ DO 320 J=1,4
+ P(ICOP,J)=P(I,J)
+ 320 CONTINUE
+ 330 CONTINUE
+ ENDIF
+
+C...Check minimum invariant mass of remnant system(s).
+ PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
+ PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
+ PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
+ PMIN(0)=SQRT(PMS(0))
+ DO 340 JT=1,2
+ PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
+ PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
+ PMIN(JT)=0D0
+ IF(MINT(44+JT).EQ.1) GOTO 340
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
+ IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
+ IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
+ IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
+ PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
+ & P(MINT(83)+JT+2,2)**2)
+ 340 CONTINUE
+ IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
+ &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
+ &PSYS(2,4))) THEN
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+
+C...Loop over two remnants; skip if none there.
+ I=NS
+ DO 410 JT=1,2
+ ISN(JT)=0
+ IF(MINT(44+JT).EQ.1) GOTO 410
+ IF(JT.EQ.1) IPU=IPU1
+ IF(JT.EQ.2) IPU=IPU2
+
+C...Store first remnant parton.
+ I=I+1
+ IS(JT)=I
+ ISN(JT)=1
+ DO 350 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 350 CONTINUE
+ K(I,1)=1
+ K(I,2)=KFLSP(JT)
+ K(I,3)=MINT(83)+JT
+ P(I,5)=PYMASS(K(I,2))
+
+C...First parton colour connections and kinematics.
+ KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
+ IF(KCOL.EQ.2) THEN
+ K(I,1)=3
+ K(I,4)=MSTU(5)*IPU+IPU
+ K(I,5)=MSTU(5)*IPU+IPU
+ K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
+ K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
+ ELSEIF(KCOL.NE.0) THEN
+ K(I,1)=3
+ KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
+ K(I,KFLS+3)=IPU
+ K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
+ ENDIF
+ IF(KFLCH(JT).EQ.0) THEN
+ P(I,1)=-P(MINT(83)+JT+2,1)
+ P(I,2)=-P(MINT(83)+JT+2,2)
+ PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
+ PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
+ P(I,3)=PSYS(JT,3)
+ P(I,4)=PSYS(JT,4)
+
+C...When extra remnant parton or hadron: store extra remnant.
+ ELSE
+ I=I+1
+ ISN(JT)=2
+ DO 360 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 360 CONTINUE
+ K(I,1)=1
+ K(I,2)=KFLCH(JT)
+ K(I,3)=MINT(83)+JT
+ P(I,5)=PYMASS(K(I,2))
+
+C...Find parton colour connections of extra remnant.
+ KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
+ IF(KCOL.EQ.2) THEN
+ K(I,1)=3
+ K(I,4)=MSTU(5)*IPU+IPU
+ K(I,5)=MSTU(5)*IPU+IPU
+ K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
+ K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
+ ELSEIF(KCOL.NE.0) THEN
+ K(I,1)=3
+ KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
+ K(I,KFLS+3)=IPU
+ K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
+ ENDIF
+
+C...Relative transverse momentum when two remnants.
+ LOOP=0
+ 370 LOOP=LOOP+1
+ CALL PYPTDI(1,P(I-1,1),P(I-1,2))
+ IF(IABS(MINT(10+JT)).LT.20) THEN
+ P(I-1,1)=0D0
+ P(I-1,2)=0D0
+ ENDIF
+ PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
+ P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
+ P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
+ PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
+
+C...Meson or baryon; photon as meson. For splitup below.
+ IMB=1
+ IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
+
+C***Relative distribution for electron into two electrons. Temporary!
+ IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
+ & THEN
+ CHI(JT)=PYR(0)
+
+C...Relative distribution of electron energy into electron plus parton.
+ ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
+ XHRD=VINT(140+JT)
+ XE=VINT(154+JT)
+ CHI(JT)=(XE-XHRD)/(1D0-XHRD)
+
+C...Relative distribution of energy for particle into two jets.
+ ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
+ CHIK=PARP(92+2*IMB)
+ IF(MSTP(92).LE.1) THEN
+ IF(IMB.EQ.1) CHI(JT)=PYR(0)
+ IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
+ ELSEIF(MSTP(92).EQ.2) THEN
+ CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
+ ELSEIF(MSTP(92).EQ.3) THEN
+ CUT=2D0*0.3D0/VINT(1)
+ 380 CHI(JT)=PYR(0)**2
+ IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
+ & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
+ ELSEIF(MSTP(92).EQ.4) THEN
+ CUT=2D0*0.3D0/VINT(1)
+ CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
+ 390 CHIR=CUT*CUTR**PYR(0)
+ CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
+ IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
+ ELSE
+ CUT=2D0*0.3D0/VINT(1)
+ CUTA=CUT**(1D0-PARP(98))
+ CUTB=(1D0+CUT)**(1D0-PARP(98))
+ 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
+ IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
+ & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
+ ENDIF
+
+C...Relative distribution of energy for particle into jet plus particle.
+ ELSE
+ IF(MSTP(94).LE.1) THEN
+ IF(IMB.EQ.1) CHI(JT)=PYR(0)
+ IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
+ IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
+ ELSEIF(MSTP(94).EQ.2) THEN
+ CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
+ IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
+ ELSEIF(MSTP(94).EQ.3) THEN
+ CALL PYZDIS(1,0,PMS(JT+4),ZZ)
+ CHI(JT)=ZZ
+ ELSE
+ CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
+ CHI(JT)=ZZ
+ ENDIF
+ ENDIF
+
+C...Construct total transverse mass; reject if too large.
+ PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
+ IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
+ IF(LOOP.LT.10) THEN
+ GOTO 370
+ ELSE
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+ ENDIF
+ PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
+ VINT(158+JT)=CHI(JT)
+
+C...Subdivide longitudinal momentum according to value selected above.
+ PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
+ P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
+ P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
+ P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
+ P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
+ ENDIF
+ 410 CONTINUE
+ N=I
+
+C...Check if longitudinal boosts needed - if so pick two systems.
+ PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
+ &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
+ IF(PDEV.LE.1D-6*VINT(1)) RETURN
+ IF(ISN(1).EQ.0) THEN
+ IR=0
+ IL=2
+ ELSEIF(ISN(2).EQ.0) THEN
+ IR=1
+ IL=0
+ ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
+ IR=1
+ IL=2
+ ELSEIF(VINT(143).GT.0.2D0) THEN
+ IR=1
+ IL=0
+ ELSEIF(VINT(144).GT.0.2D0) THEN
+ IR=0
+ IL=2
+ ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
+ IR=1
+ IL=0
+ ELSE
+ IR=0
+ IL=2
+ ENDIF
+ IG=3-IR-IL
+
+C...E+-pL wanted for system to be modified.
+ IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
+ PPB=VINT(1)
+ PNB=VINT(1)
+ ELSE
+ PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
+ PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
+ ENDIF
+
+C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
+ IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
+ PMTB=PPB*PNB
+ PMTR=PMS(IR)
+ PMTL=PMS(IL)
+ SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
+ SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
+ RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
+ & *PNB)
+ RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
+ & *PPB)
+ BER=(RKR**2-1D0)/(RKR**2+1D0)
+ BEL=-(RKL**2-1D0)/(RKL**2+1D0)
+ PPB=PPB-(PSYS(0,4)+PSYS(0,3))
+ PNB=PNB-(PSYS(0,4)-PSYS(0,3))
+ DO 420 J=1,4
+ PSYS(0,J)=0D0
+ 420 CONTINUE
+ DO 450 I=MINT(84)+1,NS
+ IF(K(I,1).GT.10) GOTO 450
+ INCL=0
+ IORIG=I
+ 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
+ IORIG=K(IORIG,3)
+ IF(IORIG.GT.LPIN) GOTO 430
+ IF(INCL.EQ.0) GOTO 450
+ DO 440 J=1,4
+ PSYS(0,J)=PSYS(0,J)+P(I,J)
+ 440 CONTINUE
+ 450 CONTINUE
+ PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
+ PPB=PPB+(PSYS(0,4)+PSYS(0,3))
+ PNB=PNB+(PSYS(0,4)-PSYS(0,3))
+ ENDIF
+
+C...Construct longitudinal boosts.
+ DPMTB=PPB*PNB
+ DPMTR=PMS(IR)
+ DPMTL=PMS(IL)
+ DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
+ IF(DSQLAM.LE.1D-6*DPMTB) THEN
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+ DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
+ DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
+ &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
+ DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
+ &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
+ DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
+ DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
+
+C...Perform longitudinal boosts.
+ IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
+ P(IS(1),3)=0D0
+ P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
+ ELSEIF(IR.EQ.1) THEN
+ CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
+ ELSEIF(IDISXQ.EQ.1) THEN
+ DO 470 I=I1,NS
+ INCL=0
+ IORIG=I
+ 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
+ IORIG=K(IORIG,3)
+ IF(IORIG.GT.LPIN) GOTO 460
+ IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
+ 470 CONTINUE
+ ELSE
+ CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
+ ENDIF
+ IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
+ P(IS(2),3)=0D0
+ P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
+ ELSEIF(IL.EQ.2) THEN
+ CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
+ ELSEIF(IDISXQ.EQ.1) THEN
+ DO 490 I=I1,NS
+ INCL=0
+ IORIG=I
+ 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
+ IORIG=K(IORIG,3)
+ IF(IORIG.GT.LPIN) GOTO 480
+ IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
+ 490 CONTINUE
+ ELSE
+ CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
+ ENDIF
+
+C...Final check that energy-momentum conservation worked.
+ PESUM=0D0
+ PZSUM=0D0
+ DO 500 I=MINT(84)+1,N
+ IF(K(I,1).GT.10) GOTO 500
+ PESUM=PESUM+P(I,4)
+ PZSUM=PZSUM+P(I,3)
+ 500 CONTINUE
+ PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
+ IF(PDEV.GT.1D-4*VINT(1)) THEN
+ MINT(51)=1
+ MINT(57)=MINT(57)+1
+ RETURN
+ ENDIF
+
+C...Calculate rotation and boost from overall CM frame to
+C...hadronic CM frame in leptoproduction.
+ MINT(91)=0
+ IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
+ MINT(91)=1
+ LESD=1
+ IF(MINT(42).EQ.1) LESD=2
+ LPIN=MINT(83)+3-LESD
+
+C...Sum upp momenta of everything not lepton or photon to define boost.
+ DO 510 J=1,4
+ PSUM(J)=0D0
+ 510 CONTINUE
+ DO 530 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
+ IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
+ IF(K(I,2).EQ.22) GOTO 530
+ DO 520 J=1,4
+ PSUM(J)=PSUM(J)+P(I,J)
+ 520 CONTINUE
+ 530 CONTINUE
+ VINT(223)=-PSUM(1)/PSUM(4)
+ VINT(224)=-PSUM(2)/PSUM(4)
+ VINT(225)=-PSUM(3)/PSUM(4)
+
+C...Boost incoming hadron to hadronic CM frame to determine rotations.
+ K(N+1,1)=1
+ DO 540 J=1,5
+ P(N+1,J)=P(LPIN,J)
+ V(N+1,J)=V(LPIN,J)
+ 540 CONTINUE
+ CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
+ VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
+ CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
+ IF(LESD.EQ.2) THEN
+ VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
+ ELSE
+ VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYDIFF
+C...Handles diffractive and elastic scattering.
+
+ SUBROUTINE PYDIFF
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
+
+C...Reset K, P and V vectors. Store incoming particles.
+ DO 110 JT=1,MSTP(126)+10
+ I=MINT(83)+JT
+ DO 100 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+ N=MINT(84)
+ MINT(3)=0
+ MINT(21)=0
+ MINT(22)=0
+ MINT(23)=0
+ MINT(24)=0
+ MINT(4)=4
+ DO 130 JT=1,2
+ I=MINT(83)+JT
+ K(I,1)=21
+ K(I,2)=MINT(10+JT)
+ DO 120 J=1,5
+ P(I,J)=VINT(285+5*JT+J)
+ 120 CONTINUE
+ 130 CONTINUE
+ MINT(6)=2
+
+C...Subprocess; kinematics.
+ SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
+ PZ=SQRT(SQLAM)/(2D0*VINT(1))
+ DO 200 JT=1,2
+ I=MINT(83)+JT
+ PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
+ KFH=MINT(102+JT)
+
+C...Elastically scattered particle.
+ IF(MINT(16+JT).LE.0) THEN
+ N=N+1
+ K(N,1)=1
+ K(N,2)=KFH
+ K(N,3)=I+2
+ P(N,3)=PZ*(-1)**(JT+1)
+ P(N,4)=PE
+ P(N,5)=SQRT(VINT(62+JT))
+
+C...Decay rho from elastic scattering of gamma with sin**2(theta)
+C...distribution of decay products (in rho rest frame).
+ IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
+ NSAV=N
+ DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
+ P(N,3)=0D0
+ P(N,4)=P(N,5)
+ CALL PYDECY(NSAV)
+ IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
+ PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
+ CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
+ THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
+ CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
+ 140 CTHE=2D0*PYR(0)-1D0
+ IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
+ CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
+ ENDIF
+ CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
+ ENDIF
+
+C...Diffracted particle: low-mass system to two particles.
+ ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
+ N=N+2
+ K(N-1,1)=1
+ K(N,1)=1
+ K(N-1,3)=I+2
+ K(N,3)=I+2
+ PMMAS=SQRT(VINT(62+JT))
+ NTRY=0
+ 150 NTRY=NTRY+1
+ IF(NTRY.LT.20) THEN
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ CALL PYSPLI(KFH,21,KFL1,KFL2)
+ CALL PYKFDI(KFL1,0,KFL3,KF1)
+ IF(KF1.EQ.0) GOTO 150
+ CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
+ IF(KF2.EQ.0) GOTO 150
+ ELSE
+ KF1=KFH
+ KF2=111
+ ENDIF
+ PM1=PYMASS(KF1)
+ PM2=PYMASS(KF2)
+ IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
+ K(N-1,2)=KF1
+ K(N,2)=KF2
+ P(N-1,5)=PM1
+ P(N,5)=PM2
+ PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
+ & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
+ P(N-1,3)=PZP
+ P(N,3)=-PZP
+ P(N-1,4)=SQRT(PM1**2+PZP**2)
+ P(N,4)=SQRT(PM2**2+PZP**2)
+ CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
+ & 0D0,0D0,0D0)
+ DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
+ CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
+
+C...Diffracted particle: valence quark kicked out.
+ ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
+ & PARP(101))) THEN
+ N=N+2
+ K(N-1,1)=2
+ K(N,1)=1
+ K(N-1,3)=I+2
+ K(N,3)=I+2
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
+ P(N-1,5)=PYMASS(K(N-1,2))
+ P(N,5)=PYMASS(K(N,2))
+ SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
+ & 4D0*P(N-1,5)**2*P(N,5)**2
+ P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
+ & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
+ P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
+ P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
+ P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
+
+C...Diffracted particle: gluon kicked out.
+ ELSE
+ N=N+3
+ K(N-2,1)=2
+ K(N-1,1)=2
+ K(N,1)=1
+ K(N-2,3)=I+2
+ K(N-1,3)=I+2
+ K(N,3)=I+2
+ MINT(105)=MINT(102+JT)
+ MINT(109)=MINT(106+JT)
+ CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
+ K(N-1,2)=21
+ P(N-2,5)=PYMASS(K(N-2,2))
+ P(N-1,5)=0D0
+ P(N,5)=PYMASS(K(N,2))
+C...Energy distribution for particle into two jets.
+ 160 IMB=1
+ IF(MOD(KFH/1000,10).NE.0) IMB=2
+ CHIK=PARP(92+2*IMB)
+ IF(MSTP(92).LE.1) THEN
+ IF(IMB.EQ.1) CHI=PYR(0)
+ IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
+ ELSEIF(MSTP(92).EQ.2) THEN
+ CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
+ ELSEIF(MSTP(92).EQ.3) THEN
+ CUT=2D0*0.3D0/VINT(1)
+ 170 CHI=PYR(0)**2
+ IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
+ & PYR(0)) GOTO 170
+ ELSEIF(MSTP(92).EQ.4) THEN
+ CUT=2D0*0.3D0/VINT(1)
+ CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
+ 180 CHIR=CUT*CUTR**PYR(0)
+ CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
+ IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
+ ELSE
+ CUT=2D0*0.3D0/VINT(1)
+ CUTA=CUT**(1D0-PARP(98))
+ CUTB=(1D0+CUT)**(1D0-PARP(98))
+ 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
+ IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
+ & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
+ ENDIF
+ IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
+ & VINT(62+JT)) GOTO 160
+ SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
+ IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
+ PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
+ & (2D0*VINT(62+JT))
+ PEI=SQRT(PZI**2+SQM)
+ PQQP=(1D0-CHI)*(PEI+PZI)
+ P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
+ P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
+ P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
+ P(N-1,3)=P(N-1,4)*(-1)**JT
+ P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
+ P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
+ ENDIF
+
+C...Documentation lines.
+ K(I+2,1)=21
+ IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
+ IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
+ K(I+2,3)=I
+ P(I+2,3)=PZ*(-1)**(JT+1)
+ P(I+2,4)=PE
+ P(I+2,5)=SQRT(VINT(62+JT))
+ 200 CONTINUE
+
+C...Rotate outgoing partons/particles using cos(theta).
+ IF(VINT(23).LT.0.9D0) THEN
+ CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
+ ELSE
+ CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYDOCU
+C...Handles the documentation of the process in MSTI and PARI,
+C...and also computes cross-sections based on accumulated statistics.
+
+ SUBROUTINE PYDOCU
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
+ &/PYINT5/
+
+C...Calculate Monte Carlo estimates of cross-sections.
+ ISUB=MINT(1)
+ IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
+ NGEN(0,3)=NGEN(0,3)+1
+ XSEC(0,3)=0D0
+ DO 100 I=1,500
+ IF(I.EQ.96.OR.I.EQ.97) THEN
+ XSEC(I,3)=0D0
+ ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
+ & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
+ XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
+ & DBLE(NGEN(96,2)))
+ ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
+ XSEC(I,3)=0D0
+ ELSEIF(NGEN(I,2).EQ.0) THEN
+ XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
+ & DBLE(NGEN(0,2)))
+ ELSE
+ XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
+ & DBLE(NGEN(I,2)))
+ ENDIF
+ XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
+ 100 CONTINUE
+
+C...Rescale to known low-pT cross-section for standard QCD processes.
+ IF(MSUB(95).EQ.1) THEN
+ XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
+ & XSEC(68,3)+XSEC(95,3)
+ XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
+ IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
+ FAC=XSECW/XSECH
+ XSEC(11,3)=FAC*XSEC(11,3)
+ XSEC(12,3)=FAC*XSEC(12,3)
+ XSEC(13,3)=FAC*XSEC(13,3)
+ XSEC(28,3)=FAC*XSEC(28,3)
+ XSEC(53,3)=FAC*XSEC(53,3)
+ XSEC(68,3)=FAC*XSEC(68,3)
+ XSEC(95,3)=FAC*XSEC(95,3)
+ XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
+ ENDIF
+ ENDIF
+
+C...Save information for gamma-p and gamma-gamma.
+ IF(MINT(121).GT.1) THEN
+ IGA=MINT(122)
+ CALL PYSAVE(2,IGA)
+ CALL PYSAVE(5,0)
+ ENDIF
+
+C...Reset information on hard interaction.
+ DO 110 J=1,200
+ MSTI(J)=0
+ PARI(J)=0D0
+ 110 CONTINUE
+
+C...Copy integer valued information from MINT into MSTI.
+ DO 120 J=1,32
+ MSTI(J)=MINT(J)
+ 120 CONTINUE
+ IF(MINT(121).GT.1) MSTI(9)=MINT(122)
+
+C...Store cross-section variables in PARI.
+ PARI(1)=XSEC(0,3)
+ PARI(2)=XSEC(0,3)/MINT(5)
+ PARI(9)=VINT(99)
+ PARI(10)=VINT(100)
+ VINT(98)=VINT(98)+VINT(100)
+ IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
+
+C...Store kinematics variables in PARI.
+ PARI(11)=VINT(1)
+ PARI(12)=VINT(2)
+ IF(ISUB.NE.95) THEN
+ DO 130 J=13,26
+ PARI(J)=VINT(30+J)
+ 130 CONTINUE
+ PARI(31)=VINT(141)
+ PARI(32)=VINT(142)
+ PARI(33)=VINT(41)
+ PARI(34)=VINT(42)
+ PARI(35)=PARI(33)-PARI(34)
+ PARI(36)=VINT(21)
+ PARI(37)=VINT(22)
+ PARI(38)=VINT(26)
+ PARI(39)=VINT(157)
+ PARI(40)=VINT(158)
+ PARI(41)=VINT(23)
+ PARI(42)=2D0*VINT(47)/VINT(1)
+ ENDIF
+
+C...Store information on scattered partons in PARI.
+ IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
+ DO 140 IS=7,8
+ I=MINT(IS)
+ PARI(36+IS)=P(I,3)/VINT(1)
+ PARI(38+IS)=P(I,4)/VINT(1)
+ PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
+ PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
+ & SQRT(PR),1D20)),P(I,3))
+ PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
+ PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
+ & SQRT(PR),1D20)),P(I,3))
+ PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
+ PARI(48+IS)=PYANGL(P(I,1),P(I,2))
+ 140 CONTINUE
+ ENDIF
+
+C...Store sum up transverse and longitudinal momenta.
+ PARI(65)=2D0*PARI(17)
+ IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
+ DO 150 I=MSTP(126)+1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
+ PT=SQRT(P(I,1)**2+P(I,2)**2)
+ PARI(69)=PARI(69)+PT
+ IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
+ IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
+ 150 CONTINUE
+ PARI(67)=PARI(68)
+ PARI(71)=VINT(151)
+ PARI(72)=VINT(152)
+ PARI(73)=VINT(151)
+ PARI(74)=VINT(152)
+ ELSE
+ PARI(66)=PARI(65)
+ PARI(69)=PARI(65)
+ ENDIF
+
+C...Store various other pieces of information into PARI.
+ PARI(61)=VINT(148)
+ PARI(75)=VINT(155)
+ PARI(76)=VINT(156)
+ PARI(77)=VINT(159)
+ PARI(78)=VINT(160)
+ PARI(81)=VINT(138)
+
+C...Set information for PYTABU.
+ IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
+ MSTU(161)=MINT(21)
+ MSTU(162)=0
+ ELSEIF(ISET(ISUB).EQ.5) THEN
+ MSTU(161)=MINT(23)
+ MSTU(162)=0
+ ELSE
+ MSTU(161)=MINT(21)
+ MSTU(162)=MINT(22)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFRAM
+C...Performs transformations between different coordinate frames.
+
+ SUBROUTINE PYFRAM(IFRAME)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/
+
+C...Check that transformation can and should be done.
+ IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
+ &MINT(91).EQ.1)) THEN
+ IF(IFRAME.EQ.MINT(6)) RETURN
+ ELSE
+ WRITE(MSTU(11),5000) IFRAME,MINT(6)
+ RETURN
+ ENDIF
+
+ IF(MINT(6).EQ.1) THEN
+C...Transform from fixed target or user specified frame to
+C...overall CM frame.
+ CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
+ CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
+ CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
+ ELSEIF(MINT(6).EQ.3) THEN
+C...Transform from hadronic CM frame in DIS to overall CM frame.
+ CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
+ & -VINT(225))
+ ENDIF
+
+ IF(IFRAME.EQ.1) THEN
+C...Transform from overall CM frame to fixed target or user specified
+C...frame.
+ CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
+ ELSEIF(IFRAME.EQ.3) THEN
+C...Transform from overall CM frame to hadronic CM frame in DIS.
+ CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
+ CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
+ CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
+ ENDIF
+
+C...Set information about new frame.
+ MINT(6)=IFRAME
+ MSTI(6)=IFRAME
+
+ 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
+ &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
+ &1X,I5)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYWIDT
+C...Calculates full and partial widths of resonances.
+
+ SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT4/,/PYMSSM/,/PYSSMT/
+C...Local arrays and saved variables.
+ DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
+ &WID2SV(3,2)
+ SAVE MOFSV,WIDWSV,WID2SV
+ DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
+
+C...Compressed code and sign; mass.
+ KFLA=IABS(KFLR)
+ KFLS=ISIGN(1,KFLR)
+ KC=PYCOMP(KFLA)
+ SHR=SQRT(SH)
+ PMR=PMAS(KC,1)
+
+C...Reset width information.
+ DO 110 I=0,200
+ WDTP(I)=0D0
+ DO 100 J=0,5
+ WDTE(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Not to be treated as a resonance: return.
+ IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
+ &KFLA.NE.22) THEN
+ WDTP(0)=1D0
+ WDTE(0,0)=1D0
+ MINT(61)=0
+ MINT(62)=0
+ MINT(63)=0
+ RETURN
+
+C...Treatment as a resonance based on tabulated branching ratios.
+ ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
+C...Loop over possible decay channels; skip irrelevant ones.
+ DO 120 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 120
+
+C...Read out decay products and nominal masses.
+ KFD1=KFDP(IDC,1)
+ KFC1=PYCOMP(KFD1)
+ IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
+ PM1=PMAS(KFC1,1)
+ KFD2=KFDP(IDC,2)
+ KFC2=PYCOMP(KFD2)
+ IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
+ PM2=PMAS(KFC2,1)
+ KFD3=KFDP(IDC,3)
+ PM3=0D0
+ IF(KFD3.NE.0) THEN
+ KFC3=PYCOMP(KFD3)
+ IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
+ PM3=PMAS(KFC3,1)
+ ENDIF
+
+C...Naive partial width and alternative threshold factors.
+ WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
+ IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
+ & PM1+PM2+PM3.GE.SHR) THEN
+ WDTP(I)=0D0
+ ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
+ WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
+ & 4D0*PM1**2*PM2**2))/SH
+ ELSEIF(MDME(IDC,2).EQ.52) THEN
+ PMA=MAX(PM1,PM2,PM3)
+ PMC=MIN(PM1,PM2,PM3)
+ PMB=PM1+PM2+PM3-PMA-PMC
+ PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
+ PMAN=PMA**2/SH
+ PMBN=PMB**2/SH
+ PMCN=PMC**2/SH
+ PMBCN=PMBC**2/SH
+ WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
+ & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
+ & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
+ & ((SHR-PMA)**2-(PMB+PMC)**2)*
+ & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
+ & ((1D0-PMBCN)*PMBCN*SH)
+ ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
+ WDTP(I)=WDTP(I)*SQRT(
+ & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
+ & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
+ ELSEIF(MDME(IDC,2).EQ.53) THEN
+ PMA=MAX(PM1,PM2,PM3)
+ PMC=MIN(PM1,PM2,PM3)
+ PMB=PM1+PM2+PM3-PMA-PMC
+ PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
+ PMAN=PMA**2/SH
+ PMBN=PMB**2/SH
+ PMCN=PMC**2/SH
+ PMBCN=PMBC**2/SH
+ FACACT=SQRT(MAX(0D0,
+ & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
+ & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
+ & ((SHR-PMA)**2-(PMB+PMC)**2)*
+ & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
+ & ((1D0-PMBCN)*PMBCN*SH)
+ PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
+ PMAN=PMA**2/PMR**2
+ PMBN=PMB**2/PMR**2
+ PMCN=PMC**2/PMR**2
+ PMBCN=PMBC**2/PMR**2
+ FACNOM=SQRT(MAX(0D0,
+ & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
+ & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
+ & ((PMR-PMA)**2-(PMB+PMC)**2)*
+ & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
+ & ((1D0-PMBCN)*PMBCN*PMR**2)
+ WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+
+C...Calculate secondary width (at most two identical/opposite).
+ IF(MDME(IDC,1).GT.0) THEN
+ IF(KFD2.EQ.KFD1) THEN
+ IF(KCHG(KFC1,3).EQ.0) THEN
+ WID2=WIDS(KFC1,1)
+ ELSEIF(KFD1.GT.0) THEN
+ WID2=WIDS(KFC1,4)
+ ELSE
+ WID2=WIDS(KFC1,5)
+ ENDIF
+ IF(KFD3.GT.0) THEN
+ WID2=WID2*WIDS(KFC3,2)
+ ELSEIF(KFD3.LT.0) THEN
+ WID2=WID2*WIDS(KFC3,3)
+ ENDIF
+ ELSEIF(KFD2.EQ.-KFD1) THEN
+ WID2=WIDS(KFC1,1)
+ IF(KFD3.GT.0) THEN
+ WID2=WID2*WIDS(KFC3,2)
+ ELSEIF(KFD3.LT.0) THEN
+ WID2=WID2*WIDS(KFC3,3)
+ ENDIF
+ ELSEIF(KFD3.EQ.KFD1) THEN
+ IF(KCHG(KFC1,3).EQ.0) THEN
+ WID2=WIDS(KFC1,1)
+ ELSEIF(KFD1.GT.0) THEN
+ WID2=WIDS(KFC1,4)
+ ELSE
+ WID2=WIDS(KFC1,5)
+ ENDIF
+ IF(KFD2.GT.0) THEN
+ WID2=WID2*WIDS(KFC2,2)
+ ELSEIF(KFD2.LT.0) THEN
+ WID2=WID2*WIDS(KFC2,3)
+ ENDIF
+ ELSEIF(KFD3.EQ.-KFD1) THEN
+ WID2=WIDS(KFC1,1)
+ IF(KFD2.GT.0) THEN
+ WID2=WID2*WIDS(KFC2,2)
+ ELSEIF(KFD2.LT.0) THEN
+ WID2=WID2*WIDS(KFC2,3)
+ ENDIF
+ ELSEIF(KFD3.EQ.KFD2) THEN
+ IF(KCHG(KFC2,3).EQ.0) THEN
+ WID2=WIDS(KFC2,1)
+ ELSEIF(KFD2.GT.0) THEN
+ WID2=WIDS(KFC2,4)
+ ELSE
+ WID2=WIDS(KFC2,5)
+ ENDIF
+ IF(KFD1.GT.0) THEN
+ WID2=WID2*WIDS(KFC1,2)
+ ELSEIF(KFD1.LT.0) THEN
+ WID2=WID2*WIDS(KFC1,3)
+ ENDIF
+ ELSEIF(KFD3.EQ.-KFD2) THEN
+ WID2=WIDS(KFC2,1)
+ IF(KFD1.GT.0) THEN
+ WID2=WID2*WIDS(KFC1,2)
+ ELSEIF(KFD1.LT.0) THEN
+ WID2=WID2*WIDS(KFC1,3)
+ ENDIF
+ ELSE
+ IF(KFD1.GT.0) THEN
+ WID2=WIDS(KFC1,2)
+ ELSE
+ WID2=WIDS(KFC1,3)
+ ENDIF
+ IF(KFD2.GT.0) THEN
+ WID2=WID2*WIDS(KFC2,2)
+ ELSE
+ WID2=WID2*WIDS(KFC2,3)
+ ENDIF
+ IF(KFD3.GT.0) THEN
+ WID2=WID2*WIDS(KFC3,2)
+ ELSEIF(KFD3.LT.0) THEN
+ WID2=WID2*WIDS(KFC3,3)
+ ENDIF
+ ENDIF
+
+C...Store effective widths according to case.
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 120 CONTINUE
+C...Return.
+ MINT(61)=0
+ MINT(62)=0
+ MINT(63)=0
+ RETURN
+ ENDIF
+
+C...Here begins detailed dynamical calculation of resonance widths.
+C...Shared treatment of Higgs states.
+ KFHIGG=25
+ IHIGG=1
+ IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
+ KFHIGG=KFLA
+ IHIGG=KFLA-33
+ ENDIF
+
+C...Common electroweak and strong constants.
+ XW=PARU(102)
+ XWV=XW
+ IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
+ XW1=1D0-XW
+ AEM=PYALEM(SH)
+ IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
+ AS=PYALPS(SH)
+ RADC=1D0+AS/PARU(1)
+
+ IF(KFLA.EQ.6) THEN
+C...t quark.
+ FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ RADCT=1D0-2.5D0*AS/PARU(1)
+ DO 130 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 130
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
+ IF(I.GE.4.AND.I.LE.7) THEN
+C...t -> W + q; including approximate QCD correction factor.
+ WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,2)
+ IF(I.EQ.7) WID2=WID2*WIDS(7,2)
+ ELSE
+ WID2=WIDS(24,3)
+ IF(I.EQ.7) WID2=WID2*WIDS(7,3)
+ ENDIF
+ ELSEIF(I.EQ.9) THEN
+C...t -> H + b.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
+ WID2=WIDS(37,2)
+ IF(KFLR.LT.0) WID2=WIDS(37,3)
+CMRENNA++
+ ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
+C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
+ BETA=ATAN(RMSS(5))
+ SINB=SIN(BETA)
+ TANW=SQRT(PARU(102)/(1D0-PARU(102)))
+ ET=KCHG(6,1)/3D0
+ T3L=SIGN(0.5D0,ET)
+ KFC1=PYCOMP(KFDP(IDC,1))
+ KFC2=PYCOMP(KFDP(IDC,2))
+ PMNCHI=PMAS(KFC1,1)
+ PMSTOP=PMAS(KFC2,1)
+ IF(SHR.GT.PMNCHI+PMSTOP) THEN
+ IZ=I-9
+ AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
+ AR=-ET*ZMIX(IZ,1)*TANW
+ BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
+ BR=AL
+ FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
+ FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
+ PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
+ & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
+ WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
+ & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
+ ELSE
+ WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
+ ENDIF
+ ENDIF
+CMRENNA--
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 130 CONTINUE
+
+ ELSEIF(KFLA.EQ.7) THEN
+C...b' quark.
+ FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ DO 140 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 140
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
+ IF(I.GE.4.AND.I.LE.7) THEN
+C...b' -> W + q.
+ WDTP(I)=FAC*VCKM(I-3,4)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,3)
+ IF(I.EQ.6) WID2=WID2*WIDS(6,2)
+ IF(I.EQ.7) WID2=WID2*WIDS(8,2)
+ ELSE
+ WID2=WIDS(24,2)
+ IF(I.EQ.6) WID2=WID2*WIDS(6,3)
+ IF(I.EQ.7) WID2=WID2*WIDS(8,3)
+ ENDIF
+ WID2=WIDS(24,3)
+ IF(KFLR.LT.0) WID2=WIDS(24,2)
+ ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
+C...b' -> H + q.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(37,3)
+ IF(I.EQ.10) WID2=WID2*WIDS(6,2)
+ ELSE
+ WID2=WIDS(37,2)
+ IF(I.EQ.10) WID2=WID2*WIDS(6,3)
+ ENDIF
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 140 CONTINUE
+
+ ELSEIF(KFLA.EQ.8) THEN
+C...t' quark.
+ FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ DO 150 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 150
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
+ IF(I.GE.4.AND.I.LE.7) THEN
+C...t' -> W + q.
+ WDTP(I)=FAC*VCKM(4,I-3)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,2)
+ IF(I.EQ.7) WID2=WID2*WIDS(7,2)
+ ELSE
+ WID2=WIDS(24,3)
+ IF(I.EQ.7) WID2=WID2*WIDS(7,3)
+ ENDIF
+ ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
+C...t' -> H + q.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(37,2)
+ IF(I.EQ.10) WID2=WID2*WIDS(7,2)
+ ELSE
+ WID2=WIDS(37,3)
+ IF(I.EQ.10) WID2=WID2*WIDS(7,3)
+ ENDIF
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 150 CONTINUE
+
+ ELSEIF(KFLA.EQ.17) THEN
+C...tau' lepton.
+ FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ DO 160 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 160
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
+ IF(I.EQ.3) THEN
+C...tau' -> W + nu'_tau.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,3)
+ WID2=WID2*WIDS(18,2)
+ ELSE
+ WID2=WIDS(24,2)
+ WID2=WID2*WIDS(18,3)
+ ENDIF
+ ELSEIF(I.EQ.5) THEN
+C...tau' -> H + nu'_tau.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(37,3)
+ WID2=WID2*WIDS(18,2)
+ ELSE
+ WID2=WIDS(37,2)
+ WID2=WID2*WIDS(18,3)
+ ENDIF
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 160 CONTINUE
+
+ ELSEIF(KFLA.EQ.18) THEN
+C...nu'_tau neutrino.
+ FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ DO 170 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 170
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
+ IF(I.EQ.2) THEN
+C...nu'_tau -> W + tau'.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,2)
+ WID2=WID2*WIDS(17,2)
+ ELSE
+ WID2=WIDS(24,3)
+ WID2=WID2*WIDS(17,3)
+ ENDIF
+ ELSEIF(I.EQ.3) THEN
+C...nu'_tau -> H + tau'.
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
+ & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(37,2)
+ WID2=WID2*WIDS(17,2)
+ ELSE
+ WID2=WIDS(37,3)
+ WID2=WID2*WIDS(17,3)
+ ENDIF
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 170 CONTINUE
+
+ ELSEIF(KFLA.EQ.21) THEN
+C...QCD:
+C***Note that widths are not given in dimensional quantities here.
+ DO 180 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 180
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
+ WID2=1D0
+ IF(I.LE.8) THEN
+C...QCD -> q + qbar
+ WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(I.EQ.6) WID2=WIDS(6,1)
+ IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 180 CONTINUE
+
+ ELSEIF(KFLA.EQ.22) THEN
+C...QED photon.
+C***Note that widths are not given in dimensional quantities here.
+ DO 190 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 190
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
+ WID2=1D0
+ IF(I.LE.8) THEN
+C...QED -> q + qbar.
+ EF=KCHG(I,1)/3D0
+ FCOF=3D0*RADC
+ IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
+ WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(I.EQ.6) WID2=WIDS(6,1)
+ IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
+ ELSEIF(I.LE.12) THEN
+C...QED -> l+ + l-.
+ EF=KCHG(9+2*(I-8),1)/3D0
+ WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(I.EQ.12) WID2=WIDS(17,1)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 190 CONTINUE
+
+ ELSEIF(KFLA.EQ.23) THEN
+C...Z0:
+ ICASE=1
+ XWC=1D0/(16D0*XW*XW1)
+ FAC=(AEM*XWC/3D0)*SHR
+ 200 CONTINUE
+ IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
+ VINT(111)=0D0
+ VINT(112)=0D0
+ VINT(114)=0D0
+ ENDIF
+ IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ KFI=IABS(MINT(15))
+ IF(KFI.GT.20) KFI=IABS(MINT(16))
+ EI=KCHG(KFI,1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ SQMZ=PMAS(23,1)**2
+ HZ=SHR*WDTP(0)
+ IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
+ IF(MSTP(43).EQ.3) VINT(112)=
+ & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
+ IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
+ & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
+ ENDIF
+ DO 210 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 210
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
+ WID2=1D0
+ IF(I.LE.8) THEN
+C...Z0 -> q + qbar
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ FCOF=3D0*RADC
+ IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
+ IF(I.EQ.6) WID2=WIDS(6,1)
+ IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
+ ELSEIF(I.LE.16) THEN
+C...Z0 -> l+ + l-, nu + nubar
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ FCOF=1D0
+ IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
+ ENDIF
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(ICASE.EQ.1) THEN
+ WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
+ & BE34
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
+ & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
+ & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
+ ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
+ FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
+ & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
+ & WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
+ IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
+ & VINT(111)+FGGF*WID2
+ IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
+ IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
+ & VINT(114)+FZZF*WID2
+ ENDIF
+ ENDIF
+ 210 CONTINUE
+ IF(MINT(61).GE.1) ICASE=3-ICASE
+ IF(ICASE.EQ.2) GOTO 200
+
+ ELSEIF(KFLA.EQ.24) THEN
+C...W+/-:
+ FAC=(AEM/(24D0*XW))*SHR
+ DO 220 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 220
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
+ WID2=1D0
+ IF(I.LE.16) THEN
+C...W+/- -> q + qbar'
+ FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
+ IF(KFLR.GT.0) THEN
+ IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
+ IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
+ IF(I.GE.13) WID2=WID2*WIDS(7,3)
+ ELSE
+ IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
+ IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
+ IF(I.GE.13) WID2=WID2*WIDS(7,2)
+ ENDIF
+ ELSEIF(I.LE.20) THEN
+C...W+/- -> l+/- + nu
+ FCOF=1D0
+ IF(KFLR.GT.0) THEN
+ IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
+ ELSE
+ IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
+ ENDIF
+ ENDIF
+ WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 220 CONTINUE
+
+ ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
+C...h0 (or H0, or A0):
+ IF(MSTP(49).EQ.0) THEN
+ FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ ELSE
+ FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
+ ENDIF
+ DO 260 I=1,MDCY(KFHIGG,3)
+ IDC=I+MDCY(KFHIGG,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 260
+ KFC1=PYCOMP(KFDP(IDC,1))
+ KFC2=PYCOMP(KFDP(IDC,2))
+ RM1=PMAS(KFC1,1)**2/SH
+ RM2=PMAS(KFC2,1)**2/SH
+ IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
+ & GOTO 260
+ WID2=1D0
+
+ IF(I.LE.8) THEN
+C...h0 -> q + qbar
+ WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
+ & 1D0-4D0*RM1))*RADC
+ IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
+ & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
+ IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
+ ENDIF
+ IF(I.EQ.6) WID2=WIDS(6,1)
+ IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
+
+ ELSEIF(I.LE.12) THEN
+C...h0 -> l+ + l-
+ WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
+ & PARU(153+10*IHIGG)**2
+ IF(I.EQ.12) WID2=WIDS(17,1)
+
+ ELSEIF(I.EQ.13) THEN
+C...h0 -> g + g; quark loop contribution only
+ ETARE=0D0
+ ETAIM=0D0
+ DO 230 J=1,2*MSTP(1)
+ EPS=(2D0*PMAS(J,1))**2/SH
+C...Loop integral; function of eps=4m^2/shat; different for A0.
+ IF(EPS.LE.1D0) THEN
+ IF(EPS.GT.1.D-4) THEN
+ ROOT=SQRT(1D0-EPS)
+ RLN=LOG((1D0+ROOT)/(1D0-ROOT))
+ ELSE
+ RLN=LOG(4D0/EPS-2D0)
+ ENDIF
+ PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
+ PHIIM=0.5D0*PARU(1)*RLN
+ ELSE
+ PHIRE=(ASIN(1D0/SQRT(EPS)))**2
+ PHIIM=0D0
+ ENDIF
+ IF(IHIGG.LE.2) THEN
+ ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
+ ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
+ ELSE
+ ETAREJ=-0.5D0*EPS*PHIRE
+ ETAIMJ=-0.5D0*EPS*PHIIM
+ ENDIF
+C...Couplings (=1 for standard model Higgs).
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ IF(MOD(J,2).EQ.1) THEN
+ ETAREJ=ETAREJ*PARU(151+10*IHIGG)
+ ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
+ ELSE
+ ETAREJ=ETAREJ*PARU(152+10*IHIGG)
+ ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
+ ENDIF
+ ENDIF
+ ETARE=ETARE+ETAREJ
+ ETAIM=ETAIM+ETAIMJ
+ 230 CONTINUE
+ ETA2=ETARE**2+ETAIM**2
+ WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
+
+ ELSEIF(I.EQ.14) THEN
+C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
+ ETARE=0D0
+ ETAIM=0D0
+ JMAX=3*MSTP(1)+1
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
+ DO 240 J=1,JMAX
+ IF(J.LE.2*MSTP(1)) THEN
+ EJ=KCHG(J,1)/3D0
+ EPS=(2D0*PMAS(J,1))**2/SH
+ ELSEIF(J.LE.3*MSTP(1)) THEN
+ JL=2*(J-2*MSTP(1))-1
+ EJ=KCHG(10+JL,1)/3D0
+ EPS=(2D0*PMAS(10+JL,1))**2/SH
+ ELSEIF(J.EQ.3*MSTP(1)+1) THEN
+ EPS=(2D0*PMAS(24,1))**2/SH
+ ELSE
+ EPS=(2D0*PMAS(37,1))**2/SH
+ ENDIF
+C...Loop integral; function of eps=4m^2/shat.
+ IF(EPS.LE.1D0) THEN
+ IF(EPS.GT.1.D-4) THEN
+ ROOT=SQRT(1D0-EPS)
+ RLN=LOG((1D0+ROOT)/(1D0-ROOT))
+ ELSE
+ RLN=LOG(4D0/EPS-2D0)
+ ENDIF
+ PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
+ PHIIM=0.5D0*PARU(1)*RLN
+ ELSE
+ PHIRE=(ASIN(1D0/SQRT(EPS)))**2
+ PHIIM=0D0
+ ENDIF
+ IF(J.LE.3*MSTP(1)) THEN
+C...Fermion loops: loop integral different for A0; charges.
+ IF(IHIGG.LE.2) THEN
+ PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
+ PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
+ ELSE
+ PHIPRE=-0.5D0*EPS*PHIRE
+ PHIPIM=-0.5D0*EPS*PHIIM
+ ENDIF
+ IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
+ EJC=3D0*EJ**2
+ EJH=PARU(151+10*IHIGG)
+ ELSEIF(J.LE.2*MSTP(1)) THEN
+ EJC=3D0*EJ**2
+ EJH=PARU(152+10*IHIGG)
+ ELSE
+ EJC=EJ**2
+ EJH=PARU(153+10*IHIGG)
+ ENDIF
+ IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
+ ETAREJ=EJC*EJH*PHIPRE
+ ETAIMJ=EJC*EJH*PHIPIM
+ ELSEIF(J.EQ.3*MSTP(1)+1) THEN
+C...W loops: loop integral and charges.
+ ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
+ ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ ETAREJ=ETAREJ*PARU(155+10*IHIGG)
+ ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
+ ENDIF
+ ELSE
+C...Charged H loops: loop integral and charges.
+ FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
+ & PARU(158+10*IHIGG+2*(IHIGG/3))
+ ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
+ ETAIMJ=-EPS**2*PHIIM*FACHHH
+ ENDIF
+ ETARE=ETARE+ETAREJ
+ ETAIM=ETAIM+ETAIMJ
+ 240 CONTINUE
+ ETA2=ETARE**2+ETAIM**2
+ WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
+
+ ELSEIF(I.EQ.15) THEN
+C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
+ ETARE=0D0
+ ETAIM=0D0
+ JMAX=3*MSTP(1)+1
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
+ DO 250 J=1,JMAX
+ IF(J.LE.2*MSTP(1)) THEN
+ EJ=KCHG(J,1)/3D0
+ AJ=SIGN(1D0,EJ+0.1D0)
+ VJ=AJ-4D0*EJ*XWV
+ EPS=(2D0*PMAS(J,1))**2/SH
+ EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
+ ELSEIF(J.LE.3*MSTP(1)) THEN
+ JL=2*(J-2*MSTP(1))-1
+ EJ=KCHG(10+JL,1)/3D0
+ AJ=SIGN(1D0,EJ+0.1D0)
+ VJ=AJ-4D0*EJ*XWV
+ EPS=(2D0*PMAS(10+JL,1))**2/SH
+ EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
+ ELSE
+ EPS=(2D0*PMAS(24,1))**2/SH
+ EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
+ ENDIF
+C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
+ IF(EPS.LE.1D0) THEN
+ ROOT=SQRT(1D0-EPS)
+ IF(EPS.GT.1.D-4) THEN
+ RLN=LOG((1D0+ROOT)/(1D0-ROOT))
+ ELSE
+ RLN=LOG(4D0/EPS-2D0)
+ ENDIF
+ PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
+ PHIIM=0.5D0*PARU(1)*RLN
+ PSIRE=0.5D0*ROOT*RLN
+ PSIIM=-0.5D0*ROOT*PARU(1)
+ ELSE
+ PHIRE=(ASIN(1D0/SQRT(EPS)))**2
+ PHIIM=0D0
+ PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
+ PSIIM=0D0
+ ENDIF
+ IF(EPSP.LE.1D0) THEN
+ ROOT=SQRT(1D0-EPSP)
+ IF(EPSP.GT.1.D-4) THEN
+ RLN=LOG((1D0+ROOT)/(1D0-ROOT))
+ ELSE
+ RLN=LOG(4D0/EPSP-2D0)
+ ENDIF
+ PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
+ PHIIMP=0.5D0*PARU(1)*RLN
+ PSIREP=0.5D0*ROOT*RLN
+ PSIIMP=-0.5D0*ROOT*PARU(1)
+ ELSE
+ PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
+ PHIIMP=0D0
+ PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
+ PSIIMP=0D0
+ ENDIF
+ FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
+ & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
+ FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
+ & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
+ F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
+ F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
+ IF(J.LE.3*MSTP(1)) THEN
+C...Fermion loops: loop integral different for A0; charges.
+ IF(IHIGG.EQ.3) FXYRE=0D0
+ IF(IHIGG.EQ.3) FXYIM=0D0
+ IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
+ EJC=-3D0*EJ*VJ
+ EJH=PARU(151+10*IHIGG)
+ ELSEIF(J.LE.2*MSTP(1)) THEN
+ EJC=-3D0*EJ*VJ
+ EJH=PARU(152+10*IHIGG)
+ ELSE
+ EJC=-EJ*VJ
+ EJH=PARU(153+10*IHIGG)
+ ENDIF
+ IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
+ ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
+ ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
+ ELSEIF(J.EQ.3*MSTP(1)+1) THEN
+C...W loops: loop integral and charges.
+ HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
+ ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
+ ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ ETAREJ=ETAREJ*PARU(155+10*IHIGG)
+ ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
+ ENDIF
+ ELSE
+C...Charged H loops: loop integral and charges.
+ FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
+ & PARU(158+10*IHIGG+2*(IHIGG/3))
+ ETAREJ=FACHHH*FXYRE
+ ETAIMJ=FACHHH*FXYIM
+ ENDIF
+ ETARE=ETARE+ETAREJ
+ ETAIM=ETAIM+ETAIMJ
+ 250 CONTINUE
+ ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
+ WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
+ WID2=WIDS(23,2)
+
+ ELSEIF(I.LE.17) THEN
+C...h0 -> Z0 + Z0, W+ + W-
+ PM1=PMAS(IABS(KFDP(IDC,1)),1)
+ PG1=PMAS(IABS(KFDP(IDC,1)),2)
+ IF(MINT(62).GE.1) THEN
+ IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
+ & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
+ & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
+ MOFSV(IHIGG,I-15)=0
+ WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
+ & 1D0-4D0*RM1))
+ WID2=1D0
+ ELSE
+ MOFSV(IHIGG,I-15)=1
+ RMAS=SQRT(MAX(0D0,SH))
+ CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
+ & WID2)
+ WIDWSV(IHIGG,I-15)=WIDW
+ WID2SV(IHIGG,I-15)=WID2
+ ENDIF
+ ELSE
+ IF(MOFSV(IHIGG,I-15).EQ.0) THEN
+ WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
+ & 1D0-4D0*RM1))
+ WID2=1D0
+ ELSE
+ WIDW=WIDWSV(IHIGG,I-15)
+ WID2=WID2SV(IHIGG,I-15)
+ ENDIF
+ ENDIF
+ WDTP(I)=FAC*WIDW/(2D0*(18-I))
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
+ & PARU(138+I+10*IHIGG)**2
+ WID2=WID2*WIDS(7+I,1)
+
+ ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
+C***H0 -> Z0 + h0 (not yet implemented).
+
+ ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
+C...H0 -> h0 + h0.
+ WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
+ & SQRT(MAX(0D0,1D0-4D0*RM1))
+ WID2=WIDS(25,2)**2
+
+ ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
+C...H0 -> A0 + A0.
+ WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
+ & SQRT(MAX(0D0,1D0-4D0*RM1))
+ WID2=WIDS(36,2)**2
+
+ ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
+C...A0 -> Z0 + h0.
+ WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
+ & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(23,2)*WIDS(25,2)
+
+CMRENNA++
+ ELSE
+C...Add in SUSY decays (two-body) by rescaling by phase space factor.
+ RM10=RM1*SH/PMR**2
+ RM20=RM2*SH/PMR**2
+ WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
+ WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
+ IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
+ WFAC=0D0
+ ELSE
+ WFAC=WFAC/WFAC0
+ ENDIF
+ WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
+CMRENNA--
+ IF(KFC2.EQ.KFC1) THEN
+ WID2=WIDS(KFC1,1)
+ ELSE
+ KSGN1=2
+ IF(KFDP(IDC,1).LT.0) KSGN1=3
+ KSGN2=2
+ IF(KFDP(IDC,2).LT.0) KSGN2=3
+ WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
+ ENDIF
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 260 CONTINUE
+
+ ELSEIF(KFLA.EQ.32) THEN
+C...Z'0:
+ ICASE=1
+ XWC=1D0/(16D0*XW*XW1)
+ FAC=(AEM*XWC/3D0)*SHR
+ VINT(117)=0D0
+ 270 CONTINUE
+ IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
+ VINT(111)=0D0
+ VINT(112)=0D0
+ VINT(113)=0D0
+ VINT(114)=0D0
+ VINT(115)=0D0
+ VINT(116)=0D0
+ ENDIF
+ IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ KFAI=IABS(MINT(15))
+ EI=KCHG(KFAI,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ KFAIC=1
+ IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
+ IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
+ IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
+ VPI=PARU(119+2*KFAIC)
+ API=PARU(120+2*KFAIC)
+ SQMZ=PMAS(23,1)**2
+ HZ=SHR*FAC*VINT(117)
+ SQMZP=PMAS(32,1)**2
+ HZP=SHR*FAC*WDTP(0)
+ IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
+ & MSTP(44).EQ.7) VINT(111)=1D0
+ IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
+ & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
+ IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
+ & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
+ IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
+ & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
+ IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
+ & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
+ & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
+ IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
+ & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
+ ENDIF
+ DO 280 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 280
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
+ WID2=1D0
+ IF(I.LE.16) THEN
+ IF(I.LE.8) THEN
+C...Z'0 -> q + qbar
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VPF=PARU(123-2*MOD(I,2))
+ APF=PARU(124-2*MOD(I,2))
+ FCOF=3D0*RADC
+ IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
+ & PYHFTH(SH,SH*RM1,1D0)
+ IF(I.EQ.6) WID2=WIDS(6,1)
+ IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
+ ELSEIF(I.LE.16) THEN
+C...Z'0 -> l+ + l-, nu + nubar
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VPF=PARU(127-2*MOD(I,2))
+ APF=PARU(128-2*MOD(I,2))
+ FCOF=1D0
+ IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
+ ENDIF
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(ICASE.EQ.1) THEN
+ WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
+ WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
+ & APF**2*(1D0-4D0*RM1))*BE34
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
+ & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
+ & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
+ & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
+ & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
+ & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
+ ELSEIF(MINT(61).EQ.2) THEN
+ FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
+ FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
+ FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
+ & BE34
+ FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
+ & BE34
+ ENDIF
+ ELSEIF(I.EQ.17) THEN
+C...Z'0 -> W+ + W-
+ WDTPZP=PARU(129)**2*XW1**2*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
+ & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
+ IF(ICASE.EQ.1) THEN
+ WDTPZ=0D0
+ WDTP(I)=FAC*WDTPZP
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
+ ELSEIF(MINT(61).EQ.2) THEN
+ FGGF=0D0
+ FGZF=0D0
+ FGZPF=0D0
+ FZZF=0D0
+ FZZPF=0D0
+ FZPZPF=WDTPZP
+ ENDIF
+ WID2=WIDS(24,1)
+ ELSEIF(I.EQ.18) THEN
+C...Z'0 -> H+ + H-
+ CZC=2D0*(1D0-2D0*XW)
+ BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(ICASE.EQ.1) THEN
+ WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
+ WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
+ & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
+ & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
+ & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
+ & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
+ ELSEIF(MINT(61).EQ.2) THEN
+ FGGF=0.25D0*BE34C
+ FGZF=0.25D0*PARU(142)*CZC*BE34C
+ FGZPF=0.25D0*PARU(143)*CZC*BE34C
+ FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
+ FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
+ FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
+ ENDIF
+ WID2=WIDS(37,1)
+ ELSEIF(I.EQ.19) THEN
+C...Z'0 -> Z0 + gamma.
+ ELSEIF(I.EQ.20) THEN
+C...Z'0 -> Z0 + h0
+ FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
+ & (3D0*RM1+0.25D0*FLAM**2)*FLAM
+ IF(ICASE.EQ.1) THEN
+ WDTPZ=0D0
+ WDTP(I)=FAC*WDTPZP
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
+ ELSEIF(MINT(61).EQ.2) THEN
+ FGGF=0D0
+ FGZF=0D0
+ FGZPF=0D0
+ FZZF=0D0
+ FZZPF=0D0
+ FZPZPF=WDTPZP
+ ENDIF
+ WID2=WIDS(23,2)*WIDS(25,2)
+ ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
+C...Z' -> h0 + A0 or H0 + A0.
+ BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(I.EQ.21) THEN
+ CZAH=PARU(186)
+ CZPAH=PARU(188)
+ ELSE
+ CZAH=PARU(187)
+ CZPAH=PARU(189)
+ ENDIF
+ IF(ICASE.EQ.1) THEN
+ WDTPZ=CZAH**2*BE34C
+ WDTP(I)=FAC*CZPAH**2*BE34C
+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
+ WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
+ & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
+ & VINT(116))*BE34C
+ ELSEIF(MINT(61).EQ.2) THEN
+ FGGF=0D0
+ FGZF=0D0
+ FGZPF=0D0
+ FZZF=CZAH**2*BE34C
+ FZZPF=CZAH*CZPAH*BE34C
+ FZPZPF=CZPAH**2*BE34C
+ ENDIF
+ IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
+ IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
+ ENDIF
+ IF(ICASE.EQ.1) THEN
+ VINT(117)=VINT(117)+WDTPZ
+ WDTP(0)=WDTP(0)+WDTP(I)
+ ENDIF
+ IF(MDME(IDC,1).GT.0) THEN
+ IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
+ & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
+ & WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
+ IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
+ & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
+ IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
+ & FGZF*WID2
+ IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
+ & FGZPF*WID2
+ IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
+ & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
+ IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
+ & FZZPF*WID2
+ IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
+ & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
+ ENDIF
+ ENDIF
+ 280 CONTINUE
+ IF(MINT(61).GE.1) ICASE=3-ICASE
+ IF(ICASE.EQ.2) GOTO 270
+
+ ELSEIF(KFLA.EQ.34) THEN
+C...W'+/-:
+ FAC=(AEM/(24D0*XW))*SHR
+ DO 290 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 290
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
+ WID2=1D0
+ IF(I.LE.20) THEN
+ IF(I.LE.16) THEN
+C...W'+/- -> q + qbar'
+ FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
+ & VCKM((I-1)/4+1,MOD(I-1,4)+1)
+ IF(KFLR.GT.0) THEN
+ IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
+ IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
+ IF(I.GE.13) WID2=WID2*WIDS(7,3)
+ ELSE
+ IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
+ IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
+ IF(I.GE.13) WID2=WID2*WIDS(7,2)
+ ENDIF
+ ELSEIF(I.LE.20) THEN
+C...W'+/- -> l+/- + nu
+ FCOF=PARU(133)**2+PARU(134)**2
+ IF(KFLR.GT.0) THEN
+ IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
+ ELSE
+ IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
+ ENDIF
+ ENDIF
+ WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ ELSEIF(I.EQ.21) THEN
+C...W'+/- -> W+/- + Z0
+ WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
+ & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
+ IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
+ IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
+ ELSEIF(I.EQ.23) THEN
+C...W'+/- -> W+/- + h0
+ FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
+ IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
+ IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 290 CONTINUE
+
+ ELSEIF(KFLA.EQ.37) THEN
+C...H+/-:
+ FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
+ DO 300 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 300
+ KFC1=PYCOMP(KFDP(IDC,1))
+ KFC2=PYCOMP(KFDP(IDC,2))
+ RM1=PMAS(KFC1,1)**2/SH
+ RM2=PMAS(KFC2,1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
+ WID2=1D0
+ IF(I.LE.4) THEN
+C...H+/- -> q + qbar'
+ RM1R=RM1
+ IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
+ & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
+ & (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ IF(KFLR.GT.0) THEN
+ IF(I.EQ.3) WID2=WIDS(6,2)
+ IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
+ ELSE
+ IF(I.EQ.3) WID2=WIDS(6,3)
+ IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
+ ENDIF
+ ELSEIF(I.LE.8) THEN
+C...H+/- -> l+/- + nu
+ WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
+ & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
+ & 4D0*RM1*RM2))
+ IF(KFLR.GT.0) THEN
+ IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
+ ELSE
+ IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
+ ENDIF
+ ELSEIF(I.EQ.9) THEN
+C...H+/- -> W+/- + h0.
+ WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
+ & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
+ IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
+
+CMRENNA++
+ ELSE
+C...Add in SUSY decays (two-body) by rescaling by phase space factor.
+ RM10=RM1*SH/PMR**2
+ RM20=RM2*SH/PMR**2
+ WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
+ WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
+ IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
+ WFAC=0D0
+ ELSE
+ WFAC=WFAC/WFAC0
+ ENDIF
+ WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
+CMRENNA--
+ KSGN1=2
+ IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
+ KSGN2=2
+ IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
+ WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 300 CONTINUE
+
+ ELSEIF(KFLA.EQ.38) THEN
+C...Techni-eta.
+ FAC=(SH/PARP(46)**2)*SHR
+ DO 310 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 310
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
+ WID2=1D0
+ IF(I.LE.2) THEN
+ WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
+ IF(I.EQ.2) WID2=WIDS(6,1)
+ ELSE
+ WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 310 CONTINUE
+
+ ELSEIF(KFLA.EQ.39) THEN
+C...LQ (leptoquark).
+ FAC=(AEM/4D0)*PARU(151)*SHR
+ DO 320 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 320
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
+ WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=1D0
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 320 CONTINUE
+
+ ELSEIF(KFLA.EQ.40) THEN
+C...R:
+ FAC=(AEM/(12D0*XW))*SHR
+ DO 330 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 330
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
+ WID2=1D0
+ IF(I.LE.6) THEN
+C...R -> q + qbar'
+ FCOF=3D0*RADC
+ ELSEIF(I.LE.9) THEN
+C...R -> l+ + l'-
+ FCOF=1D0
+ ENDIF
+ WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ IF(KFLR.GT.0) THEN
+ IF(I.EQ.4) WID2=WIDS(6,3)
+ IF(I.EQ.5) WID2=WIDS(7,3)
+ IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
+ IF(I.EQ.9) WID2=WIDS(17,3)
+ ELSE
+ IF(I.EQ.4) WID2=WIDS(6,2)
+ IF(I.EQ.5) WID2=WIDS(7,2)
+ IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
+ IF(I.EQ.9) WID2=WIDS(17,2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 330 CONTINUE
+
+ ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
+C...Techni-pi0 and techni-pi+-:
+ FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
+ DO 340 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 340
+ PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
+ PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
+ RM1=PM1**2/SH
+ RM2=PM2**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
+ WID2=1D0
+C...pi_tech -> f + f'.
+ FCOF=1D0
+ IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
+ WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 340 CONTINUE
+
+ ELSEIF(KFLA.EQ.53) THEN
+C...Techni-pi'0 not yet implemented.
+
+ ELSEIF(KFLA.EQ.54) THEN
+C...Techni-rho0:
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ FAC=(ALPRHT/12D0)*SHR
+ FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
+ SQMZ=PMAS(23,1)**2
+ GMMZ=PMAS(23,1)*PMAS(23,2)
+ XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
+ BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ DO 350 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 350
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
+ IF(I.EQ.1) THEN
+C...rho_tech0 -> W+ + W-.
+ WDTP(I)=FAC*PARP(141)**4*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(24,1)
+ ELSEIF(I.EQ.2) THEN
+C...rho_tech0 -> W+ + pi_tech-.
+ WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(24,2)*WIDS(52,3)
+ ELSEIF(I.EQ.3) THEN
+C...rho_tech0 -> pi_tech+ + W-.
+ WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(52,2)*WIDS(24,3)
+ ELSEIF(I.EQ.4) THEN
+C...rho_tech0 -> pi_tech+ + pi_tech-.
+ WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(52,1)
+ ELSE
+C...rho_tech0 -> f + fbar.
+ WID2=1D0
+ IF(I.LE.12) THEN
+ IA=I-4
+ FCOF=3D0*RADC
+ IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
+ ELSE
+ IA=I-2
+ FCOF=1D0
+ IF(IA.GE.17) WID2=WIDS(IA,1)
+ ENDIF
+ EI=KCHG(IA,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
+ & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 350 CONTINUE
+
+ ELSEIF(KFLA.EQ.55) THEN
+C...Techni-rho+/-:
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ FAC=(ALPRHT/12D0)*SHR
+ SQMW=PMAS(24,1)**2
+ GMMW=PMAS(24,1)*PMAS(24,2)
+ FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
+ & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
+ DO 360 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 360
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
+ IF(I.EQ.1) THEN
+C...rho_tech+ -> W+ + Z0.
+ WDTP(I)=FAC*PARP(141)**4*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,2)*WIDS(23,2)
+ ELSE
+ WID2=WIDS(24,3)*WIDS(23,2)
+ ENDIF
+ ELSEIF(I.EQ.2) THEN
+C...rho_tech+ -> W+ + pi_tech0.
+ WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(24,2)*WIDS(51,2)
+ ELSE
+ WID2=WIDS(24,3)*WIDS(51,2)
+ ENDIF
+ ELSEIF(I.EQ.3) THEN
+C...rho_tech+ -> pi_tech+ + Z0.
+ WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(52,2)*WIDS(23,2)
+ ELSE
+ WID2=WIDS(52,3)*WIDS(23,2)
+ ENDIF
+ ELSEIF(I.EQ.4) THEN
+C...rho_tech+ -> pi_tech+ + pi_tech0.
+ WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ IF(KFLR.GT.0) THEN
+ WID2=WIDS(52,2)*WIDS(51,2)
+ ELSE
+ WID2=WIDS(52,3)*WIDS(51,2)
+ ENDIF
+ ELSE
+C...rho_tech+ -> f + fbar'.
+ IA=I-4
+ WID2=1D0
+ IF(IA.LE.16) THEN
+ FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
+ IF(KFLR.GT.0) THEN
+ IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
+ IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
+ IF(IA.GE.13) WID2=WID2*WIDS(7,3)
+ ELSE
+ IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
+ IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
+ IF(IA.GE.13) WID2=WID2*WIDS(7,2)
+ ENDIF
+ ELSE
+ FCOF=1D0
+ IF(KFLR.GT.0) THEN
+ IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
+ ELSE
+ IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
+ ENDIF
+ ENDIF
+ WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 360 CONTINUE
+
+ ELSEIF(KFLA.EQ.56) THEN
+C...Techni-omega:
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
+ FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
+ & (2D0*PARP(143)-1D0)**2
+ SQMZ=PMAS(23,1)**2
+ GMMZ=PMAS(23,1)*PMAS(23,2)
+ BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ DO 370 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 370
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
+ IF(I.EQ.1) THEN
+C...omega_tech0 -> gamma + pi_tech0.
+ WDTP(I)=FAC*
+ & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
+ WID2=WIDS(51,2)
+ ELSEIF(I.EQ.2) THEN
+C...omega_tech0 -> Z0 + pi_tech0 not known.
+ WDTP(I)=0D0
+ WID2=WIDS(23,2)*WIDS(51,2)
+ ELSE
+C...omega_tech0 -> f + fbar.
+ WID2=1D0
+ IF(I.LE.10) THEN
+ IA=I-2
+ FCOF=3D0*RADC
+ IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
+ ELSE
+ IA=I
+ FCOF=1D0
+ IF(IA.GE.17) WID2=WIDS(IA,1)
+ ENDIF
+ EI=KCHG(IA,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
+ & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
+ & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 370 CONTINUE
+
+ ELSEIF(KFLA.EQ.KEXCIT+1) THEN
+C...d* excited quark.
+ FAC=(SH/PARU(155)**2)*SHR
+ DO 380 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 380
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
+ IF(I.EQ.1) THEN
+C...d* -> g + d.
+ WDTP(I)=FAC*AS*PARU(159)**2/3D0
+ WID2=1D0
+ ELSEIF(I.EQ.2) THEN
+C...d* -> gamma + d.
+ QF=-PARU(157)/2D0+PARU(158)/6D0
+ WDTP(I)=FAC*AEM*QF**2/4D0
+ WID2=1D0
+ ELSEIF(I.EQ.3) THEN
+C...d* -> Z0 + d.
+ QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
+ WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ WID2=WIDS(23,2)
+ ELSEIF(I.EQ.4) THEN
+C...d* -> W- + u.
+ WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ IF(KFLR.GT.0) WID2=WIDS(24,3)
+ IF(KFLR.LT.0) WID2=WIDS(24,2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 380 CONTINUE
+
+ ELSEIF(KFLA.EQ.KEXCIT+2) THEN
+C...u* excited quark.
+ FAC=(SH/PARU(155)**2)*SHR
+ DO 390 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 390
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
+ IF(I.EQ.1) THEN
+C...u* -> g + u.
+ WDTP(I)=FAC*AS*PARU(159)**2/3D0
+ WID2=1D0
+ ELSEIF(I.EQ.2) THEN
+C...u* -> gamma + u.
+ QF=PARU(157)/2D0+PARU(158)/6D0
+ WDTP(I)=FAC*AEM*QF**2/4D0
+ WID2=1D0
+ ELSEIF(I.EQ.3) THEN
+C...u* -> Z0 + u.
+ QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
+ WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ WID2=WIDS(23,2)
+ ELSEIF(I.EQ.4) THEN
+C...u* -> W+ + d.
+ WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ IF(KFLR.GT.0) WID2=WIDS(24,2)
+ IF(KFLR.LT.0) WID2=WIDS(24,3)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 390 CONTINUE
+
+ ELSEIF(KFLA.EQ.KEXCIT+11) THEN
+C...e* excited lepton.
+ FAC=(SH/PARU(155)**2)*SHR
+ DO 400 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 400
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
+ IF(I.EQ.1) THEN
+C...e* -> gamma + e.
+ QF=-PARU(157)/2D0-PARU(158)/2D0
+ WDTP(I)=FAC*AEM*QF**2/4D0
+ WID2=1D0
+ ELSEIF(I.EQ.2) THEN
+C...e* -> Z0 + e.
+ QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
+ WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ WID2=WIDS(23,2)
+ ELSEIF(I.EQ.3) THEN
+C...e* -> W- + nu.
+ WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ IF(KFLR.GT.0) WID2=WIDS(24,3)
+ IF(KFLR.LT.0) WID2=WIDS(24,2)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 400 CONTINUE
+
+ ELSEIF(KFLA.EQ.KEXCIT+12) THEN
+C...nu*_e excited neutrino.
+ FAC=(SH/PARU(155)**2)*SHR
+ DO 410 I=1,MDCY(KC,3)
+ IDC=I+MDCY(KC,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 410
+ RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
+ RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
+ IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
+ IF(I.EQ.1) THEN
+C...nu*_e -> Z0 + nu*_e.
+ QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
+ WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ WID2=WIDS(23,2)
+ ELSEIF(I.EQ.2) THEN
+C...nu*_e -> W+ + e.
+ WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
+ & (1D0-RM1)**2*(2D0+RM1)
+ IF(KFLR.GT.0) WID2=WIDS(24,2)
+ IF(KFLR.LT.0) WID2=WIDS(24,3)
+ ENDIF
+ WDTP(0)=WDTP(0)+WDTP(I)
+ IF(MDME(IDC,1).GT.0) THEN
+ WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
+ WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
+ WDTE(I,0)=WDTE(I,MDME(IDC,1))
+ WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
+ ENDIF
+ 410 CONTINUE
+
+ ENDIF
+ MINT(61)=0
+ MINT(62)=0
+ MINT(63)=0
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYOFSH
+C...Calculates partial width and differential cross-section maxima
+C...of channels/processes not allowed on mass-shell, and selects
+C...masses in such channels/processes.
+
+ SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
+ &/PYINT2/,/PYINT5/
+C...Local arrays.
+ DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
+ &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
+ &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
+ &WDTE(0:200,0:5)
+
+C...Find if particles equal, maximum mass, matrix elements, etc.
+ MINT(51)=0
+ ISUB=MINT(1)
+ KFD(1)=IABS(KFD1)
+ KFD(2)=IABS(KFD2)
+ MEQL=0
+ IF(KFD(1).EQ.KFD(2)) MEQL=1
+ MLM=0
+ IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
+ IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
+ NOFF=44
+ PMMX=PMMO
+ ELSE
+ NOFF=40
+ PMMX=VINT(1)
+ IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
+ ENDIF
+ MMED=0
+ IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
+ &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
+ IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
+ &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
+ IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
+ &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
+ LOOP=1
+
+C...Find where Breit-Wigners are required, else select discrete masses.
+ 100 DO 110 I=1,2
+ KFCA=PYCOMP(KFD(I))
+ IF(KFCA.GT.0) THEN
+ PMD(I)=PMAS(KFCA,1)
+ PGD(I)=PMAS(KFCA,2)
+ ELSE
+ PMD(I)=0D0
+ PGD(I)=0D0
+ ENDIF
+ IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
+ MBW(I)=0
+ PMG(I)=PMD(I)
+ RMG(I)=(PMG(I)/PMMX)**2
+ ELSE
+ MBW(I)=1
+ ENDIF
+ 110 CONTINUE
+
+C...Find allowed mass range and Breit-Wigner parameters.
+ DO 120 I=1,2
+ IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
+ PML(I)=PARP(42)
+ PMU(I)=PMMX-PARP(42)
+ IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
+ IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
+ ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
+ ILM=I
+ IF(MLM.EQ.2) ILM=3-I
+ PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
+ PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
+ IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
+ & CKIN(NOFF+2*ILM))
+ IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
+ IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
+ IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
+ IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
+ IF(MBW(I).EQ.1) THEN
+ ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
+ ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
+ IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
+ & PGD(I)))
+ ENDIF
+ ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
+ ILM=I
+ IF(MLM.EQ.2) ILM=3-I
+ PML(I)=MAX(CKIN(48+I),PARP(42))
+ PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
+ IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
+ IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
+ IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
+ IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
+ IF(MBW(I).EQ.1) THEN
+ ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
+ ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
+ IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
+ & PGD(I)))
+ ENDIF
+ ENDIF
+ 120 CONTINUE
+ IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
+ &THEN
+ CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
+ MINT(51)=1
+ RETURN
+ ENDIF
+
+C...Calculation of partial width of resonance.
+ IF(MOFSH.EQ.1) THEN
+
+C..If only one integration, pick that to be the inner.
+ IF(MBW(1).EQ.0) THEN
+ PM2=PMD(1)
+ PMD(1)=PMD(2)
+ PGD(1)=PGD(2)
+ PML(1)=PML(2)
+ PMU(1)=PMU(2)
+ ELSEIF(MBW(2).EQ.0) THEN
+ PM2=PMD(2)
+ ENDIF
+
+C...Start outer loop of integration.
+ IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
+ ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
+ ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
+ NPT2=1
+ XPT2(1)=1D0
+ INX2(1)=0
+ FMAX2=0D0
+ ENDIF
+ 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
+ PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
+ PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
+ ENDIF
+ RM2=(PM2/PMMX)**2
+
+C...Start inner loop of integration.
+ PML1=PML(1)
+ PMU1=MIN(PMU(1),PMMX-PM2)
+ IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
+ ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
+ ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
+ IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
+ FUNC2=0D0
+ GOTO 180
+ ENDIF
+ NPT1=1
+ XPT1(1)=1D0
+ INX1(1)=0
+ FMAX1=0D0
+ 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
+ PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
+ RM1=(PM1/PMMX)**2
+
+C...Evaluate function value - inner loop.
+ FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
+ IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
+ IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
+ & RM2**2+10D0*RM1*RM2)
+ IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
+ FPT1(NPT1)=FUNC1
+
+C...Go to next position in inner loop.
+ IF(NPT1.EQ.1) THEN
+ NPT1=NPT1+1
+ XPT1(NPT1)=0D0
+ INX1(NPT1)=1
+ GOTO 140
+ ELSEIF(NPT1.LE.8) THEN
+ NPT1=NPT1+1
+ IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
+ ISH1=ISH1+1
+ XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
+ INX1(NPT1)=INX1(ISH1)
+ INX1(ISH1)=NPT1
+ GOTO 140
+ ELSEIF(NPT1.LT.100) THEN
+ ISN1=ISH1
+ 150 ISH1=ISH1+1
+ IF(ISH1.GT.NPT1) ISH1=2
+ IF(ISH1.EQ.ISN1) GOTO 160
+ DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
+ IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
+ NPT1=NPT1+1
+ XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
+ INX1(NPT1)=INX1(ISH1)
+ INX1(ISH1)=NPT1
+ GOTO 140
+ ENDIF
+
+C...Calculate integral over inner loop.
+ 160 FSUM1=0D0
+ DO 170 IPT1=2,NPT1
+ FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
+ & (XPT1(INX1(IPT1))-XPT1(IPT1))
+ 170 CONTINUE
+ FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
+ 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
+ IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
+ FPT2(NPT2)=FUNC2
+
+C...Go to next position in outer loop.
+ IF(NPT2.EQ.1) THEN
+ NPT2=NPT2+1
+ XPT2(NPT2)=0D0
+ INX2(NPT2)=1
+ GOTO 130
+ ELSEIF(NPT2.LE.8) THEN
+ NPT2=NPT2+1
+ IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
+ ISH2=ISH2+1
+ XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
+ INX2(NPT2)=INX2(ISH2)
+ INX2(ISH2)=NPT2
+ GOTO 130
+ ELSEIF(NPT2.LT.100) THEN
+ ISN2=ISH2
+ 190 ISH2=ISH2+1
+ IF(ISH2.GT.NPT2) ISH2=2
+ IF(ISH2.EQ.ISN2) GOTO 200
+ DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
+ IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
+ NPT2=NPT2+1
+ XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
+ INX2(NPT2)=INX2(ISH2)
+ INX2(ISH2)=NPT2
+ GOTO 130
+ ENDIF
+
+C...Calculate integral over outer loop.
+ 200 FSUM2=0D0
+ DO 210 IPT2=2,NPT2
+ FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
+ & (XPT2(INX2(IPT2))-XPT2(IPT2))
+ 210 CONTINUE
+ FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
+ IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
+ ELSE
+ FSUM2=FUNC2
+ ENDIF
+
+C...Save result; second integration for user-selected mass range.
+ IF(LOOP.EQ.1) WIDW=FSUM2
+ WID2=FSUM2
+ IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
+ & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
+ LOOP=2
+ GOTO 100
+ ENDIF
+ RET1=WIDW
+ RET2=WID2/WIDW
+
+C...Select two decay product masses of a resonance.
+ ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
+ 220 DO 230 I=1,2
+ IF(MBW(I).EQ.0) GOTO 230
+ PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
+ & (ATU(I)-ATL(I)))
+ PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
+ RMG(I)=(PMG(I)/PMMX)**2
+ 230 CONTINUE
+ IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
+ & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
+
+C...Weight with matrix element (if none known, use beta factor).
+ FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
+ IF(MMED.EQ.1) THEN
+ WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
+ ELSEIF(MMED.EQ.2) THEN
+ WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
+ & RMG(2)**2+10D0*RMG(1)*RMG(2))
+ ELSEIF(MMED.EQ.3) THEN
+ WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
+ ELSE
+ WTBE=FLAM
+ ENDIF
+ IF(WTBE.LT.PYR(0)) GOTO 220
+ RET1=PMG(1)
+ RET2=PMG(2)
+
+C...Find suitable set of masses for initialization of 2 -> 2 processes.
+ ELSEIF(MOFSH.EQ.3) THEN
+ IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
+ PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
+ PMG(2)=PMD(2)
+ ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
+ PMG(1)=PMD(1)
+ PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
+ ELSE
+ IDIV=-1
+ 240 IDIV=IDIV+1
+ PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
+ PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
+ IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
+ ENDIF
+ RET1=PMG(1)
+ RET2=PMG(2)
+
+C...Evaluate importance of excluded tails of Breit-Wigners.
+ IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
+ & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
+ IF(MEQL.LE.1) THEN
+ VINT(80)=1D0
+ DO 250 I=1,2
+ IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
+ & PARU(1)
+ 250 CONTINUE
+ ELSE
+ VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
+ & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
+ ENDIF
+ IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
+ & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
+ IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
+ IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
+
+C...Pick one particle to be the lighter (if improves efficiency).
+ ELSEIF(MOFSH.EQ.4) THEN
+ IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
+ & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
+ 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
+
+C...Select two masses according to Breit-Wigner + flat in s + 1/s.
+ DO 270 I=1,2
+ IF(MBW(I).EQ.0) GOTO 270
+ PMV=PMU(I)
+ IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
+ ATV=ATU(I)
+ IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
+ RBR=PYR(0)
+ IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
+ & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
+ IF(RBR.LT.0.8D0) THEN
+ PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
+ PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
+ ELSEIF(RBR.LT.0.9D0) THEN
+ PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
+ ELSEIF(RBR.LT.1.5D0) THEN
+ PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
+ ELSE
+ PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
+ & (PMV**2-PML(I)**2))))
+ ENDIF
+ 270 CONTINUE
+ IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
+ & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
+ IF(MINT(48).EQ.1) THEN
+ NGEN(0,1)=NGEN(0,1)+1
+ NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
+ GOTO 260
+ ELSE
+ MINT(51)=1
+ RETURN
+ ENDIF
+ ENDIF
+ RET1=PMG(1)
+ RET2=PMG(2)
+
+C...Give weight for selected mass distribution.
+ VINT(80)=1D0
+ DO 280 I=1,2
+ IF(MBW(I).EQ.0) GOTO 280
+ PMV=PMU(I)
+ IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
+ ATV=ATU(I)
+ IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
+ F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
+ & (PMD(I)*PGD(I))**2)/PARU(1)
+ F1=1D0
+ F2=1D0/PMG(I)**2
+ F3=1D0/PMG(I)**4
+ FI0=(ATV-ATL(I))/PARU(1)
+ FI1=PMV**2-PML(I)**2
+ FI2=2D0*LOG(PMV/PML(I))
+ FI3=1D0/PML(I)**2-1D0/PMV**2
+ IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
+ & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
+ VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
+ & 5D0*F3/FI3))
+ ELSE
+ VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
+ ENDIF
+ VINT(80)=VINT(80)*FI0
+ 280 CONTINUE
+ IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
+ ENDIF
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYRECO
+C...Handles the possibility of colour reconnection in W+W- events,
+C...Based on the main scenarios of the Sjostrand and Khoze study:
+C...I, II, II', intermediate and instantaneous; plus one model
+C...along the lines of the Gustafson and Hakkinen: GH.
+
+ SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter value; number of points in MC integration.
+ PARAMETER (NPT=100)
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
+ &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
+ &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
+ &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
+ &TMC(20),IJOIN(100)
+
+C...Functions to give four-product and to do determinants.
+ FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
+ DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
+ &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
+ &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
+
+C...Only allow fraction of recoupling for GH, intermediate and
+C...instantaneous.
+ IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
+ IF(PYR(0).GT.PARP(120)) RETURN
+ ENDIF
+
+C...Common part for scenarios I, II, II', and GH.
+ IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
+ &MSTP(115).EQ.5) THEN
+
+C...Read out frequently-used parameters.
+ PI=PARU(1)
+ HBAR=PARU(3)
+ PMW=PMAS(24,1)
+ PGW=PMAS(24,2)
+ TFRAG=PARP(115)
+ RHAD=PARP(116)
+ FACT=PARP(117)
+ BLOWR=PARP(118)
+ BLOWT=PARP(119)
+
+C...Find range of decay products of the W's.
+C...Background: the W's are stored in IW1 and IW2.
+C...Their direct decay products in NSD1+1 through NSD1+4.
+C...Products after shower (if any) in NSD1+5 through NAFT1
+C...for first W and in NAFT1+1 through N for the second.
+ IF(K(IW1,2).GT.0) THEN
+ JT=1
+ ELSE
+ JT=2
+ ENDIF
+ JR=3-JT
+ IF(NAFT1.GT.NSD1+4) THEN
+ NBEG(JT)=NSD1+5
+ NEND(JT)=NAFT1
+ ELSE
+ NBEG(JT)=NSD1+1
+ NEND(JT)=NSD1+2
+ ENDIF
+ IF(N.GT.NAFT1) THEN
+ NBEG(JR)=NAFT1+1
+ NEND(JR)=N
+ ELSE
+ NBEG(JR)=NSD1+3
+ NEND(JR)=NSD1+4
+ ENDIF
+
+C...Rearrange parton shower products along strings.
+ NOLD=N
+ CALL PYPREP(NSD1+1)
+
+C...Find partons pointing back to W+ and W-; store them with quark
+C...end of string first.
+ NNP=0
+ NNM=0
+ ISGP=0
+ ISGM=0
+ DO 120 I=NOLD+1,N
+ IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
+ IF(IABS(K(I,2)).GE.22) GOTO 120
+ IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
+ IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
+ NNP=NNP+1
+ IF(ISGP.EQ.1) THEN
+ INP(NNP)=I
+ ELSE
+ DO 100 I1=NNP,2,-1
+ INP(I1)=INP(I1-1)
+ 100 CONTINUE
+ INP(1)=I
+ ENDIF
+ IF(K(I,1).EQ.1) ISGP=0
+ ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
+ IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
+ NNM=NNM+1
+ IF(ISGM.EQ.1) THEN
+ INM(NNM)=I
+ ELSE
+ DO 110 I1=NNM,2,-1
+ INM(I1)=INM(I1-1)
+ 110 CONTINUE
+ INM(1)=I
+ ENDIF
+ IF(K(I,1).EQ.1) ISGM=0
+ ENDIF
+ 120 CONTINUE
+
+C...Boost to W+W- rest frame (not strictly needed).
+ DO 130 J=1,3
+ BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
+ 130 CONTINUE
+ CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
+ CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
+ CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
+
+C...Select decay vertices of W+ and W-.
+ TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
+ & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
+ TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
+ & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
+ GTMAX=MAX(TP,TM)
+ DO 140 J=1,3
+ XP(J)=TP*P(IW1,J)/P(IW1,4)
+ XM(J)=TM*P(IW2,J)/P(IW2,4)
+ 140 CONTINUE
+
+C...Begin scenario I specifics.
+ IF(MSTP(115).EQ.1) THEN
+
+C...Reconstruct velocity and direction of W+ string pieces.
+ DO 170 IIP=1,NNP-1
+ IF(K(INP(IIP),2).LT.0) GOTO 170
+ I1=INP(IIP)
+ I2=INP(IIP+1)
+ P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
+ P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
+ DO 150 J=1,3
+ V1(J)=P(I1,J)/P1A
+ V2(J)=P(I2,J)/P2A
+ BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
+ DIRP(IIP,J)=V1(J)-V2(J)
+ 150 CONTINUE
+ BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
+ & BETP(IIP,3)**2)
+ DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
+ DO 160 J=1,3
+ DIRP(IIP,J)=DIRP(IIP,J)/DIRL
+ 160 CONTINUE
+ 170 CONTINUE
+
+C...Reconstruct velocity and direction of W- string pieces.
+ DO 200 IIM=1,NNM-1
+ IF(K(INM(IIM),2).LT.0) GOTO 200
+ I1=INM(IIM)
+ I2=INM(IIM+1)
+ P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
+ P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
+ DO 180 J=1,3
+ V1(J)=P(I1,J)/P1A
+ V2(J)=P(I2,J)/P2A
+ BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
+ DIRM(IIM,J)=V1(J)-V2(J)
+ 180 CONTINUE
+ BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
+ & BETM(IIM,3)**2)
+ DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
+ DO 190 J=1,3
+ DIRM(IIM,J)=DIRM(IIM,J)/DIRL
+ 190 CONTINUE
+ 200 CONTINUE
+
+C...Loop over number of space-time points.
+ NACC=0
+ SUM=0D0
+ DO 250 IPT=1,NPT
+
+C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
+ R=SQRT(-LOG(PYR(0)))
+ PHI=2D0*PI*PYR(0)
+ X=BLOWR*RHAD*R*COS(PHI)
+ Y=BLOWR*RHAD*R*SIN(PHI)
+ R=SQRT(-LOG(PYR(0)))
+ PHI=2D0*PI*PYR(0)
+ Z=BLOWR*RHAD*R*COS(PHI)
+ T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
+
+C...Weight for sample distribution.
+ WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
+ & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
+
+C...Loop over W+ string pieces and find one with largest weight.
+ IMAXP=0
+ WTMAXP=1D-10
+ XD(1)=X-XP(1)
+ XD(2)=Y-XP(2)
+ XD(3)=Z-XP(3)
+ XD(4)=T-TP
+ DO 220 IIP=1,NNP-1
+ IF(K(INP(IIP),2).LT.0) GOTO 220
+ BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
+ BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
+ DO 210 J=1,3
+ XB(J)=XD(J)+BEDG*BETP(IIP,J)
+ 210 CONTINUE
+ XB(4)=BETP(IIP,4)*(XD(4)-BED)
+ SR2=XB(1)**2+XB(2)**2+XB(3)**2
+ SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
+ & DIRP(IIP,3)*XB(3))**2
+ WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
+ & TFRAG**2)
+ IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
+ IF(WTP.GT.WTMAXP) THEN
+ IMAXP=IIP
+ WTMAXP=WTP
+ ENDIF
+ 220 CONTINUE
+
+C...Loop over W- string pieces and find one with largest weight.
+ IMAXM=0
+ WTMAXM=1D-10
+ XD(1)=X-XM(1)
+ XD(2)=Y-XM(2)
+ XD(3)=Z-XM(3)
+ XD(4)=T-TM
+ DO 240 IIM=1,NNM-1
+ IF(K(INM(IIM),2).LT.0) GOTO 240
+ BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
+ BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
+ DO 230 J=1,3
+ XB(J)=XD(J)+BEDG*BETM(IIM,J)
+ 230 CONTINUE
+ XB(4)=BETM(IIM,4)*(XD(4)-BED)
+ SR2=XB(1)**2+XB(2)**2+XB(3)**2
+ SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
+ & DIRM(IIM,3)*XB(3))**2
+ WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
+ & TFRAG**2)
+ IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
+ IF(WTM.GT.WTMAXM) THEN
+ IMAXM=IIM
+ WTMAXM=WTM
+ ENDIF
+ 240 CONTINUE
+
+C...Result of integration.
+ WT=0D0
+ IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
+ WT=WTMAXP*WTMAXM/WTSMP
+ SUM=SUM+WT
+ NACC=NACC+1
+ IAP(NACC)=IMAXP
+ IAM(NACC)=IMAXM
+ WTA(NACC)=WT
+ ENDIF
+ 250 CONTINUE
+ RES=BLOWR**3*BLOWT*SUM/NPT
+
+C...Decide whether to reconnect and, if so, where.
+ IACC=0
+ PREC=1D0-EXP(-FACT*RES)
+ IF(PREC.GT.PYR(0)) THEN
+ RSUM=PYR(0)*SUM
+ DO 260 IA=1,NACC
+ IACC=IA
+ RSUM=RSUM-WTA(IA)
+ IF(RSUM.LE.0D0) GOTO 270
+ 260 CONTINUE
+ 270 IIP=IAP(IACC)
+ IIM=IAM(IACC)
+ ENDIF
+
+C...Begin scenario II and II' specifics.
+ ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
+
+C...Loop through all string pieces, one from W+ and one from W-.
+ NCROSS=0
+ TC(0)=0D0
+ DO 340 IIP=1,NNP-1
+ IF(K(INP(IIP),2).LT.0) GOTO 340
+ I1P=INP(IIP)
+ I2P=INP(IIP+1)
+ DO 330 IIM=1,NNM-1
+ IF(K(INM(IIM),2).LT.0) GOTO 330
+ I1M=INM(IIM)
+ I2M=INM(IIM+1)
+
+C...Find endpoint velocity vectors.
+ DO 280 J=1,3
+ V1P(J)=P(I1P,J)/P(I1P,4)
+ V2P(J)=P(I2P,J)/P(I2P,4)
+ V1M(J)=P(I1M,J)/P(I1M,4)
+ V2M(J)=P(I2M,J)/P(I2M,4)
+ 280 CONTINUE
+
+C...Define q matrix and find t.
+ DO 290 J=1,3
+ Q(1,J)=V2P(J)-V1P(J)
+ Q(2,J)=-(V2M(J)-V1M(J))
+ Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
+ Q(4,J)=V1P(J)-V1M(J)
+ 290 CONTINUE
+ T=-DETER(1,2,3)/DETER(1,2,4)
+
+C...Find alpha and beta; i.e. coordinates of crossing point.
+ S11=Q(1,1)*(T-TP)
+ S12=Q(2,1)*(T-TM)
+ S13=Q(3,1)+Q(4,1)*T
+ S21=Q(1,2)*(T-TP)
+ S22=Q(2,2)*(T-TM)
+ S23=Q(3,2)+Q(4,2)*T
+ DEN=S11*S22-S12*S21
+ ALP=(S12*S23-S22*S13)/DEN
+ BET=(S21*S13-S11*S23)/DEN
+
+C...Check if solution acceptable.
+ IANSW=1
+ IF(T.LT.GTMAX) IANSW=0
+ IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
+ IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
+
+C...Find point of crossing and check that not inconsistent.
+ DO 300 J=1,3
+ XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
+ XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
+ 300 CONTINUE
+ D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
+ & (XPP(3)-XMM(3))**2
+ D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
+ D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
+ IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
+
+C...Find string eigentimes at crossing.
+ IF(IANSW.EQ.1) THEN
+ TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
+ & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
+ TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
+ & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
+ ELSE
+ TAUP=0D0
+ TAUM=0D0
+ ENDIF
+
+C...Order crossings by time. End loop over crossings.
+ IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
+ NCROSS=NCROSS+1
+ DO 310 I1=NCROSS,1,-1
+ IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
+ IPC(I1)=IIP
+ IMC(I1)=IIM
+ TC(I1)=T
+ TPC(I1)=TAUP
+ TMC(I1)=TAUM
+ GOTO 320
+ ELSE
+ IPC(I1)=IPC(I1-1)
+ IMC(I1)=IMC(I1-1)
+ TC(I1)=TC(I1-1)
+ TPC(I1)=TPC(I1-1)
+ TMC(I1)=TMC(I1-1)
+ ENDIF
+ 310 CONTINUE
+ 320 CONTINUE
+ ENDIF
+ 330 CONTINUE
+ 340 CONTINUE
+
+C...Loop over crossings; find first (if any) acceptable one.
+ IACC=0
+ IF(NCROSS.GE.1) THEN
+ DO 350 IC=1,NCROSS
+ PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
+ IF(PNFRAG.GT.PYR(0)) THEN
+C...Scenario II: only compare with fragmentation time.
+ IF(MSTP(115).EQ.2) THEN
+ IACC=IC
+ IIP=IPC(IACC)
+ IIM=IMC(IACC)
+ GOTO 360
+C...Scenario II': also require that string length decreases.
+ ELSE
+ IIP=IPC(IC)
+ IIM=IMC(IC)
+ I1P=INP(IIP)
+ I2P=INP(IIP+1)
+ I1M=INM(IIM)
+ I2M=INM(IIM+1)
+ ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
+ ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
+ IF(ELNEW.LT.ELOLD) THEN
+ IACC=IC
+ IIP=IPC(IACC)
+ IIM=IMC(IACC)
+ GOTO 360
+ ENDIF
+ ENDIF
+ ENDIF
+ 350 CONTINUE
+ 360 CONTINUE
+ ENDIF
+
+C...Begin scenario GH specifics.
+ ELSEIF(MSTP(115).EQ.5) THEN
+
+C...Loop through all string pieces, one from W+ and one from W-.
+ IACC=0
+ ELMIN=1D0
+ DO 380 IIP=1,NNP-1
+ IF(K(INP(IIP),2).LT.0) GOTO 380
+ I1P=INP(IIP)
+ I2P=INP(IIP+1)
+ DO 370 IIM=1,NNM-1
+ IF(K(INM(IIM),2).LT.0) GOTO 370
+ I1M=INM(IIM)
+ I2M=INM(IIM+1)
+
+C...Look for largest decrease of (exponent of) Lambda measure.
+ ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
+ ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
+ ELDIF=ELNEW/MAX(1D-10,ELOLD)
+ IF(ELDIF.LT.ELMIN) THEN
+ IACC=IIP+IIM
+ ELMIN=ELDIF
+ IPC(1)=IIP
+ IMC(1)=IIM
+ ENDIF
+ 370 CONTINUE
+ 380 CONTINUE
+ IIP=IPC(1)
+ IIM=IMC(1)
+ ENDIF
+
+C...Common for scenarios I, II, II' and GH: reconnect strings.
+ IF(IACC.NE.0) THEN
+ MINT(32)=1
+ NJOIN=0
+ DO 390 IS=1,NNP+NNM
+ NJOIN=NJOIN+1
+ IF(IS.LE.IIP) THEN
+ I=INP(IS)
+ ELSEIF(IS.LE.IIP+NNM-IIM) THEN
+ I=INM(IS-IIP+IIM)
+ ELSEIF(IS.LE.IIP+NNM) THEN
+ I=INM(IS-IIP-NNM+IIM)
+ ELSE
+ I=INP(IS-NNM)
+ ENDIF
+ IJOIN(NJOIN)=I
+ IF(K(I,2).LT.0) THEN
+ CALL PYJOIN(NJOIN,IJOIN)
+ NJOIN=0
+ ENDIF
+ 390 CONTINUE
+
+C...Restore original event record if no reconnection.
+ ELSE
+ DO 400 I=NSD1+1,NOLD
+ IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
+ K(I,4)=MOD(K(I,4),MSTU(5)**2)
+ K(I,5)=MOD(K(I,5),MSTU(5)**2)
+ ENDIF
+ 400 CONTINUE
+ DO 410 I=NOLD+1,N
+ K(K(I,3),1)=3
+ 410 CONTINUE
+ N=NOLD
+ ENDIF
+
+C...Boost back system.
+ CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
+ CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
+ IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
+ & BEWW(1),BEWW(2),BEWW(3))
+
+C...Common part for intermediate and instantaneous scenarios.
+ ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
+ MINT(32)=1
+
+C...Remove old shower products and reset showering ones.
+ N=NSD1+4
+ DO 420 I=NSD1+1,NSD1+4
+ K(I,1)=3
+ K(I,4)=MOD(K(I,4),MSTU(5)**2)
+ K(I,5)=MOD(K(I,5),MSTU(5)**2)
+ 420 CONTINUE
+
+C...Identify quark-antiquark pairs.
+ IQ1=NSD1+1
+ IQ2=NSD1+2
+ IQ3=NSD1+3
+ IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
+ IQ4=2*NSD1+7-IQ3
+
+C...Reconnect strings.
+ IJOIN(1)=IQ1
+ IJOIN(2)=IQ4
+ CALL PYJOIN(2,IJOIN)
+ IJOIN(1)=IQ3
+ IJOIN(2)=IQ2
+ CALL PYJOIN(2,IJOIN)
+
+C...Do new parton showers in intermediate scenario.
+ IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
+ MSTJ50=MSTJ(50)
+ MSTJ(50)=0
+ CALL PYSHOW(IQ1,IQ2,P(IW1,5))
+ CALL PYSHOW(IQ3,IQ4,P(IW2,5))
+ MSTJ(50)=MSTJ50
+
+C...Do new parton showers in instantaneous scenario.
+ ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
+ PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
+ & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
+ PPM=SQRT(MAX(0D0,PPM2))
+ CALL PYSHOW(IQ1,IQ4,PPM)
+ PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
+ & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
+ PPM=SQRT(MAX(0D0,PPM2))
+ CALL PYSHOW(IQ3,IQ2,PPM)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYKLIM
+C...Checks generated variables against pre-set kinematical limits;
+C...also calculates limits on variables used in generation.
+
+ SUBROUTINE PYKLIM(ILIM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/
+
+C...Common kinematical expressions.
+ MINT(51)=0
+ ISUB=MINT(1)
+ ISTSB=ISET(ISUB)
+ IF(ISUB.EQ.96) GOTO 100
+ SQM3=VINT(63)
+ SQM4=VINT(64)
+ IF(ILIM.NE.0) THEN
+ IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
+ CKIN09=MAX(CKIN(9),CKIN(13))
+ CKIN10=MIN(CKIN(10),CKIN(14))
+ CKIN11=MAX(CKIN(11),CKIN(15))
+ CKIN12=MIN(CKIN(12),CKIN(16))
+ ELSE
+ CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
+ CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
+ CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
+ CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
+ ENDIF
+ ENDIF
+ IF(ILIM.NE.1) THEN
+ TAU=VINT(21)
+ RM3=SQM3/(TAU*VINT(2))
+ RM4=SQM4/(TAU*VINT(2))
+ BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
+ ENDIF
+ PTHMIN=CKIN(3)
+ IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
+ &PTHMIN=MAX(CKIN(3),CKIN(5))
+
+ IF(ILIM.EQ.0) THEN
+C...Check generated values of tau, y*, cos(theta-hat), and tau' against
+C...pre-set kinematical limits.
+ YST=VINT(22)
+ CTH=VINT(23)
+ TAUP=VINT(26)
+ TAUE=TAU
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
+ X1=SQRT(TAUE)*EXP(YST)
+ X2=SQRT(TAUE)*EXP(-YST)
+ XF=X1-X2
+ IF(MINT(47).NE.1) THEN
+ IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
+ IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
+ IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
+ IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
+ ENDIF
+ IF(MINT(45).NE.1) THEN
+ IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
+ ENDIF
+ IF(MINT(46).NE.1) THEN
+ IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
+ ENDIF
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
+ EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
+ & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
+ EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
+ & MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
+ Y3=YST+0.5D0*LOG(EXPY3)
+ Y4=YST+0.5D0*LOG(EXPY4)
+ YLARGE=MAX(Y3,Y4)
+ YSMALL=MIN(Y3,Y4)
+ ETALAR=10D0
+ ETASMA=-10D0
+ STH=SQRT(MAX(0D0,1D0-CTH**2))
+ EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
+ & CTH)**2-4D0*RM3))
+ EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
+ & CTH)**2-4D0*RM4))
+ IF(STH.GE.1.D-6) THEN
+ EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
+ & (BE34*STH)
+ EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
+ & (BE34*STH)
+ ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
+ ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
+ ETALAR=MAX(ETA3,ETA4)
+ ETASMA=MIN(ETA3,ETA4)
+ ENDIF
+ CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
+ CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
+ CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
+ CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
+ SH=TAU*VINT(2)
+ RPTS=4D0*VINT(71)**2/SH
+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
+ RM34=MAX(1D-20,2D0*RM3*RM4)
+ IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
+ & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
+ RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
+ THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
+ UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
+ IF(PTH.LT.PTHMIN) MINT(51)=1
+ IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
+ IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
+ IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
+ IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
+ IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
+ IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
+ IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
+ IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
+ IF(THA.LT.CKIN(35)) MINT(51)=1
+ IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
+ IF(UHA.LT.CKIN(37)) MINT(51)=1
+ IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
+ ENDIF
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
+ IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
+ ENDIF
+
+C...Additional cuts on W2 (approximately) in DIS.
+ IF(ISUB.EQ.10) THEN
+ XBJ=X2
+ IF(IABS(MINT(12)).LT.20) XBJ=X1
+ Q2BJ=THA
+ W2BJ=Q2BJ*(1D0-XBJ)/XBJ
+ IF(W2BJ.LT.CKIN(39)) MINT(51)=1
+ IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
+ ENDIF
+
+ ELSEIF(ILIM.EQ.1) THEN
+C...Calculate limits on tau
+C...0) due to definition
+ TAUMN0=0D0
+ TAUMX0=1D0
+C...1) due to limits on subsystem mass
+ TAUMN1=CKIN(1)**2/VINT(2)
+ TAUMX1=1D0
+ IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
+C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
+ TM3=SQRT(SQM3+PTHMIN**2)
+ TM4=SQRT(SQM4+PTHMIN**2)
+ YDCOSH=1D0
+ IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
+ TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
+ TAUMX2=1D0
+C...3) due to limits on pT-hat and cos(theta-hat)
+ CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
+ CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
+ TAUMN3=0D0
+ IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
+ & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
+ & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
+ TAUMX3=1D0
+ IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
+ & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
+ & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
+C...4) due to limits on x1 and x2
+ TAUMN4=CKIN(21)*CKIN(23)
+ TAUMX4=CKIN(22)*CKIN(24)
+C...5) due to limits on xF
+ TAUMN5=0D0
+ TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
+C...6) due to limits on that and uhat
+ TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
+ TAUMX6=1D0
+ IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
+ & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
+
+C...Net effect of all separate limits.
+ VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
+ VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
+ IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
+ VINT(11)=0.99999D0
+ VINT(31)=1.00001D0
+ ELSEIF(MINT(47).EQ.5) THEN
+ VINT(31)=MIN(VINT(31),0.999998D0)
+ ENDIF
+ IF(VINT(31).LE.VINT(11)) MINT(51)=1
+
+ ELSEIF(ILIM.EQ.2) THEN
+C...Calculate limits on y*
+ TAUE=TAU
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
+ TAURT=SQRT(TAUE)
+C...0) due to kinematics
+ YSTMN0=LOG(TAURT)
+ YSTMX0=-YSTMN0
+C...1) due to explicit limits
+ YSTMN1=CKIN(7)
+ YSTMX1=CKIN(8)
+C...2) due to limits on x1
+ YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
+ YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
+C...3) due to limits on x2
+ YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
+ YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
+C...4) due to limits on xF
+ YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
+ YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
+ YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
+ YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
+C...5) due to simultaneous limits on y-large and y-small
+ YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
+ YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
+ YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
+ YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
+ YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
+ YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
+C...6) due to simultaneous limits on cos(theta-hat) and y-large or
+C... y-small
+ CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
+ RZMN=BE34*MAX(CKIN(27),-CTHLIM)
+ RZMX=BE34*MIN(CKIN(28),CTHLIM)
+ YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
+ YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
+ YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
+ YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
+ YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
+ YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
+
+C...Net effect of all separate limits.
+ VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
+ VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
+ IF(MINT(47).EQ.1) THEN
+ VINT(12)=-0.00001D0
+ VINT(32)=0.00001D0
+ ELSEIF(MINT(47).EQ.2) THEN
+ VINT(12)=0.99999D0*YSTMX0
+ VINT(32)=1.00001D0*YSTMX0
+ ELSEIF(MINT(47).EQ.3) THEN
+ VINT(12)=-1.00001D0*YSTMX0
+ VINT(32)=-0.99999D0*YSTMX0
+ ELSEIF(MINT(47).EQ.5) THEN
+ YSTEE=LOG(0.999999D0/TAURT)
+ VINT(12)=MAX(VINT(12),-YSTEE)
+ VINT(32)=MIN(VINT(32),YSTEE)
+ ENDIF
+ IF(VINT(32).LE.VINT(12)) MINT(51)=1
+
+ ELSEIF(ILIM.EQ.3) THEN
+C...Calculate limits on cos(theta-hat)
+ YST=VINT(22)
+C...0) due to definition
+ CTNMN0=-1D0
+ CTNMX0=0D0
+ CTPMN0=0D0
+ CTPMX0=1D0
+C...1) due to explicit limits
+ CTNMN1=MIN(0D0,CKIN(27))
+ CTNMX1=MIN(0D0,CKIN(28))
+ CTPMN1=MAX(0D0,CKIN(27))
+ CTPMX1=MAX(0D0,CKIN(28))
+C...2) due to limits on pT-hat
+ CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
+ CTPMX2=-CTNMN2
+ CTNMX2=0D0
+ CTPMN2=0D0
+ IF(CKIN(4).GE.0D0) THEN
+ CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
+ & (BE34**2*TAU*VINT(2))))
+ CTPMN2=-CTNMX2
+ ENDIF
+C...3) due to limits on y-large and y-small
+ CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
+ & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
+ CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
+ & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
+ CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
+ & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
+ CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
+ & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
+C...4) due to limits on that
+ CTNMN4=-1D0
+ CTNMX4=0D0
+ CTPMN4=0D0
+ CTPMX4=1D0
+ SH=TAU*VINT(2)
+ IF(CKIN(35).GT.0D0) THEN
+ CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
+ IF(CTLIM.GT.0D0) THEN
+ CTPMX4=CTLIM
+ ELSE
+ CTPMX4=0D0
+ CTNMX4=CTLIM
+ ENDIF
+ ENDIF
+ IF(CKIN(36).GT.0D0) THEN
+ CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
+ IF(CTLIM.LT.0D0) THEN
+ CTNMN4=CTLIM
+ ELSE
+ CTNMN4=0D0
+ CTPMN4=CTLIM
+ ENDIF
+ ENDIF
+C...5) due to limits on uhat
+ CTNMN5=-1D0
+ CTNMX5=0D0
+ CTPMN5=0D0
+ CTPMX5=1D0
+ IF(CKIN(37).GT.0D0) THEN
+ CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
+ IF(CTLIM.LT.0D0) THEN
+ CTNMN5=CTLIM
+ ELSE
+ CTNMN5=0D0
+ CTPMN5=CTLIM
+ ENDIF
+ ENDIF
+ IF(CKIN(38).GT.0D0) THEN
+ CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
+ IF(CTLIM.GT.0D0) THEN
+ CTPMX5=CTLIM
+ ELSE
+ CTPMX5=0D0
+ CTNMX5=CTLIM
+ ENDIF
+ ENDIF
+
+C...Net effect of all separate limits.
+ VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
+ VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
+ VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
+ VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
+ IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
+
+ ELSEIF(ILIM.EQ.4) THEN
+C...Calculate limits on tau'
+C...0) due to kinematics
+ TAPMN0=TAU
+ IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
+ PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
+ TAPMN0=(SQRT(TAU)+PQRAT)**2
+ ENDIF
+ TAPMX0=1D0
+C...1) due to explicit limits
+ TAPMN1=CKIN(31)**2/VINT(2)
+ TAPMX1=1D0
+ IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
+
+C...Net effect of all separate limits.
+ VINT(16)=MAX(TAPMN0,TAPMN1)
+ VINT(36)=MIN(TAPMX0,TAPMX1)
+ IF(MINT(47).EQ.1) THEN
+ VINT(16)=0.99999D0
+ VINT(36)=1.00001D0
+ ENDIF
+ IF(VINT(36).LE.VINT(16)) MINT(51)=1
+
+ ENDIF
+ RETURN
+
+C...Special case for low-pT and multiple interactions:
+C...effective kinematical limits for tau, y*, cos(theta-hat).
+ 100 IF(ILIM.EQ.0) THEN
+ ELSEIF(ILIM.EQ.1) THEN
+ IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
+ IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
+ VINT(31)=1D0
+ ELSEIF(ILIM.EQ.2) THEN
+ VINT(12)=0.5D0*LOG(VINT(21))
+ VINT(32)=-VINT(12)
+ ELSEIF(ILIM.EQ.3) THEN
+ IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
+ IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
+ VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
+ VINT(33)=0D0
+ VINT(14)=0D0
+ VINT(34)=-VINT(13)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYKMAP
+C...Maps a uniform distribution into a distribution of a kinematical
+C...variable according to one of the possibilities allowed. It is
+C...assumed that kinematical limits have been set by a PYKLIM call.
+
+ SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
+
+C...Convert VVAR to tau variable.
+ ISUB=MINT(1)
+ ISTSB=ISET(ISUB)
+ IF(IVAR.EQ.1) THEN
+ TAUMIN=VINT(11)
+ TAUMAX=VINT(31)
+ IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
+ TAURE=VINT(73)
+ GAMRE=VINT(74)
+ ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
+ TAURE=VINT(75)
+ GAMRE=VINT(76)
+ ENDIF
+ IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
+ TAU=1D0
+ ELSEIF(MVAR.EQ.1) THEN
+ TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
+ ELSEIF(MVAR.EQ.2) THEN
+ TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
+ ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
+ RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
+ TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
+ ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
+ AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
+ ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
+ TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
+ ELSE
+ AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
+ ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
+ TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
+ ENDIF
+ VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
+
+C...Convert VVAR to y* variable.
+ ELSEIF(IVAR.EQ.2) THEN
+ YSTMIN=VINT(12)
+ YSTMAX=VINT(32)
+ TAUE=VINT(21)
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
+ IF(MINT(47).EQ.1) THEN
+ YST=0D0
+ ELSEIF(MINT(47).EQ.2) THEN
+ YST=-0.5D0*LOG(TAUE)
+ ELSEIF(MINT(47).EQ.3) THEN
+ YST=0.5D0*LOG(TAUE)
+ ELSEIF(MVAR.EQ.1) THEN
+ YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
+ ELSEIF(MVAR.EQ.2) THEN
+ YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
+ ELSEIF(MVAR.EQ.3) THEN
+ AUPP=ATAN(EXP(YSTMAX))
+ ALOW=ATAN(EXP(YSTMIN))
+ YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
+ ELSEIF(MVAR.EQ.4) THEN
+ YST0=-0.5D0*LOG(TAUE)
+ AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
+ ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
+ YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
+ ELSE
+ YST0=-0.5D0*LOG(TAUE)
+ AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
+ ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
+ YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
+ ENDIF
+ VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
+
+C...Convert VVAR to cos(theta-hat) variable.
+ ELSEIF(IVAR.EQ.3) THEN
+ RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
+ RSQM=1D0+RM34
+ IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
+ & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
+ CTNMIN=VINT(13)
+ CTNMAX=VINT(33)
+ CTPMIN=VINT(14)
+ CTPMAX=VINT(34)
+ IF(MVAR.EQ.1) THEN
+ ANEG=CTNMAX-CTNMIN
+ APOS=CTPMAX-CTPMIN
+ IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
+ VCTN=VVAR*(ANEG+APOS)/ANEG
+ CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
+ ELSE
+ VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
+ CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
+ ENDIF
+ ELSEIF(MVAR.EQ.2) THEN
+ RMNMIN=MAX(RM34,RSQM-CTNMIN)
+ RMNMAX=MAX(RM34,RSQM-CTNMAX)
+ RMPMIN=MAX(RM34,RSQM-CTPMIN)
+ RMPMAX=MAX(RM34,RSQM-CTPMAX)
+ ANEG=LOG(RMNMIN/RMNMAX)
+ APOS=LOG(RMPMIN/RMPMAX)
+ IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
+ VCTN=VVAR*(ANEG+APOS)/ANEG
+ CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
+ ELSE
+ VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
+ CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
+ ENDIF
+ ELSEIF(MVAR.EQ.3) THEN
+ RMNMIN=MAX(RM34,RSQM+CTNMIN)
+ RMNMAX=MAX(RM34,RSQM+CTNMAX)
+ RMPMIN=MAX(RM34,RSQM+CTPMIN)
+ RMPMAX=MAX(RM34,RSQM+CTPMAX)
+ ANEG=LOG(RMNMAX/RMNMIN)
+ APOS=LOG(RMPMAX/RMPMIN)
+ IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
+ VCTN=VVAR*(ANEG+APOS)/ANEG
+ CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
+ ELSE
+ VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
+ CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
+ ENDIF
+ ELSEIF(MVAR.EQ.4) THEN
+ RMNMIN=MAX(RM34,RSQM-CTNMIN)
+ RMNMAX=MAX(RM34,RSQM-CTNMAX)
+ RMPMIN=MAX(RM34,RSQM-CTPMIN)
+ RMPMAX=MAX(RM34,RSQM-CTPMAX)
+ ANEG=1D0/RMNMAX-1D0/RMNMIN
+ APOS=1D0/RMPMAX-1D0/RMPMIN
+ IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
+ VCTN=VVAR*(ANEG+APOS)/ANEG
+ CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
+ ELSE
+ VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
+ CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
+ ENDIF
+ ELSEIF(MVAR.EQ.5) THEN
+ RMNMIN=MAX(RM34,RSQM+CTNMIN)
+ RMNMAX=MAX(RM34,RSQM+CTNMAX)
+ RMPMIN=MAX(RM34,RSQM+CTPMIN)
+ RMPMAX=MAX(RM34,RSQM+CTPMAX)
+ ANEG=1D0/RMNMIN-1D0/RMNMAX
+ APOS=1D0/RMPMIN-1D0/RMPMAX
+ IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
+ VCTN=VVAR*(ANEG+APOS)/ANEG
+ CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
+ ELSE
+ VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
+ CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
+ ENDIF
+ ENDIF
+ IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
+ IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
+ VINT(23)=CTH
+
+C...Convert VVAR to tau' variable.
+ ELSEIF(IVAR.EQ.4) THEN
+ TAU=VINT(21)
+ TAUPMN=VINT(16)
+ TAUPMX=VINT(36)
+ IF(MINT(47).EQ.1) THEN
+ TAUP=1D0
+ ELSEIF(MVAR.EQ.1) THEN
+ TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
+ ELSEIF(MVAR.EQ.2) THEN
+ AUPP=(1D0-TAU/TAUPMX)**4
+ ALOW=(1D0-TAU/TAUPMN)**4
+ TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
+ ELSE
+ AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
+ ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
+ TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
+ ENDIF
+ VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
+
+C...Selection of extra variables needed in 2 -> 3 process:
+C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
+C...Since no options are available, the functions of PYKLIM
+C...and PYKMAP are joint for these choices.
+ ELSEIF(IVAR.EQ.5) THEN
+
+C...Read out total energy and particle masses.
+ MINT(51)=0
+ MPTPK=1
+ IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
+ & .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
+ SHP=VINT(26)*VINT(2)
+ SHPR=SQRT(SHP)
+ PM1=VINT(201)
+ PM2=VINT(206)
+ PM3=SQRT(VINT(21))*VINT(1)
+ IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ PMRS1=VINT(204)**2
+ PMRS2=VINT(209)**2
+
+C...Specify coefficients of pT choice; upper and lower limits.
+ IF(MPTPK.EQ.1) THEN
+ HWT1=0.4D0
+ HWT2=0.4D0
+ ELSE
+ HWT1=0.05D0
+ HWT2=0.05D0
+ ENDIF
+ HWT3=1D0-HWT1-HWT2
+ PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
+ & (4D0*SHP)
+ IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
+ PTSMN1=CKIN(51)**2
+ PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
+ & (4D0*SHP)
+ IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
+ PTSMN2=CKIN(53)**2
+
+C...Select transverse momenta according to
+C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
+ HMX=PMRS1+PTSMX1
+ HMN=PMRS1+PTSMN1
+ IF(HMX.LT.1.0001D0*HMN) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ HDE=PTSMX1-PTSMN1
+ RPT=PYR(0)
+ IF(RPT.LT.HWT1) THEN
+ PTS1=PTSMN1+PYR(0)*HDE
+ ELSEIF(RPT.LT.HWT1+HWT2) THEN
+ PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
+ ELSE
+ PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
+ ENDIF
+ WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
+ & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
+ HMX=PMRS2+PTSMX2
+ HMN=PMRS2+PTSMN2
+ IF(HMX.LT.1.0001D0*HMN) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ HDE=PTSMX2-PTSMN2
+ RPT=PYR(0)
+ IF(RPT.LT.HWT1) THEN
+ PTS2=PTSMN2+PYR(0)*HDE
+ ELSEIF(RPT.LT.HWT1+HWT2) THEN
+ PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
+ ELSE
+ PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
+ ENDIF
+ WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
+ & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
+
+C...Select azimuthal angles and check pT choice.
+ PHI1=PARU(2)*PYR(0)
+ PHI2=PARU(2)*PYR(0)
+ PHIR=PHI2-PHI1
+ PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
+ IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
+ & CKIN(56)**2)) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+
+C...Calculate transverse masses and check phase space not closed.
+ PMS1=PM1**2+PTS1
+ PMS2=PM2**2+PTS2
+ PMS3=PM3**2+PTS3
+ PMT1=SQRT(PMS1)
+ PMT2=SQRT(PMS2)
+ PMT3=SQRT(PMS3)
+ PM12=(PMT1+PMT2)**2
+ IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+
+C...Select rapidity for particle 3 and check phase space not closed.
+ Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
+ & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
+ IF(Y3MAX.LT.1D-6) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
+ PZ3=PMT3*SINH(Y3)
+ PE3=PMT3*COSH(Y3)
+
+C...Find momentum transfers in two mirror solutions (in 1-2 frame).
+ PZ12=-PZ3
+ PE12=SHPR-PE3
+ PMS12=PE12**2-PZ12**2
+ SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
+ IF(SQL12.LT.1D-6*SHP) THEN
+ MINT(51)=1
+ RETURN
+ ENDIF
+ PMM1=PMS12+PMS1-PMS2
+ PMM2=PMS12+PMS2-PMS1
+ TFAC=-SHPR/(2D0*PMS12)
+ T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
+ T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
+ T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
+ T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
+
+C...Construct relative mirror weights and make choice.
+ IF(MPTPK.EQ.1) THEN
+ WTPU=1D0
+ WTNU=1D0
+ ELSE
+ WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
+ WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
+ ENDIF
+ WTP=WTPU/(WTPU+WTNU)
+ WTN=WTNU/(WTPU+WTNU)
+ EPS=1D0
+ IF(WTN.GT.PYR(0)) EPS=-1D0
+
+C...Store result of variable choice and associated weights.
+ VINT(202)=PTS1
+ VINT(207)=PTS2
+ VINT(203)=PHI1
+ VINT(208)=PHI2
+ VINT(205)=WTPTS1
+ VINT(210)=WTPTS2
+ VINT(211)=Y3
+ VINT(212)=Y3MAX
+ VINT(213)=EPS
+ IF(EPS.GT.0D0) THEN
+ VINT(214)=1D0/WTP
+ VINT(215)=T1P
+ VINT(216)=T2P
+ ELSE
+ VINT(214)=1D0/WTN
+ VINT(215)=T1N
+ VINT(216)=T2N
+ ENDIF
+ VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
+ VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
+ VINT(219)=0.5D0*(PMS12-PTS3)
+ VINT(220)=SQL12
+ ENDIF
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYSIGH
+C...Differential matrix elements for all included subprocesses
+C...Note that what is coded is (disregarding the COMFAC factor)
+C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
+C...when d(sigma-hat) is given in the zero-width limit, the delta
+C...function in tau is replaced by a (modified) Breit-Wigner:
+C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
+C...where H_res = s-hat/m_res*Gamma_res(s-hat);
+C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
+C...i.e., dimensionless quantities
+C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
+C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
+C...(2pi)^4 delta^4(P - sum p_i)
+C...COMFAC contains the factor pi/s (or equivalent) and
+C...the conversion factor from GeV^-2 to mb
+
+ SUBROUTINE PYSIGH(NCHN,SIGS)
+
+C...Double precision and integer declarations
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
+ &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
+ &/PYSSMT/
+C...Local arrays and complex variables
+ DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
+ &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
+ COMPLEX A004,A204,A114,A00U,A20U,A11U
+ COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
+ &COULCK,COULCP,COULCD,COULCR,COULCS
+ REAL A00L,A11L,A20L,COULXX
+
+C...Reset number of channels and cross-section
+ NCHN=0
+ SIGS=0D0
+
+C...Convert H or A process into equivalent h one
+ ISUB=MINT(1)
+ ISUBSV=ISUB
+ IHIGG=1
+ KFHIGG=25
+ IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
+ &ISUB.LE.190)) THEN
+ IHIGG=2
+ IF(MOD(ISUB-1,10).GE.5) IHIGG=3
+ KFHIGG=33+IHIGG
+ IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
+ IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
+ IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
+ IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
+ IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
+ IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
+ IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
+ IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
+ IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
+ ENDIF
+
+CMRENNA++
+C...Convert almost equivalent SUSY processes into each other
+C...Extract differences in flavours and couplings
+ IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
+
+C...Sleptons and sneutrinos
+ IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
+ KFID=MOD(KFPR(ISUB,1),KSUSY1)
+ ISUB=201
+ ILR=0
+ ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
+ KFID=MOD(KFPR(ISUB,1),KSUSY1)
+ ISUB=201
+ ILR=1
+ ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
+ KFID=MOD(KFPR(ISUB,1),KSUSY1)
+ ISUB=203
+ ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
+ IF(ISUB.EQ.210) THEN
+ RKF=2.0D0
+ ELSEIF(ISUB.EQ.211) THEN
+ RKF=SFMIX(15,1)**2
+ ELSEIF(ISUB.EQ.212) THEN
+ RKF=SFMIX(15,2)**2
+ ENDIF
+ ISUB=210
+ ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
+ IF(ISUB.EQ.213) THEN
+ KFID=MOD(KFPR(ISUB,1),KSUSY1)
+ RKF=2.0D0
+ ELSEIF(ISUB.EQ.214) THEN
+ KFID=16
+ RKF=1.0D0
+ ENDIF
+ ISUB=213
+
+C...Neutralinos
+ ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
+ IF(ISUB.EQ.216) THEN
+ IZID1=1
+ IZID2=1
+ ELSEIF(ISUB.EQ.217) THEN
+ IZID1=2
+ IZID2=2
+ ELSEIF(ISUB.EQ.218) THEN
+ IZID1=3
+ IZID2=3
+ ELSEIF(ISUB.EQ.219) THEN
+ IZID1=4
+ IZID2=4
+ ELSEIF(ISUB.EQ.220) THEN
+ IZID1=1
+ IZID2=2
+ ELSEIF(ISUB.EQ.221) THEN
+ IZID1=1
+ IZID2=3
+ ELSEIF(ISUB.EQ.222) THEN
+ IZID1=1
+ IZID2=4
+ ELSEIF(ISUB.EQ.223) THEN
+ IZID1=2
+ IZID2=3
+ ELSEIF(ISUB.EQ.224) THEN
+ IZID1=2
+ IZID2=4
+ ELSEIF(ISUB.EQ.225) THEN
+ IZID1=3
+ IZID2=4
+ ENDIF
+ ISUB=216
+
+C...Charginos
+ ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
+ IF(ISUB.EQ.226) THEN
+ IZID1=1
+ IZID2=1
+ ELSEIF(ISUB.EQ.227) THEN
+ IZID1=2
+ IZID2=2
+ ELSEIF(ISUB.EQ.228) THEN
+ IZID1=1
+ IZID2=2
+ ENDIF
+ ISUB=226
+
+C...Neutralino + chargino
+ ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
+ IF(ISUB.EQ.229) THEN
+ IZID1=1
+ IZID2=1
+ ELSEIF(ISUB.EQ.230) THEN
+ IZID1=1
+ IZID2=2
+ ELSEIF(ISUB.EQ.231) THEN
+ IZID1=1
+ IZID2=3
+ ELSEIF(ISUB.EQ.232) THEN
+ IZID1=1
+ IZID2=4
+ ELSEIF(ISUB.EQ.233) THEN
+ IZID1=2
+ IZID2=1
+ ELSEIF(ISUB.EQ.234) THEN
+ IZID1=2
+ IZID2=2
+ ELSEIF(ISUB.EQ.235) THEN
+ IZID1=2
+ IZID2=3
+ ELSEIF(ISUB.EQ.236) THEN
+ IZID1=2
+ IZID2=4
+ ENDIF
+ ISUB=229
+
+C...Gluino + neutralino
+ ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
+ IF(ISUB.EQ.237) THEN
+ IZID=1
+ ELSEIF(ISUB.EQ.238) THEN
+ IZID=2
+ ELSEIF(ISUB.EQ.239) THEN
+ IZID=3
+ ELSEIF(ISUB.EQ.240) THEN
+ IZID=4
+ ENDIF
+ ISUB=237
+
+C...Gluino + chargino
+ ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
+ IF(ISUB.EQ.241) THEN
+ IZID=1
+ ELSEIF(ISUB.EQ.242) THEN
+ IZID=2
+ ENDIF
+ ISUB=241
+
+C...Squark + neutralino
+ ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
+ ILR=0
+ IF(MOD(ISUB,2).NE.0) ILR=1
+ IF(ISUB.LE.247) THEN
+ IZID=1
+ ELSEIF(ISUB.LE.249) THEN
+ IZID=2
+ ELSEIF(ISUB.LE.251) THEN
+ IZID=3
+ ELSEIF(ISUB.LE.253) THEN
+ IZID=4
+ ENDIF
+ ISUB=246
+ RKF=5D0
+
+C...Squark + chargino
+ ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
+ IF(ISUB.LE.255) THEN
+ IZID=1
+ ELSEIF(ISUB.LE.257) THEN
+ IZID=2
+ ENDIF
+ IF(MOD(ISUB,2).EQ.0) THEN
+ ILR=0
+ ELSE
+ ILR=1
+ ENDIF
+ ISUB=254
+ RKF=5D0
+
+C...Squark + gluino
+ ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
+ ISUB=258
+ RKF=5D0
+
+C...Stops
+ ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
+ ILR=0
+ IF(ISUB.EQ.262) ILR=1
+ ISUB=261
+ ELSEIF(ISUB.EQ.265) THEN
+ ISUB=264
+
+C...Squarks
+ ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
+ ILR=0
+ IF(ISUB.LE.273) THEN
+ IF(ISUB.EQ.273) ILR=1
+ ISUB=271
+ RKF=25D0
+ ELSEIF(ISUB.LE.276) THEN
+ IF(ISUB.EQ.276) ILR=1
+ ISUB=274
+ RKF=25D0
+ ELSEIF(ISUB.LE.278) THEN
+ IF(ISUB.EQ.278) ILR=1
+ ISUB=277
+ RKF=5D0
+ ELSE
+ IF(ISUB.EQ.280) ILR=1
+ ISUB=279
+ RKF=5D0
+ ENDIF
+ ENDIF
+ ENDIF
+CMRENNA--
+
+C...Read kinematical variables and limits
+ ISTSB=ISET(ISUBSV)
+ TAUMIN=VINT(11)
+ YSTMIN=VINT(12)
+ CTNMIN=VINT(13)
+ CTPMIN=VINT(14)
+ TAUPMN=VINT(16)
+ TAU=VINT(21)
+ YST=VINT(22)
+ CTH=VINT(23)
+ XT2=VINT(25)
+ TAUP=VINT(26)
+ TAUMAX=VINT(31)
+ YSTMAX=VINT(32)
+ CTNMAX=VINT(33)
+ CTPMAX=VINT(34)
+ TAUPMX=VINT(36)
+
+C...Derive kinematical quantities
+ TAUE=TAU
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
+ X(1)=SQRT(TAUE)*EXP(YST)
+ X(2)=SQRT(TAUE)*EXP(-YST)
+ IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
+ IF(X(1).GT.0.9999D0) RETURN
+ ELSEIF(MINT(45).EQ.3) THEN
+ X(1)=MIN(0.9999989D0,X(1))
+ ENDIF
+ IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
+ IF(X(2).GT.0.9999D0) RETURN
+ ELSEIF(MINT(46).EQ.3) THEN
+ X(2)=MIN(0.9999989D0,X(2))
+ ENDIF
+ SH=TAU*VINT(2)
+ SQM3=VINT(63)
+ SQM4=VINT(64)
+ RM3=SQM3/SH
+ RM4=SQM4/SH
+ BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
+ RPTS=4D0*VINT(71)**2/SH
+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
+ RM34=MAX(1D-20,2D0*RM3*RM4)
+ RSQM=1D0+RM34
+ IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
+ &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
+ RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
+ IF(ISTSB.EQ.0) THEN
+ TH=VINT(45)
+ UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
+ SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
+ ELSE
+ TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
+ UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
+ SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
+ ENDIF
+ SHR=SQRT(SH)
+ SH2=SH**2
+ TH2=TH**2
+ UH2=UH**2
+
+C...Choice of Q2 scale: hard, parton distributions, parton showers
+ IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
+ Q2=SH
+ ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
+ IF(MSTP(32).EQ.1) THEN
+ Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
+ ELSEIF(MSTP(32).EQ.2) THEN
+ Q2=SQPTH+0.5D0*(SQM3+SQM4)
+ ELSEIF(MSTP(32).EQ.3) THEN
+ Q2=MIN(-TH,-UH)
+ ELSEIF(MSTP(32).EQ.4) THEN
+ Q2=SH
+ ELSEIF(MSTP(32).EQ.5) THEN
+ Q2=-TH
+ ENDIF
+ IF(ISTSB.EQ.9) Q2=SQPTH
+ IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
+ & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
+ ENDIF
+ Q2SF=Q2
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ Q2SF=PMAS(23,1)**2
+ IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
+ & Q2SF=PMAS(24,1)**2
+ IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
+ Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
+ IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
+ IF(MSTP(39).EQ.3) Q2SF=SH
+ IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
+ ENDIF
+ ENDIF
+ Q2PS=Q2SF
+ Q2SF=Q2SF*PARP(34)
+ IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
+ IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
+ &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
+ XBJ=X(2)
+ IF(MINT(43).EQ.3) XBJ=X(1)
+ IF(MSTP(22).EQ.1) THEN
+ Q2PS=-TH
+ ELSEIF(MSTP(22).EQ.2) THEN
+ Q2PS=((1D0-XBJ)/XBJ)*(-TH)
+ ELSEIF(MSTP(22).EQ.3) THEN
+ Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
+ ELSE
+ Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
+ ENDIF
+ ENDIF
+ IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
+
+C...Store derived kinematical quantities
+ VINT(41)=X(1)
+ VINT(42)=X(2)
+ VINT(44)=SH
+ VINT(43)=SQRT(SH)
+ VINT(45)=TH
+ VINT(46)=UH
+ VINT(48)=SQPTH
+ VINT(47)=SQRT(SQPTH)
+ VINT(50)=TAUP*VINT(2)
+ VINT(49)=SQRT(MAX(0D0,VINT(50)))
+ VINT(52)=Q2
+ VINT(51)=SQRT(Q2)
+ VINT(54)=Q2SF
+ VINT(53)=SQRT(Q2SF)
+ VINT(56)=Q2PS
+ VINT(55)=SQRT(Q2PS)
+
+C...Calculate parton distributions
+ IF(ISTSB.LE.0) GOTO 170
+ IF(MINT(47).GE.2) THEN
+ DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
+ XSF=X(I)
+ IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
+ MINT(105)=MINT(102+I)
+ MINT(109)=MINT(106+I)
+ IF(MSTP(57).LE.1) THEN
+ CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
+ ELSE
+ CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
+ ENDIF
+ DO 100 KFL=-25,25
+ XSFX(I,KFL)=XPQ(KFL)
+ 100 CONTINUE
+ 110 CONTINUE
+ ENDIF
+
+C...Calculate alpha_em, alpha_strong and K-factor
+ XW=PARU(102)
+ XWV=XW
+ IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
+ &1D0-(PMAS(24,1)/PMAS(23,1))**2
+ XW1=1D0-XW
+ XWC=1D0/(16D0*XW*XW1)
+ AEM=PYALEM(Q2)
+ IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
+ IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
+ FACK=1D0
+ FACA=1D0
+ IF(MSTP(33).EQ.1) THEN
+ FACK=PARP(31)
+ ELSEIF(MSTP(33).EQ.2) THEN
+ FACK=PARP(31)
+ FACA=PARP(32)/PARP(31)
+ ELSEIF(MSTP(33).EQ.3) THEN
+ Q2AS=PARP(33)*Q2
+ IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
+ & PARU(112)*PARP(82)
+ AS=PYALPS(Q2AS)
+ ENDIF
+ VINT(138)=1D0
+ VINT(57)=AEM
+ VINT(58)=AS
+
+C...Set flags for allowed reacting partons/leptons
+ DO 140 I=1,2
+ DO 120 J=-25,25
+ KFAC(I,J)=0
+ 120 CONTINUE
+ IF(MINT(44+I).EQ.1) THEN
+ KFAC(I,MINT(10+I))=1
+ ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
+ KFAC(I,MINT(10+I))=1
+ KFAC(I,22)=1
+ KFAC(I,24)=1
+ KFAC(I,-24)=1
+ ELSE
+ DO 130 J=-25,25
+ KFAC(I,J)=KFIN(I,J)
+ IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
+ IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
+ 130 CONTINUE
+ ENDIF
+ 140 CONTINUE
+
+C...Lower and upper limit for fermion flavour loops
+ MMIN1=0
+ MMAX1=0
+ MMIN2=0
+ MMAX2=0
+ DO 150 J=-20,20
+ IF(KFAC(1,-J).EQ.1) MMIN1=-J
+ IF(KFAC(1,J).EQ.1) MMAX1=J
+ IF(KFAC(2,-J).EQ.1) MMIN2=-J
+ IF(KFAC(2,J).EQ.1) MMAX2=J
+ 150 CONTINUE
+ MMINA=MIN(MMIN1,MMIN2)
+ MMAXA=MAX(MMAX1,MMAX2)
+
+C...Common resonance mass and width combinations
+ SQMZ=PMAS(23,1)**2
+ SQMW=PMAS(24,1)**2
+ SQMH=PMAS(KFHIGG,1)**2
+ GMMZ=PMAS(23,1)*PMAS(23,2)
+ GMMW=PMAS(24,1)*PMAS(24,2)
+ GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
+C...MRENNA+++
+ ZWID=PMAS(23,2)
+ WWID=PMAS(24,2)
+ TANW=SQRT(XW/XW1)
+C...MRENNA---
+
+C...Phase space integral in tau
+ COMFAC=PARU(1)*PARU(5)/VINT(2)
+ IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
+ IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
+ &ISTSB.NE.9) THEN
+ ATAU1=LOG(TAUMAX/TAUMIN)
+ ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
+ H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
+ IF(MINT(72).GE.1) THEN
+ TAUR1=VINT(73)
+ GAMR1=VINT(74)
+ ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
+ ATAU3=ATAUD/TAUR1
+ IF(ATAUD.GT.1D-6) H1=H1+
+ & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
+ ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
+ ATAU4=ATAUD/GAMR1
+ IF(ATAUD.GT.1D-6) H1=H1+
+ & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
+ ENDIF
+ IF(MINT(72).EQ.2) THEN
+ TAUR2=VINT(75)
+ GAMR2=VINT(76)
+ ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
+ ATAU5=ATAUD/TAUR2
+ IF(ATAUD.GT.1D-6) H1=H1+
+ & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
+ ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
+ ATAU6=ATAUD/GAMR2
+ IF(ATAUD.GT.1D-6) H1=H1+
+ & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
+ ENDIF
+ IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
+ ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
+ IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
+ & MAX(2D-6,1D0-TAU)
+ ENDIF
+ COMFAC=COMFAC*ATAU1/(TAU*H1)
+ ENDIF
+
+C...Phase space integral in y*
+ IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
+ AYST0=YSTMAX-YSTMIN
+ IF(AYST0.LT.1D-6) THEN
+ COMFAC=0D0
+ ELSE
+ AYST1=0.5D0*(YSTMAX-YSTMIN)**2
+ AYST2=AYST1
+ AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
+ H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
+ & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
+ & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
+ IF(MINT(45).EQ.3) THEN
+ YST0=-0.5D0*LOG(TAUE)
+ AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
+ & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
+ IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
+ & MAX(1D-6,1D0-EXP(YST-YST0))
+ ENDIF
+ IF(MINT(46).EQ.3) THEN
+ YST0=-0.5D0*LOG(TAUE)
+ AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
+ & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
+ IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
+ & MAX(1D-6,1D0-EXP(-YST-YST0))
+ ENDIF
+ COMFAC=COMFAC*AYST0/H2
+ ENDIF
+ ENDIF
+
+C...2 -> 1 processes: reduction in angular part of phase space integral
+C...for case of decaying resonance
+ ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
+ IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
+ IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
+ IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
+ & KFPR(ISUB,1).EQ.39) THEN
+ COMFAC=COMFAC*0.5D0*ACTH0
+ ELSE
+ COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
+ & CTPMAX**3-CTPMIN**3)
+ ENDIF
+ ENDIF
+
+C...2 -> 2 processes: angular part of phase space integral
+ ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
+ ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
+ & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
+ ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
+ & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
+ ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
+ & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
+ ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
+ & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
+ H3=COEF(ISUBSV,13)+
+ & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
+ & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
+ & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
+ & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
+ COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
+
+C...2 -> 2 processes: take into account final state Breit-Wigners
+ COMFAC=COMFAC*VINT(80)
+ ENDIF
+
+C...2 -> 3, 4 processes: phace space integral in tau'
+ IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
+ ATAUP1=LOG(TAUPMX/TAUPMN)
+ ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
+ H4=COEF(ISUBSV,18)+
+ & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
+ IF(MINT(47).EQ.5) THEN
+ ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
+ H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
+ ENDIF
+ COMFAC=COMFAC*ATAUP1/H4
+ ENDIF
+
+C...2 -> 3, 4 processes: effective W/Z parton distributions
+ IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
+ IF(1D0-TAU/TAUP.GT.1.D-4) THEN
+ FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
+ ELSE
+ FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
+ ENDIF
+ COMFAC=COMFAC*FZW
+ ENDIF
+
+C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
+ IF(ISTSB.EQ.5) THEN
+ COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
+ & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
+ ENDIF
+
+C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
+ IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
+ &SQPTH**2/(PARP(82)**2+SQPTH)**2
+
+C...gamma + gamma: include factor 2 when different nature
+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
+ &COMFAC=2D0*COMFAC
+
+C...Phase space integral for low-pT and multiple interactions
+ IF(ISTSB.EQ.9) THEN
+ COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
+ ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
+ ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
+ H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
+ COMFAC=COMFAC*ATAU1/H1
+ AYST0=YSTMAX-YSTMIN
+ AYST1=0.5D0*(YSTMAX-YSTMIN)**2
+ AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
+ H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
+ & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
+ & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
+ COMFAC=COMFAC*AYST0/H2
+ IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
+C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
+C...introduced to make cross-section finite for xT2 -> 0
+ IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
+ & (1D0+VINT(149)))
+ ENDIF
+
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
+ &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
+C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
+ IF(MSTP(46).LE.4) THEN
+ HDTLH=LOG(PMAS(25,1)/PARP(44))
+ HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
+ HDTNR=-1D0/18D0+HDTLH/6D0
+ ELSE
+ HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
+ HDTLQ=LOG(PARP(45)/PARP(44))
+ HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
+ HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
+ ENDIF
+
+C...Calculate lowest and next-to-lowest order partial wave amplitudes
+ HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
+ A00L=SNGL(HDTV*SH)
+ A20L=-0.5*A00L
+ A11L=A00L/6.
+ HDTLS=LOG(SH/PARP(44)**2)
+ A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
+ & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
+ & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
+ A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
+ & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
+ & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
+ A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
+ & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
+
+C...Unitarize partial wave amplitudes with Pade or K-matrix method
+ IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
+ A00U=A00L/(1.-A004/A00L)
+ A20U=A20L/(1.-A204/A20L)
+ A11U=A11L/(1.-A114/A11L)
+ ELSE
+ A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
+ A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
+ A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
+ ENDIF
+ ENDIF
+
+C...Supersymmetric processes - all of type 2 -> 2 :
+C...correct final-state Breit-Wigners from fixed to running width.
+ IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
+ DO 160 I=1,2
+ KFLW=KFPR(ISUBSV,I)
+ KCW=PYCOMP(KFLW)
+ IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
+ IF(I.EQ.1) SQMI=SQM3
+ IF(I.EQ.2) SQMI=SQM4
+ SQMS=PMAS(KCW,1)**2
+ GMMS=PMAS(KCW,1)*PMAS(KCW,2)
+ HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
+ CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
+ GMMI=SQRT(SQMI)*WDTP(0)
+ HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
+ COMFAC=COMFAC*(HBWI/HBWS)
+ 160 CONTINUE
+ ENDIF
+
+C...A: 2 -> 1, tree diagrams
+
+ 170 IF(ISUB.LE.10) THEN
+ IF(ISUB.EQ.1) THEN
+C...f + fbar -> gamma*/Z0
+ MINT(61)=2
+ CALL PYWIDT(23,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACZ=4D0*COMFAC*3D0
+ HP0=AEM/3D0*SH
+ HP1=AEM/3D0*XWC*SH
+ DO 180 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ HI0=HP0
+ IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
+ HI1=HP1
+ IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
+ & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
+ & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
+ & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
+ 180 CONTINUE
+
+ ELSEIF(ISUB.EQ.2) THEN
+C...f + fbar' -> W+/-
+ CALL PYWIDT(24,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
+ HP=AEM/(24D0*XW)*SH
+ DO 200 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
+ IA=IABS(I)
+ DO 190 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
+ JA=IABS(J)
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 190
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ HI=HP*2D0
+ IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
+ SIGH(NCHN)=HI*FACBW*HF
+ 190 CONTINUE
+ 200 CONTINUE
+
+ ELSEIF(ISUB.EQ.3) THEN
+C...f + fbar -> h0 (or H0, or A0)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ HP=AEM/(8D0*XW)*SH/SQMW*SH
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ DO 210 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
+ IA=IABS(I)
+ RMQ=PMAS(IA,1)**2/SH
+ HI=HP*RMQ
+ IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
+ IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
+ & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ IKFI=1
+ IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
+ IF(IA.GT.10) IKFI=3
+ HI=HI*PARU(150+10*IHIGG+IKFI)**2
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 210 CONTINUE
+
+ ELSEIF(ISUB.EQ.4) THEN
+C...gamma + W+/- -> W+/-
+
+ ELSEIF(ISUB.EQ.5) THEN
+C...Z0 + Z0 -> h0
+ CALL PYWIDT(25,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
+ HP=AEM/(8D0*XW)*SH/SQMW*SH
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ HI=HP/4D0
+ FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
+ DO 230 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
+ DO 220 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ EJ=KCHG(IABS(J),1)/3D0
+ AJ=SIGN(1D0,EJ)
+ VJ=AJ-4D0*EJ*XWV
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
+ 220 CONTINUE
+ 230 CONTINUE
+
+ ELSEIF(ISUB.EQ.6) THEN
+C...Z0 + W+/- -> W+/-
+
+ ELSEIF(ISUB.EQ.7) THEN
+C...W+ + W- -> Z0
+
+ ELSEIF(ISUB.EQ.8) THEN
+C...W+ + W- -> h0
+ CALL PYWIDT(25,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
+ HP=AEM/(8D0*XW)*SH/SQMW*SH
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ HI=HP/2D0
+ FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
+ DO 250 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
+ EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
+ DO 240 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
+ EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
+ IF(EI*EJ.GT.0D0) GOTO 240
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
+ 240 CONTINUE
+ 250 CONTINUE
+
+C...B: 2 -> 2, tree diagrams
+
+ ELSEIF(ISUB.EQ.10) THEN
+C...f + f' -> f + f' (gamma/Z/W exchange)
+ FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
+ FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
+ FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
+ FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
+ DO 270 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
+ IA=IABS(I)
+ DO 260 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
+ JA=IABS(J)
+C...Electroweak couplings
+ EI=KCHG(IA,1)*ISIGN(1,I)/3D0
+ AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
+ VI=AI-4D0*EI*XWV
+ EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
+ AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
+ VJ=AJ-4D0*EJ*XWV
+ EPSIJ=ISIGN(1,I*J)
+C...gamma/Z exchange, only gamma exchange, or only Z exchange
+ IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
+ IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
+ FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
+ & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
+ & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
+ & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
+ ELSEIF(MSTP(21).EQ.2) THEN
+ FACNCF=FACGGF*EI**2*EJ**2
+ ELSE
+ FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
+ & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACNCF
+ ENDIF
+C...W exchange
+ IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
+ FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
+ IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
+ IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
+ IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACCCF
+ ENDIF
+ 260 CONTINUE
+ 270 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.20) THEN
+ IF(ISUB.EQ.11) THEN
+C...f + f' -> f + f' (g exchange)
+ FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
+ FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
+ & MSTP(34)*2D0/3D0*UH2/(SH*TH))
+ FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
+ & MSTP(34)*2D0/3D0*SH2/(TH*UH))
+ IF(MSTP(5).GE.1) THEN
+C...Modifications from contact interactions (compositeness)
+ FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
+ FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
+ & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
+ FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
+ & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
+ FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
+ ENDIF
+ DO 290 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
+ DO 280 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
+ & JA.GE.3))) THEN
+ SIGH(NCHN)=FACQQ1
+ IF(I.EQ.-J) SIGH(NCHN)=FACQQB
+ ELSE
+ SIGH(NCHN)=FACCI1
+ IF(I*J.LT.0) SIGH(NCHN)=FACCI3
+ IF(I.EQ.-J) SIGH(NCHN)=FACCIB
+ ENDIF
+ IF(I.EQ.J) THEN
+ SIGH(NCHN)=0.5D0*SIGH(NCHN)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
+ SIGH(NCHN)=0.5D0*FACQQ2
+ ELSE
+ SIGH(NCHN)=0.5D0*FACCI2
+ ENDIF
+ ENDIF
+ 280 CONTINUE
+ 290 CONTINUE
+
+ ELSEIF(ISUB.EQ.12) THEN
+C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
+ CALL PYWIDT(21,SH,WDTP,WDTE)
+ FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
+ & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ IF(MSTP(5).EQ.1) THEN
+C...Modifications from contact interactions (compositeness)
+ FACCIB=FACQQB
+ DO 300 I=1,2
+ FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
+ & WDTE(I,2)+WDTE(I,4))
+ 300 CONTINUE
+ ELSEIF(MSTP(5).GE.2) THEN
+ FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
+ & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ ENDIF
+ DO 310 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
+ SIGH(NCHN)=FACQQB
+ ELSE
+ SIGH(NCHN)=FACCIB
+ ENDIF
+ 310 CONTINUE
+
+ ELSEIF(ISUB.EQ.13) THEN
+C...f + fbar -> g + g (q + qbar -> g + g only)
+ FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
+ & UH2/SH2)
+ FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
+ & TH2/SH2)
+ DO 320 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACGG1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=0.5D0*FACGG2
+ 320 CONTINUE
+
+ ELSEIF(ISUB.EQ.14) THEN
+C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
+ FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
+ DO 330 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
+ EI=KCHG(IABS(I),1)/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGG*EI**2
+ 330 CONTINUE
+
+ ELSEIF(ISUB.EQ.15) THEN
+C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
+ FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
+C...gamma, gamma/Z interference and Z couplings to final fermion pairs
+ HFGG=0D0
+ HFGZ=0D0
+ HFZZ=0D0
+ RADC4=1D0+PYALPS(SQM4)/PARU(1)
+ DO 340 I=1,MIN(16,MDCY(23,3))
+ IDC=I+MDCY(23,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 340
+ IMDM=0
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
+ & IMDM=1
+ IF(I.LE.8) THEN
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ELSEIF(I.LE.16) THEN
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC4
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.EQ.1) THEN
+ HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ 340 CONTINUE
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
+ MINT(15)=1
+ MINT(61)=1
+ CALL PYWIDT(23,SQM4,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ HFGG=HFGG*HFAEM*VINT(111)/SQM4
+ HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
+ HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
+C...Loop over flavours; consider full gamma/Z structure
+ DO 350 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
+ & (VI**2+AI**2)*HFZZ)/HBW4
+ 350 CONTINUE
+
+ ELSEIF(ISUB.EQ.16) THEN
+C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
+ FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
+ GMMWC=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
+ FACWG=FACWG*HBW4C/HBW4
+ DO 370 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
+ DO 360 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
+ FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWG*FCKM*WIDSC
+ 360 CONTINUE
+ 370 CONTINUE
+
+ ELSEIF(ISUB.EQ.17) THEN
+C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
+
+ ELSEIF(ISUB.EQ.18) THEN
+C...f + fbar -> gamma + gamma
+ FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
+ DO 380 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
+ EI=KCHG(IABS(I),1)/3D0
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
+ 380 CONTINUE
+
+ ELSEIF(ISUB.EQ.19) THEN
+C...f + fbar -> gamma + (gamma*/Z0)
+ FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
+C...gamma, gamma/Z interference and Z couplings to final fermion pairs
+ HFGG=0D0
+ HFGZ=0D0
+ HFZZ=0D0
+ RADC4=1D0+PYALPS(SQM4)/PARU(1)
+ DO 390 I=1,MIN(16,MDCY(23,3))
+ IDC=I+MDCY(23,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 390
+ IMDM=0
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
+ & IMDM=1
+ IF(I.LE.8) THEN
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ELSEIF(I.LE.16) THEN
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC4
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.EQ.1) THEN
+ HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ 390 CONTINUE
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
+ MINT(15)=1
+ MINT(61)=1
+ CALL PYWIDT(23,SQM4,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ HFGG=HFGG*HFAEM*VINT(111)/SQM4
+ HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
+ HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
+C...Loop over flavours; consider full gamma/Z structure
+ DO 400 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
+ & (VI**2+AI**2)*HFZZ)/HBW4
+ 400 CONTINUE
+
+ ELSEIF(ISUB.EQ.20) THEN
+C...f + fbar' -> gamma + W+/-
+ FACGW=COMFAC*0.5D0*AEM**2/XW
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
+ GMMWC=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
+ FACGW=FACGW*HBW4C/HBW4
+C...Anomalous couplings
+ TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
+ TERM2=0D0
+ TERM3=0D0
+ IF(MSTP(5).GE.1) THEN
+ TERM2=PARU(153)*(TH-UH)/(TH+UH)
+ TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
+ & (4D0*SQMW))/(TH+UH)**2
+ ENDIF
+ DO 420 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
+ DO 410 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 410
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
+ IF(IA.LE.10) THEN
+ FACWR=UH/(TH+UH)-1D0/3D0
+ FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ FCOI=FACA/3D0
+ ELSE
+ FACWR=-TH/(TH+UH)
+ FCKM=1D0
+ FCOI=1D0
+ ENDIF
+ FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
+ 410 CONTINUE
+ 420 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.30) THEN
+ IF(ISUB.EQ.21) THEN
+C...f + fbar -> gamma + h0
+
+ ELSEIF(ISUB.EQ.22) THEN
+C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
+C...Kinematics dependence
+ FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
+ & SQM3*SQM4*(1D0/TH2+1D0/UH2))
+C...gamma, gamma/Z interference and Z couplings to final fermion pairs
+ DO 440 I=1,6
+ DO 430 J=1,3
+ HGZ(I,J)=0D0
+ 430 CONTINUE
+ 440 CONTINUE
+ RADC3=1D0+PYALPS(SQM3)/PARU(1)
+ RADC4=1D0+PYALPS(SQM4)/PARU(1)
+ DO 450 I=1,MIN(16,MDCY(23,3))
+ IDC=I+MDCY(23,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 450
+ IMDM=0
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
+ IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
+ IF(I.LE.8) THEN
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ELSEIF(I.LE.16) THEN
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC3
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.GE.1) THEN
+ HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC4
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.GE.1) THEN
+ HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ 450 CONTINUE
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
+ HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
+ MINT(15)=1
+ MINT(61)=1
+ CALL PYWIDT(23,SQM3,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ DO 460 J=1,3
+ HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
+ HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
+ HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
+ 460 CONTINUE
+ MINT(61)=1
+ CALL PYWIDT(23,SQM4,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ DO 470 J=1,3
+ HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
+ HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
+ HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
+ 470 CONTINUE
+C...Loop over flavours; separate left- and right-handed couplings
+ DO 490 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ VALI=VI-AI
+ VARI=VI+AI
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ DO 480 J=1,3
+ HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
+ HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
+ HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
+ HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
+ 480 CONTINUE
+ FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
+ & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
+ & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
+ & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
+ 490 CONTINUE
+
+ ELSEIF(ISUB.EQ.23) THEN
+C...f + fbar' -> Z0 + W+/-
+ FACZW=COMFAC*0.5D0*(AEM/XW)**2
+ FACZW=FACZW*WIDS(23,2)
+ THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
+ FACBW=1D0/((SH-SQMW)**2+GMMW**2)
+ DO 510 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
+ DO 500 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 500
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ EI=KCHG(IA,1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ EJ=KCHG(JA,1)/3D0
+ AJ=SIGN(1D0,EJ+0.1D0)
+ VJ=AJ-4D0*EJ*XWV
+ IF(VI+AI.GT.0) THEN
+ VISAV=VI
+ AISAV=AI
+ VI=VJ
+ AI=AJ
+ VJ=VISAV
+ AJ=AISAV
+ ENDIF
+ FCKM=1D0
+ IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ FCOI=1D0
+ IF(IA.LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
+ & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
+ & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
+ & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
+ & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
+ & WIDS(24,(5-KCHW)/2)
+ 500 CONTINUE
+ 510 CONTINUE
+
+ ELSEIF(ISUB.EQ.24) THEN
+C...f + fbar -> Z0 + h0 (or H0, or A0)
+ THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
+ FACHZ=COMFAC*8D0*(AEM*XWC)**2*
+ & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
+ FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
+ & PARU(154+10*IHIGG)**2
+ DO 520 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
+ 520 CONTINUE
+
+ ELSEIF(ISUB.EQ.25) THEN
+C...f + fbar -> W+ + W-
+C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
+ CALL PYWIDT(23,SH,WDTP,WDTE)
+ GMMZC=SHR*WDTP(0)
+ HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
+ HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM3,WDTP,WDTE)
+ GMMW3=SQRT(SQM3)*WDTP(0)
+ HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
+ HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
+ GMMW4=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
+C...Kinematical functions
+ THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
+ THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
+ GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
+ GT=THUH34+4D0*THUH/TH2
+ GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
+ GU=THUH34+4D0*THUH/UH2
+ GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
+C...Common factors and couplings
+ FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
+ FACWW=FACWW*WIDS(24,1)
+ CGG=AEM**2/2D0
+ CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
+ CZZ=AEM**2/(32D0*XW**2)*HBWZC
+ CNG=AEM**2/(4D0*XW)
+ CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
+ CNN=AEM**2/(16D0*XW**2)
+C...Coulomb factor for W+W- pair
+ IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
+ COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
+ COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
+ IF(COULE.LT.100D0*PMAS(24,2)) THEN
+ COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
+ & PMAS(24,2)**2)-COULE))
+ ELSE
+ COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
+ ENDIF
+ IF(COULE.GT.-100D0*PMAS(24,2)) THEN
+ COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
+ & PMAS(24,2)**2)+COULE))
+ ELSE
+ COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
+ & ABS(COULE)))
+ ENDIF
+ IF(MSTP(40).EQ.1) THEN
+ COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
+ & MAX(1D-10,2D0*COULP*COULP1))
+ FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
+ ELSEIF(MSTP(40).EQ.2) THEN
+ COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
+ COULCP=CMPLX(0.,SNGL(COULP))
+ COULCD=(COULCK+COULCP)/(COULCK-COULCP)
+ COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
+ COULCS=CMPLX(0.,0.)
+ NSTP=100
+ DO 530 ISTP=1,NSTP
+ COULXX=(ISTP-0.5)/NSTP
+ COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
+ & (1.+COULXX/COULCD))
+ 530 CONTINUE
+ COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
+ & (COULCS/NSTP)
+ FACCOU=ABS(COULCR)**2
+ ELSEIF(MSTP(40).EQ.3) THEN
+ COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
+ & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
+ FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
+ ENDIF
+ ELSEIF(MSTP(40).EQ.4) THEN
+ FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
+ ELSE
+ FACCOU=1D0
+ ENDIF
+ VINT(95)=FACCOU
+ FACWW=FACWW*FACCOU
+C...Loop over allowed flavours
+ DO 540 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ IF(AI.LT.0D0) THEN
+ DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
+ & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
+ ELSE
+ DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
+ & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWW*FCOI*DSIGWW
+ 540 CONTINUE
+
+ ELSEIF(ISUB.EQ.26) THEN
+C...f + fbar' -> W+/- + h0 (or H0, or A0)
+ THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
+ FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
+ & ((SH-SQMW)**2+GMMW**2)
+ FACHW=FACHW*WIDS(KFHIGG,2)
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
+ & PARU(155+10*IHIGG)**2
+ DO 560 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
+ DO 550 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 550
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ FCKM=1D0
+ IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ FCOI=1D0
+ IF(IA.LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
+ 550 CONTINUE
+ 560 CONTINUE
+
+ ELSEIF(ISUB.EQ.27) THEN
+C...f + fbar -> h0 + h0
+
+ ELSEIF(ISUB.EQ.28) THEN
+C...f + g -> f + g (q + g -> q + g only)
+ FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
+ & UH/SH)*FACA
+ FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
+ & SH/UH)
+ DO 580 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
+ DO 570 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQG1
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQG2
+ 570 CONTINUE
+ 580 CONTINUE
+
+ ELSEIF(ISUB.EQ.29) THEN
+C...f + g -> f + gamma (q + g -> q + gamma only)
+ FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
+ DO 600 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
+ EI=KCHG(IABS(I),1)/3D0
+ FACGQ=FGQ*EI**2
+ DO 590 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGQ
+ 590 CONTINUE
+ 600 CONTINUE
+
+ ELSEIF(ISUB.EQ.30) THEN
+C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
+ FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
+ & (-SH*UH)
+C...gamma, gamma/Z interference and Z couplings to final fermion pairs
+ HFGG=0D0
+ HFGZ=0D0
+ HFZZ=0D0
+ RADC4=1D0+PYALPS(SQM4)/PARU(1)
+ DO 610 I=1,MIN(16,MDCY(23,3))
+ IDC=I+MDCY(23,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 610
+ IMDM=0
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
+ & IMDM=1
+ IF(I.LE.8) THEN
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ELSEIF(I.LE.16) THEN
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC4
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.EQ.1) THEN
+ HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ 610 CONTINUE
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
+ MINT(15)=1
+ MINT(61)=1
+ CALL PYWIDT(23,SQM4,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ HFGG=HFGG*HFAEM*VINT(111)/SQM4
+ HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
+ HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
+C...Loop over flavours; consider full gamma/Z structure
+ DO 630 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
+ & (VI**2+AI**2)*HFZZ)/HBW4
+ DO 620 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZQ
+ 620 CONTINUE
+ 630 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.40) THEN
+ IF(ISUB.EQ.31) THEN
+C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
+ FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
+ & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
+ GMMWC=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
+ FACWQ=FACWQ*HBW4C/HBW4
+ DO 650 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
+ IA=IABS(I)
+ KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
+ WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
+ DO 640 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
+ 640 CONTINUE
+ 650 CONTINUE
+
+ ELSEIF(ISUB.EQ.32) THEN
+C...f + g -> f + h0 (q + g -> q + h0 only)
+
+ ELSEIF(ISUB.EQ.33) THEN
+C...f + gamma -> f + g (q + gamma -> q + g only)
+ FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
+ DO 670 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
+ EI=KCHG(IABS(I),1)/3D0
+ FACGQ=FGQ*EI**2
+ DO 660 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
+ IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGQ
+ 660 CONTINUE
+ 670 CONTINUE
+
+ ELSEIF(ISUB.EQ.34) THEN
+C...f + gamma -> f + gamma
+ FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
+ DO 690 I=MMINA,MMAXA
+ IF(I.EQ.0) GOTO 690
+ EI=KCHG(IABS(I),1)/3D0
+ FACGQ=FGQ*EI**4
+ DO 680 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
+ IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGQ
+ 680 CONTINUE
+ 690 CONTINUE
+
+ ELSEIF(ISUB.EQ.35) THEN
+C...f + gamma -> f + (gamma*/Z0)
+ FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
+ FZQD=SQPTH*SQM4-SH*UH
+C...gamma, gamma/Z interference and Z couplings to final fermion pairs
+ HFGG=0D0
+ HFGZ=0D0
+ HFZZ=0D0
+ RADC4=1D0+PYALPS(SQM4)/PARU(1)
+ DO 700 I=1,MIN(16,MDCY(23,3))
+ IDC=I+MDCY(23,2)-1
+ IF(MDME(IDC,1).LT.0) GOTO 700
+ IMDM=0
+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
+ & IMDM=1
+ IF(I.LE.8) THEN
+ EF=KCHG(I,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ELSEIF(I.LE.16) THEN
+ EF=KCHG(I+2,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ ENDIF
+ RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
+ IF(4D0*RM1.LT.1D0) THEN
+ FCOF=1D0
+ IF(I.LE.8) FCOF=3D0*RADC4
+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
+ IF(IMDM.EQ.1) THEN
+ HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
+ HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
+ HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
+ & AF**2*(1D0-4D0*RM1))*BE34
+ ENDIF
+ ENDIF
+ 700 CONTINUE
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
+ MINT(15)=1
+ MINT(61)=1
+ CALL PYWIDT(23,SQM4,WDTP,WDTE)
+ HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
+ HFGG=HFGG*HFAEM*VINT(111)/SQM4
+ HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
+ HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
+C...Loop over flavours; consider full gamma/Z structure
+ DO 720 I=MMINA,MMAXA
+ IF(I.EQ.0) GOTO 720
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
+ & (VI**2+AI**2)*HFZZ)/HBW4
+ DO 710 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
+ IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
+ 710 CONTINUE
+ 720 CONTINUE
+
+ ELSEIF(ISUB.EQ.36) THEN
+C...f + gamma -> f' + W+/-
+ FWQ=COMFAC*AEM**2/(2D0*XW)*
+ & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
+C...Propagators: as simulated in PYOFSH and as desired
+ HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
+ GMMWC=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
+ FWQ=FWQ*HBW4C/HBW4
+ DO 740 I=MMINA,MMAXA
+ IF(I.EQ.0) GOTO 740
+ IA=IABS(I)
+ EIA=ABS(KCHG(IABS(I),1)/3D0)
+ FACWQ=FWQ*(EIA-SH/(SH+UH))**2
+ KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
+ WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
+ DO 730 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
+ IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
+ 730 CONTINUE
+ 740 CONTINUE
+
+ ELSEIF(ISUB.EQ.37) THEN
+C...f + gamma -> f + h0
+
+ ELSEIF(ISUB.EQ.38) THEN
+C...f + Z0 -> f + g (q + Z0 -> q + g only)
+
+ ELSEIF(ISUB.EQ.39) THEN
+C...f + Z0 -> f + gamma
+
+ ELSEIF(ISUB.EQ.40) THEN
+C...f + Z0 -> f + Z0
+ ENDIF
+
+ ELSEIF(ISUB.LE.50) THEN
+ IF(ISUB.EQ.41) THEN
+C...f + Z0 -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.42) THEN
+C...f + Z0 -> f + h0
+
+ ELSEIF(ISUB.EQ.43) THEN
+C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
+
+ ELSEIF(ISUB.EQ.44) THEN
+C...f + W+/- -> f' + gamma
+
+ ELSEIF(ISUB.EQ.45) THEN
+C...f + W+/- -> f' + Z0
+
+ ELSEIF(ISUB.EQ.46) THEN
+C...f + W+/- -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.47) THEN
+C...f + W+/- -> f' + h0
+
+ ELSEIF(ISUB.EQ.48) THEN
+C...f + h0 -> f + g (q + h0 -> q + g only)
+
+ ELSEIF(ISUB.EQ.49) THEN
+C...f + h0 -> f + gamma
+
+ ELSEIF(ISUB.EQ.50) THEN
+C...f + h0 -> f + Z0
+ ENDIF
+
+ ELSEIF(ISUB.LE.60) THEN
+ IF(ISUB.EQ.51) THEN
+C...f + h0 -> f' + W+/-
+
+ ELSEIF(ISUB.EQ.52) THEN
+C...f + h0 -> f + h0
+
+ ELSEIF(ISUB.EQ.53) THEN
+C...g + g -> f + fbar (g + g -> q + qbar only)
+ CALL PYWIDT(21,SH,WDTP,WDTE)
+ FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
+ & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
+ FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
+ & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ2
+ 750 CONTINUE
+
+ ELSEIF(ISUB.EQ.54) THEN
+C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
+ CALL PYWIDT(21,SH,WDTP,WDTE)
+ WDTESU=0D0
+ DO 760 I=1,MIN(8,MDCY(21,3))
+ EF=KCHG(I,1)/3D0
+ WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
+ & WDTE(I,4))
+ 760 CONTINUE
+ FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
+ IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ
+ ENDIF
+ IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ
+ ENDIF
+
+ ELSEIF(ISUB.EQ.55) THEN
+C...g + Z -> f + fbar (g + Z -> q + qbar only)
+
+ ELSEIF(ISUB.EQ.56) THEN
+C...g + W -> f + f'bar (g + W -> q + q'bar only)
+
+ ELSEIF(ISUB.EQ.57) THEN
+C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
+
+ ELSEIF(ISUB.EQ.58) THEN
+C...gamma + gamma -> f + fbar
+ CALL PYWIDT(22,SH,WDTP,WDTE)
+ WDTESU=0D0
+ DO 770 I=1,MIN(12,MDCY(22,3))
+ IF(I.LE.8) EF= KCHG(I,1)/3D0
+ IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
+ WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
+ & WDTE(I,4))
+ 770 CONTINUE
+ FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
+ IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACFF
+ ENDIF
+
+ ELSEIF(ISUB.EQ.59) THEN
+C...gamma + Z0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.60) THEN
+C...gamma + W+/- -> f + fbar'
+ ENDIF
+
+ ELSEIF(ISUB.LE.70) THEN
+ IF(ISUB.EQ.61) THEN
+C...gamma + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.62) THEN
+C...Z0 + Z0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.63) THEN
+C...Z0 + W+/- -> f + fbar'
+
+ ELSEIF(ISUB.EQ.64) THEN
+C...Z0 + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.65) THEN
+C...W+ + W- -> f + fbar
+
+ ELSEIF(ISUB.EQ.66) THEN
+C...W+/- + h0 -> f + fbar'
+
+ ELSEIF(ISUB.EQ.67) THEN
+C...h0 + h0 -> f + fbar
+
+ ELSEIF(ISUB.EQ.68) THEN
+C...g + g -> g + g
+ FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
+ & TH2/SH2)*FACA
+ FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
+ & SH2/UH2)*FACA
+ FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
+ & UH2/TH2)
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACGG1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=0.5D0*FACGG2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=3
+ SIGH(NCHN)=0.5D0*FACGG3
+ 780 CONTINUE
+
+ ELSEIF(ISUB.EQ.69) THEN
+C...gamma + gamma -> W+ + W-
+ SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
+ FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
+ FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
+ & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
+ IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWW
+ 790 CONTINUE
+
+ ELSEIF(ISUB.EQ.70) THEN
+C...gamma + W+/- -> Z0 + W+/-
+ SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
+ FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
+ FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
+ & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
+ & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
+ DO 810 KCHW=1,-1,-2
+ DO 800 ISDE=1,2
+ IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=22
+ ISIG(NCHN,3-ISDE)=24*KCHW
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
+ 800 CONTINUE
+ 810 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.80) THEN
+ IF(ISUB.EQ.71) THEN
+C...Z0 + Z0 -> Z0 + Z0
+ IF(SH.LE.4.01D0*SQMZ) GOTO 840
+
+ IF(MSTP(46).LE.2) THEN
+C...Exact scattering ME:s for on-mass-shell gauge bosons
+ BE2=1D0-4D0*SQMZ/SH
+ TH=-0.5D0*SH*BE2*(1D0-CTH)
+ UH=-0.5D0*SH*BE2*(1D0+CTH)
+ IF(MAX(TH,UH).GT.-1D0) GOTO 840
+ SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
+ ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
+ ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
+ THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
+ ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
+ ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
+ UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
+ AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
+ AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
+ FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
+ & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
+ IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
+ IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
+ & (ASHIM+ATHIM+AUHIM)**2)
+ IF(MSTP(46).EQ.2) FACZZ=0D0
+
+ ELSE
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
+ & ABS(A00U+2.*A20U)**2
+ ENDIF
+ FACZZ=FACZZ*WIDS(23,1)
+
+ DO 830 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ AVI=AI**2+VI**2
+ DO 820 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
+ EJ=KCHG(IABS(J),1)/3D0
+ AJ=SIGN(1D0,EJ)
+ VJ=AJ-4D0*EJ*XWV
+ AVJ=AJ**2+VJ**2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
+ 820 CONTINUE
+ 830 CONTINUE
+ 840 CONTINUE
+
+ ELSEIF(ISUB.EQ.72) THEN
+C...Z0 + Z0 -> W+ + W-
+ IF(SH.LE.4.01D0*SQMZ) GOTO 870
+
+ IF(MSTP(46).LE.2) THEN
+C...Exact scattering ME:s for on-mass-shell gauge bosons
+ BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
+ CTH2=CTH**2
+ TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
+ UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
+ IF(MAX(TH,UH).GT.-1D0) GOTO 870
+ SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
+ & (1D0-2D0*SQMZ/SH)
+ ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
+ ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
+ ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
+ & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
+ & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
+ ATWIM=0D0
+ AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
+ & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
+ & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
+ AUWIM=0D0
+ A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
+ A4IM=0D0
+ FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
+ & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
+ IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
+ IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
+ & (ASHIM+ATWIM+AUWIM+A4IM)**2)
+ IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
+ & (ATWIM+AUWIM+A4IM)**2)
+
+ ELSE
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
+ & ABS(A00U-A20U)**2
+ ENDIF
+ FACWW=FACWW*WIDS(24,1)
+
+ DO 860 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ AVI=AI**2+VI**2
+ DO 850 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
+ EJ=KCHG(IABS(J),1)/3D0
+ AJ=SIGN(1D0,EJ)
+ VJ=AJ-4D0*EJ*XWV
+ AVJ=AJ**2+VJ**2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWW*AVI*AVJ
+ 850 CONTINUE
+ 860 CONTINUE
+ 870 CONTINUE
+
+ ELSEIF(ISUB.EQ.73) THEN
+C...Z0 + W+/- -> Z0 + W+/-
+ IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
+
+ IF(MSTP(46).LE.2) THEN
+C...Exact scattering ME:s for on-mass-shell gauge bosons
+ BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
+ EP1=1D0-(SQMZ-SQMW)/SH
+ EP2=1D0+(SQMZ-SQMW)/SH
+ TH=-0.5D0*SH*BE2*(1D0-CTH)
+ UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
+ IF(MAX(TH,UH).GT.-1D0) GOTO 900
+ THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
+ ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
+ ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
+ ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
+ & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
+ & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
+ & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
+ ASWIM=0D0
+ AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
+ & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
+ & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
+ & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
+ & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
+ & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
+ & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
+ & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
+ & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
+ & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
+ & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
+ & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
+ AUWIM=0D0
+ A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
+ & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
+ A4IM=0D0
+ FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
+ & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
+ IF(MSTP(46).LE.0) FACZW=0D0
+ IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
+ & (ATHIM+ASWIM+AUWIM+A4IM)**2)
+ IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
+ & (ASWIM+AUWIM+A4IM)**2)
+
+ ELSE
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
+ & ABS(A20U+3.*A11U*SNGL(CTH))**2
+ ENDIF
+ FACZW=FACZW*WIDS(23,2)
+
+ DO 890 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ AVI=AI**2+VI**2
+ KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
+ DO 880 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
+ EJ=KCHG(IABS(J),1)/3D0
+ AJ=SIGN(1D0,EJ)
+ VJ=AI-4D0*EJ*XWV
+ AVJ=AJ**2+VJ**2
+ KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
+ 880 CONTINUE
+ 890 CONTINUE
+ 900 CONTINUE
+
+ ELSEIF(ISUB.EQ.75) THEN
+C...W+ + W- -> gamma + gamma
+
+ ELSEIF(ISUB.EQ.76) THEN
+C...W+ + W- -> Z0 + Z0
+ IF(SH.LE.4.01D0*SQMZ) GOTO 930
+
+ IF(MSTP(46).LE.2) THEN
+C...Exact scattering ME:s for on-mass-shell gauge bosons
+ BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
+ CTH2=CTH**2
+ TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
+ UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
+ IF(MAX(TH,UH).GT.-1D0) GOTO 930
+ SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
+ & (1D0-2D0*SQMZ/SH)
+ ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
+ ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
+ ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
+ & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
+ & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
+ ATWIM=0D0
+ AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
+ & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
+ & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
+ AUWIM=0D0
+ A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
+ A4IM=0D0
+ FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
+ & (SH/SQMW)**2*SH2
+ IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
+ IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
+ & (ASHIM+ATWIM+AUWIM+A4IM)**2)
+ IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
+ & (ATWIM+AUWIM+A4IM)**2)
+
+ ELSE
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
+ & ABS(A00U-A20U)**2
+ ENDIF
+ FACZZ=FACZZ*WIDS(23,1)
+
+ DO 920 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
+ EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
+ DO 910 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
+ EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
+ IF(EI*EJ.GT.0D0) GOTO 910
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
+ 910 CONTINUE
+ 920 CONTINUE
+ 930 CONTINUE
+
+ ELSEIF(ISUB.EQ.77) THEN
+C...W+/- + W+/- -> W+/- + W+/-
+ IF(SH.LE.4.01D0*SQMW) GOTO 960
+
+ IF(MSTP(46).LE.2) THEN
+C...Exact scattering ME:s for on-mass-shell gauge bosons
+ BE2=1D0-4D0*SQMW/SH
+ BE4=BE2**2
+ CTH2=CTH**2
+ CTH3=CTH**3
+ TH=-0.5D0*SH*BE2*(1D0-CTH)
+ UH=-0.5D0*SH*BE2*(1D0+CTH)
+ IF(MAX(TH,UH).GT.-1D0) GOTO 960
+ SHANG=(1D0+BE2)**2
+ ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
+ ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
+ THANG=(BE2-CTH)**2
+ ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
+ ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
+ UHANG=(BE2+CTH)**2
+ AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
+ AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
+ SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
+ ASGRE=XW*SGZANG
+ ASGIM=0D0
+ ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
+ ASZIM=0D0
+ TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
+ ATGRE=0.5D0*XW*SH/TH*TGZANG
+ ATGIM=0D0
+ ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
+ ATZIM=0D0
+ UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
+ AUGRE=0.5D0*XW*SH/UH*UGZANG
+ AUGIM=0D0
+ AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
+ AUZIM=0D0
+ A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
+ A4AIM=0D0
+ A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
+ A4SIM=0D0
+ FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
+ & (SH/SQMW)**2*SH2
+ IF(MSTP(46).LE.0) THEN
+ AWWARE=ASHRE
+ AWWAIM=ASHIM
+ AWWSRE=0D0
+ AWWSIM=0D0
+ ELSEIF(MSTP(46).EQ.1) THEN
+ AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
+ AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
+ AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
+ AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
+ ELSE
+ AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
+ AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
+ AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
+ AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
+ ENDIF
+ AWWA2=AWWARE**2+AWWAIM**2
+ AWWS2=AWWSRE**2+AWWSIM**2
+
+ ELSE
+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
+ FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
+ & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
+ FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
+ ENDIF
+
+ DO 950 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
+ EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
+ DO 940 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
+ EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
+ IF(EI*EJ.LT.0D0) THEN
+C...W+W-
+ IF(MSTP(45).EQ.1) GOTO 940
+ IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
+ IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
+ ELSE
+C...W+W+/W-W-
+ IF(MSTP(45).EQ.2) GOTO 940
+ IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
+ IF(MSTP(46).GE.3) FACWW=FWWS
+ IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
+ IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
+ IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
+ 940 CONTINUE
+ 950 CONTINUE
+ 960 CONTINUE
+
+ ELSEIF(ISUB.EQ.78) THEN
+C...W+/- + h0 -> W+/- + h0
+
+ ELSEIF(ISUB.EQ.79) THEN
+C...h0 + h0 -> h0 + h0
+
+ ELSEIF(ISUB.EQ.80) THEN
+C...q + gamma -> q' + pi+/-
+ FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
+ ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
+ Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
+ DELSH=UH*SQRT(ASSH*Q2FPSH)
+ ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
+ Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
+ DELUH=SH*SQRT(ASUH*Q2FPUH)
+ DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
+ IF(I.EQ.0) GOTO 980
+ EI=KCHG(IABS(I),1)/3D0
+ EJ=SIGN(1D0-ABS(EI),EI)
+ DO 970 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
+ IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
+ 970 CONTINUE
+ 980 CONTINUE
+
+ ENDIF
+
+C...C: 2 -> 2, tree diagrams with masses
+
+ ELSEIF(ISUB.LE.90) THEN
+ IF(ISUB.EQ.81) THEN
+C...q + qbar -> Q + Qbar
+ FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
+ & (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
+ IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
+ WID2=1D0
+ IF(MINT(55).EQ.6) WID2=WIDS(6,1)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
+ FACQQB=FACQQB*WID2
+ DO 990 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQB
+ 990 CONTINUE
+
+ ELSEIF(ISUB.EQ.82) THEN
+C...g + g -> Q + Qbar
+ IF(MSTP(34).EQ.0) THEN
+ FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
+ & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
+ & (TH-SQM3)**2)
+ FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
+ & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
+ & (UH-SQM3)**2)
+ ELSE
+ FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
+ & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
+ & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
+ & (SH*(TH-SQM3)))
+ FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
+ & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
+ & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
+ & (SH*(UH-SQM3)))
+ ENDIF
+ IF(MSTP(35).GE.1) THEN
+ FATRE=PYHFTH(SH,SQM3,2D0/7D0)
+ FACQQ1=FACQQ1*FATRE
+ FACQQ2=FACQQ2*FATRE
+ ENDIF
+ WID2=1D0
+ IF(MINT(55).EQ.6) WID2=WIDS(6,1)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
+ FACQQ1=FACQQ1*WID2
+ FACQQ2=FACQQ2*WID2
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ2
+ 1000 CONTINUE
+
+ ELSEIF(ISUB.EQ.83) THEN
+C...f + q -> f' + Q
+ FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
+ FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
+ DO 1020 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
+ DO 1010 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
+ IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
+ IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
+ IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
+ & THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
+ & (IABS(I)+1)/2)*VINT(180+J)
+ IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
+ & (MINT(55)+1)/2)*VINT(180+J)
+ WID2=1D0
+ IF(I.GT.0) THEN
+ IF(MINT(55).EQ.6) WID2=WIDS(6,2)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
+ & WIDS(MINT(55),2)
+ ELSE
+ IF(MINT(55).EQ.6) WID2=WIDS(6,3)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
+ & WIDS(MINT(55),3)
+ ENDIF
+ IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
+ IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
+ ENDIF
+ IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
+ & THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
+ & (IABS(J)+1)/2)*VINT(180+I)
+ IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
+ & (MINT(55)+1)/2)*VINT(180+I)
+ IF(J.GT.0) THEN
+ IF(MINT(55).EQ.6) WID2=WIDS(6,2)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
+ & WIDS(MINT(55),2)
+ ELSE
+ IF(MINT(55).EQ.6) WID2=WIDS(6,3)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
+ & WIDS(MINT(55),3)
+ ENDIF
+ IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
+ IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
+ ENDIF
+ 1010 CONTINUE
+ 1020 CONTINUE
+
+ ELSEIF(ISUB.EQ.84) THEN
+C...g + gamma -> Q + Qbar
+ FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
+ FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
+ & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
+ IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
+ WID2=1D0
+ IF(MINT(55).EQ.6) WID2=WIDS(6,1)
+ IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
+ FACQQ=FACQQ*WID2
+ IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ
+ ENDIF
+ IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ
+ ENDIF
+
+ ELSEIF(ISUB.EQ.85) THEN
+C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
+ FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
+ FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
+ & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
+ IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
+ IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
+ & FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
+ WID2=1D0
+ IF(MINT(56).EQ.6) WID2=WIDS(6,1)
+ IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
+ IF(MINT(56).EQ.17) WID2=WIDS(17,1)
+ FACFF=FACFF*WID2
+ IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACFF
+ ENDIF
+
+ ELSEIF(ISUB.EQ.86) THEN
+C...g + g -> J/Psi + g
+ FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
+ & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
+ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
+ IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+ ELSEIF(ISUB.EQ.87) THEN
+C...g + g -> chi_0c + g
+ PGTW=(SH*TH+TH*UH+UH*SH)/SH2
+ QGTW=(SH*TH*UH)/SH**3
+ RGTW=SQM3/SH
+ FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
+ & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
+ & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
+ & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
+ & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
+ & (QGTW*(QGTW-RGTW*PGTW)**4)
+ IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+ ELSEIF(ISUB.EQ.88) THEN
+C...g + g -> chi_1c + g
+ PGTW=(SH*TH+TH*UH+UH*SH)/SH2
+ QGTW=(SH*TH*UH)/SH**3
+ RGTW=SQM3/SH
+ FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
+ & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
+ & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
+ & (QGTW-RGTW*PGTW)**4
+ IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+ ELSEIF(ISUB.EQ.89) THEN
+C...g + g -> chi_2c + g
+ PGTW=(SH*TH+TH*UH+UH*SH)/SH2
+ QGTW=(SH*TH*UH)/SH**3
+ RGTW=SQM3/SH
+ FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
+ & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
+ & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
+ & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
+ & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
+ & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
+ IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+ ENDIF
+
+C...D: Mimimum bias processes
+
+ ELSEIF(ISUB.LE.100) THEN
+ IF(ISUB.EQ.91) THEN
+C...Elastic scattering
+ SIGS=SIGT(0,0,1)
+
+ ELSEIF(ISUB.EQ.92) THEN
+C...Single diffractive scattering (first side, i.e. XB)
+ SIGS=SIGT(0,0,2)
+
+ ELSEIF(ISUB.EQ.93) THEN
+C...Single diffractive scattering (second side, i.e. AX)
+ SIGS=SIGT(0,0,3)
+
+ ELSEIF(ISUB.EQ.94) THEN
+C...Double diffractive scattering
+ SIGS=SIGT(0,0,4)
+
+ ELSEIF(ISUB.EQ.95) THEN
+C...Low-pT scattering
+ SIGS=SIGT(0,0,5)
+
+ ELSEIF(ISUB.EQ.96) THEN
+C...Multiple interactions: sum of QCD processes
+ CALL PYWIDT(21,SH,WDTP,WDTE)
+
+C...q + q' -> q + q'
+ FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
+ FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
+ & MSTP(34)*2D0/3D0*UH2/(SH*TH))
+ FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
+ & MSTP(34)*2D0/3D0*SH2/(TH*UH))
+ DO 1040 I=-3,3
+ IF(I.EQ.0) GOTO 1040
+ DO 1030 J=-3,3
+ IF(J.EQ.0) GOTO 1030
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=111
+ SIGH(NCHN)=FACQQ1
+ IF(I.EQ.-J) SIGH(NCHN)=FACQQB
+ IF(I.EQ.J) THEN
+ SIGH(NCHN)=0.5D0*SIGH(NCHN)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=112
+ SIGH(NCHN)=0.5D0*FACQQ2
+ ENDIF
+ 1030 CONTINUE
+ 1040 CONTINUE
+
+C...q + qbar -> q' + qbar' or g + g
+ FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
+ & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
+ FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
+ & UH2/SH2)
+ FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
+ & TH2/SH2)
+ DO 1050 I=-3,3
+ IF(I.EQ.0) GOTO 1050
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=121
+ SIGH(NCHN)=FACQQB
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=131
+ SIGH(NCHN)=0.5D0*FACGG1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=132
+ SIGH(NCHN)=0.5D0*FACGG2
+ 1050 CONTINUE
+
+C...q + g -> q + g
+ FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
+ & UH/SH)*FACA
+ FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
+ & SH/UH)
+ DO 1070 I=-3,3
+ IF(I.EQ.0) GOTO 1070
+ DO 1060 ISDE=1,2
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=281
+ SIGH(NCHN)=FACQG1
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=282
+ SIGH(NCHN)=FACQG2
+ 1060 CONTINUE
+ 1070 CONTINUE
+
+C...g + g -> q + qbar or g + g
+ FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
+ & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
+ FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
+ & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
+ FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
+ & 2D0*TH/SH+TH2/SH2)*FACA
+ FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
+ & 2D0*SH/UH+SH2/UH2)*FACA
+ FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
+ & 2D0*UH/TH+UH2/TH2)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=531
+ SIGH(NCHN)=FACQQ1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=532
+ SIGH(NCHN)=FACQQ2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=681
+ SIGH(NCHN)=0.5D0*FACGG1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=682
+ SIGH(NCHN)=0.5D0*FACGG2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=683
+ SIGH(NCHN)=0.5D0*FACGG3
+ ENDIF
+
+C...E: 2 -> 1, loop diagrams
+
+ ELSEIF(ISUB.LE.110) THEN
+ IF(ISUB.EQ.101) THEN
+C...g + g -> gamma*/Z0
+
+ ELSEIF(ISUB.EQ.102) THEN
+C...g + g -> h0 (or H0, or A0)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ HI=SHR*WDTP(13)/32D0
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1080 CONTINUE
+
+ ELSEIF(ISUB.EQ.103) THEN
+C...gamma + gamma -> h0 (or H0, or A0)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ HI=SHR*WDTP(14)*2D0
+ IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1090 CONTINUE
+
+C...Continuation C: 2 -> 2, tree diagrams with masses.
+
+ ELSEIF(ISUB.EQ.106) THEN
+C...g + g -> J/Psi + gamma.
+ EQ=2D0/3D0
+ FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
+ & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
+ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
+ IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+ ELSEIF(ISUB.EQ.107) THEN
+C...g + gamma -> J/Psi + g.
+ EQ=2D0/3D0
+ FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
+ & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
+ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
+ IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+ IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+ ELSEIF(ISUB.EQ.108) THEN
+C...gamma + gamma -> J/Psi + gamma.
+ EQ=2D0/3D0
+ FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
+ & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
+ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
+ IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=22
+ ISIG(NCHN,2)=22
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQG
+ ENDIF
+
+C...F: 2 -> 2, box diagrams
+
+ ELSEIF(ISUB.EQ.110) THEN
+C...f + fbar -> gamma + h0
+ THUH=MAX(TH*UH,SH*CKIN(3)**2)
+ FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
+ FACHG=FACHG*WIDS(KFHIGG,2)
+C...Calculate loop contributions for intermediate gamma* and Z0
+ CIGTOT=CMPLX(0.,0.)
+ CIZTOT=CMPLX(0.,0.)
+ JMAX=3*MSTP(1)+1
+ DO 1100 J=1,JMAX
+ IF(J.LE.2*MSTP(1)) THEN
+ FNC=1D0
+ EJ=KCHG(J,1)/3D0
+ AJ=SIGN(1D0,EJ+0.1D0)
+ VJ=AJ-4D0*EJ*XWV
+ BALP=SQM4/(2D0*PMAS(J,1))**2
+ BBET=SH/(2D0*PMAS(J,1))**2
+ ELSEIF(J.LE.3*MSTP(1)) THEN
+ FNC=3D0
+ JL=2*(J-2*MSTP(1))-1
+ EJ=KCHG(10+JL,1)/3D0
+ AJ=SIGN(1D0,EJ+0.1D0)
+ VJ=AJ-4D0*EJ*XWV
+ BALP=SQM4/(2D0*PMAS(10+JL,1))**2
+ BBET=SH/(2D0*PMAS(10+JL,1))**2
+ ELSE
+ BALP=SQM4/(2D0*PMAS(24,1))**2
+ BBET=SH/(2D0*PMAS(24,1))**2
+ ENDIF
+ BABI=1D0/(BALP-BBET)
+ IF(BALP.LT.1D0) THEN
+ F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
+ F1ALP=F0ALP**2
+ ELSE
+ F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
+ & -SNGL(0.5D0*PARU(1)))
+ F1ALP=-F0ALP**2
+ ENDIF
+ F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
+ IF(BBET.LT.1D0) THEN
+ F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
+ F1BET=F0BET**2
+ ELSE
+ F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
+ & -SNGL(0.5D0*PARU(1)))
+ F1BET=-F0BET**2
+ ENDIF
+ F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
+ IF(J.LE.3*MSTP(1)) THEN
+ FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
+ & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
+ CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
+ CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
+ ELSE
+ TXW=XW/XW1
+ CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
+ & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
+ & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
+ CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
+ & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
+ & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
+ & (F1BET-F1ALP))
+ ENDIF
+ 1100 CONTINUE
+ CIGTOT=CIGTOT/SNGL(SH)
+ CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
+C...Loop over initial flavours
+ DO 1110 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
+ & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
+ 1110 CONTINUE
+
+ ENDIF
+
+ ELSEIF(ISUB.LE.120) THEN
+ IF(ISUB.EQ.111) THEN
+C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
+ A5STUR=0D0
+ A5STUI=0D0
+ DO 1120 I=1,2*MSTP(1)
+ SQMQ=PMAS(I,1)**2
+ EPSS=4D0*SQMQ/SH
+ EPSH=4D0*SQMQ/SQMH
+ CALL PYWAUX(1,EPSS,W1SR,W1SI)
+ CALL PYWAUX(1,EPSH,W1HR,W1HI)
+ CALL PYWAUX(2,EPSS,W2SR,W2SI)
+ CALL PYWAUX(2,EPSH,W2HR,W2HI)
+ A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
+ & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
+ A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
+ & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
+ 1120 CONTINUE
+ FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
+ & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
+ FACGH=FACGH*WIDS(25,2)
+ DO 1130 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGH
+ 1130 CONTINUE
+
+ ELSEIF(ISUB.EQ.112) THEN
+C...f + g -> f + h0 (q + g -> q + h0 only)
+ A5TSUR=0D0
+ A5TSUI=0D0
+ DO 1140 I=1,2*MSTP(1)
+ SQMQ=PMAS(I,1)**2
+ EPST=4D0*SQMQ/TH
+ EPSH=4D0*SQMQ/SQMH
+ CALL PYWAUX(1,EPST,W1TR,W1TI)
+ CALL PYWAUX(1,EPSH,W1HR,W1HI)
+ CALL PYWAUX(2,EPST,W2TR,W2TI)
+ CALL PYWAUX(2,EPSH,W2HR,W2HI)
+ A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
+ & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
+ A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
+ & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
+ 1140 CONTINUE
+ FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
+ & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
+ FACQH=FACQH*WIDS(25,2)
+ DO 1160 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
+ DO 1150 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQH
+ 1150 CONTINUE
+ 1160 CONTINUE
+
+ ELSEIF(ISUB.EQ.113) THEN
+C...g + g -> g + h0
+ A2STUR=0D0
+ A2STUI=0D0
+ A2USTR=0D0
+ A2USTI=0D0
+ A2TUSR=0D0
+ A2TUSI=0D0
+ A4STUR=0D0
+ A4STUI=0D0
+ DO 1170 I=1,2*MSTP(1)
+ SQMQ=PMAS(I,1)**2
+ EPSS=4D0*SQMQ/SH
+ EPST=4D0*SQMQ/TH
+ EPSU=4D0*SQMQ/UH
+ EPSH=4D0*SQMQ/SQMH
+ IF(EPSH.LT.1.D-6) GOTO 1170
+ CALL PYWAUX(1,EPSS,W1SR,W1SI)
+ CALL PYWAUX(1,EPST,W1TR,W1TI)
+ CALL PYWAUX(1,EPSU,W1UR,W1UI)
+ CALL PYWAUX(1,EPSH,W1HR,W1HI)
+ CALL PYWAUX(2,EPSS,W2SR,W2SI)
+ CALL PYWAUX(2,EPST,W2TR,W2TI)
+ CALL PYWAUX(2,EPSU,W2UR,W2UI)
+ CALL PYWAUX(2,EPSH,W2HR,W2HI)
+ CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
+ CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
+ CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
+ CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
+ CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
+ CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
+ CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
+ CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
+ CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
+ CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
+ CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
+ CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
+ W3STUR=YHSTUR-Y3STUR-Y3UTSR
+ W3STUI=YHSTUI-Y3STUI-Y3UTSI
+ W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
+ W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
+ W3TSUR=YHTSUR-Y3TSUR-Y3USTR
+ W3TSUI=YHTSUI-Y3TSUI-Y3USTI
+ W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
+ W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
+ W3USTR=YHUSTR-Y3USTR-Y3TSUR
+ W3USTI=YHUSTI-Y3USTI-Y3TSUI
+ W3UTSR=YHUTSR-Y3UTSR-Y3STUR
+ W3UTSI=YHUTSI-Y3UTSI-Y3STUI
+ B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
+ & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
+ & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
+ & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
+ & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
+ B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
+ & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
+ & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
+ & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
+ & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
+ B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
+ & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
+ & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
+ & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
+ & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
+ B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
+ & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
+ & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
+ & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
+ & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
+ B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
+ & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
+ & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
+ & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
+ & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
+ B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
+ & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
+ & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
+ & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
+ & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
+ B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
+ & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
+ & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
+ & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
+ & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
+ B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
+ & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
+ & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
+ & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
+ & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
+ B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
+ & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
+ & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
+ & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
+ & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
+ B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
+ & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
+ & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
+ & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
+ & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
+ B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
+ & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
+ & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
+ & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
+ & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
+ B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
+ & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
+ & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
+ & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
+ & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
+ B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
+ & (W2SR-W2HR+W3STUR))
+ B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
+ B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
+ & (W2TR-W2HR+W3TUSR))
+ B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
+ B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
+ & (W2UR-W2HR+W3USTR))
+ B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
+ A2STUR=A2STUR+B2STUR+B2SUTR
+ A2STUI=A2STUI+B2STUI+B2SUTI
+ A2USTR=A2USTR+B2USTR+B2UTSR
+ A2USTI=A2USTI+B2USTI+B2UTSI
+ A2TUSR=A2TUSR+B2TUSR+B2TSUR
+ A2TUSI=A2TUSI+B2TUSI+B2TSUI
+ A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
+ A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
+ 1170 CONTINUE
+ FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
+ & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
+ & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
+ FACGH=FACGH*WIDS(25,2)
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGH
+ 1180 CONTINUE
+
+ ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
+C...g + g -> gamma + gamma or g + g -> g + gamma
+ A0STUR=0D0
+ A0STUI=0D0
+ A0TSUR=0D0
+ A0TSUI=0D0
+ A0UTSR=0D0
+ A0UTSI=0D0
+ A1STUR=0D0
+ A1STUI=0D0
+ A2STUR=0D0
+ A2STUI=0D0
+ ALST=LOG(-SH/TH)
+ ALSU=LOG(-SH/UH)
+ ALTU=LOG(TH/UH)
+ IMAX=2*MSTP(1)
+ IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
+ DO 1190 I=1,IMAX
+ EI=KCHG(IABS(I),1)/3D0
+ EIWT=EI**2
+ IF(ISUB.EQ.115) EIWT=EI
+ SQMQ=PMAS(I,1)**2
+ EPSS=4D0*SQMQ/SH
+ EPST=4D0*SQMQ/TH
+ EPSU=4D0*SQMQ/UH
+ IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
+ B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
+ & PARU(1)**2)
+ B0STUI=0D0
+ B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
+ B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
+ B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
+ B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
+ B1STUR=-1D0
+ B1STUI=0D0
+ B2STUR=-1D0
+ B2STUI=0D0
+ ELSE
+ CALL PYWAUX(1,EPSS,W1SR,W1SI)
+ CALL PYWAUX(1,EPST,W1TR,W1TI)
+ CALL PYWAUX(1,EPSU,W1UR,W1UI)
+ CALL PYWAUX(2,EPSS,W2SR,W2SI)
+ CALL PYWAUX(2,EPST,W2TR,W2TI)
+ CALL PYWAUX(2,EPSU,W2UR,W2UI)
+ CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
+ CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
+ CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
+ CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
+ CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
+ CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
+ B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
+ & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
+ & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
+ & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
+ & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
+ & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
+ B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
+ & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
+ & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
+ & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
+ & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
+ & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
+ B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
+ & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
+ & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
+ & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
+ & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
+ & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
+ B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
+ & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
+ & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
+ & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
+ & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
+ & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
+ B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
+ & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
+ & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
+ & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
+ & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
+ & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
+ B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
+ & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
+ & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
+ & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
+ & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
+ & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
+ B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
+ & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
+ & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
+ & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
+ B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
+ & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
+ & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
+ & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
+ B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
+ & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
+ & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
+ B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
+ & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
+ & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
+ ENDIF
+ A0STUR=A0STUR+EIWT*B0STUR
+ A0STUI=A0STUI+EIWT*B0STUI
+ A0TSUR=A0TSUR+EIWT*B0TSUR
+ A0TSUI=A0TSUI+EIWT*B0TSUI
+ A0UTSR=A0UTSR+EIWT*B0UTSR
+ A0UTSI=A0UTSI+EIWT*B0UTSI
+ A1STUR=A1STUR+EIWT*B1STUR
+ A1STUI=A1STUI+EIWT*B1STUI
+ A2STUR=A2STUR+EIWT*B2STUR
+ A2STUI=A2STUI+EIWT*B2STUI
+ 1190 CONTINUE
+ ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
+ & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
+ FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
+ FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
+ IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
+ 1200 CONTINUE
+
+ ELSEIF(ISUB.EQ.116) THEN
+C...g + g -> gamma + Z0
+
+ ELSEIF(ISUB.EQ.117) THEN
+C...g + g -> Z0 + Z0
+
+ ELSEIF(ISUB.EQ.118) THEN
+C...g + g -> W+ + W-
+
+ ENDIF
+
+C...G: 2 -> 3, tree diagrams
+
+ ELSEIF(ISUB.LE.140) THEN
+ IF(ISUB.EQ.121) THEN
+C...g + g -> Q + Qbar + h0
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
+ IA=KFPR(ISUBSV,2)
+ PMF=PMAS(IA,1)
+ FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
+ & (0.5D0*PMF/PMAS(24,1))**2
+ IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
+ & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ WID2=1D0
+ IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
+ FACQQH=FACQQH*WID2
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ IKFI=1
+ IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
+ IF(IA.GT.10) IKFI=3
+ FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
+ ENDIF
+ CALL PYQQBH(WTQQBH)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQH*WTQQBH*FACBW
+ 1210 CONTINUE
+
+ ELSEIF(ISUB.EQ.122) THEN
+C...q + qbar -> Q + Qbar + h0
+ IA=KFPR(ISUBSV,2)
+ PMF=PMAS(IA,1)
+ FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
+ & (0.5D0*PMF/PMAS(24,1))**2
+ IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
+ & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ WID2=1D0
+ IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
+ FACQQH=FACQQH*WID2
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
+ IKFI=1
+ IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
+ IF(IA.GT.10) IKFI=3
+ FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
+ ENDIF
+ CALL PYQQBH(WTQQBH)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ DO 1220 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQH*WTQQBH*FACBW
+ 1220 CONTINUE
+
+ ELSEIF(ISUB.EQ.123) THEN
+C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
+C...inner process)
+ FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
+ & PARU(154+10*IHIGG)**2
+ FACPRP=1D0/((VINT(215)-VINT(204)**2)*
+ & (VINT(216)-VINT(209)**2))**2
+ FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
+ FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ DO 1240 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
+ IA=IABS(I)
+ DO 1230 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
+ JA=IABS(J)
+ EI=KCHG(IA,1)*ISIGN(1,I)/3D0
+ AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
+ VI=AI-4D0*EI*XWV
+ EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
+ AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
+ VJ=AJ-4D0*EJ*XWV
+ FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
+ FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
+ 1230 CONTINUE
+ 1240 CONTINUE
+
+ ELSEIF(ISUB.EQ.124) THEN
+C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
+C...inner process)
+ FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
+ & PARU(155+10*IHIGG)**2
+ FACPRP=1D0/((VINT(215)-VINT(204)**2)*
+ & (VINT(216)-VINT(209)**2))**2
+ FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
+ CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
+ & FACBW=0D0
+ DO 1260 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
+ EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
+ DO 1250 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
+ EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
+ IF(EI*EJ.GT.0D0) GOTO 1250
+ FACLR=VINT(180+I)*VINT(180+J)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACLR*FACWW*FACBW
+ 1250 CONTINUE
+ 1260 CONTINUE
+
+ ELSEIF(ISUB.EQ.131) THEN
+C...g + g -> Z0 + q + qbar
+
+ ENDIF
+
+C...H: 2 -> 1, tree diagrams, non-standard model processes
+
+ ELSEIF(ISUB.LE.160) THEN
+ IF(ISUB.EQ.141) THEN
+C...f + fbar -> gamma*/Z0/Z'0
+ SQMZP=PMAS(32,1)**2
+ MINT(61)=2
+ CALL PYWIDT(32,SH,WDTP,WDTE)
+ HP0=AEM/3D0*SH
+ HP1=AEM/3D0*XWC*SH
+ HP2=HP1
+ HS=SHR*VINT(117)
+ HSP=SHR*WDTP(0)
+ FACZP=4D0*COMFAC*3D0
+ DO 1270 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI)
+ VI=AI-4D0*EI*XWV
+ IF(IABS(I).LT.10) THEN
+ VPI=PARU(123-2*MOD(IABS(I),2))
+ API=PARU(124-2*MOD(IABS(I),2))
+ ELSE
+ VPI=PARU(127-2*MOD(IABS(I),2))
+ API=PARU(128-2*MOD(IABS(I),2))
+ ENDIF
+ HI0=HP0
+ IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
+ HI1=HP1
+ IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
+ HI2=HP2
+ IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
+ & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
+ & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
+ & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
+ & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
+ & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
+ & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
+ & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
+ 1270 CONTINUE
+
+ ELSEIF(ISUB.EQ.142) THEN
+C...f + fbar' -> W'+/-
+ SQMWP=PMAS(34,1)**2
+ CALL PYWIDT(34,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
+ HP=AEM/(24D0*XW)*SH
+ DO 1290 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
+ IA=IABS(I)
+ DO 1280 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
+ JA=IABS(J)
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 1280
+ KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ HI=HP*(PARU(133)**2+PARU(134)**2)
+ IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
+ & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
+ SIGH(NCHN)=HI*FACBW*HF
+ 1280 CONTINUE
+ 1290 CONTINUE
+
+ ELSEIF(ISUB.EQ.143) THEN
+C...f + fbar' -> H+/-
+ SQMHC=PMAS(37,1)**2
+ CALL PYWIDT(37,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
+ HP=AEM/(8D0*XW)*SH/SQMW*SH
+ DO 1310 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
+ IA=IABS(I)
+ IM=(MOD(IA,10)+1)/2
+ DO 1300 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
+ JA=IABS(J)
+ JM=(MOD(JA,10)+1)/2
+ IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 1300
+ IF(MOD(IA,2).EQ.0) THEN
+ IU=IA
+ IL=JA
+ ELSE
+ IU=JA
+ IL=IA
+ ENDIF
+ RML=PMAS(IL,1)**2/SH
+ RMU=PMAS(IU,1)**2/SH
+ IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
+ & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
+ & 2D0*MSTU(118)))
+ HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
+ IF(IA.LE.10) HI=HI*FACA/3D0
+ KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1300 CONTINUE
+ 1310 CONTINUE
+
+ ELSEIF(ISUB.EQ.144) THEN
+C...f + fbar' -> R
+ SQMR=PMAS(40,1)**2
+ CALL PYWIDT(40,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
+ HP=AEM/(12D0*XW)*SH
+ DO 1330 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
+ IA=IABS(I)
+ DO 1320 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
+ JA=IABS(J)
+ IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
+ HI=HP
+ IF(IA.LE.10) HI=HI*FACA/3D0
+ HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1320 CONTINUE
+ 1330 CONTINUE
+
+ ELSEIF(ISUB.EQ.145) THEN
+C...q + l -> LQ (leptoquark)
+ SQMLQ=PMAS(39,1)**2
+ CALL PYWIDT(39,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
+ IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
+ HP=AEM/4D0*SH
+ KFLQQ=KFDP(MDCY(39,2),1)
+ KFLQL=KFDP(MDCY(39,2),2)
+ DO 1350 I=MMIN1,MMAX1
+ IF(KFAC(1,I).EQ.0) GOTO 1350
+ IA=IABS(I)
+ IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
+ DO 1340 J=MMIN2,MMAX2
+ IF(KFAC(2,J).EQ.0) GOTO 1340
+ JA=IABS(J)
+ IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
+ IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
+ IF(JA.EQ.IA) GOTO 1340
+ IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
+ IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
+ HI=HP*PARU(151)
+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1340 CONTINUE
+ 1350 CONTINUE
+
+ ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
+C...d + g -> d* and u + g -> u* (excited quarks)
+ KFQSTR=KFPR(ISUB,1)
+ KCQSTR=PYCOMP(KFQSTR)
+ KFQEXC=MOD(KFQSTR,KEXCIT)
+ CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
+ FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
+ IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
+ & FACBW=0D0
+ HP=SH
+ DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
+ DO 1360 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
+ HI=HP
+ IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1360 CONTINUE
+ 1370 CONTINUE
+
+ ELSEIF(ISUB.EQ.149) THEN
+C...g + g -> eta_techni
+ CALL PYWIDT(38,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
+ IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
+ HP=SH
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
+ HI=HP*WDTP(3)
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1380 CONTINUE
+
+ ENDIF
+
+C...I: 2 -> 2, tree diagrams, non-standard model processes
+
+ ELSEIF(ISUB.LE.200) THEN
+ IF(ISUB.EQ.161) THEN
+C...f + g -> f' + H+/- (b + g -> t + H+/- only)
+C...(choice of only b and t to avoid kinematics problems)
+ SQMHC=PMAS(37,1)**2
+ FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
+ DO 1400 I=MMINA,MMAXA
+ IA=IABS(I)
+ IF(IA.NE.5) GOTO 1400
+ SQML=PMAS(IA,1)**2
+ IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
+ & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
+ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
+ IUA=IA+MOD(IA,2)
+ SQMQ=PMAS(IUA,1)**2
+ FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
+ & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
+ & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
+ & (SQMHC-SQMQ-SH)/SH)
+ KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
+ DO 1390 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
+ 1390 CONTINUE
+ 1400 CONTINUE
+
+ ELSEIF(ISUB.EQ.162) THEN
+C...q + g -> LQ + lbar; LQ=leptoquark
+ SQMLQ=PMAS(39,1)**2
+ FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
+ & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
+ KFLQQ=KFDP(MDCY(39,2),1)
+ DO 1420 I=MMINA,MMAXA
+ IF(IABS(I).NE.KFLQQ) GOTO 1420
+ KCHLQ=ISIGN(1,I)
+ DO 1410 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
+ 1410 CONTINUE
+ 1420 CONTINUE
+
+ ELSEIF(ISUB.EQ.163) THEN
+C...g + g -> LQ + LQbar; LQ=leptoquark
+ SQMLQ=PMAS(39,1)**2
+ FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
+ & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
+ & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
+ & ((TH-SQMLQ)*(UH-SQMLQ)))
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+C...Since don't know proper colour flow, randomize between alternatives
+ ISIG(NCHN,3)=INT(1.5D0+PYR(0))
+ SIGH(NCHN)=FACLQ
+ 1430 CONTINUE
+
+ ELSEIF(ISUB.EQ.164) THEN
+C...q + qbar -> LQ + LQbar; LQ=leptoquark
+ SQMLQ=PMAS(39,1)**2
+ FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
+ & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
+ FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
+ & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
+ & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
+ KFLQQ=KFDP(MDCY(39,2),1)
+ DO 1440 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACLQA
+ IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
+ 1440 CONTINUE
+
+ ELSEIF(ISUB.EQ.165) THEN
+C...q + qbar -> l+ + l- (including contact term for compositeness)
+ ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ KFF=IABS(KFPR(ISUB,1))
+ EF=KCHG(KFF,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VALF=VF+AF
+ VARF=VF-AF
+ FCOF=1D0
+ IF(KFF.LE.10) FCOF=3D0
+ WID2=1D0
+ IF(KFF.EQ.6) WID2=WIDS(6,1)
+ IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
+ IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
+ DO 1450 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=VI+AI
+ VARI=VI-AI
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
+ FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
+ & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
+ & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
+ ELSE
+ FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
+ & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
+ ENDIF
+ FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
+ & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
+ FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
+ IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
+ & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
+ 1450 CONTINUE
+
+ ELSEIF(ISUB.EQ.166) THEN
+C...q + q'bar -> l + nu_l (including contact term for compositeness)
+ WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
+ WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
+ KFF=IABS(KFPR(ISUB,1))
+ FCOF=1D0
+ IF(KFF.LE.10) FCOF=3D0
+ DO 1470 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
+ IA=IABS(I)
+ DO 1460 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
+ JA=IABS(J)
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 1460
+ FCOI=1D0
+ IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
+ WID2=1D0
+ IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
+ & MOD(J,2).EQ.0)) THEN
+ IF(KFF.EQ.5) WID2=WIDS(6,2)
+ IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
+ IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
+ ELSE
+ IF(KFF.EQ.5) WID2=WIDS(6,3)
+ IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
+ IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
+ IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
+ & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
+ 1460 CONTINUE
+ 1470 CONTINUE
+
+ ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
+C...d + g -> d* and u + g -> u* (excited quarks)
+ KFQSTR=KFPR(ISUB,2)
+ KCQSTR=PYCOMP(KFQSTR)
+ KFQEXC=MOD(KFQSTR,KEXCIT)
+ FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
+ FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
+ & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
+C...Propagators: as simulated in PYOFSH and as desired
+ GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
+ HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
+ CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
+ GMMQC=SQRT(SQM4)*WDTP(0)
+ HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
+ FACQSA=FACQSA*HBW4C/HBW4
+ FACQSB=FACQSB*HBW4C/HBW4
+ DO 1490 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
+ DO 1480 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
+ IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=(4D0/3D0)*FACQSA
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=(4D0/3D0)*FACQSA
+ ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQSA
+ ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=(8D0/3D0)*FACQSB
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=(8D0/3D0)*FACQSB
+ ELSEIF(I.EQ.-J) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQSB
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQSB
+ ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQSB
+ ENDIF
+ 1480 CONTINUE
+ 1490 CONTINUE
+
+ ELSEIF(ISUB.EQ.191) THEN
+C...q + qbar -> rho_tech0.
+ SQMRHT=PMAS(54,1)**2
+ CALL PYWIDT(54,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
+ IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
+ XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
+ BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ DO 1500 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
+ IA=IABS(I)
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
+ IF(IA.LE.10) HI=HI*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1500 CONTINUE
+
+ ELSEIF(ISUB.EQ.192) THEN
+C...q + qbar' -> rho_tech+/-.
+ SQMRHT=PMAS(55,1)**2
+ CALL PYWIDT(55,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
+ IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
+ & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
+ DO 1520 I=MMIN1,MMAX1
+ IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
+ IA=IABS(I)
+ DO 1510 J=MMIN2,MMAX2
+ IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
+ JA=IABS(J)
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
+ IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
+ & GOTO 1510
+ KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
+ HI=HP
+ IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1510 CONTINUE
+ 1520 CONTINUE
+
+ ELSEIF(ISUB.EQ.193) THEN
+C...q + qbar -> omega_tech0.
+ SQMOMT=PMAS(56,1)**2
+ CALL PYWIDT(56,SH,WDTP,WDTE)
+ HS=SHR*WDTP(0)
+ FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
+ IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
+ & (2D0*PARP(143)-1D0)**2
+ BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
+ BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
+ DO 1530 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
+ IA=IABS(I)
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
+ & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
+ IF(IA.LE.10) HI=HI*FACA/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=HI*FACBW*HF
+ 1530 CONTINUE
+
+ ELSEIF(ISUB.EQ.194) THEN
+C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
+ SQMRHT=PMAS(54,1)**2
+ CALL PYWIDT(54,SH,WDTP,WDTE)
+ HSRHT=SHR*WDTP(0)
+ BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
+ BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
+ XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
+ SQMOMT=PMAS(56,1)**2
+ CALL PYWIDT(56,SH,WDTP,WDTE)
+ HSOMT=SHR*WDTP(0)
+ BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
+ BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
+ XWOMT=0.5D0/(1D0-XW)
+ KFF=IABS(KFPR(ISUB,1))
+ EF=KCHG(KFF,1)/3D0
+ AF=SIGN(1D0,EF+0.1D0)
+ VF=AF-4D0*EF*XWV
+ VALF=0.5D0*(VF+AF)
+ VARF=0.5D0*(VF-AF)
+ FCOF=1D0
+ IF(KFF.LE.10) FCOF=3D0
+ WID2=1D0
+ IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
+ IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
+ ALPRHT=2.91D0*(3D0/PARP(144))
+ FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
+ BWZ=SH/(SH-SQMZ)
+ ALEFTF=EF+VALF*XWRHT*BWZ
+ ARIGHF=EF+VARF*XWRHT*BWZ
+ BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
+ BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
+ DO 1540 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
+ EI=KCHG(IABS(I),1)/3D0
+ AI=SIGN(1D0,EI+0.1D0)
+ VI=AI-4D0*EI*XWV
+ VALI=0.5D0*(VI+AI)
+ VARI=0.5D0*(VI-AI)
+ FCOI=1D0
+ IF(IABS(I).LE.10) FCOI=FACA/3D0
+ ALEFTI=EI+VALI*XWRHT*BWZ
+ ARIGHI=EI+VARI*XWRHT*BWZ
+ BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
+ BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
+ DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
+ & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
+ DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
+ & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
+ DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
+ & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
+ DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
+ & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
+ FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACTC*FCOI*FACSIG
+ 1540 CONTINUE
+
+ ENDIF
+
+CMRENNA++
+C...J: 2 -> 2, tree diagrams, SUSY processes
+
+ ELSEIF(ISUB.LE.210) THEN
+ IF(ISUB.EQ.201) THEN
+C...f + fbar -> e_L + e_Lbar
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ DO 1570 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
+ EI=KCHG(IA,1)/3D0
+ TT3I=SIGN(1D0,EI+1D-6)/2D0
+ EJ=-1D0
+ TT3J=-1D0/2D0
+ FCOL=1D0
+C...Color factor for e+ e-
+ IF(IA.GE.11) FCOL=3D0
+ IF(ILR.EQ.1) THEN
+ A1=SFMIX(KFID,3)**2
+ A2=SFMIX(KFID,4)**2
+ ELSEIF(ILR.EQ.0) THEN
+ A1=SFMIX(KFID,1)**2
+ A2=SFMIX(KFID,2)**2
+ ENDIF
+ XLQ=(TT3J-EJ*XW)*A1
+ XRQ=(-EJ*XW)*A2
+ XLF=(TT3I-EI*XW)
+ XRF=(-EI*XW)
+ TAA=2D0*(EI*EJ)**2
+ TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
+ TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
+ TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
+ TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
+ TNN=0.0D0
+ TAN=0.0D0
+ TZN=0.0D0
+ IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
+ FAC2=SQRT(2D0)
+ TNN1=0D0
+ TNN2=0D0
+ TNN3=0D0
+ DO 1560 II=1,4
+ DK=1D0/(TH-SMZ(II)**2)
+ FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
+ & ZMIX(II,1))
+ FREK=FAC2*TANW*EI*ZMIX(II,1)
+ TNN1=TNN1+FLEK**2*DK
+ TNN2=TNN2+FREK**2*DK
+ DO 1550 JJ=1,4
+ DL=1D0/(TH-SMZ(JJ)**2)
+ FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
+ & ZMIX(JJ,1))
+ FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
+ TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
+ 1550 CONTINUE
+ 1560 CONTINUE
+ TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
+ TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
+ TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
+ & (TNN1*XLF*A1+TNN2*XRF*A2)
+ TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
+ & (1D0-SQMZ/SH)/SH
+ TZN=TZN/XW**2/XW1
+ TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
+ ENDIF
+ FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
+ FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
+ FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1+FACQQ2
+ 1570 CONTINUE
+
+ ELSEIF(ISUB.EQ.203) THEN
+C...f + fbar -> e_L + e_Rbar
+ DO 1600 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
+ EI=KCHG(IABS(I),1)/3D0
+ TT3I=SIGN(1D0,EI)/2D0
+ EJ=-1
+ TT3J=-1D0/2D0
+ FCOL=1D0
+C...Color factor for e+ e-
+ IF(IA.GE.11) FCOL=3D0
+ A1=SFMIX(KFID,1)**2
+ A2=SFMIX(KFID,2)**2
+ XLQ=(TT3J-EJ*XW)
+ XRQ=(-EJ*XW)
+ XLF=(TT3I-EI*XW)
+ XRF=(-EI*XW)
+ TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
+ TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
+ TNN=0.0D0
+ TZN=0.0D0
+ IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
+ FAC2=SQRT(2D0)
+ TNN1=0D0
+ TNN2=0D0
+ TNN3=0D0
+ DO 1590 II=1,4
+ DK=1D0/(TH-SMZ(II)**2)
+ FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
+ & ZMIX(II,1))
+ FREK=FAC2*TANW*EI*ZMIX(II,1)
+ TNN1=TNN1+FLEK**2*DK
+ TNN2=TNN2+FREK**2*DK
+ DO 1580 JJ=1,4
+ DL=1D0/(TH-SMZ(JJ)**2)
+ FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
+ & ZMIX(JJ,1))
+ FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
+ TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
+ 1580 CONTINUE
+ 1590 CONTINUE
+ TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
+ TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
+ TZN=(UH*TH-SQM3*SQM4)*A1*A2
+ TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
+ TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
+ & (1D0-SQMZ/SH)/SH
+ ENDIF
+ FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
+ FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
+ FACQQ=(FACQQ1+FACQQ2)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ 1600 CONTINUE
+
+ ELSEIF(ISUB.EQ.210) THEN
+C...q + qbar' -> W*- > ~l_L + ~nu_L
+ FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
+ FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
+ DO 1620 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
+ DO 1610 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
+ FCKM=3D0
+ IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
+ KCHW=2
+ IF(KCHSUM.LT.0) KCHW=3
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
+ & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
+ 1610 CONTINUE
+ 1620 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.220) THEN
+ IF(ISUB.EQ.213) THEN
+C...f + fbar -> ~nu_L + ~nu_Lbar
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
+ XLL=0.5D0
+ XLR=0.0D0
+ DO 1630 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
+ EI=KCHG(IA,1)/3D0
+ FCOL=1D0
+C...Color factor for e+ e-
+ IF(IA.GE.11) FCOL=3D0
+ XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
+ XRQ=-EI*XW
+ TZC=0.0D0
+ TCC=0.0D0
+ IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
+ TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
+ & (TH-SMW(2)**2)
+ TCC=TZC**2
+ TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
+ ENDIF
+ FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
+ FACQQ2=TZC+TCC/4D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
+ & *AEM**2*FCOL/3D0/XW**2
+ 1630 CONTINUE
+
+ ELSEIF(ISUB.EQ.216) THEN
+C...q + qbar -> ~chi0_1 + ~chi0_1
+ IF(IZID1.EQ.IZID2) THEN
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ ELSE
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ ENDIF
+ FACGG1=COMFAC*AEM**2/3D0/XW**2
+ IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
+ ZM12=SQM3
+ ZM22=SQM4
+ SR2=SQRT(2D0)
+ WU2 = (UH-ZM12)*(UH-ZM22)/SH2
+ WT2 = (TH-ZM12)*(TH-ZM22)/SH2
+ XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
+ PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
+ REPRPZ = (SH-SQMZ)/PROPZ2
+ OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
+ & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
+ DO 1640 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
+ EI=KCHG(IABS(I),1)/3D0
+ FCOL=1D0
+ IF(ABS(I).GE.11) FCOL=3D0
+ XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
+ XRQ=-EI*XW
+ XLQ=XLQ/XW1
+ XRQ=XRQ/XW1
+C...Factored out sqrt(2)
+ FR1=TANW*EI*ZMIX(IZID1,1)
+ FR2=TANW*EI*ZMIX(IZID2,1)
+ FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
+ & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
+ FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
+ & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
+ FR12=FR1**2
+ FR22=FR2**2
+ FL12=FL1**2
+ FL22=FL2**2
+ XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
+ XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
+ FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
+ FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
+ & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
+ FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
+ & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
+ FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
+ & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
+ FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
+ & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
+ 1640 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.230) THEN
+ IF(ISUB.EQ.226) THEN
+C...f + fbar -> ~chi+_1 + ~chi-_1
+ FACGG1=COMFAC*AEM**2/3D0/XW**2
+ ZM12=SQM3
+ ZM22=SQM4
+ WU2 = (UH-ZM12)*(UH-ZM22)/SH2
+ WT2 = (TH-ZM12)*(TH-ZM22)/SH2
+ WS2 = SMW(IZID1)*SMW(IZID2)/SH
+ PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
+ REPRPZ = (SH-SQMZ)/PROPZ2
+ DIFF=0D0
+ IF(IZID1.EQ.IZID2) DIFF=1D0
+ DO 1650 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
+ EI=KCHG(IABS(I),1)/3D0
+ FCOL=1D0
+ IF(IABS(I).GE.11) FCOL=3D0
+ XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
+ XRQ=-EI*XW
+ XLQ=XLQ/XW1
+ XRQ=XRQ/XW1
+ XLQ2=XLQ**2
+ XRQ2=XRQ**2
+ OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
+ & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
+ ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
+ & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
+ ORP2=ORP**2
+ OLP2=OLP**2
+C...u-type quark - d-type squark
+ IF(MOD(I,2).EQ.0) THEN
+ FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
+ XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
+C...d-type quark - u-type squark
+ ELSE
+ FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
+ XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
+ ENDIF
+ FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
+ FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
+ & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
+ & (WU2-WT2))*SH2/PROPZ2
+ FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
+ FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
+ & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
+ FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
+ FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
+ FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ IF(IZID1.EQ.IZID2) THEN
+ SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ ELSE
+ SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
+ ENDIF
+ 1650 CONTINUE
+
+ ELSEIF(ISUB.EQ.229) THEN
+C...q + qbar' -> ~chi0_1 + ~chi+-_1
+ FACGG1=COMFAC*AEM**2/6D0/XW**2
+ ZM12=SQM3
+ ZM22=SQM4
+ ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
+ ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
+ WU2 = (UH-ZM12)*(UH-ZM22)/SH2
+ WT2 = (TH-ZM12)*(TH-ZM22)/SH2
+ WS2 = SMW(IZID1)*SMZ(IZID2)/SH
+ RT2I = 1D0/SQRT(2D0)
+ PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
+ OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
+ & ZMIX(IZID2,2)*VMIX(IZID1,1)
+ OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
+ & ZMIX(IZID2,2)*UMIX(IZID1,1)
+ OL2=OL**2
+ OR2=OR**2
+ CROSS=2D0*OL*OR
+ FACST0=UMIX(IZID1,1)
+ FACSU0=VMIX(IZID1,1)
+ FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
+ FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
+ FACT0=FACST0**2
+ FACU0=FACSU0**2
+ FACTU0=FACSU0*FACST0
+ FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
+ & + SH2*WS2*OL)*FACST0
+ FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
+ & + SH2*WS2*OR)*FACSU0
+ FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
+ FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
+ FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
+ FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
+ FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
+ DO 1670 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
+ DO 1660 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
+ FCKM=3D0
+ IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
+ KCHW=2
+ IF(KCHSUM.LT.0) KCHW=3
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
+ 1660 CONTINUE
+ 1670 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.240) THEN
+ IF(ISUB.EQ.237) THEN
+C...q + qbar -> gluino + ~chi0_1
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ FAC0=COMFAC*AS*AEM*4D0/9D0/XW
+ GM2=SQM3
+ ZM2=SQM4
+ DO 1680 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
+ EI=KCHG(IABS(I),1)/3D0
+ IA=IABS(I)
+ XLQC = -TANW*EI*ZMIX(IZID,1)
+ XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
+ & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
+ XLQ2=XLQC**2
+ XRQ2=XRQC**2
+ XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
+ XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
+ ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
+ AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
+ ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
+ SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
+ ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
+ AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
+ ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
+ SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
+ 1680 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.250) THEN
+ IF(ISUB.EQ.241) THEN
+C...q + qbar' -> ~chi+-_1 + gluino
+ FACWG=COMFAC*AS*AEM/XW*2D0/9D0
+ GM2=SQM3
+ ZM2=SQM4
+ FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
+ FAC0=UMIX(IZID,1)**2
+ FAC1=VMIX(IZID,1)**2
+ DO 1700 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
+ DO 1690 J=MMIN2,MMAX2
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
+ IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
+ FCKM=1D0
+ IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
+ KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
+ KCHW=2
+ IF(KCHSUM.LT.0) KCHW=3
+ XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
+ XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
+ ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
+ AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
+ ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
+ XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
+ XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
+ ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
+ AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
+ ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
+ & SH/(TH-XMU2)/(UH-XMD2))/2D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
+ & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
+ 1690 CONTINUE
+ 1700 CONTINUE
+
+ ELSEIF(ISUB.EQ.243) THEN
+C...q + qbar -> gluino + gluino
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ XMT=SQM3-TH
+ XMU=SQM3-UH
+ DO 1710 I=MMINA,MMAXA
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
+ NCHN=NCHN+1
+ XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
+ XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
+ FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
+ & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
+ & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
+ & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
+ XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
+ XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
+ FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
+ & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
+ & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
+ & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+C...1/2 for identical particles
+ SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
+ 1710 CONTINUE
+
+ ELSEIF(ISUB.EQ.244) THEN
+C...g + g -> gluino + gluino
+ COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ XMT=SQM3-TH
+ XMU=SQM3-UH
+ FACQQ1=COMFAC*AS**2*9D0/4D0*(
+ & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
+ & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
+ FACQQ2=COMFAC*AS**2*9D0/4D0*(
+ & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
+ & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
+ FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
+ & SQM3*(SH-4D0*SQM3)/XMT/XMU)
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1/2D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ2/2D0
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=3
+ SIGH(NCHN)=FACQQ3/2D0
+ 1720 CONTINUE
+
+ ELSEIF(ISUB.EQ.246) THEN
+C...g + q_j -> ~chi0_1 + ~q_j
+ FAC0=COMFAC*AS*AEM/6D0/XW
+ ZM2=SQM4
+ QM2=SQM3
+ FACZQ0=FAC0*( (ZM2-TH)/SH +
+ & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
+ & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
+ KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
+ DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
+ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
+ EI=KCHG(IABS(I),1)/3D0
+ IA=IABS(I)
+ XRQZ = -TANW*EI*ZMIX(IZID,1)
+ XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
+ & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
+ IF(ILR.EQ.0) THEN
+ BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
+ ELSE
+ BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
+ ENDIF
+ FACZQ=FACZQ0*BS
+ KCHQ=2
+ IF(I.LT.0) KCHQ=3
+ DO 1730 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ 1730 CONTINUE
+ 1740 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.260) THEN
+ IF(ISUB.EQ.254) THEN
+C...g + q_j -> ~chi1_1 + ~q_i
+ FAC0=COMFAC*AS*AEM/12D0/XW
+ ZM2=SQM4
+ QM2=SQM3
+ AU=UMIX(IZID,1)**2
+ AD=VMIX(IZID,1)**2
+ FACZQ0=FAC0*( (ZM2-TH)/SH +
+ & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
+ & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
+ KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
+ IF(MOD(KFNSQ1,2).EQ.0) THEN
+ KFNSQ=KFNSQ1-1
+ KCHW=2
+ ELSE
+ KFNSQ=KFNSQ1+1
+ KCHW=3
+ ENDIF
+ DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
+ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
+ IA=IABS(I)
+ IF(MOD(IA,2).EQ.0) THEN
+ FACZQ=FACZQ0*AU
+ ELSE
+ FACZQ=FACZQ0*AD
+ ENDIF
+ FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
+ KCHQ=2
+ IF(I.LT.0) KCHQ=3
+ KCHWQ=KCHW
+ IF(I.LT.0) KCHWQ=5-KCHW
+ DO 1750 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
+ 1750 CONTINUE
+ 1760 CONTINUE
+
+ ELSEIF(ISUB.EQ.258) THEN
+C...g + q_j -> gluino + ~q_i
+ XG2=SQM4
+ XQ2=SQM3
+ XMT=XG2-TH
+ XMU=XG2-UH
+ XST=XQ2-TH
+ XSU=XQ2-UH
+ FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
+ & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
+ & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
+ & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
+ FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
+ & (SH*(UH+XG2)
+ & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
+ & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
+ & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
+ FACQG1=COMFAC*AS**2*FACQG1/2D0
+ FACQG2=COMFAC*AS**2*FACQG2/2D0
+ KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
+ DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
+ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
+ IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
+ KCHQ=2
+ IF(I.LT.0) KCHQ=3
+ FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ DO 1770 ISDE=1,2
+ IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
+ IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQG1*FACSEL
+ NCHN=NCHN+1
+ ISIG(NCHN,ISDE)=I
+ ISIG(NCHN,3-ISDE)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQG2*FACSEL
+ 1770 CONTINUE
+ 1780 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.270) THEN
+ IF(ISUB.EQ.261) THEN
+C...q_i + q_ibar -> ~t_1 + ~t_1bar
+ FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
+ FAC0=AS**2*4D0/9D0
+ DO 1790 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
+ IF(IA.GE.11.AND.IA.LE.18) THEN
+ EI=KCHG(IA,1)/3D0
+ EJ=KCHG(KFNSQ,1)/3D0
+ T3I=SIGN(1D0,EI)/2D0
+ T3J=SIGN(1D0,EJ)/2D0
+ XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
+ XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
+ XLF=2D0*(T3I-EI*XW)
+ XRF=2D0*(-EI*XW)
+ TAA=0.5D0*(EI*EJ)**2
+ TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
+ TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
+ TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
+ TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
+ FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1*FAC0
+ 1790 CONTINUE
+
+ ELSEIF(ISUB.EQ.263) THEN
+C...f + fbar -> ~t1 + ~t2bar
+ DO 1800 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
+ EI=KCHG(IABS(I),1)/3D0
+ TT3I=SIGN(1D0,EI)/2D0
+ EJ=2D0/3D0
+ TT3J=1D0/2D0
+ FCOL=1D0
+C...Color factor for e+ e-
+ IF(IA.GE.11) FCOL=3D0
+ XLQ=2D0*(TT3J-EJ*XW)
+ XRQ=2D0*(-EJ*XW)
+ XLF=2D0*(TT3I-EI*XW)
+ XRF=2D0*(-EI*XW)
+ TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
+ TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
+ TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
+C...Factor of 2 for t1 t2bar + t2 t1bar
+ FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
+ FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
+ 1800 CONTINUE
+
+ ELSEIF(ISUB.EQ.264) THEN
+C...g + g -> ~t_1 + ~t_1bar
+ XSU=SQM3-UH
+ XST=SQM3-TH
+ FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
+ FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ2
+ 1810 CONTINUE
+ ENDIF
+
+ ELSEIF(ISUB.LE.280) THEN
+ IF(ISUB.EQ.271) THEN
+C...q + q' -> ~q + ~q' (~g exchange)
+ XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
+ XMT=XMG2-TH
+ XMU=XMG2-UH
+ XSU1=SQM3-UH
+ XSU2=SQM4-UH
+ XST1=SQM3-TH
+ XST2=SQM4-TH
+ IF(ILR.EQ.1) THEN
+ FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
+ FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
+ FACQQB=0.0D0
+ ELSE
+ FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
+ FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
+ FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
+ & XMT/XMU )
+ ENDIF
+ KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
+ KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
+ DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
+ IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
+ KCHQ=2
+ IF(I.LT.0) KCHQ=3
+ DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
+ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
+ IF(I*J.LT.0) GOTO 1820
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
+ IF(I.EQ.J) THEN
+ IF(ISUBSV.LE.272) THEN
+ SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
+ ELSE
+ SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=2
+ IF(ISUBSV.LE.272) THEN
+ SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
+ ELSE
+ SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
+ ENDIF
+ ENDIF
+ 1820 CONTINUE
+ 1830 CONTINUE
+
+ ELSEIF(ISUB.EQ.274) THEN
+C...q + qbar -> ~q' + ~qbar'
+ XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
+ XMT=XMG2-TH
+ XMU=XMG2-UH
+ IF(ILR.EQ.0) THEN
+ FACQQ1=COMFAC*AS**2*4D0/9D0*(
+ & (UH*TH-SQM3*SQM4)/XMT**2 )
+ FACQQB=COMFAC*AS**2*4D0/9D0*(
+ & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
+ FACQQB=FACQQB+FACQQ1
+ ELSE
+ FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
+ FACQQB=FACQQ1
+ ENDIF
+ KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
+ KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
+ DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
+ IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
+ KCHQ=2
+ IF(I.LT.0) KCHQ=3
+ DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
+ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
+ JA=IABS(J)
+ IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
+ IF(I*J.GT.0) GOTO 1840
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=J
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
+ IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ 1840 CONTINUE
+ 1850 CONTINUE
+
+ ELSEIF(ISUB.EQ.277) THEN
+C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
+C...if i .eq. j covered in 274
+ FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
+ KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
+ FAC0=0D0
+ DO 1860 I=MMIN1,MMAX1
+ IA=IABS(I)
+ IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
+ & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
+ IF(IA.EQ.KFNSQ) GOTO 1860
+ IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
+ EI=KCHG(IA,1)/3D0
+ EJ=KCHG(KFNSQ,1)/3D0
+ T3J=SIGN(0.5D0,EJ)
+ T3I=SIGN(1D0,EI)/2D0
+ IF(ILR.EQ.0) THEN
+ XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
+ XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
+ ELSE
+ XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
+ XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
+ ENDIF
+ XLF=2D0*(T3I-EI*XW)
+ XRF=2D0*(-EI*XW)
+ IF(ILR.EQ.0) THEN
+ XRQ=0D0
+ ELSE
+ XLQ=0D0
+ ENDIF
+ TAA=0.5D0*(EI*EJ)**2
+ TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
+ TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
+ TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
+ TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
+ FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
+ ELSEIF(IA.LE.6) THEN
+ FAC0=AS**2*8D0/9D0/2D0
+ ENDIF
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=I
+ ISIG(NCHN,2)=-I
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ 1860 CONTINUE
+
+ ELSEIF(ISUB.EQ.279) THEN
+C...g + g -> ~q_j + ~q_jbar
+ XSU=SQM3-UH
+ XST=SQM3-TH
+C...5=RKF because ~t ~tbar treated separately
+ FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
+ FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
+ FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
+ IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=1
+ SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ NCHN=NCHN+1
+ ISIG(NCHN,1)=21
+ ISIG(NCHN,2)=21
+ ISIG(NCHN,3)=2
+ SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
+ 1870 CONTINUE
+
+ ENDIF
+CMRENNA--
+ ENDIF
+
+C...Multiply with parton distributions
+ IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
+ DO 1880 ICHN=1,NCHN
+ IF(MINT(45).GE.2) THEN
+ KFL1=ISIG(ICHN,1)
+ SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
+ ENDIF
+ IF(MINT(46).GE.2) THEN
+ KFL2=ISIG(ICHN,2)
+ SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
+ ENDIF
+ SIGS=SIGS+SIGH(ICHN)
+ 1880 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDFU
+C...Gives electron, photon, pi+, neutron, proton and hyperon
+C...parton distributions according to a few different parametrizations.
+C...Note that what is coded is x times the probability distribution,
+C...i.e. xq(x,Q2) etc.
+
+ SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
+C...Local arrays.
+ DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
+ &XPPI(-6:6),XPPR(-6:6)
+
+C...Interface to PDFLIB.
+ COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
+ SAVE /W50513/
+ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
+ &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
+ CHARACTER*20 PARM(20)
+ DATA VALUE/20*0D0/,PARM/20*' '/
+
+C...Data related to Schuler-Sjostrand photon distributions.
+ DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
+
+C...Reset parton distributions.
+ MINT(92)=0
+ DO 100 KFL=-25,25
+ XPQ(KFL)=0D0
+ 100 CONTINUE
+
+C...Check x and particle species.
+ IF(X.LE.0D0.OR.X.GE.1D0) THEN
+ WRITE(MSTU(11),5000) X
+ RETURN
+ ENDIF
+ KFA=IABS(KF)
+ IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
+ &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
+ &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
+ &KFA.NE.3334.AND.KFA.NE.111) THEN
+ WRITE(MSTU(11),5100) KF
+ RETURN
+ ENDIF
+
+C...Electron parton distribution call.
+ IF(KFA.EQ.11) THEN
+ CALL PYPDEL(X,Q2,XPEL)
+ DO 110 KFL=-25,25
+ XPQ(KFL)=XPEL(KFL)
+ 110 CONTINUE
+
+C...Photon parton distribution call (VDM+anomalous).
+ ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
+ IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
+ CALL PYPDGA(X,Q2,XPGA)
+ DO 120 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 120 CONTINUE
+ ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
+ Q2MX=Q2
+ P2MX=0.36D0
+ IF(MSTP(55).GE.7) P2MX=4.0D0
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
+ DO 130 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 130 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
+ Q2MX=Q2
+ P2MX=0.36D0
+ IF(MSTP(55).GE.11) P2MX=4.0D0
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
+ DO 140 KFL=-6,6
+ XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
+ 140 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(56).EQ.2) THEN
+C...Call PDFLIB parton distributions.
+ PARM(1)='NPTYPE'
+ VALUE(1)=3
+ PARM(2)='NGROUP'
+ VALUE(2)=MSTP(55)/1000
+ PARM(3)='NSET'
+ VALUE(3)=MOD(MSTP(55),1000)
+ IF(MINT(93).NE.3000000+MSTP(55)) THEN
+ CALL PDFSET(PARM,VALUE)
+ MINT(93)=3000000+MSTP(55)
+ ENDIF
+ XX=X
+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
+ VINT(231)=Q2MIN
+ XPQ(0)=GLU
+ XPQ(1)=DNV
+ XPQ(-1)=DNV
+ XPQ(2)=UPV
+ XPQ(-2)=UPV
+ XPQ(3)=STR
+ XPQ(-3)=STR
+ XPQ(4)=CHM
+ XPQ(-4)=CHM
+ XPQ(5)=BOT
+ XPQ(-5)=BOT
+ XPQ(6)=TOP
+ XPQ(-6)=TOP
+ ELSE
+ WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
+ ENDIF
+
+C...Pion/gammaVDM parton distribution call.
+ ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
+ & MINT(109).EQ.2)) THEN
+ IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
+ & MSTP(55).LE.12) THEN
+ ISET=1+MOD(MSTP(55)-1,4)
+ Q2MX=Q2
+ P2MX=0.36D0
+ IF(ISET.GE.3) P2MX=4.0D0
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
+ DO 150 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 150 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
+ CALL PYPDPI(X,Q2,XPPI)
+ DO 160 KFL=-6,6
+ XPQ(KFL)=XPPI(KFL)
+ 160 CONTINUE
+ ELSEIF(MSTP(54).EQ.2) THEN
+C...Call PDFLIB parton distributions.
+ PARM(1)='NPTYPE'
+ VALUE(1)=2
+ PARM(2)='NGROUP'
+ VALUE(2)=MSTP(53)/1000
+ PARM(3)='NSET'
+ VALUE(3)=MOD(MSTP(53),1000)
+ IF(MINT(93).NE.2000000+MSTP(53)) THEN
+ CALL PDFSET(PARM,VALUE)
+ MINT(93)=2000000+MSTP(53)
+ ENDIF
+ XX=X
+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
+ VINT(231)=Q2MIN
+ XPQ(0)=GLU
+ XPQ(1)=DSEA
+ XPQ(-1)=UPV+DSEA
+ XPQ(2)=UPV+USEA
+ XPQ(-2)=USEA
+ XPQ(3)=STR
+ XPQ(-3)=STR
+ XPQ(4)=CHM
+ XPQ(-4)=CHM
+ XPQ(5)=BOT
+ XPQ(-5)=BOT
+ XPQ(6)=TOP
+ XPQ(-6)=TOP
+ ELSE
+ WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
+ ENDIF
+
+C...Anomalous photon parton distribution call.
+ ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
+ Q2MX=Q2
+ P2MX=PARP(15)**2
+ IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
+ IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
+ IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
+ DO 170 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 170 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(56).EQ.1) THEN
+ IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
+ IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
+ DO 180 KFL=-6,6
+ XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
+ 180 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(56).EQ.2) THEN
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
+ DO 190 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 190 CONTINUE
+ VINT(231)=P2MX
+ ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
+ DO 200 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 200 CONTINUE
+ VINT(231)=P2MX
+ ELSE
+ 210 RKF=11D0*PYR(0)
+ KFR=1
+ IF(RKF.GT.1D0) KFR=2
+ IF(RKF.GT.5D0) KFR=3
+ IF(RKF.GT.6D0) KFR=4
+ IF(RKF.GT.10D0) KFR=5
+ IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
+ IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
+ IF(MSTP(57).EQ.0) Q2MX=P2MX
+ CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
+ DO 220 KFL=-6,6
+ XPQ(KFL)=XPGA(KFL)
+ 220 CONTINUE
+ VINT(231)=P2MX
+ ENDIF
+
+C...Proton parton distribution call.
+ ELSE
+ IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
+ CALL PYPDPR(X,Q2,XPPR)
+ DO 230 KFL=-6,6
+ XPQ(KFL)=XPPR(KFL)
+ 230 CONTINUE
+ ELSEIF(MSTP(52).EQ.2) THEN
+C...Call PDFLIB parton distributions.
+ PARM(1)='NPTYPE'
+ VALUE(1)=1
+ PARM(2)='NGROUP'
+ VALUE(2)=MSTP(51)/1000
+ PARM(3)='NSET'
+ VALUE(3)=MOD(MSTP(51),1000)
+ IF(MINT(93).NE.1000000+MSTP(51)) THEN
+ CALL PDFSET(PARM,VALUE)
+ MINT(93)=1000000+MSTP(51)
+ ENDIF
+ XX=X
+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
+ VINT(231)=Q2MIN
+ XPQ(0)=GLU
+ XPQ(1)=DNV+DSEA
+ XPQ(-1)=DSEA
+ XPQ(2)=UPV+USEA
+ XPQ(-2)=USEA
+ XPQ(3)=STR
+ XPQ(-3)=STR
+ XPQ(4)=CHM
+ XPQ(-4)=CHM
+ XPQ(5)=BOT
+ XPQ(-5)=BOT
+ XPQ(6)=TOP
+ XPQ(-6)=TOP
+ ELSE
+ WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
+ ENDIF
+ ENDIF
+
+C...Isospin average for pi0/gammaVDM.
+ IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
+ IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
+ XPV=XPQ(2)-XPQ(1)
+ XPQ(2)=XPQ(1)
+ XPQ(-2)=XPQ(-1)
+ ELSE
+ XPS=0.5D0*(XPQ(1)+XPQ(-2))
+ XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
+ XPQ(2)=XPS
+ XPQ(-1)=XPS
+ ENDIF
+ IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
+ XPQ(1)=XPQ(1)+0.2D0*XPV
+ XPQ(-1)=XPQ(-1)+0.2D0*XPV
+ XPQ(2)=XPQ(2)+0.8D0*XPV
+ XPQ(-2)=XPQ(-2)+0.8D0*XPV
+ ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
+ XPQ(3)=XPQ(3)+XPV
+ XPQ(-3)=XPQ(-3)+XPV
+ ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
+ XPQ(4)=XPQ(4)+XPV
+ XPQ(-4)=XPQ(-4)+XPV
+ IF(MSTP(55).GE.9) THEN
+ DO 240 KFL=-6,6
+ XPQ(KFL)=0D0
+ 240 CONTINUE
+ ENDIF
+ ELSE
+ XPQ(1)=XPQ(1)+0.5D0*XPV
+ XPQ(-1)=XPQ(-1)+0.5D0*XPV
+ XPQ(2)=XPQ(2)+0.5D0*XPV
+ XPQ(-2)=XPQ(-2)+0.5D0*XPV
+ ENDIF
+
+C...Rescale for gammaVDM by effective gamma -> rho coupling.
+ IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
+ DO 250 KFL=-6,6
+ XPQ(KFL)=VINT(281)*XPQ(KFL)
+ 250 CONTINUE
+ VINT(232)=VINT(281)*XPV
+ ENDIF
+
+C...Isospin conjugation for neutron.
+ ELSEIF(KFA.EQ.2112) THEN
+ XPS=XPQ(1)
+ XPQ(1)=XPQ(2)
+ XPQ(2)=XPS
+ XPS=XPQ(-1)
+ XPQ(-1)=XPQ(-2)
+ XPQ(-2)=XPS
+
+C...Simple recipes for hyperon (average valence parton distribution).
+ ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
+ & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
+ XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
+ XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
+ XPQ(1)=XPSEA
+ XPQ(2)=XPSEA
+ XPQ(-1)=XPSEA
+ XPQ(-2)=XPSEA
+ XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
+ XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
+ XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
+ ENDIF
+
+C...Charge conjugation for antiparticle.
+ IF(KF.LT.0) THEN
+ DO 260 KFL=1,25
+ IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
+ XPS=XPQ(KFL)
+ XPQ(KFL)=XPQ(-KFL)
+ XPQ(-KFL)=XPS
+ 260 CONTINUE
+ ENDIF
+
+C...Allow gluon also in position 21.
+ XPQ(21)=XPQ(0)
+
+C...Check positivity and reset above maximum allowed flavour.
+ DO 270 KFL=-25,25
+ XPQ(KFL)=MAX(0D0,XPQ(KFL))
+ IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
+ 270 CONTINUE
+
+C...Formats for error printouts.
+ 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
+ 5100 FORMAT(' Error: illegal particle code for parton distribution;',
+ &' KF =',I5)
+ 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
+ &3I5)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDFL
+C...Gives proton parton distribution at small x and/or Q^2 according to
+C...correct limiting behaviour.
+
+ SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
+ DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
+
+C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
+ MINT(92)=0
+ KFA=IABS(KF)
+ IACC=0
+ IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
+ IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
+ IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
+ IF(IACC.EQ.0) THEN
+ CALL PYPDFU(KF,X,Q2,XPQ)
+ RETURN
+ ENDIF
+
+C...Reset. Check x.
+ DO 100 KFL=-25,25
+ XPQ(KFL)=0D0
+ 100 CONTINUE
+ IF(X.LE.0D0.OR.X.GE.1D0) THEN
+ WRITE(MSTU(11),5000) X
+ RETURN
+ ENDIF
+
+C...Define valence content.
+ KFC=KF
+ NV1=2
+ NV2=1
+ IF(KF.EQ.2212) THEN
+ KFV1=2
+ KFV2=1
+ ELSEIF(KF.EQ.-2212) THEN
+ KFV1=-2
+ KFV2=-1
+ ELSEIF(KF.EQ.2112) THEN
+ KFV1=1
+ KFV2=2
+ ELSEIF(KF.EQ.-2112) THEN
+ KFV1=-1
+ KFV2=-2
+ ELSEIF(KF.EQ.211) THEN
+ NV1=1
+ KFV1=2
+ KFV2=-1
+ ELSEIF(KF.EQ.-211) THEN
+ NV1=1
+ KFV1=-2
+ KFV2=1
+ ELSEIF(MINT(105).LE.223) THEN
+ KFV1=1
+ WTV1=0.2D0
+ KFV2=2
+ WTV2=0.8D0
+ ELSEIF(MINT(105).EQ.333) THEN
+ KFV1=3
+ WTV1=1.0D0
+ KFV2=1
+ WTV2=0.0D0
+ ELSEIF(MINT(105).EQ.443) THEN
+ KFV1=4
+ WTV1=1.0D0
+ KFV2=1
+ WTV2=0.0D0
+ ENDIF
+
+C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
+ CALL PYPDFU(KFC,X,Q2,XPA)
+ Q2MN=MAX(3D0,VINT(231))
+ Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
+ XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
+
+C...Large Q2 and large x: naive call is enough.
+ IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
+ DO 110 KFL=-25,25
+ XPQ(KFL)=XPA(KFL)
+ 110 CONTINUE
+ MINT(92)=1
+
+C...Small Q2 and large x: dampen boundary value.
+ ELSEIF(X.GT.XMN) THEN
+
+C...Evaluate at boundary and define dampening factors.
+ CALL PYPDFU(KFC,X,Q2MN,XPA)
+ FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
+ FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
+
+C...Separate valence and sea parts of parton distribution.
+ IF(KFA.NE.22) THEN
+ XFV1=XPA(KFV1)-XPA(-KFV1)
+ XPA(KFV1)=XPA(-KFV1)
+ XFV2=XPA(KFV2)-XPA(-KFV2)
+ XPA(KFV2)=XPA(-KFV2)
+ ELSE
+ XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
+ XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
+ XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
+ XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
+ ENDIF
+
+C...Dampen valence and sea separately. Put back together.
+ DO 120 KFL=-25,25
+ XPQ(KFL)=FS*XPA(KFL)
+ 120 CONTINUE
+ IF(KFA.NE.22) THEN
+ XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
+ XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
+ ELSE
+ XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
+ XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
+ XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
+ XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
+ ENDIF
+ MINT(92)=2
+
+C...Large Q2 and small x: interpolate behaviour.
+ ELSEIF(Q2.GT.Q2MN) THEN
+
+C...Evaluate at extremes and define coefficients for interpolation.
+ CALL PYPDFU(KFC,XMN,Q2MN,XPA)
+ VI232A=VINT(232)
+ CALL PYPDFU(KFC,X,Q2B,XPB)
+ VI232B=VINT(232)
+ FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
+ FVA=(X/XMN)**0.45D0*FLA
+ FSA=(X/XMN)**(-0.08D0)*FLA
+ FB=1D0-FLA
+
+C...Separate valence and sea parts of parton distribution.
+ IF(KFA.NE.22) THEN
+ XFVA1=XPA(KFV1)-XPA(-KFV1)
+ XPA(KFV1)=XPA(-KFV1)
+ XFVA2=XPA(KFV2)-XPA(-KFV2)
+ XPA(KFV2)=XPA(-KFV2)
+ XFVB1=XPB(KFV1)-XPB(-KFV1)
+ XPB(KFV1)=XPB(-KFV1)
+ XFVB2=XPB(KFV2)-XPB(-KFV2)
+ XPB(KFV2)=XPB(-KFV2)
+ ELSE
+ XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
+ XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
+ XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
+ XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
+ XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
+ XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
+ XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
+ XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
+ ENDIF
+
+C...Interpolate for valence and sea. Put back together.
+ DO 130 KFL=-25,25
+ XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
+ 130 CONTINUE
+ IF(KFA.NE.22) THEN
+ XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
+ XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
+ ELSE
+ XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
+ XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
+ XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
+ XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
+ ENDIF
+ MINT(92)=3
+
+C...Small Q2 and small x: dampen boundary value and add term.
+ ELSE
+
+C...Evaluate at boundary and define dampening factors.
+ CALL PYPDFU(KFC,XMN,Q2MN,XPA)
+ FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
+ FA=1D0-FB
+ FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
+ FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
+ FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
+ FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
+ FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
+ FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
+
+C...Separate valence and sea parts of parton distribution.
+ IF(KFA.NE.22) THEN
+ XFV1=XPA(KFV1)-XPA(-KFV1)
+ XPA(KFV1)=XPA(-KFV1)
+ XFV2=XPA(KFV2)-XPA(-KFV2)
+ XPA(KFV2)=XPA(-KFV2)
+ ELSE
+ XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
+ XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
+ XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
+ XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
+ ENDIF
+
+C...Dampen valence and sea separately. Add constant terms.
+C...Put back together.
+ DO 140 KFL=-25,25
+ XPQ(KFL)=FSA*XPA(KFL)
+ 140 CONTINUE
+ IF(KFA.NE.22) THEN
+ DO 150 KFL=-3,3
+ XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
+ 150 CONTINUE
+ XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
+ XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
+ ELSE
+ DO 160 KFL=-3,3
+ XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
+ 160 CONTINUE
+ XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
+ XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
+ XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
+ XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
+ ENDIF
+ XPQ(21)=XPQ(0)
+ MINT(92)=4
+ ENDIF
+
+C...Format for error printout.
+ 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDEL
+C...Gives electron parton distribution.
+
+ SUBROUTINE PYPDEL(X,Q2,XPEL)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
+
+C...Interface to PDFLIB.
+ COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
+ SAVE /W50513/
+ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
+ &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
+ CHARACTER*20 PARM(20)
+ DATA VALUE/20*0D0/,PARM/20*' '/
+
+C...Some common constants.
+ DO 100 KFL=-25,25
+ XPEL(KFL)=0D0
+ 100 CONTINUE
+ AEM=PARU(101)
+ PME=PMAS(11,1)
+ XL=LOG(MAX(1D-10,X))
+ X1L=LOG(MAX(1D-10,1D0-X))
+ HLE=LOG(MAX(3D0,Q2/PME**2))
+ HBE2=(AEM/PARU(1))*(HLE-1D0)
+
+C...Electron inside electron, see R. Kleiss et al., in Z physics at
+C...LEP 1, CERN 89-08, p. 34
+ IF(MSTP(59).LE.1) THEN
+ HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
+ & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
+ HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
+ & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
+ & 4D0*XL/(1D0-X)-5D0-X)
+ ELSE
+ HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
+ & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
+ & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
+ ENDIF
+ IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
+ HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
+ ELSEIF(X.GT.0.999999D0) THEN
+ HEE=0D0
+ ENDIF
+ XPEL(11)=X*HEE
+
+C...Photon and (transverse) W- inside electron.
+ AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
+ IF(MSTP(13).LE.1) THEN
+ HLG=HLE
+ ELSE
+ HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
+ ENDIF
+ XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
+ HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
+ XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
+
+C...Electron or positron inside photon inside electron.
+ IF(MSTP(12).EQ.1) THEN
+ XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
+ & 2D0*X*(1D0+X)*XL)
+ XPEL(11)=XPEL(11)+XFSEA
+ XPEL(-11)=XFSEA
+
+C...Initialize PDFLIB photon parton distributions.
+ IF(MSTP(56).EQ.2) THEN
+ PARM(1)='NPTYPE'
+ VALUE(1)=3
+ PARM(2)='NGROUP'
+ VALUE(2)=MSTP(55)/1000
+ PARM(3)='NSET'
+ VALUE(3)=MOD(MSTP(55),1000)
+ IF(MINT(93).NE.3000000+MSTP(55)) THEN
+ CALL PDFSET(PARM,VALUE)
+ MINT(93)=3000000+MSTP(55)
+ ENDIF
+ ENDIF
+
+C...Quarks and gluons inside photon inside electron:
+C...numerical convolution required.
+ DO 110 KFL=0,6
+ SXP(KFL)=0D0
+ 110 CONTINUE
+ SUMXPP=0D0
+ ITER=-1
+ 120 ITER=ITER+1
+ SUMXP=SUMXPP
+ NSTP=2**(ITER-1)
+ IF(ITER.EQ.0) NSTP=2
+ DO 130 KFL=0,6
+ SXP(KFL)=0.5D0*SXP(KFL)
+ 130 CONTINUE
+ WTSTP=0.5D0/NSTP
+ IF(ITER.EQ.0) WTSTP=0.5D0
+C...Pick grid of x_{gamma} values logarithmically even.
+ DO 150 ISTP=1,NSTP
+ IF(ITER.EQ.0) THEN
+ XLE=XL*(ISTP-1)
+ ELSE
+ XLE=XL*(ISTP-0.5D0)/NSTP
+ ENDIF
+ XE=MIN(0.999999D0,EXP(XLE))
+ XG=MIN(0.999999D0,X/XE)
+C...Evaluate photon inside electron parton distribution for convolution.
+ XPGP=1D0+(1D0-XE)**2
+ IF(MSTP(13).LE.1) THEN
+ XPGP=XPGP*HLE
+ ELSE
+ XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
+ ENDIF
+C...Evaluate photon parton distributions for convolution.
+ IF(MSTP(56).EQ.1) THEN
+ CALL PYPDGA(XG,Q2,XPGA)
+ DO 140 KFL=0,5
+ SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
+ 140 CONTINUE
+ ELSEIF(MSTP(56).EQ.2) THEN
+C...Call PDFLIB parton distributions.
+ XX=XG
+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
+ SXP(0)=SXP(0)+WTSTP*XPGP*GLU
+ SXP(1)=SXP(1)+WTSTP*XPGP*DNV
+ SXP(2)=SXP(2)+WTSTP*XPGP*UPV
+ SXP(3)=SXP(3)+WTSTP*XPGP*STR
+ SXP(4)=SXP(4)+WTSTP*XPGP*CHM
+ SXP(5)=SXP(5)+WTSTP*XPGP*BOT
+ SXP(6)=SXP(6)+WTSTP*XPGP*TOP
+ ENDIF
+ 150 CONTINUE
+ SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
+ IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
+ & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
+
+C...Put convolution into output arrays.
+ FCONV=AEMP*(-XL)
+ XPEL(0)=FCONV*SXP(0)
+ DO 160 KFL=1,6
+ XPEL(KFL)=FCONV*SXP(KFL)
+ XPEL(-KFL)=XPEL(KFL)
+ 160 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDGA
+C...Gives photon parton distribution.
+
+ SUBROUTINE PYPDGA(X,Q2,XPGA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
+ &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
+ &DGCS(4,3),DGDS(4,3),DGES(4,3)
+
+C...The following data lines are coefficients needed in the
+C...Drees and Grassie photon parton distribution parametrization.
+ DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
+ &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
+ DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
+ &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
+ DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
+ &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
+ DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
+ &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
+ DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
+ &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
+ DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
+ &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
+ DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
+ &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
+ DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
+ &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
+ DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
+ &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
+ DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
+ &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
+ DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
+ &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
+ DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
+ &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
+ DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
+ &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
+
+C...Photon parton distribution from Drees and Grassie.
+C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0D0
+ 100 CONTINUE
+ VINT(231)=1D0
+ IF(MSTP(57).LE.0) THEN
+ T=LOG(1D0/0.16D0)
+ ELSE
+ T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
+ ENDIF
+ X1=1D0-X
+ NF=3
+ IF(Q2.GT.25D0) NF=4
+ IF(Q2.GT.300D0) NF=5
+ NFE=NF-2
+ AEM=PARU(101)
+
+C...Evaluate gluon content.
+ DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
+ DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
+ DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
+ XPGL=DGA*X**DGB*X1**DGC
+
+C...Evaluate up- and down-type quark content.
+ DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
+ DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
+ DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
+ DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
+ DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
+ XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
+ DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
+ DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
+ DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
+ DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
+ DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
+ DGF=9D0
+ IF(NF.EQ.4) DGF=10D0
+ IF(NF.EQ.5) DGF=55D0/6D0
+ XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
+ IF(NF.LE.3) THEN
+ XPQU=(XPQS+9D0*XPQN)/6D0
+ XPQD=(XPQS-4.5D0*XPQN)/6D0
+ ELSEIF(NF.EQ.4) THEN
+ XPQU=(XPQS+6D0*XPQN)/8D0
+ XPQD=(XPQS-6D0*XPQN)/8D0
+ ELSE
+ XPQU=(XPQS+7.5D0*XPQN)/10D0
+ XPQD=(XPQS-5D0*XPQN)/10D0
+ ENDIF
+
+C...Put into output arrays.
+ XPGA(0)=AEM*XPGL
+ XPGA(1)=AEM*XPQD
+ XPGA(2)=AEM*XPQU
+ XPGA(3)=AEM*XPQD
+ IF(NF.GE.4) XPGA(4)=AEM*XPQU
+ IF(NF.GE.5) XPGA(5)=AEM*XPQD
+ DO 110 KFL=1,6
+ XPGA(-KFL)=XPGA(KFL)
+ 110 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGGAM
+C...Constructs the F2 and parton distributions of the photon
+C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
+C...For F2, c and b are included by the Bethe-Heitler formula;
+C...in the 'MSbar' scheme additionally a Cgamma term is added.
+C...Contains the SaS sets 1D, 1M, 2D and 2M.
+C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
+
+ SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+ SAVE /PYINT8/,/PYINT9/
+C...Local arrays.
+ DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
+C...Charm and bottom masses (low to compensate for J/psi etc.).
+ DATA PMC/1.3D0/, PMB/4.6D0/
+C...alpha_em and alpha_em/(2*pi).
+ DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
+C...Lambda value for 4 flavours.
+ DATA ALAM/0.20D0/
+C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
+ DATA FRACU/0.8D0/
+C...VMD couplings f_V**2/(4*pi).
+ DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
+C...Masses for rho (=omega) and phi.
+ DATA PMRHO/0.770D0/, PMPHI/1.020D0/
+C...Number of points in integration for IP2=1.
+ DATA NSTEP/100/
+
+C...Reset output.
+ F2GM=0D0
+ DO 100 KFL=-6,6
+ XPDFGM(KFL)=0D0
+ XPVMD(KFL)=0D0
+ XPANL(KFL)=0D0
+ XPANH(KFL)=0D0
+ XPBEH(KFL)=0D0
+ XPDIR(KFL)=0D0
+ VXPVMD(KFL)=0D0
+ VXPANL(KFL)=0D0
+ VXPANH(KFL)=0D0
+ VXPDGM(KFL)=0D0
+ 100 CONTINUE
+
+C...Set Q0 cut-off parameter as function of set used.
+ IF(ISET.LE.2) THEN
+ Q0=0.6D0
+ ELSE
+ Q0=2D0
+ ENDIF
+ Q02=Q0**2
+
+C...Scale choice for off-shell photon; common factors.
+ Q2A=Q2
+ FACNOR=1D0
+ IF(IP2.EQ.1) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ FACNOR=LOG(Q2/Q02)/NSTEP
+ ELSEIF(IP2.EQ.2) THEN
+ P2MX=MAX(P2,Q02)
+ ELSEIF(IP2.EQ.3) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ ELSEIF(IP2.EQ.4) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ ELSEIF(IP2.EQ.5) THEN
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
+ ELSEIF(IP2.EQ.6) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
+ ELSE
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ P2MXB=P2MX
+ P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
+ P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
+ ENDIF
+
+C...Call VMD parametrization for d quark and use to give rho, omega,
+C...phi. Note dipole dampening for off-shell photon.
+ CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ XFVAL=VXPGA(1)
+ XPGA(1)=XPGA(2)
+ XPGA(-1)=XPGA(-2)
+ FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
+ FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
+ DO 110 KFL=-5,5
+ XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
+ 110 CONTINUE
+ XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
+ XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
+ XPVMD(3)=XPVMD(3)+FACS*XFVAL
+ XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
+ XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
+ XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
+ VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
+ VXPVMD(2)=FRACU*FACUD*XFVAL
+ VXPVMD(3)=FACS*XFVAL
+ VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
+ VXPVMD(-2)=FRACU*FACUD*XFVAL
+ VXPVMD(-3)=FACS*XFVAL
+
+ IF(IP2.NE.1) THEN
+C...Anomalous parametrizations for different strategies
+C...for off-shell photons; except full integration.
+
+C...Call anomalous parametrization for d + u + s.
+ CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 120 KFL=-5,5
+ XPANL(KFL)=FACNOR*XPGA(KFL)
+ VXPANL(KFL)=FACNOR*VXPGA(KFL)
+ 120 CONTINUE
+
+C...Call anomalous parametrization for c and b.
+ CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 130 KFL=-5,5
+ XPANH(KFL)=FACNOR*XPGA(KFL)
+ VXPANH(KFL)=FACNOR*VXPGA(KFL)
+ 130 CONTINUE
+ CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 140 KFL=-5,5
+ XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
+ VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
+ 140 CONTINUE
+
+ ELSE
+C...Special option: loop over flavours and integrate over k2.
+ DO 170 KF=1,5
+ DO 160 ISTEP=1,NSTEP
+ Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
+ IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
+ & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
+ CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
+ FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
+ IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
+ IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
+ DO 150 KFL=-5,5
+ IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
+ IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
+ IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
+ IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ ENDIF
+
+C...Call Bethe-Heitler term expression for charm and bottom.
+ CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
+ XPBEH(4)=XPBH
+ XPBEH(-4)=XPBH
+ CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
+ XPBEH(5)=XPBH
+ XPBEH(-5)=XPBH
+
+C...For MSbar subtraction call C^gamma term expression for d, u, s.
+ IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
+ CALL PYGDIR(X,Q2,P2,Q02,XPGA)
+ DO 180 KFL=-5,5
+ XPDIR(KFL)=XPGA(KFL)
+ 180 CONTINUE
+ ENDIF
+
+C...Store result in output array.
+ DO 190 KFL=-5,5
+ CHSQ=1D0/9D0
+ IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
+ XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
+ IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
+ XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
+ VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
+ 190 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGVMD
+C...Evaluates the VMD parton distributions of a photon,
+C...evolved homogeneously from an initial scale P2 to Q2.
+C...Does not include dipole suppression factor.
+C...ISET is parton distribution set, see above;
+C...additionally ISET=0 is used for the evolution of an anomalous photon
+C...which branched at a scale P2 and then evolved homogeneously to Q2.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
+
+ SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Local arrays and data.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+ DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0D0
+ VXPGA(KFL)=0D0
+ 100 CONTINUE
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
+ ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
+ P2EFF=MAX(P2,1.2D0*ALAM3**2)
+ IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Find s as sum of 3-, 4- and 5-flavour parts.
+ S=0D0
+ IF(NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ IF(NFQ.EQ.3) Q2DIV=Q2EFF
+ S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
+ ENDIF
+ IF(NFP.LE.4.AND.NFQ.GE.4) THEN
+ P2DIV=P2EFF
+ IF(NFP.EQ.3) P2DIV=PMC**2
+ Q2DIV=Q2EFF
+ IF(NFQ.EQ.5) Q2DIV=PMB**2
+ S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
+ ENDIF
+ IF(NFQ.EQ.5) THEN
+ P2DIV=PMB**2
+ IF(NFP.EQ.5) P2DIV=P2EFF
+ S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
+ ENDIF
+
+C...Calculate frequent combinations of x and s.
+ X1=1D0-X
+ XL=-LOG(X)
+ S2=S**2
+ S3=S**3
+ S4=S**4
+
+C...Evaluate homogeneous anomalous parton distributions below or
+C...above threshold.
+ IF(ISET.EQ.0) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X * 1.5D0 * (X**2+X1**2)
+ XGLU = 0D0
+ XSEA = 0D0
+ ELSE
+ XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
+ & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
+ & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
+ & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
+ XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
+ & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
+ & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
+ XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
+ & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
+ & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
+ & (2D0*X-1D0)*X*XL**2)
+ ENDIF
+
+C...Evaluate set 1D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.1) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
+ XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
+ XSEA = 0.100D0 * X1**3.76D0
+ ELSE
+ XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
+ & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
+ XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
+ & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
+ & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
+ & X**0.40D0 * X1**(1.76D0+3D0*S)
+ XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
+ & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
+ & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
+ XSEA0 = 0.100D0 * X1**3.76D0
+ ENDIF
+
+C...Evaluate set 1M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.2) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
+ XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
+ XSEA = 0D0
+ ELSE
+ XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
+ & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
+ XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
+ & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
+ & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
+ & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
+ XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
+ & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
+ & XL**(2.8D0*S)
+ XSEA0 = 0D0
+ ENDIF
+
+C...Evaluate set 2D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.3) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
+ XGLU = 1.925D0 * X1**2
+ XSEA = 0.242D0 * X1**4
+ ELSE
+ XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
+ & X**(0.46D0+0.25D0*S) *
+ & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
+ & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
+ XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
+ & EXP(-18.67D0*S) *
+ & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
+ & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
+ & XL**(9.3D0*S/(1D0+1.7D0*S))
+ XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
+ & (1D0-0.607D0*S+21.95D0*S2) *
+ & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
+ XSEA0 = 0.242D0 * X1**4
+ ENDIF
+
+C...Evaluate set 2M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.4) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
+ XGLU = 1.808D0 * X1**2
+ XSEA = 0.209D0 * X1**4
+ ELSE
+ XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
+ & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
+ & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
+ & XL**(5.15D0*S/(1D0+2D0*S)) +
+ & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
+ XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
+ & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
+ & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
+ & XL**(10.9D0*S/(1D0+2.5D0*S))
+ XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
+ & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
+ & X1**(4D0+S) * XL**(0.45D0*S)
+ XSEA0 = 0.209D0 * X1**4
+ ENDIF
+ ENDIF
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0D0
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
+ SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XCHM=XSEA*(1D0-(SCH/SLL)**2)
+ ELSE
+ XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
+ ENDIF
+ ENDIF
+ XBOT=0D0
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
+ SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XBOT=XSEA*(1D0-(SBT/SLL)**2)
+ ELSE
+ XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
+ ENDIF
+ ENDIF
+
+C...Fill parton distributions.
+ XPGA(0)=XGLU
+ XPGA(1)=XSEA
+ XPGA(2)=XSEA
+ XPGA(3)=XSEA
+ XPGA(4)=XCHM
+ XPGA(5)=XBOT
+ XPGA(KFA)=XPGA(KFA)+XVAL
+ DO 110 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ 110 CONTINUE
+ VXPGA(KFA)=XVAL
+ VXPGA(-KFA)=XVAL
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGANO
+C...Evaluates the parton distributions of the anomalous photon,
+C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
+C...KF=0 gives the sum over (up to) 5 flavours,
+C...KF<0 limits to flavours up to abs(KF),
+C...KF>0 is for flavour KF only.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
+
+ SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Local arrays and data.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
+ DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0D0
+ VXPGA(KFL)=0D0
+ 100 CONTINUE
+ IF(Q2.LE.P2) RETURN
+ KFA=IABS(KF)
+
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
+ ALAMSQ(4)=ALAM**2
+ ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
+ P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
+ IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ XL=-LOG(X)
+
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+
+C...Define range of flavour loop.
+ IF(KF.EQ.0) THEN
+ KFLMN=1
+ KFLMX=5
+ ELSEIF(KF.LT.0) THEN
+ KFLMN=1
+ KFLMX=KFA
+ ELSE
+ KFLMN=KFA
+ KFLMX=KFA
+ ENDIF
+
+C...Loop over flavours the photon can branch into.
+ DO 110 KFL=KFLMN,KFLMX
+
+C...Light flavours: calculate t range and (approximate) s range.
+ IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.GT.NFP) THEN
+ Q2DIV=PMB**2
+ IF(NFQ.EQ.4) Q2DIV=PMC**2
+ SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+ IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
+ & LOG(P2EFF/ALAMSQ(4)))
+ SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
+ & LOG(P2EFF/ALAMSQ(3)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
+ ENDIF
+
+C...u and s quark do not need a separate treatment when d has been done.
+ ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
+
+C...Charm: as above, but only include range above c threshold.
+ ELSEIF(KFL.EQ.4) THEN
+ IF(Q2.LE.PMC**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMC**2)
+ Q2EFF=MAX(Q2EFF,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
+ Q2DIV=PMB**2
+ SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+
+C...Bottom: as above, but only include range above b threshold.
+ ELSEIF(KFL.EQ.5) THEN
+ IF(Q2.LE.PMB**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ ENDIF
+
+C...Evaluate flavour-dependent prefactor (charge^2 etc.).
+ CHSQ=1D0/9D0
+ IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
+ FAC=AEM2PI*2D0*CHSQ*TDIFF
+
+C...Evaluate parton distributions (normalized to unit momentum sum).
+ IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
+ XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
+ & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
+ & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
+ & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
+ XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
+ & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
+ & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
+ XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
+ & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
+ & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
+ & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
+
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0D0
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
+ SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XCHM=XSEA*(1D0-(SCH/SLL)**3)
+ ENDIF
+ XBOT=0D0
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
+ SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XBOT=XSEA*(1D0-(SBT/SLL)**3)
+ ENDIF
+ ENDIF
+
+C...Add contribution of each valence flavour.
+ XPGA(0)=XPGA(0)+FAC*XGLU
+ XPGA(1)=XPGA(1)+FAC*XSEA
+ XPGA(2)=XPGA(2)+FAC*XSEA
+ XPGA(3)=XPGA(3)+FAC*XSEA
+ XPGA(4)=XPGA(4)+FAC*XCHM
+ XPGA(5)=XPGA(5)+FAC*XBOT
+ XPGA(KFL)=XPGA(KFL)+FAC*XVAL
+ VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
+ 110 CONTINUE
+ DO 120 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ VXPGA(-KFL)=VXPGA(KFL)
+ 120 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGBEH
+C...Evaluates the Bethe-Heitler cross section for heavy flavour
+C...production.
+C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
+
+ SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local data.
+ DATA AEM2PI/0.0011614D0/
+
+C...Reset output.
+ XPBH=0D0
+ SIGBH=0D0
+
+C...Check kinematics limits.
+ IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
+ W2=Q2*(1D0-X)/X-P2
+ BETA2=1D0-4D0*PM2/W2
+ IF(BETA2.LT.1D-10) RETURN
+ BETA=SQRT(BETA2)
+ RMQ=4D0*PM2/Q2
+
+C...Simple case: P2 = 0.
+ IF(P2.LT.1D-4) THEN
+ IF(BETA.LT.0.99D0) THEN
+ XBL=LOG((1D0+BETA)/(1D0-BETA))
+ ELSE
+ XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
+ ENDIF
+ SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
+
+C...Complicated case: P2 > 0, based on approximation of
+C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
+ ELSE
+ RPQ=1D0-4D0*X**2*P2/Q2
+ IF(RPQ.GT.1D-10) THEN
+ RPBE=SQRT(RPQ*BETA2)
+ IF(RPBE.LT.0.99D0) THEN
+ XBL=LOG((1D0+RPBE)/(1D0-RPBE))
+ XBI=2D0*RPBE/(1D0-RPBE**2)
+ ELSE
+ RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
+ XBL=LOG((1D0+RPBE)**2/RPBESN)
+ XBI=2D0*RPBE/RPBESN
+ ENDIF
+ SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
+ & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
+ ENDIF
+ ENDIF
+
+C...Multiply by charge-squared etc. to get parton distribution.
+ CHSQ=1D0/9D0
+ IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
+ XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGDIR
+C...Evaluates the direct contribution, i.e. the C^gamma term,
+C...as needed in MSbar parametrizations.
+C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
+
+ SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Local array and data.
+ DIMENSION XPGA(-6:6)
+ DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
+
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0D0
+ 100 CONTINUE
+
+C...Evaluate common x-dependent expression.
+ XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
+ CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
+
+C...d, u, s part by simple charge factor.
+ XPGA(1)=(1D0/9D0)*CGAM
+ XPGA(2)=(4D0/9D0)*CGAM
+ XPGA(3)=(1D0/9D0)*CGAM
+
+C...Also fill for antiquarks.
+ DO 110 KF=1,5
+ XPGA(-KF)=XPGA(KF)
+ 110 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDPI
+C...Gives pi+ parton distribution according to two different
+C...parametrizations.
+
+ SUBROUTINE PYPDPI(X,Q2,XPPI)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/
+C...Local arrays.
+ DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
+
+C...The following data lines are coefficients needed in the
+C...Owens pion parton distribution parametrizations, see below.
+C...Expansion coefficients for up and down valence quark distributions.
+ DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
+ &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
+ DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
+ &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
+C...Expansion coefficients for gluon distribution.
+ DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
+ &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
+ &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
+ &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
+ DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
+ &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
+ &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
+ &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
+C...Expansion coefficients for (up+down+strange) quark sea distribution.
+ DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
+ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
+ &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
+ DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
+ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
+ &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
+ &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
+C...Expansion coefficients for charm quark sea distribution.
+ DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
+ &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
+ &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
+ &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
+ DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
+ &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
+ &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
+ &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
+
+C...Euler's beta function, requires ordinary Gamma function
+ EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
+
+C...Reset output array.
+ DO 100 KFL=-6,6
+ XPPI(KFL)=0D0
+ 100 CONTINUE
+
+ IF(MSTP(53).LE.2) THEN
+C...Pion parton distributions from Owens.
+C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
+
+C...Determine set, Lambda and s expansion variable.
+ NSET=MSTP(53)
+ IF(NSET.EQ.1) ALAM=0.2D0
+ IF(NSET.EQ.2) ALAM=0.4D0
+ VINT(231)=4D0
+ IF(MSTP(57).LE.0) THEN
+ SD=0D0
+ ELSE
+ Q2IN=MIN(2D3,MAX(4D0,Q2))
+ SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
+ ENDIF
+
+C...Calculate parton distributions.
+ DO 120 KFL=1,4
+ DO 110 IS=1,5
+ TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
+ & COW(3,IS,KFL,NSET)*SD**2
+ 110 CONTINUE
+ IF(KFL.EQ.1) THEN
+ XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
+ ELSE
+ XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
+ & TS(5)*X**2)
+ ENDIF
+ 120 CONTINUE
+
+C...Put into output array.
+ XPPI(0)=XQ(2)
+ XPPI(1)=XQ(3)/6D0
+ XPPI(2)=XQ(1)+XQ(3)/6D0
+ XPPI(3)=XQ(3)/6D0
+ XPPI(4)=XQ(4)
+ XPPI(-1)=XQ(1)+XQ(3)/6D0
+ XPPI(-2)=XQ(3)/6D0
+ XPPI(-3)=XQ(3)/6D0
+ XPPI(-4)=XQ(4)
+
+C...Leading order pion parton distributions from Gluck, Reya and Vogt.
+C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
+C...10^-5 < x < 1.
+ ELSE
+
+C...Determine s expansion variable and some x expressions.
+ VINT(231)=0.25D0
+ IF(MSTP(57).LE.0) THEN
+ SD=0D0
+ ELSE
+ Q2IN=MIN(1D8,MAX(0.25D0,Q2))
+ SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
+ ENDIF
+ SD2=SD**2
+ XL=-LOG(X)
+ XS=SQRT(X)
+
+C...Evaluate valence, gluon and sea distributions.
+ XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
+ & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
+ XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
+ & SD-0.175D0*SD2)+
+ & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
+ & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
+ & XL)))*
+ & (1D0-X)**(0.390D0+1.053D0*SD)
+ XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
+ & X)**3.359D0*
+ & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
+ & XL))/
+ & XL**(2.538D0-0.763D0*SD)
+ IF(SD.LE.0.888D0) THEN
+ XFCHM=0D0
+ ELSE
+ XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
+ & 0.771D0*SD)*
+ & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
+ & XL))
+ ENDIF
+ IF(SD.LE.1.351D0) THEN
+ XFBOT=0D0
+ ELSE
+ XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
+ & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
+ & XL))
+ ENDIF
+
+C...Put into output array.
+ XPPI(0)=XFGLU
+ XPPI(1)=XFSEA
+ XPPI(2)=XFSEA
+ XPPI(3)=XFSEA
+ XPPI(4)=XFCHM
+ XPPI(5)=XFBOT
+ DO 130 KFL=1,5
+ XPPI(-KFL)=XPPI(KFL)
+ 130 CONTINUE
+ XPPI(2)=XPPI(2)+XFVAL
+ XPPI(-1)=XPPI(-1)+XFVAL
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPDPR
+C...Gives proton parton distributions according to a few different
+C...parametrizations.
+
+ SUBROUTINE PYPDPR(X,Q2,XPPR)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
+C...Arrays and data.
+ DIMENSION XPPR(-6:6),Q2MIN(6)
+ DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
+
+C...Reset output array.
+ DO 100 KFL=-6,6
+ XPPR(KFL)=0D0
+ 100 CONTINUE
+
+C...Common preliminaries.
+ NSET=MAX(1,MIN(6,MSTP(51)))
+ VINT(231)=Q2MIN(NSET)
+ IF(MSTP(57).EQ.0) THEN
+ Q2L=Q2MIN(NSET)
+ ELSE
+ Q2L=MAX(Q2MIN(NSET),Q2)
+ ENDIF
+
+ IF(NSET.GE.1.AND.NSET.LE.3) THEN
+C...Interface to the CTEQ 3 parton distributions.
+ QRT=SQRT(MAX(1D0,Q2L))
+
+C...Loop over flavours.
+ DO 110 I=-6,6
+ IF(I.LE.0) THEN
+ XPPR(I)=PYCTEQ(NSET,I,X,QRT)
+ ELSEIF(I.LE.2) THEN
+ XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
+ ELSE
+ XPPR(I)=XPPR(-I)
+ ENDIF
+ 110 CONTINUE
+
+ ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
+C...Interface to the GRV 94 distributions.
+ IF(NSET.EQ.4) THEN
+ CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+ ELSEIF(NSET.EQ.5) THEN
+ CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+ ELSE
+ CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+ ENDIF
+
+C...Put into output array.
+ XPPR(0)=GL
+ XPPR(-1)=0.5D0*(UDB+DEL)
+ XPPR(-2)=0.5D0*(UDB-DEL)
+ XPPR(-3)=SB
+ XPPR(-4)=CHM
+ XPPR(-5)=BOT
+ XPPR(1)=DV+XPPR(-1)
+ XPPR(2)=UV+XPPR(-2)
+ XPPR(3)=SB
+ XPPR(4)=CHM
+ XPPR(5)=BOT
+
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCTEQ
+C...Gives the CTEQ 3 parton distribution function sets in
+C...parametrized form, of October 24, 1994.
+C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
+C...J. Qiu, W.K. Tung and H. Weerts.
+
+ FUNCTION PYCTEQ (ISET, IPRT, X, Q)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+
+C...Data on Lambda values of fits, minimum Q and quark masses.
+ DIMENSION ALM(3), QMS(4:6)
+ DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
+ DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
+
+C....Check flavour thresholds. Set up QI for SB.
+ IP = IABS(IPRT)
+ IF(IP .GE. 4) THEN
+ IF(Q .LE. QMS(IP)) THEN
+ PYCTEQ = 0D0
+ RETURN
+ ENDIF
+ QI = QMS(IP)
+ ELSE
+ QI = QMN
+ ENDIF
+
+C...Use "standard lambda" of parametrization program for expansion.
+ ALAM = ALM (ISET)
+ SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
+ SB = LOG (SBL)
+ SB2 = SB*SB
+ SB3 = SB2*SB
+
+C...Expansion for CTEQ3L.
+ IF(ISET .EQ. 1) THEN
+ IF(IPRT .EQ. 2) THEN
+ A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
+ & 0.3171D+00*SB3)
+ A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
+ A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
+ A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
+ A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
+ A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
+ ELSEIF(IPRT .EQ. 1) THEN
+ A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
+ & 0.7728D+00*SB3)
+ A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
+ A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
+ A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
+ A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
+ A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
+ ELSEIF(IPRT .EQ. 0) THEN
+ A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
+ & 0.5343D+00*SB3)
+ A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
+ A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
+ A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
+ A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
+ A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
+ ELSEIF(IPRT .EQ. -1) THEN
+ A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
+ & 0.2031D+01*SB3)
+ A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
+ A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
+ A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
+ A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
+ A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
+ ELSEIF(IPRT .EQ. -2) THEN
+ A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
+ & 0.9872D-01*SB3)
+ A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
+ A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
+ A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
+ A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
+ A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
+ ELSEIF(IPRT .EQ. -3) THEN
+ A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
+ & 0.8390D+00*SB3)
+ A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
+ A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
+ A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
+ A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
+ A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
+ ELSEIF(IPRT .EQ. -4) THEN
+ A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
+ & 0.1651D-01*SB2)
+ A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
+ A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
+ A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
+ A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
+ A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
+ ELSEIF(IPRT .EQ. -5) THEN
+ A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
+ & 0.3702D+01*SB2)
+ A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
+ A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
+ A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
+ A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
+ A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
+ ELSEIF(IPRT .EQ. -6) THEN
+ A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
+ & 0.6943D+00*SB2)
+ A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
+ A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
+ A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
+ A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
+ A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
+ ENDIF
+
+C...Expansion for CTEQ3M.
+ ELSEIF(ISET .EQ. 2) THEN
+ IF(IPRT .EQ. 2) THEN
+ A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
+ & 0.2935D+00*SB3)
+ A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
+ A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
+ A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
+ A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
+ A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
+ ELSEIF(IPRT .EQ. 1) THEN
+ A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
+ & 0.4305D-01*SB3)
+ A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
+ A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
+ A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
+ A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
+ A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
+ ELSEIF(IPRT .EQ. 0) THEN
+ A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
+ & 0.1037D-01*SB3)
+ A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
+ A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
+ A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
+ A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
+ A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
+ ELSEIF(IPRT .EQ. -1) THEN
+ A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
+ & 0.1602D+01*SB3)
+ A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
+ A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
+ A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
+ A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
+ A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
+ ELSEIF(IPRT .EQ. -2) THEN
+ A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
+ & 0.2496D+00*SB3)
+ A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
+ A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
+ A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
+ A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
+ A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
+ ELSEIF(IPRT .EQ. -3) THEN
+ A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
+ & 0.1936D+01*SB3)
+ A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
+ A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
+ A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
+ A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
+ A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
+ ELSEIF(IPRT .EQ. -4) THEN
+ A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
+ & 0.5348D+00*SB2)
+ A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
+ A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
+ A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
+ A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
+ A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
+ ELSEIF(IPRT .EQ. -5) THEN
+ A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
+ & 0.1569D+01*SB2)
+ A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
+ A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
+ A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
+ A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
+ A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
+ ELSEIF(IPRT .EQ. -6) THEN
+ A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
+ & 0.8838D+01*SB2)
+ A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
+ A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
+ A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
+ A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
+ A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
+ ENDIF
+
+C...Expansion for CTEQ3D.
+ ELSEIF(ISET .EQ. 3) THEN
+ IF(IPRT .EQ. 2) THEN
+ A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
+ & 0.2902D+00*SB3)
+ A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
+ A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
+ A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
+ A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
+ A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
+ ELSEIF(IPRT .EQ. 1) THEN
+ A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
+ & 0.7257D+00*SB3)
+ A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
+ A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
+ A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
+ A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
+ A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
+ ELSEIF(IPRT .EQ. 0) THEN
+ A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
+ & 0.2734D-04*SB3)
+ A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
+ A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
+ A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
+ A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
+ A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
+ ELSEIF(IPRT .EQ. -1) THEN
+ A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
+ & 0.1671D+01*SB3)
+ A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
+ A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
+ A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
+ A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
+ A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
+ ELSEIF(IPRT .EQ. -2) THEN
+ A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
+ & 0.2223D+00*SB3)
+ A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
+ A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
+ A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
+ A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
+ A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
+ ELSEIF(IPRT .EQ. -3) THEN
+ A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
+ & 0.1937D+01*SB3)
+ A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
+ A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
+ A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
+ A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
+ A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
+ ELSEIF(IPRT .EQ. -4) THEN
+ A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
+ & 0.5137D+00*SB2)
+ A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
+ A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
+ A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
+ A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
+ A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
+ ELSEIF(IPRT .EQ. -5) THEN
+ A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
+ & 0.2143D+01*SB2)
+ A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
+ A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
+ A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
+ A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
+ A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
+ ELSEIF(IPRT .EQ. -6) THEN
+ A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
+ & 0.9998D+01*SB2)
+ A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
+ A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
+ A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
+ A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
+ A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
+ ENDIF
+ ENDIF
+
+C...Calculation of x * f(x, Q).
+ PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
+ & *(LOG(1D0+1D0/X))**A5 )
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVL
+C...Gives the GRV 94 L (leading order) parton distribution function set
+C...in parametrized form.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Common expressions.
+ MU2 = 0.23D0
+ LAM2 = 0.2322D0 * 0.2322D0
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+
+C...uv :
+ NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
+ AKU = 0.590D0 - 0.024D0 * S
+ BKU = 0.131D0 + 0.063D0 * S
+ AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
+ BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
+ CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
+ DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
+ UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
+
+C...dv :
+ ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
+ AKD = 0.376D0
+ BKD = 0.486D0 + 0.062D0 * S
+ AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
+ BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
+ CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
+ DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
+ DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
+
+C...del :
+ NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
+ AKE = 0.409D0 - 0.005D0 * S
+ BKE = 0.799D0 + 0.071D0 * S
+ AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
+ BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
+ CE = 0.0D0
+ DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
+ DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
+
+C...udb :
+ ALX = 1.451D0
+ BEX = 0.271D0
+ AKX = 0.410D0 - 0.232D0 * S
+ BKX = 0.534D0 - 0.457D0 * S
+ AGX = 0.890D0 - 0.140D0 * S
+ BGX = -0.981D0
+ CX = 0.320D0 + 0.683D0 * S
+ DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
+ EX = 4.119D0 + 1.713D0 * S
+ ESX = 0.682D0 + 2.978D0 * S
+ UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
+ & DX, EX, ESX)
+
+C...sb :
+ STS = 0D0
+ ALS = 0.914D0
+ BES = 0.577D0
+ AKS = 1.798D0 - 0.596D0 * S
+ AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
+ BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
+ DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
+ EST = 3.981D0 + 1.638D0 * S
+ ESS = 6.402D0
+ SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+
+C...cb :
+ STC = 0.888D0
+ ALC = 1.01D0
+ BEC = 0.37D0
+ AKC = 0D0
+ AC = 0D0
+ BC = 4.24D0 - 0.804D0 * S
+ DCT = 3.46D0 - 1.076D0 * S
+ ECT = 4.61D0 + 1.49D0 * S
+ ESC = 2.555D0 + 1.961D0 * S
+ CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
+
+C...bb :
+ STB = 1.351D0
+ ALB = 1.00D0
+ BEB = 0.51D0
+ AKB = 0D0
+ AB = 0D0
+ BB = 1.848D0
+ DBT = 2.929D0 + 1.396D0 * S
+ EBT = 4.71D0 + 1.514D0 * S
+ ESB = 4.02D0 + 1.239D0 * S
+ BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
+
+C...gl :
+ ALG = 0.524D0
+ BEG = 1.088D0
+ AKG = 1.742D0 - 0.930D0 * S
+ BKG = - 0.399D0 * S2
+ AG = 7.486D0 - 2.185D0 * S
+ BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
+ CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
+ DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
+ EG = 0.807D0 + 2.005D0 * S
+ ESG = 3.841D0 + 0.316D0 * S
+ GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
+ & DG, EG, ESG)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVM
+C...Gives the GRV 94 M (MSbar) parton distribution function set
+C...in parametrized form.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Common expressions.
+ MU2 = 0.34D0
+ LAM2 = 0.248D0 * 0.248D0
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+
+C...uv :
+ NU = 1.304D0 + 0.863D0 * S
+ AKU = 0.558D0 - 0.020D0 * S
+ BKU = 0.183D0 * S
+ AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
+ BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
+ CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
+ DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
+ UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
+
+C...dv :
+ ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
+ AKD = 0.270D0 - 0.019D0 * S
+ BKD = 0.260D0
+ AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
+ BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
+ CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
+ DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
+ DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
+
+C...del :
+ NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
+ AKE = 0.409D0 - 0.007D0 * S
+ BKE = 0.782D0 + 0.082D0 * S
+ AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
+ BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
+ CE = 0.0D0
+ DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
+ DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
+
+C...udb :
+ ALX = 0.877D0
+ BEX = 0.561D0
+ AKX = 0.275D0
+ BKX = 0.0D0
+ AGX = 0.997D0
+ BGX = 3.210D0 - 1.866D0 * S
+ CX = 7.300D0
+ DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
+ EX = 3.077D0 + 1.446D0 * S
+ ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
+ UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
+ & DX, EX, ESX)
+
+C...sb :
+ STS = 0D0
+ ALS = 0.756D0
+ BES = 0.216D0
+ AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
+ AS = -4.329D0 + 1.131D0 * S
+ BS = 9.568D0 - 1.744D0 * S
+ DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
+ EST = 3.031D0 + 1.639D0 * S
+ ESS = 5.837D0 + 0.815D0 * S
+ SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+
+C...cb :
+ STC = 0.820D0
+ ALC = 0.98D0
+ BEC = 0D0
+ AKC = -0.625D0 - 0.523D0 * S
+ AC = 0D0
+ BC = 1.896D0 + 1.616D0 * S
+ DCT = 4.12D0 + 0.683D0 * S
+ ECT = 4.36D0 + 1.328D0 * S
+ ESC = 0.677D0 + 0.679D0 * S
+ CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
+
+C...bb :
+ STB = 1.297D0
+ ALB = 0.99D0
+ BEB = 0D0
+ AKB = - 0.193D0 * S
+ AB = 0D0
+ BB = 0D0
+ DBT = 3.447D0 + 0.927D0 * S
+ EBT = 4.68D0 + 1.259D0 * S
+ ESB = 1.892D0 + 2.199D0 * S
+ BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
+
+C...gl :
+ ALG = 1.014D0
+ BEG = 1.738D0
+ AKG = 1.724D0 + 0.157D0 * S
+ BKG = 0.800D0 + 1.016D0 * S
+ AG = 7.517D0 - 2.547D0 * S
+ BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
+ CG = 4.039D0 + 1.491D0 * S
+ DG = 3.404D0 + 0.830D0 * S
+ EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
+ ESG = 3.256D0 - 0.436D0 * S
+ GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVD
+C...Gives the GRV 94 D (DIS) parton distribution function set
+C...in parametrized form.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Common expressions.
+ MU2 = 0.34D0
+ LAM2 = 0.248D0 * 0.248D0
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+ S3 = S2 * S
+
+C...uv :
+ NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
+ AKU = 0.563D0 - 0.025D0 * S
+ BKU = 0.054D0 + 0.154D0 * S
+ AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
+ BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
+ CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
+ DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
+ UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
+
+C...dv :
+ ND = 0.156D0 - 0.017D0 * S
+ AKD = 0.299D0 - 0.022D0 * S
+ BKD = 0.259D0 - 0.015D0 * S
+ AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
+ BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
+ CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
+ DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
+ DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
+
+C...del :
+ NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
+ AKE = 0.419D0 - 0.013D0 * S
+ BKE = 1.064D0 - 0.038D0 * S
+ AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
+ BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
+ CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
+ DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
+ DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
+
+C...udb :
+ ALX = 1.215D0
+ BEX = 0.466D0
+ AKX = 0.326D0 + 0.150D0 * S
+ BKX = 0.956D0 + 0.405D0 * S
+ AGX = 0.272D0
+ BGX = 3.794D0 - 2.359D0 * DS
+ CX = 2.014D0
+ DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
+ EX = 3.049D0 + 1.597D0 * S
+ ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
+ UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
+ & DX, EX, ESX)
+
+C...sb :
+ STS = 0D0
+ ALS = 0.175D0
+ BES = 0.344D0
+ AKS = 1.415D0 - 0.641D0 * DS
+ AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
+ BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
+ DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
+ EST = 4.546D0 + 0.372D0 * S2
+ ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
+ SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
+
+C...cb :
+ STC = 0.820D0
+ ALC = 0.98D0
+ BEC = 0D0
+ AKC = -0.625D0 - 0.523D0 * S
+ AC = 0D0
+ BC = 1.896D0 + 1.616D0 * S
+ DCT = 4.12D0 + 0.683D0 * S
+ ECT = 4.36D0 + 1.328D0 * S
+ ESC = 0.677D0 + 0.679D0 * S
+ CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
+
+C...bb :
+ STB = 1.297D0
+ ALB = 0.99D0
+ BEB = 0D0
+ AKB = - 0.193D0 * S
+ AB = 0D0
+ BB = 0D0
+ DBT = 3.447D0 + 0.927D0 * S
+ EBT = 4.68D0 + 1.259D0 * S
+ ESB = 1.892D0 + 2.199D0 * S
+ BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
+
+C...gl :
+ ALG = 1.258D0
+ BEG = 1.846D0
+ AKG = 2.423D0
+ BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
+ AG = 25.09D0 - 7.935D0 * S
+ BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
+ CG = 590.3D0 - 173.8D0 * S
+ DG = 5.196D0 + 1.857D0 * S
+ EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
+ ESG = 3.232D0 - 0.542D0 * S
+ GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVV
+C...Auxiliary for the GRV 94 parton distribution functions
+C...for u and d valence and d-u sea.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Evaluation.
+ DX = SQRT (X)
+ PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
+ & (1D0- X)**D
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVW
+C...Auxiliary for the GRV 94 parton distribution functions
+C...for d+u sea and gluon.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Evaluation.
+ LX = LOG (1D0/X)
+ PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
+ & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGRVS
+C...Auxiliary for the GRV 94 parton distribution functions
+C...for s, c and b sea.
+C...Authors: M. Glueck, E. Reya and A. Vogt.
+
+ FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION (A - Z)
+
+C...Evaluation.
+ IF(S.LE.STH) THEN
+ PYGRVS = 0D0
+ ELSE
+ DX = SQRT (X)
+ LX = LOG (1D0/X)
+ PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
+ & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYHFTH
+C...Gives threshold attractive/repulsive factor for heavy flavour
+C...production.
+
+ FUNCTION PYHFTH(SH,SQM,FRATT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/
+
+C...Value for alpha_strong.
+ IF(MSTP(35).LE.1) THEN
+ ALSSG=PARP(35)
+ ELSE
+ MST115=MSTU(115)
+ MSTU(115)=MSTP(36)
+ Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
+ & PARP(36)**2)))
+ ALSSG=PYALPS(Q2BN)
+ MSTU(115)=MST115
+ ENDIF
+
+C...Evaluate attractive and repulsive factors.
+ XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
+ FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
+ XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
+ FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
+ PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
+ VINT(138)=PYHFTH
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSPLI
+C...Splits a hadron remnant into two (partons or hadron + parton)
+C...in case it is more complicated than just a quark or a diquark.
+
+ SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ SAVE /PYPARS/,/PYINT1/
+C...Local array.
+ DIMENSION KFL(3)
+
+C...Preliminaries. Parton composition.
+ KFA=IABS(KF)
+ KFS=ISIGN(1,KF)
+ KFL(1)=MOD(KFA/1000,10)
+ KFL(2)=MOD(KFA/100,10)
+ KFL(3)=MOD(KFA/10,10)
+ IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
+ KFL(2)=INT(1.5D0+PYR(0))
+ IF(MINT(105).EQ.333) KFL(2)=3
+ IF(MINT(105).EQ.443) KFL(2)=4
+ KFL(3)=KFL(2)
+ ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
+ KFL(2)=2
+ KFL(3)=2
+ ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
+ KFL(2)=1
+ KFL(3)=1
+ ENDIF
+ IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
+ KFLR=KFLIN*KFS
+ ELSE
+ KFLR=KFLIN
+ ENDIF
+ KFLCH=0
+
+C...Subdivide lepton.
+ IF(KFA.GE.11.AND.KFA.LE.18) THEN
+ IF(KFLR.EQ.KFA) THEN
+ KFLSP=KFS*22
+ ELSEIF(KFLR.EQ.22) THEN
+ KFLSP=KFA
+ ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
+ KFLSP=KFA+1
+ ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
+ KFLSP=KFA-1
+ ELSEIF(KFLR.EQ.21) THEN
+ KFLSP=KFA
+ KFLCH=KFS*21
+ ELSE
+ KFLSP=KFA
+ KFLCH=-KFLR
+ ENDIF
+
+C...Subdivide photon.
+ ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
+ IF(KFLR.NE.21) THEN
+ KFLSP=-KFLR
+ ELSE
+ RAGR=0.75D0*PYR(0)
+ KFLSP=1
+ IF(RAGR.GT.0.125D0) KFLSP=2
+ IF(RAGR.GT.0.625D0) KFLSP=3
+ IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
+ KFLCH=-KFLSP
+ ENDIF
+
+C...Subdivide Reggeon or Pomeron.
+ ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
+ IF(KFLIN.EQ.21) THEN
+ KFLSP=KFS*21
+ ELSE
+ KFLSP=-KFLIN
+ ENDIF
+
+C...Subdivide meson.
+ ELSEIF(KFL(1).EQ.0) THEN
+ KFL(2)=KFL(2)*(-1)**KFL(2)
+ KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
+ IF(KFLR.EQ.KFL(2)) THEN
+ KFLSP=KFL(3)
+ ELSEIF(KFLR.EQ.KFL(3)) THEN
+ KFLSP=KFL(2)
+ ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
+ KFLSP=KFL(2)
+ KFLCH=KFL(3)
+ ELSEIF(KFLR.EQ.21) THEN
+ KFLSP=KFL(3)
+ KFLCH=KFL(2)
+ ELSEIF(KFLR*KFL(2).GT.0) THEN
+ CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
+ KFLSP=KFL(3)
+ ELSE
+ CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
+ KFLSP=KFL(2)
+ ENDIF
+
+C...Subdivide baryon.
+ ELSE
+ NAGR=0
+ DO 100 J=1,3
+ IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
+ 100 CONTINUE
+ IF(NAGR.GE.1) THEN
+ RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
+ IAGR=0
+ DO 110 J=1,3
+ IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
+ IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
+ 110 CONTINUE
+ ELSE
+ IAGR=1.00001D0+2.99998D0*PYR(0)
+ ENDIF
+ ID1=1
+ IF(IAGR.EQ.1) ID1=2
+ IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
+ ID2=6-IAGR-ID1
+ KSP=3
+ IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
+ IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
+ ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
+ IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
+ ELSEIF(MOD(KFA,10).EQ.2) THEN
+ IF(IAGR.EQ.1) KSP=1
+ IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
+ ENDIF
+ KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
+ IF(KFLR.EQ.21) THEN
+ KFLCH=KFL(IAGR)
+ ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
+ CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
+ ELSEIF(NAGR.EQ.0) THEN
+ CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
+ KFLSP=KFL(IAGR)
+ ENDIF
+ ENDIF
+
+C...Add on correct sign for result.
+ KFLCH=KFLCH*KFS
+ KFLSP=KFLSP*KFS
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGAMM
+C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
+C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
+C...(Dover, 1965) 6.1.36.
+
+ FUNCTION PYGAMM(X)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Local array and data.
+ DIMENSION B(8)
+ DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
+ &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
+
+ NX=INT(X)
+ DX=X-NX
+
+ PYGAMM=1D0
+ DXP=1D0
+ DO 100 I=1,8
+ DXP=DXP*DX
+ PYGAMM=PYGAMM+B(I)*DXP
+ 100 CONTINUE
+ IF(X.LT.1D0) THEN
+ PYGAMM=PYGAMM/X
+ ELSE
+ DO 110 IX=1,NX-1
+ PYGAMM=(X-IX)*PYGAMM
+ 110 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYWAUX
+C...Calculates real and imaginary parts of the auxiliary functions W1
+C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
+C...der Bij, Nucl. Phys. B297 (1988) 221.
+
+ SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+ ASINH(X)=LOG(X+SQRT(X**2+1D0))
+ ACOSH(X)=LOG(X+SQRT(X**2-1D0))
+
+ IF(EPS.LT.0D0) THEN
+ IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
+ IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
+ WIM=0D0
+ ELSEIF(EPS.LT.1D0) THEN
+ IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
+ IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
+ IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
+ IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
+ ELSE
+ IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
+ IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
+ WIM=0D0
+ ENDIF
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYI3AU
+C...Calculates real and imaginary parts of the auxiliary function I3;
+C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
+C...Nucl. Phys. B297 (1988) 221.
+
+ SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+ BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
+ IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
+
+ IF(EPS.LT.0D0) THEN
+ IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
+ F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
+ & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
+ & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
+ & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
+ & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
+ & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
+ & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
+ & EPS))
+ ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
+ F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
+ & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
+ & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
+ & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
+ & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
+ & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
+ & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
+ ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
+ F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
+ & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
+ & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
+ & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
+ & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
+ & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
+ & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
+ ELSE
+ F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
+ & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
+ & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
+ & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
+ & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
+ ENDIF
+ F3IM=0D0
+ ELSEIF(EPS.LT.1D0) THEN
+ IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
+ F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
+ & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
+ & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
+ & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
+ & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
+ & (0.25D0*(RAT+1D0)*EPS))
+ F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
+ & (0.25D0*(RAT+1D0)*EPS))
+ ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
+ F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
+ & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
+ & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
+ & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
+ & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
+ & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
+ F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
+ ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
+ F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
+ & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
+ & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
+ & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
+ & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
+ & (1D0+0.25D0*RAT*EPS-GA))
+ F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
+ & (1D0+0.25D0*RAT*EPS-GA))
+ ELSE
+ F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
+ & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
+ & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
+ & LOG((GA+BE-1D0)/(BE-GA))
+ F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
+ ENDIF
+ ELSE
+ RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
+ RCTHE=RSQ*(1D0-2D0*BE/EPS)
+ RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
+ RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
+ RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
+ R=SQRT(RSQ)
+ THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
+ PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
+ F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
+ & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
+ & (PHI-THE)*(PHI+THE-PARU(1))
+ F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
+ & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
+ ENDIF
+
+ Y3RE=2D0/(2D0*BE-1D0)*F3RE
+ Y3IM=2D0/(2D0*BE-1D0)*F3IM
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYSPEN
+C...Calculates real and imaginary part of Spence function; see
+C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
+
+ FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+C...Local array and data.
+ DIMENSION B(0:14)
+ DATA B/
+ &1.000000D+00, -5.000000D-01, 1.666667D-01,
+ &0.000000D+00, -3.333333D-02, 0.000000D+00,
+ &2.380952D-02, 0.000000D+00, -3.333333D-02,
+ &0.000000D+00, 7.575757D-02, 0.000000D+00,
+ &-2.531135D-01, 0.000000D+00, 1.166667D+00/
+
+ XRE=XREIN
+ XIM=XIMIN
+ IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
+ IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
+ IF(IREIM.EQ.2) PYSPEN=0D0
+ RETURN
+ ENDIF
+
+ XMOD=SQRT(XRE**2+XIM**2)
+ IF(XMOD.LT.1.D-6) THEN
+ IF(IREIM.EQ.1) PYSPEN=0D0
+ IF(IREIM.EQ.2) PYSPEN=0D0
+ RETURN
+ ENDIF
+
+ XARG=SIGN(ACOS(XRE/XMOD),XIM)
+ SP0RE=0D0
+ SP0IM=0D0
+ SGN=1D0
+ IF(XMOD.GT.1D0) THEN
+ ALGXRE=LOG(XMOD)
+ ALGXIM=XARG-SIGN(PARU(1),XARG)
+ SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
+ SP0IM=-ALGXRE*ALGXIM
+ SGN=-1D0
+ XMOD=1D0/XMOD
+ XARG=-XARG
+ XRE=XMOD*COS(XARG)
+ XIM=XMOD*SIN(XARG)
+ ENDIF
+ IF(XRE.GT.0.5D0) THEN
+ ALGXRE=LOG(XMOD)
+ ALGXIM=XARG
+ XRE=1D0-XRE
+ XIM=-XIM
+ XMOD=SQRT(XRE**2+XIM**2)
+ XARG=SIGN(ACOS(XRE/XMOD),XIM)
+ ALGYRE=LOG(XMOD)
+ ALGYIM=XARG
+ SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
+ SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
+ SGN=-SGN
+ ENDIF
+
+ XRE=1D0-XRE
+ XIM=-XIM
+ XMOD=SQRT(XRE**2+XIM**2)
+ XARG=SIGN(ACOS(XRE/XMOD),XIM)
+ ZRE=-LOG(XMOD)
+ ZIM=-XARG
+
+ SPRE=0D0
+ SPIM=0D0
+ SAVERE=1D0
+ SAVEIM=0D0
+ DO 100 I=0,14
+ IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
+ TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
+ TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
+ SAVERE=TERMRE
+ SAVEIM=TERMIM
+ SPRE=SPRE+B(I)*TERMRE
+ SPIM=SPIM+B(I)*TERMIM
+ 100 CONTINUE
+
+ 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
+ IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
+
+ RETURN
+ END
+
+C***********************************************************************
+
+C...PYQQBH
+C...Calculates the matrix element for the processes
+C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
+C...REDUCE output and part of the rest courtesy Z. Kunszt, see
+C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
+
+ SUBROUTINE PYQQBH(WTQQBH)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
+C...Local arrays and function.
+ DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
+ DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
+ &PP(I,3)*PP(J,3)
+
+C...Mass parameters.
+ WTQQBH=0D0
+ ISUB=MINT(1)
+ SHPR=SQRT(VINT(26))*VINT(1)
+ PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
+ PH=SQRT(VINT(21))*VINT(1)
+ SPQ=PQ**2
+ SPH=PH**2
+
+C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
+ DO 100 I=1,2
+ PT=SQRT(MAX(0D0,VINT(197+5*I)))
+ PP(I,1)=PT*COS(VINT(198+5*I))
+ PP(I,2)=PT*SIN(VINT(198+5*I))
+ 100 CONTINUE
+ PP(3,1)=-PP(1,1)-PP(2,1)
+ PP(3,2)=-PP(1,2)-PP(2,2)
+ PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
+ PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
+ PMS3=SPH+PP(3,1)**2+PP(3,2)**2
+ PMT3=SQRT(PMS3)
+ PP(3,3)=PMT3*SINH(VINT(211))
+ PP(3,4)=PMT3*COSH(VINT(211))
+ PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
+ PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
+ &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
+ PP(2,3)=-PP(1,3)-PP(3,3)
+ PP(1,4)=SQRT(PMS1+PP(1,3)**2)
+ PP(2,4)=SQRT(PMS2+PP(2,3)**2)
+
+C...Set up incoming kinematics and derived momentum combinations.
+ DO 110 I=4,5
+ PP(I,1)=0D0
+ PP(I,2)=0D0
+ PP(I,3)=-0.5D0*SHPR*(-1)**I
+ PP(I,4)=-0.5D0*SHPR
+ 110 CONTINUE
+ DO 120 J=1,4
+ PP(6,J)=PP(1,J)+PP(2,J)
+ PP(7,J)=PP(1,J)+PP(3,J)
+ PP(8,J)=PP(1,J)+PP(4,J)
+ PP(9,J)=PP(1,J)+PP(5,J)
+ PP(10,J)=-PP(2,J)-PP(3,J)
+ PP(11,J)=-PP(2,J)-PP(4,J)
+ PP(12,J)=-PP(2,J)-PP(5,J)
+ PP(13,J)=-PP(4,J)-PP(5,J)
+ 120 CONTINUE
+
+C...Derived kinematics invariants.
+ X1=DOT(1,2)
+ X2=DOT(1,3)
+ X3=DOT(1,4)
+ X4=DOT(1,5)
+ X5=DOT(2,3)
+ X6=DOT(2,4)
+ X7=DOT(2,5)
+ X8=DOT(3,4)
+ X9=DOT(3,5)
+ X10=DOT(4,5)
+
+C...Propagators.
+ SS1=DOT(7,7)-SPQ
+ SS2=DOT(8,8)-SPQ
+ SS3=DOT(9,9)-SPQ
+ SS4=DOT(10,10)-SPQ
+ SS5=DOT(11,11)-SPQ
+ SS6=DOT(12,12)-SPQ
+ SS7=DOT(13,13)
+ DX(1)=SS1*SS6
+ DX(2)=SS2*SS6
+ DX(3)=SS2*SS4
+ DX(4)=SS1*SS5
+ DX(5)=SS3*SS5
+ DX(6)=SS3*SS4
+ DX(7)=SS7*SS1
+ DX(8)=SS7*SS4
+
+C...Define colour coefficients for g + g -> Q + Qbar + H.
+ IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
+ DO 140 I=1,3
+ DO 130 J=1,3
+ CLR(I,J)=16D0/3D0
+ CLR(I+3,J+3)=16D0/3D0
+ CLR(I,J+3)=-2D0/3D0
+ CLR(I+3,J)=-2D0/3D0
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 160 L=1,2
+ DO 150 I=1,3
+ CLR(I,6+L)=-6D0
+ CLR(I+3,6+L)=6D0
+ CLR(6+L,I)=-6D0
+ CLR(6+L,I+3)=6D0
+ 150 CONTINUE
+ 160 CONTINUE
+ DO 180 K1=1,2
+ DO 170 K2=1,2
+ CLR(6+K1,6+K2)=12D0
+ 170 CONTINUE
+ 180 CONTINUE
+
+C...Evaluate matrix elements for g + g -> Q + Qbar + H.
+ FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
+ & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
+ & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
+ FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
+ & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
+ & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
+ & X10)
+ FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
+ & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
+ & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
+ & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
+ & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
+ & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
+ FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
+ & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
+ & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
+ & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
+ & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
+ FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
+ & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
+ & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
+ & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
+ & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
+ & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
+ & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
+ & X4*X6*X5)
+ FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
+ & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
+ & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
+ & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
+ & +X4*X9*X5+X4*X5**2)
+ FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
+ & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
+ & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
+ & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
+ & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
+ & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
+ FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
+ & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
+ & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
+ & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
+ & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
+ & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
+ & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
+ & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
+ & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
+ FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
+ & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
+ FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
+ & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
+ & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
+ & X6)
+ FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
+ & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
+ & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
+ & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
+ & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
+ & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
+ & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
+ & X5+X4*X6*X5)
+ FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
+ & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
+ & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
+ & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
+ & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
+ & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
+ & X6**2)
+ FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
+ & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
+ & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
+ & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
+ & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
+ & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
+ & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
+ & X4*X6*X5)
+ FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
+ & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
+ & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
+ & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
+ & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
+ & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
+ & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
+ & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
+ & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
+ & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
+ & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
+ FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
+ & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
+ & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
+ & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
+ & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
+ & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
+ & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
+ & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
+ & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
+ & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
+ & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
+ FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
+ & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
+ & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
+ FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
+ & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
+ & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
+ & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
+ & +X3*X8*X5+X3*X5**2)
+ FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
+ & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
+ & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
+ & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
+ & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
+ & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
+ & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
+ & X5+X4*X6*X5)
+ FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
+ & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
+ & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
+ & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
+ & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
+ FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
+ & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
+ & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
+ & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
+ & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
+ & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
+ & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
+ & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
+ & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
+ FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
+ & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
+ & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
+ & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
+ & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
+ & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
+ FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
+ & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
+ & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
+ FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
+ & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
+ & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
+ & X10)
+ FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
+ & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
+ & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
+ & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
+ & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
+ & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
+ FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
+ & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
+ & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
+ & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
+ & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
+ & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
+ FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
+ & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
+ & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
+ & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
+ & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
+ & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
+ & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
+ & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
+ & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
+ FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
+ & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
+ FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
+ & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
+ & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
+ & X7)
+ FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
+ & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
+ & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
+ & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
+ & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
+ & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
+ & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
+ & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
+ & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
+ & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
+ & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
+ FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
+ & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
+ & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
+ & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
+ & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
+ & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
+ & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
+ & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
+ & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
+ & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
+ & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
+ FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
+ & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
+ & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
+ FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
+ & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
+ & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
+ & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
+ & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
+ & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
+ & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
+ & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
+ & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
+ FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
+ & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
+ & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
+ & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
+ & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
+ & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
+ FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
+ & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
+ & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
+ & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
+ & *X6)
+ FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
+ & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
+ & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
+ & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
+ & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
+ & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
+ & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
+ FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
+ & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
+ & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
+ & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
+ & X8)
+ FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
+ & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
+ & )+2*X2*(-X10*X5+X9*X6+X8*X7)
+ FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
+ & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
+ & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
+ & X9*X5)
+ FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
+ & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
+ & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
+ & X8*X5)
+ FM(9,10)=0.5D0*(FMXX+FM(9,10))
+ FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
+ & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
+ & )+2*X5*(-X10*X2+X9*X3+X8*X4)
+
+C...Repackage matrix elements.
+ DO 200 I=1,8
+ DO 190 J=1,8
+ RM(I,J)=FM(I,J)
+ 190 CONTINUE
+ 200 CONTINUE
+ RM(7,7)=FM(7,7)-2D0*FM(9,9)
+ RM(7,8)=FM(7,8)-2D0*FM(9,10)
+ RM(8,8)=FM(8,8)-2D0*FM(10,10)
+
+C...Produce final result: matrix elements * colours * propagators.
+ DO 220 I=1,8
+ DO 210 J=I,8
+ FAC=8D0
+ IF(I.EQ.J)FAC=4D0
+ WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
+ 210 CONTINUE
+ 220 CONTINUE
+ WTQQBH=-WTQQBH/256D0
+
+ ELSE
+C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
+ A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
+ & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
+ & *X6+X8*X7)
+ A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
+ & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
+ & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
+ & X5)
+ A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
+ & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
+ & *X9+X4*X8)
+
+C...Produce final result: matrix elements * propagators.
+ A11=A11/DX(7)**2
+ A12=A12/(DX(7)*DX(8))
+ A22=A22/DX(8)**2
+ WTQQBH=-(A11+A22+2D0*A12)/8D0
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYMSIN
+C...Initializes supersymmetry: finds sparticle masses and
+C...branching ratios and stores this information.
+C...AUTHOR: STEPHEN MRENNA
+
+ SUBROUTINE PYMSIN
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
+ &/PYSSMT/
+
+C...Local variables.
+ INTEGER NSTR
+ DOUBLE PRECISION ALFA,BETA
+ DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
+ DOUBLE PRECISION PYALEM
+ INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
+ INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
+ DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
+ DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
+ DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
+ DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
+ DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
+ DOUBLE PRECISION DELM,XMDIF,BRLIM
+ DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
+ DOUBLE PRECISION ARG,SGNMU,R,GAM
+ INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
+ INTEGER IMSSM,KFHIGG
+ INTEGER IRPRTY
+ INTEGER KFSUSY(36)
+ DATA KFSUSY/
+ &1000001,2000001,1000002,2000002,1000003,2000003,
+ &1000004,2000004,1000005,2000005,1000006,2000006,
+ &1000011,2000011,1000012,2000012,1000013,2000013,
+ &1000014,2000014,1000015,2000015,1000016,2000016,
+ &1000021,1000022,1000023,1000025,1000035,1000024,
+ &1000037,1000039, 25, 35, 36, 37/
+
+C...Do nothing if SUSY not requested.
+ IMSSM=IMSS(1)
+ IF(IMSSM.EQ.0) RETURN
+
+C...First part of routine: set masses and couplings.
+
+C...Reset mixing values in sfermion sector to pure left/right.
+ DO 100 I=1,16
+ SFMIX(I,1)=1D0
+ SFMIX(I,4)=1D0
+ SFMIX(I,2)=0D0
+ SFMIX(I,3)=0D0
+ 100 CONTINUE
+
+C...Common couplings.
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ COSB=COS(BETA)
+ SINB=TANB*COSB
+ COS2B=COS(2D0*BETA)
+ ALFA=RMSS(18)
+ XMW2=PMAS(24,1)**2
+ XMZ2=PMAS(23,1)**2
+ XW=PARU(102)
+
+C...Define sparticle masses for a general MSSM simulation.
+ IF(IMSSM.EQ.1) THEN
+ IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
+ DO 110 I=1,5,2
+ KC=PYCOMP(KSUSY1+I)
+ PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
+ KC=PYCOMP(KSUSY2+I)
+ PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
+ KC=PYCOMP(KSUSY1+I+1)
+ PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
+ KC=PYCOMP(KSUSY2+I+1)
+ PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
+ 110 CONTINUE
+ XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
+ IF(XARG.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
+ & ' FROM THE SUM RULE. '
+ WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
+ RETURN
+ ELSE
+ XARG=SQRT(XARG)
+ ENDIF
+ DO 120 I=11,15,2
+ PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
+ PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
+ PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
+ PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
+ 120 CONTINUE
+ IF(IMSS(8).EQ.1) THEN
+ RMSS(13)=RMSS(6)
+ RMSS(14)=RMSS(7)
+ ENDIF
+
+C...Alternatively derive masses from SUGRA relations.
+ ELSEIF(IMSSM.EQ.2) THEN
+ CALL PYAPPS
+ ENDIF
+
+C...Add in extra D-term contributions.
+ IF(IMSS(7).EQ.1) THEN
+ R=0.43D0
+ DX=RMSS(23)
+ DY=RMSS(24)
+ DS=RMSS(25)
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
+ WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
+ WRITE(MSTU(11),*) 'C DX = ',DX
+ WRITE(MSTU(11),*) 'C DY = ',DY
+ WRITE(MSTU(11),*) 'C DS = ',DS
+ WRITE(MSTU(11),*) 'C '
+ DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
+ WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ DQ2=DY/6D0-DX/3D0-DS/3D0
+ DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
+ DD2=DY/3D0+DX-2D0*DS/3D0
+ DL2=-DY/2D0+DX-2D0*DS/3D0
+ DE2=DY-DX/3D0-DS/3D0
+ DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
+ DHD2=-DY/2D0-2D0*DX/3D0+DS
+ DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
+ & /ABS(COS2B)
+ DMA2 = 2D0*DMU2+DHU2+DHD2
+ DO 130 I=1,5,2
+ KC=PYCOMP(KSUSY1+I)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
+ KC=PYCOMP(KSUSY2+I)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
+ KC=PYCOMP(KSUSY1+I+1)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
+ KC=PYCOMP(KSUSY2+I+1)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
+ 130 CONTINUE
+ DO 140 I=11,15,2
+ KC=PYCOMP(KSUSY1+I)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
+ KC=PYCOMP(KSUSY2+I)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
+ KC=PYCOMP(KSUSY1+I+1)
+ PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
+ 140 CONTINUE
+ IF(RMSS(4)**2+DMU2.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
+ STOP
+ ENDIF
+ SGNMU=SIGN(1D0,RMSS(4))
+ RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
+ ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
+ RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
+ ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
+ RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
+ ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
+ RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
+ ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
+ RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
+ ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
+ RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
+ IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
+ WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
+ STOP
+ ENDIF
+ RMSS(19)=SQRT(RMSS(19)**2+DMA2)
+ RMSS(6)=SQRT(RMSS(6)**2+DL2)
+ RMSS(7)=SQRT(RMSS(7)**2+DE2)
+ WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
+ WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
+ WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
+ WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
+ WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
+ ENDIF
+
+C...Fix the third generation sfermions.
+ CALL PYTHRG
+ XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
+ IF(XARG.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
+ & ' THE SUM RULE. '
+ WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
+ RETURN
+ ELSE
+ PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
+ ENDIF
+
+C...Fix the neutralino--chargino--gluino sector.
+ CALL PYINOM
+
+C...Fix the Higgs sector.
+ CALL PYHGGM(ALFA)
+
+C...Choose the Gunion-Haber convention.
+ ALFA=-ALFA
+ RMSS(18)=ALFA
+
+C...Print information on mass parameters.
+ IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
+ WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
+ WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
+ WRITE(MSTU(11),*) ' TANB=',RMSS(5)
+ WRITE(MSTU(11),*) ' MU = ',RMSS(4)
+ WRITE(MSTU(11),*) ' AT = ',RMSS(16)
+ WRITE(MSTU(11),*) ' MA = ',RMSS(19)
+ WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ ENDIF
+ IF(IMSS(20).EQ.1) THEN
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ WRITE(MSTU(11),*) ' DEBUG MODE '
+ WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
+ & UMIX(2,1),UMIX(2,2)
+ WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
+ & VMIX(2,1),VMIX(2,2)
+ WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
+ WRITE(MSTU(11),*) ' ALFA = ',ALFA
+ WRITE(MSTU(11),*) ' BETA = ',BETA
+ WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
+ WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
+ WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
+ ENDIF
+
+C...Set up the Higgs couplings - needed here since initialization
+C...in PYINRE did not yet occur when PYWIDT is called below.
+ AL=ALFA
+ BE=BETA
+ SINA=SIN(AL)
+ COSA=COS(AL)
+ COSB=COS(BE)
+ SINB=TANB*COSB
+C...tanb (used for H+)
+ PARU(141)=TANB
+
+C...Firstly: h
+C...Coupling to d-type quarks
+ PARU(161)=SINA/COSB
+C...Coupling to u-type quarks
+ PARU(162)=-COSA/SINB
+C...Coupling to leptons
+ PARU(163)=PARU(161)
+C...Coupling to Z
+ PARU(164)=SIN(BE-AL)
+C...Coupling to W
+ PARU(165)=PARU(164)
+C...Coupling to H+
+ PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
+
+C...Secondly: H
+C...Coupling to d-type quarks
+ PARU(171)=-COSA/COSB
+C...Coupling to u-type quarks
+ PARU(172)=-SINA/SINB
+C...Coupling to leptons
+ PARU(173)=PARU(171)
+C...Coupling to Z
+ PARU(174)=COS(BE-AL)
+C...Coupling to W
+ PARU(175)=PARU(174)
+C...Coupling to h
+ PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
+C...Coupling to A
+ PARU(177)=COS(2D0*BE)*COS(BE+AL)
+C...Coupling to H+
+ PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
+
+C...Thirdly, A
+C...Coupling to d-type quarks
+ PARU(181)=TANB
+C...Coupling to u-type quarks
+ PARU(182)=1D0/PARU(181)
+C...Coupling to leptons
+ PARU(183)=PARU(181)
+ PARU(184)=0D0
+ PARU(185)=0D0
+C...Coupling to Z h
+ PARU(186)=COS(BE-AL)
+C...Coupling to Z H
+ PARU(187)=SIN(BE-AL)
+ PARU(188)=0D0
+ PARU(189)=0D0
+ PARU(190)=0D0
+
+C...Finally: H+
+C...Coupling to W h
+ PARU(195)=COS(BE-AL)
+
+C...Tell that all Higgs couplings have been set.
+ MSTP(4)=1
+
+C...Second part of routine: set decay modes and branching ratios.
+
+C...Allow chi10 -> gravitino + gamma or not.
+ KC=PYCOMP(KSUSY1+39)
+ IF( IMSS(11) .NE. 0 ) THEN
+ PMAS(KC,1)=RMSS(21)/1000000000D0
+ PMAS(KC,2)=0.0001D0
+ IRPRTY=0
+ WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
+ ELSE
+ PMAS(KC,1)=9999D0
+ IRPRTY=1
+ ENDIF
+
+C...Loop over sparticle and Higgs species.
+ PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
+ DO 200 I=1,36
+ KF=KFSUSY(I)
+ KC=PYCOMP(KF)
+ LKNT=0
+
+C...Sfermion decays.
+ IF(I.LE.24) THEN
+C...First check to see if sneutrino is lighter than chi10.
+ IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
+ & PMAS(KC,1).LT.PMCHI1) THEN
+ ELSE
+ CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
+ ENDIF
+
+C...Gluino decays.
+ ELSEIF(I.EQ.25) THEN
+ CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
+
+C...Neutralino decays.
+ ELSEIF(I.GE.26.AND.I.LE.29) THEN
+ CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
+C...chi10 stable or chi10 -> gravitino + gamma.
+ IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
+ PMAS(KC,2)=1D-6
+ MDCY(KC,1)=0
+ MWID(KC)=0
+ ENDIF
+
+C...Chargino decays.
+ ELSEIF(I.GE.30.AND.I.LE.31) THEN
+ CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
+
+C...Gravitino is stable.
+ ELSEIF(I.EQ.32) THEN
+ MDCY(KC,1)=0
+ MWID(KC)=0
+
+C...Higgs decays.
+ ELSEIF(I.GE.33.AND.I.LE.36) THEN
+C...Calculate decays to non-SUSY particles.
+ CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
+ LKNT=0
+ DO 150 I1=0,100
+ XLAM(I1)=0D0
+ 150 CONTINUE
+ DO 170 I1=1,MDCY(KC,3)
+ K1=MDCY(KC,2)+I1-1
+ IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
+ & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
+ XLAM(I1)=WDTP(I1)
+ XLAM(0)=XLAM(0)+XLAM(I1)
+ DO 160 J1=1,3
+ IDLAM(I1,J1)=KFDP(K1,J1)
+ 160 CONTINUE
+ LKNT=LKNT+1
+ 170 CONTINUE
+C...Add the decays to SUSY particles.
+ CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
+ ENDIF
+
+C...Set stable particles.
+ IF(LKNT.EQ.0) THEN
+ MDCY(KC,1)=0
+ MWID(KC)=0
+ PMAS(KC,2)=1D-6
+ PMAS(KC,3)=1D-5
+ PMAS(KC,4)=0D0
+
+C...Store branching ratios in the standard tables.
+ ELSE
+ IDC=MDCY(KC,2)+MDCY(KC,3)-1
+ DELM=1D6
+ DO 190 IL=1,LKNT
+ IDCSV=IDC
+ 180 IDC=IDC+1
+ IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
+ IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
+ & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
+ BRAT(IDC)=XLAM(IL)/XLAM(0)
+ XMDIF=PMAS(KC,1)
+ IF(MDME(IDC,1).GE.1) THEN
+ XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
+ & PMAS(PYCOMP(KFDP(IDC,2)),1)
+ IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
+ & PMAS(PYCOMP(KFDP(IDC,3)),1)
+ ENDIF
+ IF(I.LE.32) THEN
+ IF(XMDIF.GE.0D0) THEN
+ DELM=MIN(DELM,XMDIF)
+ ELSE
+ WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
+ WRITE(MSTU(11),*) ' KF = ',KF
+ WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
+ ENDIF
+ ENDIF
+ GOTO 190
+ ELSEIF(IDC.EQ.IDCSV) THEN
+ WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
+ & 'channel not recognized:'
+ WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
+ GOTO 190
+ ELSE
+ GOTO 180
+ ENDIF
+ 190 CONTINUE
+
+C...Store width, cutoff and lifetime.
+ PMAS(KC,2)=XLAM(0)
+ IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
+ PMAS(KC,3)=PMAS(KC,2)*10D0
+ ELSE
+ PMAS(KC,3)=0.95D0*DELM
+ ENDIF
+ IF(PMAS(KC,2).NE.0D0) THEN
+ PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYAPPS
+C...Uses approximate analytical formulae to determine the full set of
+C...MSSM parameters from SUGRA input.
+C...See M. Drees and S.P. Martin, hep-ph/9504124
+
+ SUBROUTINE PYAPPS
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
+
+ XMT=PMAS(6,1)
+ XMZ2=PMAS(23,1)**2
+ XMW2=PMAS(24,1)**2
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ XW=PARU(102)
+ XMG=RMSS(1)
+ XMG2=XMG*XMG
+ XM0=RMSS(8)
+ XM02=XM0*XM0
+ AT=-RMSS(16)
+ RMSS(15)=AT
+ RMSS(17)=AT
+ COSB=COS(BETA)
+ SINB=TANB*COSB
+
+ DTERM=XMZ2*COS(2D0*BETA)
+ XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
+ XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
+ RMSS(6)=XMEL
+ RMSS(7)=XMER
+ XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
+ XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
+ XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
+ XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
+ DO 100 I=1,5,2
+ PMAS(PYCOMP(KSUSY1+I),1)=XMDL
+ PMAS(PYCOMP(KSUSY2+I),1)=XMDR
+ PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
+ PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
+ 100 CONTINUE
+ XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
+ IF(XARG.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
+ & ' FROM THE SUM RULE. '
+ WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
+ RETURN
+ ELSE
+ XARG=SQRT(XARG)
+ ENDIF
+ DO 110 I=11,15,2
+ PMAS(PYCOMP(KSUSY1+I),1)=XMEL
+ PMAS(PYCOMP(KSUSY2+I),1)=XMER
+ PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
+ PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
+ 110 CONTINUE
+ XMNU=XARG
+
+ RMT=PYRNMT(XMT)
+ XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
+ &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
+ RMB=3D0
+ XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
+ &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
+ XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
+ ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
+ &SINB)**2)
+ RMSS(16)=-ATP
+ XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
+ XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
+ XMU=SIGN(SQRT(XMU2),RMSS(4))
+ RMSS(4)=XMU
+ RMSS(19)=SQRT(XMA2)
+ ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
+ IF(ARG.GT.0D0) THEN
+ RMSS(14)=SQRT(ARG)
+ ELSE
+ WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
+ STOP
+ ENDIF
+ ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
+ IF(ARG.GT.0D0) THEN
+ RMSS(13)=SQRT(ARG)
+ ELSE
+ WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
+ STOP
+ ENDIF
+ ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
+ IF(ARG.GT.0D0) THEN
+ RMSS(10)=SQRT(ARG)
+ ELSE
+ RMSS(10)=-SQRT(-ARG)
+ ENDIF
+ ARG=PYRNMQ(2,-2D0*XTOP/3D0)
+ IF(ARG.GT.0D0) THEN
+ RMSS(12)=SQRT(ARG)
+ ELSE
+ RMSS(12)=-SQRT(-ARG)
+ ENDIF
+ ARG=PYRNMQ(3,-2D0*XBOT/3D0)
+ IF(ARG.GT.0D0) THEN
+ RMSS(11)=SQRT(ARG)
+ ELSE
+ RMSS(11)=-SQRT(-ARG)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRNMQ
+C...Determines the running mass of quarks.
+
+ FUNCTION PYRNMQ(ID,DTERM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblock.
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYMSSM/
+
+C...Local variables.
+ DOUBLE PRECISION PI,R
+ DOUBLE PRECISION TOL
+ DOUBLE PRECISION CI(3)
+ EXTERNAL PYALPS
+ DATA TOL/0.001D0/
+ DATA PI,R/3.141592654D0,.61803399D0/
+ DATA CI/0.47D0,0.07D0,0.02D0/
+
+ C=1D0-R
+ CA=CI(ID)
+ AG=(0.71D0)**2/4D0/PI
+ AG=RMSS(20)
+ XM0=RMSS(8)
+ XMG=RMSS(1)
+ XM02=XM0*XM0
+ XMG2=XMG*XMG
+
+ AS=PYALPS(XM02+6D0*XMG2)
+ CG=8D0/9D0*((AS/AG)**2-1D0)
+ BX=XM02+(CA+CG)*XMG2+DTERM
+ AX=MIN(50D0**2,0.5D0*BX)
+ CX=MAX(2000D0**2,2D0*BX)
+
+ X0=AX
+ X3=CX
+ IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
+ X1=BX
+ X2=BX+C*(CX-BX)
+ ELSE
+ X2=BX
+ X1=BX-C*(BX-AX)
+ ENDIF
+ AS1=PYALPS(X1)
+ CG=8D0/9D0*((AS1/AG)**2-1D0)
+ F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
+ AS2=PYALPS(X2)
+ CG=8D0/9D0*((AS2/AG)**2-1D0)
+ F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
+ 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
+ IF(F2.LT.F1) THEN
+ X0=X1
+ X1=X2
+ X2=R*X1+C*X3
+ F1=F2
+ AS2=PYALPS(X2)
+ CG=8D0/9D0*((AS2/AG)**2-1D0)
+ F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
+ ELSE
+ X3=X2
+ X2=X1
+ X1=R*X2+C*X0
+ F2=F1
+ AS1=PYALPS(X1)
+ CG=8D0/9D0*((AS1/AG)**2-1D0)
+ F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
+ ENDIF
+ GOTO 100
+ ENDIF
+ IF(F1.LT.F2) THEN
+ PYRNMQ=X1
+ XMIN=X1
+ ELSE
+ PYRNMQ=X2
+ XMIN=X2
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRNMT
+C...Determines the running mass of the top quark.
+
+ FUNCTION PYRNMT(XMT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblock.
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYMSSM/
+
+C...Local variables.
+ DOUBLE PRECISION XMT
+ DOUBLE PRECISION PI,R
+ DOUBLE PRECISION TOL
+ EXTERNAL PYALPS
+ DATA TOL/0.001D0/
+ DATA PI,R/3.141592654D0,0.61803399D0/
+
+ C=1D0-R
+
+ BX=XMT
+ AX=MIN(50D0,BX*0.5D0)
+ CX=MAX(300D0,2D0*BX)
+
+ X0=AX
+ X3=CX
+ IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
+ X1=BX
+ X2=BX+C*(CX-BX)
+ ELSE
+ X2=BX
+ X1=BX-C*(BX-AX)
+ ENDIF
+ AS1=PYALPS(X1**2)/PI
+ F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
+ AS2=PYALPS(X2**2)/PI
+ F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
+ 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
+ IF(F2.LT.F1) THEN
+ X0=X1
+ X1=X2
+ X2=R*X1+C*X3
+ F1=F2
+ AS2=PYALPS(X2**2)/PI
+ F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
+ ELSE
+ X3=X2
+ X2=X1
+ X1=R*X2+C*X0
+ F2=F1
+ AS1=PYALPS(X1**2)/PI
+ F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
+ ENDIF
+ GOTO 100
+ ENDIF
+ IF(F1.LT.F2) THEN
+ PYRNMT=X1
+ XMIN=X1
+ ELSE
+ PYRNMT=X2
+ XMIN=X2
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTHRG
+C...Calculates the mass eigenstates of the third generation sfermions.
+C...Created: 5-31-96
+
+ SUBROUTINE PYTHRG
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ DOUBLE PRECISION BETA
+ DOUBLE PRECISION PYRNMT
+ DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
+ DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
+ DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
+ DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
+ INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
+ INTEGER IF,I,J,II,JJ,IT,L
+ LOGICAL DTERM
+ DATA SMALL/1D-3/
+ DATA ID1/10,10,13/
+ DATA ID2/5,6,15/
+ DATA ID3/15,16,17/
+ DATA ID4/11,12,14/
+ DATA DTERM/.TRUE./
+
+ XMZ2=PMAS(23,1)**2
+ XMW2=PMAS(24,1)**2
+ TANB=RMSS(5)
+ XMU=-RMSS(4)
+ BETA=ATAN(TANB)
+ COS2B=COS(2D0*BETA)
+
+C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
+
+ IOPT=IMSS(5)
+ IF(IOPT.EQ.1) THEN
+ CTT=RMSS(27)
+ CTT2=CTT**2
+ STT2=1D0-CTT2
+ STT=SQRT(STT2)
+ XM12=RMSS(12)**2
+ XM22=RMSS(10)**2
+ XMQL2=CTT2*XM12+STT2*XM22
+ XMQR2=STT2*XM12+CTT2*XM22
+ XMFR=PMAS(6,1)
+ XMF2=PYRNMT(XMFR)**2
+ ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
+ ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
+ XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
+ IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
+ STT=-STT
+ ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
+ ENDIF
+ RMSS(16)=ATOP
+C......SUBTRACT OUT D-TERM AND FERMION MASS
+ XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
+ XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
+ IF(XMQL2.GE.0D0) THEN
+ RMSS(10)=SQRT(XMQL2)
+ ELSE
+ RMSS(10)=-SQRT(-XMQL2)
+ ENDIF
+ IF(XMQR2.GE.0D0) THEN
+ RMSS(12)=SQRT(XMQR2)
+ ELSE
+ RMSS(12)=-SQRT(-XMQR2)
+ ENDIF
+C SAME FOR SBOTTOM SQUARK
+ CTT=RMSS(26)
+ CTT2=CTT**2
+ STT2=1D0-CTT2
+ STT=MAX(SQRT(STT2),1D-6)
+ XMF=3D00
+ XMF2=XMF**2
+ XM12=RMSS(11)**2
+ XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
+ IF(ABS(CTT).EQ.1D0) THEN
+ XM22=XM12
+ XM12=XMQL2
+ XMQR2=XM22
+ ELSEIF(CTT.EQ.0D0) THEN
+ XM22=XMQL2
+ XMQR2=XM12
+ ELSE
+ XM22=(XMQL2-CTT2*XM12)/STT2
+ XMQR2=STT2*XM12+CTT2*XM22
+ ENDIF
+ ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
+ ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
+ XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
+ IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
+ STT=-STT
+ ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
+ ENDIF
+ RMSS(15)=ABOT
+C......SUBTRACT OUT D-TERM AND FERMION MASS
+ XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
+ IF(XMQR2.GE.0D0) THEN
+ RMSS(11)=SQRT(XMQR2)
+ ELSE
+ RMSS(11)=-SQRT(-XMQR2)
+ ENDIF
+ ENDIF
+
+ DO 170 L=1,3
+ AMQL=RMSS(ID1(L))
+ IF(AMQL.LT.0D0) THEN
+ XMQL2=-AMQL**2
+ ELSE
+ XMQL2=AMQL**2
+ ENDIF
+ IF=ID2(L)
+ XMF=PMAS(IF,1)
+ IF(L.EQ.1) XMF=3D0
+ IF(L.EQ.2) XMF=PYRNMT(XMF)
+ XMF2=XMF**2
+ ATR=RMSS(ID3(L))
+ AMQR=RMSS(ID4(L))
+ IF(AMQR.LT.0D0) THEN
+ XMQR2=-AMQR**2
+ ELSE
+ XMQR2=AMQR**2
+ ENDIF
+ AM2(1,1)=XMQL2+XMF2
+ AM2(2,2)=XMQR2+XMF2
+ IF(DTERM) THEN
+ IF(L.EQ.1) THEN
+ AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
+ AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
+ AM2(1,2)=XMF*(ATR+XMU*TANB)
+ ELSEIF(L.EQ.2) THEN
+ AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
+ AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
+ AM2(1,2)=XMF*(ATR+XMU/TANB)
+ ELSEIF(L.EQ.3) THEN
+ IF(IMSS(8).EQ.1) THEN
+ AM2(1,1)=RMSS(6)**2
+ AM2(2,2)=RMSS(7)**2
+ AM2(1,2)=0D0
+ RMSS(13)=RMSS(6)
+ RMSS(14)=RMSS(7)
+ ELSE
+ AM2(1,2)=XMF*(ATR+XMU*TANB)
+ ENDIF
+ ENDIF
+ ENDIF
+ AM2(2,1)=AM2(1,2)
+ SAME=0.5D0*(AM2(1,1)+AM2(2,2))
+ DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
+ XMF12=SAME-DIFF
+ XMF22=SAME+DIFF
+ IF(XMF12.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
+ STOP
+ ENDIF
+ IT=0
+ IF(XMF22-XMF12.GT.0D0) THEN
+ RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
+ RT(2,2) = RT(1,1)
+ RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
+ RT(2,1) = -RT(1,2)
+ ELSE
+ RT(1,1) = 1D0
+ RT(2,2) = RT(1,1)
+ RT(1,2) = 0D0
+ RT(2,1) = -RT(1,2)
+ ENDIF
+ 100 CONTINUE
+ IT=IT+1
+
+ DO 140 I=1,2
+ DO 130 JJ=1,2
+ DI(I,JJ)=0D0
+ DO 120 II=1,2
+ DO 110 J=1,2
+ DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+
+ IF(DI(1,1).GT.DI(2,2)) THEN
+ WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
+ WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
+ WRITE(MSTU(11),*) AM2
+ WRITE(MSTU(11),*) DI
+ WRITE(MSTU(11),*) RT
+ DI(1,1)=-RT(2,1)
+ DI(2,2)=RT(1,2)
+ DI(1,2)=-RT(2,2)
+ DI(2,1)=RT(1,1)
+ DO 160 I=1,2
+ DO 150 J=1,2
+ RT(I,J)=DI(I,J)
+ 150 CONTINUE
+ 160 CONTINUE
+ GOTO 100
+ ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
+ WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
+ & ' OFF DIAGONAL ELEMENTS '
+ WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
+ WRITE(MSTU(11),*) DI
+ WRITE(MSTU(11),*) ' ROTATION = ',RT
+C...STOP
+ ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
+ WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
+ & ' NEGATIVE MASSES '
+ STOP
+ ENDIF
+ PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
+ PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
+ SFMIX(IF,1)=RT(1,1)
+ SFMIX(IF,2)=RT(1,2)
+ SFMIX(IF,3)=RT(2,1)
+ SFMIX(IF,4)=RT(2,2)
+ 170 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINOM
+C...Finds the mass eigenstates and mixing matrices for neutralinos
+C...and charginos.
+
+ SUBROUTINE PYINOM
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ DOUBLE PRECISION XMW,XMZ
+ DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
+ DOUBLE PRECISION ZP(4,4)
+ DOUBLE PRECISION DETX,XI(2,2)
+ DOUBLE PRECISION XXX,YYY,XMH,XML
+ DOUBLE PRECISION COSW,SINW
+ DOUBLE PRECISION XMU
+ DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
+ DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
+ DOUBLE PRECISION XM1,XM2,XM3,BETA
+ DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
+ DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
+ DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
+ DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
+ DOUBLE PRECISION PYALPS,PYALEM
+ DOUBLE PRECISION PYRNM3
+ INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+
+ IOPT=IMSS(2)
+ IF(IMSS(1).EQ.2) THEN
+ IOPT=1
+ ENDIF
+C...M1, M2, AND M3 ARE INDEPENDENT
+ IF(IOPT.EQ.0) THEN
+ XM1=RMSS(1)
+ XM2=RMSS(2)
+ XM3=RMSS(3)
+ ELSEIF(IOPT.GE.1) THEN
+ Q2=PMAS(23,1)**2
+ AEM=PYALEM(Q2)
+ A2=AEM/PARU(102)
+ A1=AEM/(1D0-PARU(102))
+ XM1=RMSS(1)
+ XM2=RMSS(2)
+ IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
+ IF(IOPT.EQ.1) THEN
+ XM2=XM1*A2/A1*3D0/5D0
+ ELSEIF(IOPT.EQ.3) THEN
+ XM1=XM2*5D0/3D0*A1/A2
+ ENDIF
+ XM3=PYRNM3(XM2/A2)
+ IF(XM3.LE.0D0) THEN
+ WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
+ STOP
+ ENDIF
+ ENDIF
+
+C...GLUINO MASS
+ IF(IMSS(3).EQ.1) THEN
+ PMAS(PYCOMP(KSUSY1+21),1)=XM3
+ ELSE
+ AQ=0D0
+ DO 110 I=1,4
+ DO 100 ILR=1,2
+ RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
+ AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
+ & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
+ 100 CONTINUE
+ 110 CONTINUE
+
+ DO 130 I=5,6
+ DO 120 ILR=1,2
+ RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
+ RM2=PMAS(I,1)**2/XM3**2
+ ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
+ IF(ARG.GE.0D0) THEN
+ X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
+ AX0=ABS(X0)
+ X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
+ AX1=ABS(X1)
+ IF(X0.EQ.1D0) THEN
+ AT=-1D0
+ BT=0.25D0
+ ELSEIF(X0.EQ.0D0) THEN
+ AT=0D0
+ BT=-0.25D0
+ ELSE
+ AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
+ & 0.5D0*X0**2*LOG(AX0)
+ BT=(-1D0-2D0*X0)/4D0
+ ENDIF
+ IF(X1.EQ.1D0) THEN
+ AT=-1D0+AT
+ BT=0.25D0+BT
+ ELSEIF(X1.EQ.0D0) THEN
+ AT=0D0+AT
+ BT=-0.25D0+BT
+ ELSE
+ AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
+ & X1**2*LOG(AX1)+AT
+ BT=(-1D0-2D0*X1)/4D0+BT
+ ENDIF
+ AQ=AQ+AT+BT
+ ELSE
+ X0=0.5D0*(1D0+RM2-RM1)
+ Y0=-0.5D0*SQRT(-ARG)
+ AMGX0=SQRT(X0**2+Y0**2)
+ AM1X0=SQRT((1D0-X0)**2+Y0**2)
+ ARGX0=ATAN2(-X0,-Y0)
+ AR1X0=ATAN2(1D0-X0,Y0)
+ X1=X0
+ Y1=-Y0
+ AMGX1=AMGX0
+ AM1X1=AM1X0
+ ARGX1=ATAN2(-X1,-Y1)
+ AR1X1=ATAN2(1D0-X1,Y1)
+ AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
+ & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
+ BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
+ AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
+ & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
+ BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
+ AQ=AQ+AT+BT
+ ENDIF
+ 120 CONTINUE
+ 130 CONTINUE
+ PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
+ & (15D0+AQ))
+ ENDIF
+
+C...NEUTRALINO MASSES
+ XMZ=PMAS(23,1)
+ XMW=PMAS(24,1)
+ XMU=RMSS(4)
+ SINW=SQRT(PARU(102))
+ COSW=SQRT(1D0-PARU(102))
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ COSB=COS(BETA)
+ SINB=TANB*COSB
+ AR(1,1) = XM1
+ AR(2,2) = XM2
+ AR(3,3) = 0D0
+ AR(4,4) = 0D0
+ AR(1,2) = 0D0
+ AR(2,1) = 0D0
+ AR(1,3) = -XMZ*SINW*COSB
+ AR(3,1) = AR(1,3)
+ AR(1,4) = XMZ*SINW*SINB
+ AR(4,1) = AR(1,4)
+ AR(2,3) = XMZ*COSW*COSB
+ AR(3,2) = AR(2,3)
+ AR(2,4) = -XMZ*COSW*SINB
+ AR(4,2) = AR(2,4)
+ AR(3,4) = -XMU
+ AR(4,3) = -XMU
+ CALL PYEIG4(AR,WR,ZR)
+ DO 150 I=1,4
+ SMZ(I)=WR(I)
+ PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
+ DO 140 J=1,4
+ ZMIX(I,J)=ZR(I,J)
+ IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
+ 140 CONTINUE
+ 150 CONTINUE
+
+C...CHARGINO MASSES
+ AR(1,1) = XM2
+ AR(2,2) = XMU
+ AR(1,2) = SQRT(2D0)*XMW*SINB
+ AR(2,1) = SQRT(2D0)*XMW*COSB
+ TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
+ TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
+ TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
+ &(AR(1,2)**2+AR(2,1)**2)+
+ &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
+ DISCR=TERMC
+ IF(DISCR.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
+ ELSE
+ DISCR=SQRT(DISCR)
+ ENDIF
+ XML2=0.5D0*(TERMB-DISCR)
+ XMH2=0.5D0*(TERMB+DISCR)
+ XML=SQRT(XML2)
+ XMH=SQRT(XMH2)
+ PMAS(PYCOMP(KSUSY1+24),1)=XML
+ PMAS(PYCOMP(KSUSY1+37),1)=XMH
+ SMW(1)=XML
+ SMW(2)=XMH
+ XXX=AR(1,1)**2+AR(2,1)**2
+ YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
+ VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
+ VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
+ VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
+ VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
+ ZR(1,1) = XML
+ ZR(1,2) = 0D0
+ ZR(2,1) = 0D0
+ ZR(2,2) = XMH
+ DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
+ XI(1,1) = AR(2,2)/DETX
+ XI(2,2) = AR(1,1)/DETX
+ XI(1,2) = -AR(1,2)/DETX
+ XI(2,1) = -AR(2,1)/DETX
+ DO 190 I=1,2
+ DO 180 J=1,2
+ UMIX(I,J)=0D0
+ DO 170 K=1,2
+ DO 160 L=1,2
+ UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+ 190 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRNM3
+C...Calculates the running of M3, the SU(3) gluino mass parameter.
+
+ FUNCTION PYRNM3(RGUT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION PI,R
+ DOUBLE PRECISION TOL
+ EXTERNAL PYALPS
+ DATA TOL/0.001D0/
+ DATA PI,R/3.141592654D0,0.61803399D0/
+
+ C=1D0-R
+
+ BX=RGUT*PYALPS(RGUT**2)
+ AX=MIN(50D0,BX*0.5D0)
+ CX=MAX(2000D0,2D0*BX)
+
+ X0=AX
+ X3=CX
+ IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
+ X1=BX
+ X2=BX+C*(CX-BX)
+ ELSE
+ X2=BX
+ X1=BX-C*(BX-AX)
+ ENDIF
+ AS1=PYALPS(X1**2)
+ F1=ABS(X1-RGUT*AS1)
+ AS2=PYALPS(X2**2)
+ F2=ABS(X2-RGUT*AS2)
+ 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
+ IF(F2.LT.F1) THEN
+ X0=X1
+ X1=X2
+ X2=R*X1+C*X3
+ F1=F2
+ AS2=PYALPS(X2**2)
+ F2=ABS(X2-RGUT*AS2)
+ ELSE
+ X3=X2
+ X2=X1
+ X1=R*X2+C*X0
+ F2=F1
+ AS1=PYALPS(X1**2)
+ F1=ABS(X1-RGUT*AS1)
+ ENDIF
+ GOTO 100
+ ENDIF
+ IF(F1.LT.F2) THEN
+ PYRNM3=X1
+ XMIN=X1
+ ELSE
+ PYRNM3=X2
+ XMIN=X2
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEIG4
+C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
+C...Specific application: mixing in neutralino sector.
+
+ SUBROUTINE PYEIG4(A,W,Z)
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Arrays: in call and local.
+ DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
+
+C...Coefficients of fourth-degree equation from matrix.
+C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
+ B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
+ B2=0D0
+ DO 110 I=1,3
+ DO 100 J=I+1,4
+ B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
+ 100 CONTINUE
+ 110 CONTINUE
+ B1=0D0
+ B0=0D0
+ DO 120 I=1,4
+ I1=MOD(I,4)+1
+ I2=MOD(I+1,4)+1
+ I3=MOD(I+2,4)+1
+ B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
+ & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
+ & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
+ B0=B0+(-1D0)**(I+1)*A(1,I)*(
+ & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
+ & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
+ & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
+ 120 CONTINUE
+
+C...Coefficients of third-degree equation needed for
+C...separation into two second-degree equations.
+C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
+ C2=-B2
+ C1=B1*B3-4D0*B0
+ C0=-B1**2-B0*B3**2+4D0*B0*B2
+ CQ=C1/3D0-C2**2/9D0
+ CR=C1*C2/6D0-C0/2D0-C2**3/27D0
+ CQR=CQ**3+CR**2
+
+C...Cases with one or three real roots.
+ IF(CQR.GE.0D0) THEN
+ S1=(CR+SQRT(CQR))**(1D0/3D0)
+ S2=(CR-SQRT(CQR))**(1D0/3D0)
+ U=S1+S2-C2/3D0
+ ELSE
+ SABS=SQRT(-CQ)
+ THE=ACOS(CR/SABS**3)/3D0
+ SRE=SABS*COS(THE)
+ U=2D0*SRE-C2/3D0
+ ENDIF
+
+C...Find and solve two second-degree equations.
+ P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
+ P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
+ Q1=U/2D0+SQRT(U**2/4D0-B0)
+ Q2=U/2D0-SQRT(U**2/4D0-B0)
+ IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
+ QSAV=Q1
+ Q1=Q2
+ Q2=QSAV
+ ENDIF
+ X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
+ X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
+ X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
+ X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
+
+C...Order eigenvalues in asceding mass.
+ W(1)=X(1)
+ DO 150 I1=2,4
+ DO 130 I2=I1-1,1,-1
+ IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
+ W(I2+1)=W(I2)
+ 130 CONTINUE
+ 140 W(I2+1)=X(I1)
+ 150 CONTINUE
+
+C...Find equation system for eigenvectors.
+ DO 250 I=1,4
+ DO 170 J1=1,4
+ D(J1,J1)=A(J1,J1)-W(I)
+ DO 160 J2=J1+1,4
+ D(J1,J2)=A(J1,J2)
+ D(J2,J1)=A(J2,J1)
+ 160 CONTINUE
+ 170 CONTINUE
+
+C...Find largest element in matrix.
+ DAMAX=0D0
+ DO 190 J1=1,4
+ DO 180 J2=1,4
+ IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
+ JA=J1
+ JB=J2
+ DAMAX=ABS(D(J1,J2))
+ 180 CONTINUE
+ 190 CONTINUE
+
+C...Subtract others by multiple of row selected above.
+ DAMAX=0D0
+ DO 210 J3=JA+1,JA+3
+ J1=J3-4*((J3-1)/4)
+ RL=D(J1,JB)/D(JA,JB)
+ DO 200 J2=1,4
+ D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
+ IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
+ JC=J1
+ JD=J2
+ DAMAX=ABS(D(J1,J2))
+ 200 CONTINUE
+ 210 CONTINUE
+
+C...Do one more subtraction of a row.
+ DAMAX=0D0
+ DO 230 J3=JC+1,JC+3
+ J1=J3-4*((J3-1)/4)
+ IF(J1.EQ.JA) GOTO 230
+ RL=D(J1,JD)/D(JC,JD)
+ DO 220 J2=1,4
+ IF(J2.EQ.JB) GOTO 220
+ D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
+ IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
+ JE=J1
+ DAMAX=ABS(D(J1,J2))
+ 220 CONTINUE
+ 230 CONTINUE
+
+C...Construct unnormalized eigenvector.
+ JF1=JD+1-4*(JD/4)
+ JF2=JD+2-4*((JD+1)/4)
+ IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
+ IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
+ E(JF1)=-D(JE,JF2)
+ E(JF2)=D(JE,JF1)
+ E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
+ E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
+ & D(JA,JB)
+
+C...Normalize and fill in final array.
+ EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
+ DO 240 J=1,4
+ Z(I,J)=SGN*E(J)/EA
+ 240 CONTINUE
+ 250 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYHGGM
+C...Determines the Higgs boson mass spectrum using several inputs.
+
+ SUBROUTINE PYHGGM(ALPHA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
+
+C...Local variables.
+ DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
+ DOUBLE PRECISION ALPHA
+ INTEGER I,J,IHOPT,II,JJ,IT
+ DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
+ DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
+ DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
+ DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
+
+ IHOPT=IMSS(4)
+ IF(IHOPT.EQ.2) THEN
+ ALPHA=RMSS(18)
+ RETURN
+ ENDIF
+ AT=RMSS(16)
+ AB=RMSS(15)
+ XMU=RMSS(4)
+ TANB=RMSS(5)
+
+ DMA=RMSS(19)
+ DTANB=TANB
+ DMQ=RMSS(10)
+ DMUR=RMSS(12)
+ DMDR=RMSS(11)
+ DMTOP=PMAS(6,1)
+ DMC=PMAS(PYCOMP(KSUSY1+37),1)
+ DAU=AT
+ DAD=AB
+ DMU=XMU
+
+ IF(IHOPT.EQ.0) THEN
+ CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
+ & DMHCH,DSA,DCA,DTANBA)
+ ELSEIF(IHOPT.EQ.1) THEN
+ CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
+ & DMHCH,DSA,DCA,DTANBA)
+ CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
+ & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
+ & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
+ DMH=DMHP
+ DHM=DHMP
+ DMA=DAMP
+ IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
+ WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
+ WRITE(MSTU(11),*) ' STOP1 MASSES = ',
+ & PMAS(PYCOMP(1000006),1),DSTOP2
+ ENDIF
+ IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
+ WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
+ WRITE(MSTU(11),*) ' STOP2 MASSES = ',
+ & PMAS(PYCOMP(2000006),1),DSTOP1
+ ENDIF
+ IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
+ WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
+ WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
+ & PMAS(PYCOMP(1000005),1),DSBOT2
+ ENDIF
+ IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
+ WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
+ WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
+ & PMAS(PYCOMP(2000005),1),DSBOT1
+ ENDIF
+
+ ENDIF
+
+ ALPHA=ACOS(DCA)
+
+ PMAS(25,1)=DMH
+ PMAS(35,1)=DHM
+ PMAS(36,1)=DMA
+ PMAS(37,1)=DMHCH
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSUBH
+C...This routine computes the renormalization group improved
+C...values of Higgs masses and couplings in the MSSM.
+
+C...Program based on the work by M. Carena, J.R. Espinosa,
+c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
+
+C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
+C...All masses in GeV units. MA is the CP-odd Higgs mass,
+C...MTOP is the physical top mass, MQ and MUR are the soft
+C...supersymmetry breaking mass parameters of left handed
+C...and right handed stops respectively, AU and AD are the
+C...stop and sbottom trilinear soft breaking terms,
+C...respectively, and MU is the supersymmetric
+C...Higgs mass parameter. We use the conventions from
+C...the physics report of Haber and Kane: left right
+C...stop mixing term proportional to (AU - MU/TANB)
+C...We use as input TANB defined at the scale MTOP
+
+C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
+C...where MH and HM are the lightest and heaviest CP-even
+C...Higgs masses, MHCH is the charged Higgs mass and
+C...ALPHA is the Higgs mixing angle
+C...TANBA is the angle TANB at the CP-odd Higgs mass scale
+
+C...Range of validity:
+C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
+C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
+C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
+C...are the sbottom mass eigenvalues, respectively. This
+C...range automatically excludes the existence of tachyons.
+C...For the charged Higgs mass computation, the method is
+C...valid if
+C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
+C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
+C...where M_SUSY**2 is the average of the squared stop mass
+C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
+C...masses have been assumed to be of order of the stop ones
+C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
+
+ SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
+ &XMHCH,SA,CA,TANBA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Local variables.
+ DOUBLE PRECISION PYALEM,PYALPS
+ DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
+ DOUBLE PRECISION XMHCH,SA,CA
+ DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
+ DOUBLE PRECISION Q02
+ DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
+ DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
+ DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
+ DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
+ DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
+ DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
+ DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
+ DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
+
+ XMZ = PMAS(23,1)
+ Q02=XMZ**2
+ AEM=PYALEM(Q02)
+ ALP1=AEM/(1D0-PARU(102))
+ ALP2=AEM/PARU(102)
+ ALPH3Z=PYALPS(Q02)
+
+ ALP1 = 0.0101D0
+ ALP2 = 0.0337D0
+ ALPH3Z = 0.12D0
+
+ V = 174.1D0
+ PI = PARU(1)
+ TANBA = TANB
+ TANBT = TANB
+
+C...MBOTTOM(MTOP) = 3. GEV
+ XMB = 3D0
+ ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
+ &LOG(XMTOP**2/XMZ**2))
+
+C...RMTOP= RUNNING TOP QUARK MASS
+ RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
+ XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
+ T = LOG(XMS**2/XMTOP**2)
+ SINB = TANB/((1D0 + TANB**2)**0.5D0)
+ COSB = SINB/TANB
+C...IF(MA.LE.XMTOP) TANBA = TANBT
+ IF(XMA.GT.XMTOP)
+ &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
+ &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
+ &LOG(XMA**2/XMTOP**2))
+
+ SINBT = TANBT/SQRT(1D0 + TANBT**2)
+ COSBT = 1D0/SQRT(1D0 + TANBT**2)
+ COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
+ G1 = SQRT(ALP1*4D0*PI)
+ G2 = SQRT(ALP2*4D0*PI)
+ G3 = SQRT(ALP3*4D0*PI)
+ HU = RMTOP/V/SINBT
+ HD = XMB/V/COSBT
+ HU2=HU*HU
+ HD2=HD*HD
+ HU4=HU2*HU2
+ HD4=HD2*HD2
+ AU2=AU**2
+ AD2=AD**2
+ XMS2=XMS**2
+ XMS3=XMS**3
+ XMS4=XMS2*XMS2
+ XMU2=XMU*XMU
+ PI2=PI*PI
+
+ XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
+ XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
+ AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
+ &+ 3D0*(AU + AD)**2/XMS2)/6D0
+ XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
+ &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
+ &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
+ &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
+ &- 16D0*G3**2) *T/16D0/PI2)
+ XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
+ &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
+ &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
+ &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
+ &- 16D0*G3**2) *T/16D0/PI2)
+ XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
+ &(HU2 + HD2)*T/16D0/PI2)
+ &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
+ &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
+ &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
+ &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
+ &- 16D0*G3**2) *T/16D0/PI2)
+ &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
+ &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
+ &- 16D0*G3**2) *T/16D0/PI2)
+ XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
+ &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
+ &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
+ &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
+ &XMS4)*
+ &(1+ (6D0*HU2 -2D0* HD2
+ &- 16D0*G3**2) *T/16D0/PI2)
+ &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
+ &XMS4)*
+ &(1+ (6D0*HD2 -2D0* HU2/2D0
+ &- 16D0*G3**2) *T/16D0/PI2)
+ XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
+ &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
+ &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
+ &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
+ XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
+ &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
+ &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
+ &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
+ XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
+ &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
+ &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
+ &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
+ TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
+ &2D0* XLAM6*SINBT*COSBT
+ &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
+ &+ XLAM5*COSBT**2)
+ DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
+ &XLAM6*COSBT**2
+ &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
+ &2D0* XLAM6* COSBT*SINBT
+ &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
+ &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
+ &((XLAM1* COSBT**2 +2D0*
+ &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
+ &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
+ &*SINBT**2
+ &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
+ &+ XLAM4) + XLAM6*COSBT**2
+ &+ XLAM7* SINBT**2))
+
+ XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
+ XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
+ XHM = SQRT(XHM2)
+ XMH = SQRT(XMH2)
+ XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
+ XMHCH = SQRT(XMHCH2)
+
+ SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
+ &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
+ &XLAM6* COSBT*SINBT
+ &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
+ &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
+ &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
+ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
+
+ COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
+ &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
+ &XMA**2*SINBT*COSBT))/2D0**0.5D0/
+ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
+ &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
+ &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
+ &XLAM6* COSBT*SINBT
+ &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
+ &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
+ &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
+
+ SA = -SINALP
+ CA = -COSALP
+
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPOLE
+C...This subroutine computes the CP-even higgs and CP-odd pole
+c...Higgs masses and mixing angles.
+
+C...Program based on the work by M. Carena, M. Quiros
+C...and C.E.M. Wagner, "Effective potential methods and
+C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
+
+C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
+C...AT,AB,MU
+C...where MCHI is the largest chargino mass, MA is the running
+C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
+C...expectaion values at the scale MTOP, MQ is the third generation
+C...left handed squark mass parameter, MUR is the third generation
+C...right handed stop mass parameter, MDR is the third generation
+C...right handed sbottom mass parameter, MTOP is the pole top quark
+C...mass; AT,AB are the soft supersymmetry breaking trilinear
+C...couplings of the stop and sbottoms, respectively, and MU is the
+C...supersymmetric mass parameter
+
+C...The parameter IHIGGS=0,1,2,3 corresponds to the
+c...number of Higgses whose pole mass is computed
+c...by the subroutine PYVACU(...). If IHIGGS=0 only running
+c...masses are given, what makes the running of the program
+c...much faster and it is quite generally a good approximation
+c...(for a theoretical discussion see ref. below).
+c...If IHIGGS=1, only the pole
+c...mass for H is computed. If IHIGGS=2, then h and H, and
+c...if IHIGGS=3, then h,H,A polarizations are computed
+
+C...Output: MH and MHP which are the lightest CP-even Higgs running
+C...and pole masses, respectively; HM and HMP are the heaviest CP-even
+C...Higgs running and pole masses, repectively; SA and CA are the
+C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
+C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
+C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
+C...the value of TANB at the CP-odd Higgs mass scale
+
+C...This subroutine makes use of CERN library subroutine
+C...integration package, which makes the computation of the
+C...pole Higgs masses somewhat faster. We thank P. Janot for this
+C...improvement. Those who are not able to call the CERN
+C...libraries, please use the subroutine SUBHPOLE2.F, which
+C...although somewhat slower, gives identical results
+
+ SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
+ &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+ CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
+ &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
+ &SA,CA,STOP1W,STOP2W,TANBA)
+ SINB = TANB/(TANB**2+1D0)**0.5D0
+ COSB = 1D0/(TANB**2+1D0)**0.5D0
+ SINBMA = SINB*CA - COSB*SA
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYVACU
+C...Computes Higgs masses and mixing angles, see PYPOLE above.
+
+ SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
+ &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
+ &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Parameters.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
+ &SSBOT2(2),B(2,2),COUPB(2,2),
+ &HCOUPT(2,2),HCOUPB(2,2),
+ &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
+
+ DELTA(1,1) = 1D0
+ DELTA(2,2) = 1D0
+ DELTA(1,2) = 0D0
+ DELTA(2,1) = 0D0
+ V = 174.1D0
+ XMZ=91.18D0
+ PI=3.14159D0
+ ALP3Z=0.12D0
+ ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
+
+C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
+ RXMT = PYRNMT(XMT)
+
+ HT = RXMT /V
+ CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
+ &XMU,XMH,HM,SA,CA,TANBA)
+ SINB = TANB/(TANB**2+1D0)**0.5D0
+ COSB = 1D0/(TANB**2+1D0)**0.5D0
+ COS2B = SINB**2 - COSB**2
+ SINBPA = SINB*CA + COSB*SA
+ COSBPA = COSB*CA - SINB*SA
+ RMBOT = 3D0
+ XMQ2 = XMQ**2
+ XMUR2 = XMUR**2
+ IF(XMUR.LT.0D0) XMUR2=-XMUR2
+ XMDR2 = XMDR**2
+ XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
+ XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
+ IF(XMST11.LT.0D0) GOTO 500
+ IF(XMST22.LT.0D0) GOTO 500
+ XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
+ XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
+ IF(XMSB11.LT.0D0) GOTO 500
+ IF(XMSB22.LT.0D0) GOTO 500
+ WMST11 = RXMT**2 + XMQ2
+ WMST22 = RXMT**2 + XMUR2
+ XMST12 = RXMT*(AT - XMU/TANB)
+ XMSB12 = RMBOT*(AB - XMU*TANB)
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...STOP EIGENVALUES CALCULATION
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ STOP12 = 0.5D0*(XMST11+XMST22) +
+ &0.5D0*((XMST11+XMST22)**2 -
+ &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
+ STOP22 = 0.5D0*(XMST11+XMST22) -
+ &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
+ &XMST12**2))**0.5D0
+
+ IF(STOP22.LT.0D0) GOTO 500
+ SSTOP2(1) = STOP12
+ SSTOP2(2) = STOP22
+ STOP1 = STOP12**0.5D0
+ STOP2 = STOP22**0.5D0
+ STOP1W = STOP1
+ STOP2W = STOP2
+
+ IF(XMST12.EQ.0D0) XST11 = 1D0
+ IF(XMST12.EQ.0D0) XST12 = 0D0
+ IF(XMST12.EQ.0D0) XST21 = 0D0
+ IF(XMST12.EQ.0D0) XST22 = 1D0
+
+ IF(XMST12.EQ.0D0) GOTO 110
+
+ 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
+ XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
+ XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
+ XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
+
+ 110 T(1,1) = XST11
+ T(2,2) = XST22
+ T(1,2) = XST12
+ T(2,1) = XST21
+
+ SBOT12 = 0.5D0*(XMSB11+XMSB22) +
+ &0.5D0*((XMSB11+XMSB22)**2 -
+ &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
+ SBOT22 = 0.5D0*(XMSB11+XMSB22) -
+ &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
+ &XMSB12**2))**0.5D0
+ IF(SBOT22.LT.0D0) GOTO 500
+ SBOT1 = SBOT12**0.5D0
+ SBOT2 = SBOT22**0.5D0
+
+ SSBOT2(1) = SBOT12
+ SSBOT2(2) = SBOT22
+
+ IF(XMSB12.EQ.0D0) XSB11 = 1D0
+ IF(XMSB12.EQ.0D0) XSB12 = 0D0
+ IF(XMSB12.EQ.0D0) XSB21 = 0D0
+ IF(XMSB12.EQ.0D0) XSB22 = 1D0
+
+ IF(XMSB12.EQ.0D0) GOTO 130
+
+ 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
+ XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
+ XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
+ XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
+
+ 130 B(1,1) = XSB11
+ B(2,2) = XSB22
+ B(1,2) = XSB12
+ B(2,1) = XSB21
+
+
+ SINT = 0.2320D0
+ SQR = 2D0**0.5D0
+ VP = 174.1D0*SQR
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...STARTING OF LIGHT HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ IF(IHIGGS.EQ.0) GOTO 490
+
+ DO 150 I = 1,2
+ DO 140 J = 1,2
+ COUPT(I,J) =
+ & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
+ & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
+ & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
+ & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
+ & T(1,J)*T(2,I))
+ 140 CONTINUE
+ 150 CONTINUE
+
+
+ DO 170 I = 1,2
+ DO 160 J = 1,2
+ COUPB(I,J) =
+ & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
+ & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
+ & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
+ & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
+ & B(1,J)*B(2,I))
+ 160 CONTINUE
+ 170 CONTINUE
+
+ PRUN = XMH
+ EPS = 1D-4*PRUN
+ ITER = 0
+ 180 ITER = ITER + 1
+ DO 230 I3 = 1,3
+
+ PR(I3)=PRUN+(I3-2)*EPS/2
+ P2=PR(I3)**2
+ POLT = 0D0
+ DO 200 I = 1,2
+ DO 190 J = 1,2
+ POLT = POLT + COUPT(I,J)**2*3D0*
+ & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
+ 190 CONTINUE
+ 200 CONTINUE
+ POLB = 0D0
+ DO 220 I = 1,2
+ DO 210 J = 1,2
+ POLB = POLB + COUPB(I,J)**2*3D0*
+ & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
+ 210 CONTINUE
+ 220 CONTINUE
+ RXMT2 = RXMT**2
+ XMT2=XMT**2
+
+ POLTT =
+ & 3D0*RXMT**2/8D0/PI**2/ V **2*
+ & CA**2/SINB**2 *
+ & (-2D0*XMT**2+0.5D0*P2)*
+ & PYFINT(P2,XMT2,XMT2)
+
+ POL = POLT + POLB + POLTT
+ POLAR(I3) = P2 - XMH**2 - POL
+ 230 CONTINUE
+ DERIV = (POLAR(3)-POLAR(1))/EPS
+ DRUN = - POLAR(2)/DERIV
+ PRUN = PRUN + DRUN
+ P2 = PRUN**2
+ IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
+ GOTO 180
+ 240 CONTINUE
+
+ XMHP = P2**0.5D0
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...END OF LIGHT HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ 250 IF(IHIGGS.EQ.1) GOTO 490
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C... STARTING OF HEAVY HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ DO 270 I = 1,2
+ DO 260 J = 1,2
+ HCOUPT(I,J) =
+ & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
+ & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
+ & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
+ & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
+ & T(1,J)*T(2,I))
+ 260 CONTINUE
+ 270 CONTINUE
+
+ DO 290 I = 1,2
+ DO 280 J = 1,2
+ HCOUPB(I,J) =
+ & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
+ & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
+ & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
+ & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
+ & B(1,J)*B(2,I))
+ HCOUPB(I,J)=0D0
+ 280 CONTINUE
+ 290 CONTINUE
+
+ PRUN = HM
+ EPS = 1D-4*PRUN
+ ITER = 0
+ 300 ITER = ITER + 1
+ DO 350 I3 = 1,3
+ PR(I3)=PRUN+(I3-2)*EPS/2
+ HP2=PR(I3)**2
+
+ HPOLT = 0D0
+ DO 320 I = 1,2
+ DO 310 J = 1,2
+ HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
+ & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
+ 310 CONTINUE
+ 320 CONTINUE
+
+ HPOLB = 0D0
+ DO 340 I = 1,2
+ DO 330 J = 1,2
+ HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
+ & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
+ 330 CONTINUE
+ 340 CONTINUE
+
+ RXMT2 = RXMT**2
+ XMT2 = XMT**2
+
+ HPOLTT =
+ & 3D0*RXMT**2/8D0/PI**2/ V **2*
+ & SA**2/SINB**2 *
+ & (-2D0*XMT**2+0.5D0*HP2)*
+ & PYFINT(HP2,XMT2,XMT2)
+
+ HPOL = HPOLT + HPOLB + HPOLTT
+ POLAR(I3) =HP2-HM**2-HPOL
+ 350 CONTINUE
+ DERIV = (POLAR(3)-POLAR(1))/EPS
+ DRUN = - POLAR(2)/DERIV
+ PRUN = PRUN + DRUN
+ HP2 = PRUN**2
+ IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
+ GOTO 300
+ 360 CONTINUE
+
+
+ 370 CONTINUE
+ HMP = HP2**0.5D0
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C... END OF HEAVY HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ IF(IHIGGS.EQ.2) GOTO 490
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...BEGINNING OF PSEUDOSCALAR HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ DO 390 I = 1,2
+ DO 380 J = 1,2
+ ACOUPT(I,J) =
+ & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
+ & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
+ 380 CONTINUE
+ 390 CONTINUE
+ DO 410 I = 1,2
+ DO 400 J = 1,2
+ ACOUPB(I,J) =
+ & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
+ & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
+ 400 CONTINUE
+ 410 CONTINUE
+
+ PRUN = XMA
+ EPS = 1D-4*PRUN
+ ITER = 0
+ 420 ITER = ITER + 1
+ DO 470 I3 = 1,3
+ PR(I3)=PRUN+(I3-2)*EPS/2
+ AP2=PR(I3)**2
+ APOLT = 0D0
+ DO 440 I = 1,2
+ DO 430 J = 1,2
+ APOLT = APOLT + ACOUPT(I,J)**2*3D0*
+ & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
+ 430 CONTINUE
+ 440 CONTINUE
+ APOLB = 0D0
+ DO 460 I = 1,2
+ DO 450 J = 1,2
+ APOLB = APOLB + ACOUPB(I,J)**2*3D0*
+ & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
+ 450 CONTINUE
+ 460 CONTINUE
+ RXMT2 = RXMT**2
+ XMT2=XMT**2
+ APOLTT =
+ & 3D0*RXMT**2/8D0/PI**2/ V **2*
+ & COSB**2/SINB**2 *
+ & (-0.5D0*AP2)*
+ & PYFINT(AP2,XMT2,XMT2)
+ APOL = APOLT + APOLB + APOLTT
+ POLAR(I3) = AP2 - XMA**2 -APOL
+ 470 CONTINUE
+ DERIV = (POLAR(3)-POLAR(1))/EPS
+ DRUN = - POLAR(2)/DERIV
+ PRUN = PRUN + DRUN
+ AP2 = PRUN**2
+ IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
+ GOTO 420
+ 480 CONTINUE
+
+ AMP = AP2**0.5D0
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...END OF PSEUDOSCALAR HIGGS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ IF(IHIGGS.EQ.3) GOTO 490
+
+ 490 CONTINUE
+ RETURN
+ 500 CONTINUE
+ WRITE(MSTU(11),*) ' EXITING IN PYVACU '
+ WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
+ WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
+ WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
+ STOP
+ END
+
+C*********************************************************************
+
+C...PYRGHM
+C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
+
+ SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
+ &XMHP,HMP,SA,CA,TANBA)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
+
+ XMZ = 91.18D0
+ ALP1 = 0.0101D0
+ ALP2 = 0.0337D0
+ ALP3Z = 0.12D0
+ V = 174.1D0
+ PI = 3.14159D0
+ TANBA = TANB
+ TANBT = TANB
+
+C...MBOTTOM(XMT) = 3. GEV
+ XMB = 3D0
+ ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
+ &LOG(XMT**2/XMZ**2))
+
+C...RXMT= RUNNING TOP QUARK MASS
+ RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
+ TQ = LOG((XMQ**2+XMT**2)/XMT**2)
+ TU = LOG((XMUR**2 + XMT**2)/XMT**2)
+ TD = LOG((XMDL**2 + XMT**2)/XMT**2)
+ SINB = TANB/((1D0 + TANB**2)**0.5D0)
+ COSB = SINB/TANB
+ IF(XMA.GT.XMT)
+ &TANBA = TANB*(1D0-3D0/32D0/PI**2*
+ &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
+ &LOG(XMA**2/XMT**2))
+ IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
+ SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
+ COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
+ COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
+ G1 = (ALP1*4D0*PI)**0.5D0
+ G2 = (ALP2*4D0*PI)**0.5D0
+ G3 = (ALP3*4D0*PI)**0.5D0
+ HU = RXMT/V/SINB
+ HD = XMB/V/COSB
+
+ CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
+ &XMU,VH,STOP1,STOP2)
+
+ IF(XMQ.GT.XMUR) TP = TQ - TU
+ IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
+ IF(XMQ.GT.XMUR) TDP = TU
+ IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
+ IF(XMQ.GT.XMDL) TPD = TQ - TD
+ IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
+ IF(XMQ.GT.XMDL) TDPD = TD
+ IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
+
+ IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
+ IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
+ &HD**2*(G1**2/3D0+G2**2)*TPD
+
+ IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
+ IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
+ &HU**2*(-G1**2/3D0+G2**2)*TP
+
+ DLAM3 = 0D0
+ DLAM4 = 0D0
+
+ IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
+ IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
+ &(G2**2-G1**2/3D0)*TPD
+
+ IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
+ &1D0/16D0/PI**2*G1**2*HU**2*TP
+ IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
+ &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
+
+ IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
+ IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
+ &HD**2*TPD
+
+ XLAM1 = ((G1**2 + G2**2)/4D0)*
+ &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
+ &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
+ &+ (3D0*HD**2/2D0 + HU**2/2D0
+ &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
+ &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
+ &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
+ XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
+ &(TP + TDP)/8D0/PI**2)
+ &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
+ &+ (3D0*HU**2/2D0 + HD**2/2D0
+ &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
+ &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
+ &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
+ XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
+ &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
+ &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
+ XLAM4 = (- G2**2/2D0)*(1D0
+ &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
+ &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
+
+ XLAM5 = 0D0
+ XLAM6 = 0D0
+ XLAM7 = 0D0
+
+ XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
+ &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
+
+ XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
+ &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
+ XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
+ &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
+
+ XM2(2,1) = XM2(1,2)
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
+
+ IF(XMC.GT.XMSSU) GOTO 100
+ IF(XMC.LT.XMT) XMC=XMT
+
+ TCHAR=LOG(XMSSU**2/XMC**2)
+
+ DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
+ DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
+ &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
+
+ DEM112=2D0*DEL12*V**2*COSB**2
+ DEM222=2D0*DEL12*V**2*SINB**2
+ DEM122=2D0*DEL3P4*V**2*SINB*COSB
+
+ XM2(1,1)=XM2(1,1)+DEM112
+ XM2(2,2)=XM2(2,2)+DEM222
+ XM2(1,2)=XM2(1,2)+DEM122
+ XM2(2,1)=XM2(2,1)+DEM122
+
+ 100 CONTINUE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...END OF CHARGINOS/NEUTRALINOS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ DO 120 I = 1,2
+ DO 110 J = 1,2
+ XM2P(I,J) = XM2(I,J) + VH(I,J)
+ 110 CONTINUE
+ 120 CONTINUE
+
+ TRM2P = XM2P(1,1) + XM2P(2,2)
+ DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
+
+ XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
+ HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
+ HMP = HM2P**0.5D0
+ IF(XMH2P.LT.0D0) GOTO 130
+ XMHP = XMH2P**0.5D0
+ S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
+ C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
+ IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
+ IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
+ SA = SIN(ALP)
+ CA = COS(ALP)
+ SQBMA = (SINB*CA - COSB*SA)**2
+ 130 XIN = 1D0
+ 140 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGFXX
+C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
+
+ SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
+ &STOP1,STOP2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
+ &VH3T(2,2),VH3B(2,2),
+ &HMIX(2,2),AL(2,2),XM2(2,2)
+
+C...Statement function.
+ G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
+
+ IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
+ XMQ2 = XMQ**2
+ XMUR2 = XMUR**2
+ XMDL2 = XMDL**2
+ TANBA = TANB
+ SINBA = TANBA/(TANBA**2+1D0)**0.5D0
+ COSBA = SINBA/TANBA
+
+ SINB = TANB/(TANB**2+1D0)**0.5D0
+ COSB = SINB/TANB
+ PI = 3.14159D0
+ G2 = (0.0336D0*4D0*PI)**0.5D0
+ G12 = (0.0101D0*4D0*PI)
+ G1 = G12**0.5D0
+ XMZ = 91.18D0
+ V = 174.1D0
+ MW = (G2**2*V**2/2D0)**0.5D0
+ ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
+
+ XMB = 3D0
+ IF(XMQ.GT.XMUR) XMST = XMQ
+ IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
+
+ XMSUT = (XMST**2 + XMT**2)**0.5D0
+
+ IF(XMQ.GT.XMDL) XMSB = XMQ
+ IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
+
+ XMSUB = (XMSB**2 + XMB**2)**0.5D0
+
+ TT = LOG(XMSUT**2/XMT**2)
+ TB = LOG(XMSUB**2/XMT**2)
+
+ RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
+ HT = RXMT/(174.1D0*SINB)
+ HTST = RXMT/174.1D0
+ HB = XMB/174.1D0/COSB
+ G32 = ALP3*4D0*PI
+ BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
+ BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
+ AL2 = 3D0/8D0/PI**2*HT**2
+ BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
+ ALST = 3D0/8D0/PI**2*HTST**2
+ AL1 = 3D0/8D0/PI**2*HB**2
+
+ AL(1,1) = AL1
+ AL(1,2) = (AL2+AL1)/2D0
+ AL(2,1) = (AL2+AL1)/2D0
+ AL(2,2) = AL2
+
+ XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
+ XMT2 = SQRT(XMT4)
+ XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
+ XMBOT2 = SQRT(XMBOT4)
+
+ IF(XMA.GT.XMT) THEN
+ VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
+ & LOG(XMT**2/XMA**2))
+ H1I = VI* COSBA
+ H2I = VI*SINBA
+ H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
+ H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
+ H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
+ H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
+ ELSE
+ VI = 174.1D0
+ H1I = VI*COSB
+ H2I = VI*SINB
+ H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
+ H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
+ H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
+ H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
+ ENDIF
+
+ TANBST = H2T/H1T
+ SINBT = TANBST/(1D0+TANBST**2)**0.5D0
+ COSBT = SINBT/TANBST
+
+ TANBSB = H2B/H1B
+ SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
+ COSBB = SINBB/TANBSB
+
+ STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
+ &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
+ &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
+ &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
+ STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
+ &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
+ &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
+ &XMQ2 - XMUR2)**2*0.25D0
+ &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
+ IF(STOP22.LT.0D0) GOTO 120
+ SBOT12 = (XMQ2 + XMDL2)*0.5D0
+ &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
+ &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
+ &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
+ SBOT22 = (XMQ2 + XMDL2)*0.5D0
+ &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
+ &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
+ &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
+ IF(SBOT22.LT.0D0) GOTO 120
+
+ STOP1 = STOP12**0.5D0
+ STOP2 = STOP22**0.5D0
+ SBOT1 = SBOT12**0.5D0
+ SBOT2 = SBOT22**0.5D0
+
+ VH1(1,1) = 1D0/TANBST
+ VH1(2,1) = -1D0
+ VH1(1,2) = -1D0
+ VH1(2,2) = TANBST
+ VH2(1,1) = TANBST
+ VH2(1,2) = -1D0
+ VH2(2,1) = -1D0
+ VH2(2,2) = 1D0/TANBST
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C...D-TERMS
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ STW=0.2320D0
+
+ F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
+ &LOG(STOP1/STOP2)
+ &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
+ &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
+
+ F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
+ &LOG(SBOT1/SBOT2)
+ &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
+ &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
+
+ F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
+ &(-0.5D0*LOG(STOP12/STOP22)
+ &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
+ &G(STOP12,STOP22))
+
+ F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
+ &(0.5D0*LOG(SBOT12/SBOT22)
+ &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
+ &G(SBOT12,SBOT22))
+
+ VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
+ &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
+ &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
+ &LOG(SBOT1**2/SBOT2**2)) +
+ &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
+ &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
+
+ VH3T(1,1) =
+ &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
+ &-STOP2**2))**2*G(STOP12,STOP22)
+
+ VH3B(1,1)=VH3B(1,1)+
+ &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
+
+ VH3T(1,1) = VH3T(1,1) +
+ &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
+
+ VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
+ &(XMQ2+XMT2)/(XMUR2+XMT2))
+ &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
+ &LOG(STOP1**2/STOP2**2)) +
+ &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
+ &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
+
+ VH3B(2,2) =
+ &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
+ &-SBOT2**2))**2*G(SBOT12,SBOT22)
+
+ VH3T(2,2)=VH3T(2,2)+
+ &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
+
+ VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
+
+ VH3T(1,2) = -
+ &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
+ &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
+ &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
+
+ VH3B(1,2) =
+ &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
+ &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
+ &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
+
+ VH3T(1,2)=VH3T(1,2) +
+ &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
+
+ VH3B(1,2)=VH3B(1,2)
+ &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
+
+ VH3T(2,1) = VH3T(1,2)
+ VH3B(2,1) = VH3B(1,2)
+
+ TQ = LOG((XMQ2 + XMT2)/XMT2)
+ TU = LOG((XMUR2+XMT2)/XMT2)
+ TQD = LOG((XMQ2 + XMB**2)/XMB**2)
+ TD = LOG((XMDL2+XMB**2)/XMB**2)
+
+ DO 110 I = 1,2
+ DO 100 J = 1,2
+
+ VH(I,J) =
+ & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
+ & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
+ & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
+ & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
+
+ 100 CONTINUE
+ 110 CONTINUE
+
+ GOTO 150
+ 120 DO 140 I =1,2
+ DO 130 J = 1,2
+ VH(I,J) = -1D+15
+ 130 CONTINUE
+ 140 CONTINUE
+
+ 150 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFINT
+C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
+
+ FUNCTION PYFINT(A,B,C)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblock.
+ COMMON/PYINTS/XXM(20)
+ SAVE/PYINTS/
+
+C...Local variables.
+ EXTERNAL PYFISB
+
+ XXM(1)=A
+ XXM(2)=B
+ XXM(3)=C
+ XLO=0D0
+ XHI=1D0
+ PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFISB
+C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
+
+ FUNCTION PYFISB(X)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblock.
+ COMMON/PYINTS/XXM(20)
+ SAVE/PYINTS/
+
+ PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
+ &(X*(XXM(2)-XXM(3))+XXM(3)))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSFDC
+C...Calculates decays of sfermions.
+
+ SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ INTEGER KFIN,KCIN
+ DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
+ &XMZ2,AXMJ,AXMI
+ DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
+ DOUBLE PRECISION PYLAMF,XL
+ DOUBLE PRECISION TANW,XW,AEM,C1,AS
+ DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
+ DOUBLE PRECISION CH1,CH2,CH3,CH4
+ DOUBLE PRECISION XMBOT,XMTOP
+ DOUBLE PRECISION XLAM(0:200)
+ INTEGER IDLAM(200,3)
+ INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
+ DOUBLE PRECISION SR2
+ DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
+ DOUBLE PRECISION CW
+ DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
+ DOUBLE PRECISION COSA,SINA,TANB
+ DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
+ DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
+ INTEGER IG,KF1,KF2,ILR2,IDP
+ INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
+ DATA IGG/23,25,35,36/
+ DATA PI/3.141592654D0/
+ DATA SR2/1.4142136D0/
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+ DATA KFCCHI/1000024,1000037/
+
+C...COUNT THE NUMBER OF DECAY MODES
+ LKNT=0
+
+C...NO NU_R DECAYS
+ IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
+ &KFIN.EQ.KSUSY2+16) RETURN
+
+ XMW=PMAS(24,1)
+ XMW2=XMW**2
+ XMZ=PMAS(23,1)
+ XMZ2=XMZ**2
+ XW=PARU(102)
+ TANW = SQRT(XW/(1D0-XW))
+ CW=SQRT(1D0-XW)
+
+C...KCIN
+ KCIN=PYCOMP(KFIN)
+C...ILR is 1 for left and 2 for right.
+ ILR=KFIN/KSUSY1
+C...IFL is matching non-SUSY flavour.
+ IFL=MOD(KFIN,KSUSY1)
+C...IDU is weak isospin, 1 for down and 2 for up.
+ IDU=2-MOD(IFL,2)
+
+ XMI=PMAS(KCIN,1)
+ XMI2=XMI**2
+ AEM=PYALEM(XMI2)
+ AS =PYALPS(XMI2)
+ C1=AEM/XW
+ XMI3=XMI**3
+ EI=KCHG(IFL,1)/3D0
+
+ XMBOT=3D0
+ XMTOP=PYRNMT(PMAS(6,1))
+ XMBOT=0D0
+
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ ALFA=RMSS(18)
+ CBETA=COS(BETA)
+ SBETA=TANB*CBETA
+ SINA=SIN(ALFA)
+ COSA=COS(ALFA)
+ XMU=-RMSS(4)
+ ATRIT=RMSS(16)
+ ATRIB=RMSS(15)
+ ATRIL=RMSS(17)
+
+C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
+
+ IF(IMSS(11).EQ.1) THEN
+ XMP=RMSS(28)
+ IDG=39+KSUSY1
+ XMGR=PMAS(PYCOMP(IDG),1)
+ XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
+ IF(IFL.EQ.5) THEN
+ XMF=XMBOT
+ ELSEIF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ ELSE
+ XMF=PMAS(IFL,1)
+ ENDIF
+ IF(XMI.GT.XMGR+XMF) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=IFL
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
+ ENDIF
+ ENDIF
+
+C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
+
+C...CHARGED DECAYS:
+ DO 100 IX=1,2
+C...DI -> U CHI1-,CHI2-
+ IF(IDU.EQ.1) THEN
+ XMFP=PMAS(IFL+1,1)
+ XMF =PMAS(IFL,1)
+C...UI -> D CHI1+,CHI2+
+ ELSE
+ XMFP=PMAS(IFL-1,1)
+ XMF =PMAS(IFL,1)
+ ENDIF
+ XMJ=SMW(IX)
+ AXMJ=ABS(XMJ)
+ IF(XMI.GE.AXMJ+XMFP) THEN
+ XMA2=XMJ**2
+ XMB2=XMFP**2
+ IF(IDU.EQ.2) THEN
+ IF(IFL.EQ.6) THEN
+ XMFP=XMBOT
+ XMF =XMTOP
+ ELSEIF(IFL.LT.6) THEN
+ XMF=0D0
+ XMFP=0D0
+ ENDIF
+ BL=VMIX(IX,1)
+ AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
+ BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
+ AR=0D0
+ ELSE
+ IF(IFL.EQ.5) THEN
+ XMF =XMBOT
+ XMFP=XMTOP
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ XMFP=0D0
+ ENDIF
+ BL=UMIX(IX,1)
+ AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
+ BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
+ AR=0D0
+ ENDIF
+
+ ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
+ BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
+ ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
+ BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
+ AL=ALP
+ BL=BLP
+ AR=ARP
+ BR=BRP
+
+C...F1 -> F` CHI
+ IF(ILR.EQ.1) THEN
+ CA=AL
+ CB=BL
+C...F2 -> F` CHI
+ ELSE
+ CA=AR
+ CB=BR
+ ENDIF
+ LKNT=LKNT+1
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
+ XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
+ & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
+ IDLAM(LKNT,3)=0
+ IF(IDU.EQ.1) THEN
+ IDLAM(LKNT,1)=-KFCCHI(IX)
+ IDLAM(LKNT,2)=IFL+1
+ ELSE
+ IDLAM(LKNT,1)=KFCCHI(IX)
+ IDLAM(LKNT,2)=IFL-1
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+
+C...NEUTRAL DECAYS
+ DO 110 IX=1,4
+C...DI -> D CHI10
+ XMF=PMAS(IFL,1)
+ XMJ=SMZ(IX)
+ AXMJ=ABS(XMJ)
+ IF(XMI.GE.AXMJ+XMF) THEN
+ XMA2=XMJ**2
+ XMB2=XMF**2
+ IF(IDU.EQ.1) THEN
+ IF(IFL.EQ.5) THEN
+ XMF=XMBOT
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ ENDIF
+ BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
+ AL=XMF*ZMIX(IX,3)/XMW/CBETA
+ AR=-2D0*EI*TANW*ZMIX(IX,1)
+ BR=AL
+ ELSE
+ IF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ ENDIF
+ BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
+ AL=XMF*ZMIX(IX,4)/XMW/SBETA
+ AR=-2D0*EI*TANW*ZMIX(IX,1)
+ BR=AL
+ ENDIF
+
+ ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
+ BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
+ ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
+ BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
+ AL=ALP
+ BL=BLP
+ AR=ARP
+ BR=BRP
+
+C...F1 -> F CHI
+ IF(ILR.EQ.1) THEN
+ CA=AL
+ CB=BL
+C...F2 -> F CHI
+ ELSE
+ CA=AR
+ CB=BR
+ ENDIF
+ LKNT=LKNT+1
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
+ XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
+ & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=IFL
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 110 CONTINUE
+
+C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
+C...IG=23,25,35,36
+ DO 120 II=1,4
+ IG=IGG(II)
+ IF(ILR.EQ.1) GOTO 120
+ XMB=PMAS(IG,1)
+ XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
+ IF(XMI.LT.XMSF1+XMB) GOTO 120
+ IF(IG.EQ.23) THEN
+ BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
+ BR=EI*XW/CW
+ BLR=0D0
+ ELSEIF(IG.EQ.25) THEN
+ IF(IFL.EQ.5) THEN
+ XMF=XMBOT
+ ELSEIF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ ELSE
+ XMF=PMAS(IFL,1)
+ ENDIF
+ IF(IDU.EQ.2) THEN
+ GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
+ & XMF**2/XMW*COSA/SBETA
+ GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
+ & XMF**2/XMW*COSA/SBETA
+ ELSE
+ GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
+ & XMF**2/XMW*(-SINA)/CBETA
+ GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
+ & XMF**2/XMW*(-SINA)/CBETA
+ ENDIF
+ IF(IFL.EQ.5) THEN
+ AT=ATRIB
+ ELSEIF(IFL.EQ.6) THEN
+ AT=ATRIT
+ ELSEIF(IFL.EQ.15) THEN
+ AT=ATRIL
+ ELSE
+ AT=0D0
+ ENDIF
+ IF(IDU.EQ.2) THEN
+ GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
+ & AT*COSA)
+ ELSE
+ GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
+ & AT*SINA)
+ ENDIF
+ BL=GHLL
+ BR=GHRR
+ BLR=-GHLR
+ ELSEIF(IG.EQ.35) THEN
+ IF(IFL.EQ.5) THEN
+ XMF=XMBOT
+ ELSEIF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ ELSE
+ XMF=PMAS(IFL,1)
+ ENDIF
+ IF(IDU.EQ.2) THEN
+ GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
+ & XMF**2/XMW*SINA/SBETA
+ GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
+ & XMF**2/XMW*SINA/SBETA
+ ELSE
+ GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
+ & XMF**2/XMW*COSA/CBETA
+ GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
+ & XMF**2/XMW*COSA/CBETA
+ ENDIF
+ IF(IFL.EQ.5) THEN
+ AT=ATRIB
+ ELSEIF(IFL.EQ.6) THEN
+ AT=ATRIT
+ ELSEIF(IFL.EQ.15) THEN
+ AT=ATRIL
+ ELSE
+ AT=0D0
+ ENDIF
+ IF(IDU.EQ.2) THEN
+ GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
+ & AT*SINA)
+ ELSE
+ GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
+ & AT*COSA)
+ ENDIF
+ BL=GHLL
+ BR=GHRR
+ BLR=GHLR
+ ELSEIF(IG.EQ.36) THEN
+ GHLL=0D0
+ GHRR=0D0
+ IF(IFL.EQ.5) THEN
+ XMF=XMBOT
+ ELSEIF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ ELSEIF(IFL.LT.5) THEN
+ XMF=0D0
+ ELSE
+ XMF=PMAS(IFL,1)
+ ENDIF
+ IF(IFL.EQ.5) THEN
+ AT=ATRIB
+ ELSEIF(IFL.EQ.6) THEN
+ AT=ATRIT
+ ELSEIF(IFL.EQ.15) THEN
+ AT=ATRIL
+ ELSE
+ AT=0D0
+ ENDIF
+ IF(IDU.EQ.2) THEN
+ GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
+ ELSE
+ GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
+ ENDIF
+ BL=GHLL
+ BR=GHRR
+ BLR=GHLR
+ ENDIF
+ AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
+ & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
+ & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
+ XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
+ LKNT=LKNT+1
+ IF(IG.EQ.23) THEN
+ XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
+ ELSE
+ XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
+ ENDIF
+ IDLAM(LKNT,3)=0
+ IDLAM(LKNT,1)=KFIN-KSUSY1
+ IDLAM(LKNT,2)=IG
+ 120 CONTINUE
+
+C...SF -> SF' + W
+ XMB=PMAS(24,1)
+ IF(MOD(IFL,2).EQ.0) THEN
+ KF1=KSUSY1+IFL-1
+ ELSE
+ KF1=KSUSY1+IFL+1
+ ENDIF
+ KF2=KF1+KSUSY1
+ XMSF1=PMAS(PYCOMP(KF1),1)
+ XMSF2=PMAS(PYCOMP(KF2),1)
+ IF(XMI.GT.XMB+XMSF1) THEN
+ IF(MOD(IFL,2).EQ.0) THEN
+ IF(ILR.EQ.1) THEN
+ AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
+ ELSE
+ AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
+ ENDIF
+ ELSE
+ IF(ILR.EQ.1) THEN
+ AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
+ ELSE
+ AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
+ ENDIF
+ ENDIF
+ XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
+ IDLAM(LKNT,3)=0
+ IDLAM(LKNT,1)=KF1
+ IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
+ ENDIF
+ IF(XMI.GT.XMB+XMSF2) THEN
+ IF(MOD(IFL,2).EQ.0) THEN
+ IF(ILR.EQ.1) THEN
+ AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
+ ELSE
+ AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
+ ENDIF
+ ELSE
+ IF(ILR.EQ.1) THEN
+ AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
+ ELSE
+ AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
+ ENDIF
+ ENDIF
+ XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
+ IDLAM(LKNT,3)=0
+ IDLAM(LKNT,1)=KF2
+ IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
+ ENDIF
+
+C...SF -> SF' + HC
+ XMB=PMAS(37,1)
+ IF(MOD(IFL,2).EQ.0) THEN
+ KF1=KSUSY1+IFL-1
+ ELSE
+ KF1=KSUSY1+IFL+1
+ ENDIF
+ KF2=KF1+KSUSY1
+ XMSF1=PMAS(PYCOMP(KF1),1)
+ XMSF2=PMAS(PYCOMP(KF2),1)
+ IF(XMI.GT.XMB+XMSF1) THEN
+ XMF=0D0
+ XMFP=0D0
+ AT=0D0
+ AB=0D0
+ IF(MOD(IFL,2).EQ.0) THEN
+C...T1-> B1 HC
+ IF(ILR.EQ.1) THEN
+ CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
+ CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
+ CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
+ CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
+C...T2-> B1 HC
+ ELSE
+ CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
+ CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
+ CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
+ CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
+ ENDIF
+ IF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ XMFP=XMBOT
+ AT=ATRIT
+ AB=ATRIB
+ ENDIF
+ ELSE
+C...B1 -> T1 HC
+ IF(ILR.EQ.1) THEN
+ CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
+ CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
+ CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
+ CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
+C...B2-> T1 HC
+ ELSE
+ CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
+ CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
+ CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
+ CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
+ ENDIF
+ IF(IFL.EQ.5) THEN
+ XMF=XMTOP
+ XMFP=XMBOT
+ AT=ATRIT
+ AB=ATRIB
+ ENDIF
+ ENDIF
+ XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
+ LKNT=LKNT+1
+ AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
+ XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
+ IDLAM(LKNT,3)=0
+ IDLAM(LKNT,1)=KF1
+ IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
+ ENDIF
+ IF(XMI.GT.XMB+XMSF2) THEN
+ XMF=0D0
+ XMFP=0D0
+ AT=0D0
+ AB=0D0
+ IF(MOD(IFL,2).EQ.0) THEN
+C...T1-> B2 HC
+ IF(ILR.EQ.1) THEN
+ CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
+ CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
+ CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
+ CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
+C...T2-> B2 HC
+ ELSE
+ CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
+ CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
+ CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
+ CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
+ ENDIF
+ IF(IFL.EQ.6) THEN
+ XMF=XMTOP
+ XMFP=XMBOT
+ AT=ATRIT
+ AB=ATRIB
+ ENDIF
+ ELSE
+C...B1 -> T2 HC
+ IF(ILR.EQ.1) THEN
+ CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
+ CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
+ CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
+ CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
+C...B2-> T2 HC
+ ELSE
+ CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
+ CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
+ CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
+ CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
+ ENDIF
+ IF(IFL.EQ.5) THEN
+ XMF=XMTOP
+ XMFP=XMBOT
+ AT=ATRIT
+ AB=ATRIB
+ ENDIF
+ ENDIF
+ XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
+ LKNT=LKNT+1
+ AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
+ XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
+ IDLAM(LKNT,3)=0
+ IDLAM(LKNT,1)=KF2
+ IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
+ ENDIF
+
+C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
+
+ IF(IFL.LE.6) THEN
+ XMFP=0D0
+ XMF=0D0
+ IF(IFL.EQ.6) XMF=PMAS(6,1)
+ IF(IFL.EQ.5) XMF=PMAS(5,1)
+ XMJ=PMAS(PYCOMP(KSUSY1+21),1)
+ AXMJ=ABS(XMJ)
+ IF(XMI.GE.AXMJ+XMF) THEN
+ AL=-SFMIX(IFL,2)
+ BL=SFMIX(IFL,1)
+ AR=-SFMIX(IFL,4)
+ BR=SFMIX(IFL,3)
+C...F1 -> F CHI
+ IF(ILR.EQ.1) THEN
+ CA=AL
+ CB=BL
+C...F2 -> F CHI
+ ELSE
+ CA=AR
+ CB=BR
+ ENDIF
+ LKNT=LKNT+1
+ XMA2=XMJ**2
+ XMB2=XMF**2
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
+ & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=IFL
+ IDLAM(LKNT,3)=0
+ ENDIF
+ ENDIF
+
+C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
+ IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
+ &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
+C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
+C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
+C...M*M = C1**2 * G**2/(16PI**2)
+C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
+ LKNT=LKNT+1
+ XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
+ XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
+ IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
+ IDLAM(LKNT,1)=KSUSY1+22
+ IDLAM(LKNT,2)=4
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+ IKNT=LKNT
+ XLAM(0)=0D0
+ DO 130 I=1,IKNT
+ IF(XLAM(I).LT.0D0) XLAM(I)=0D0
+ XLAM(0)=XLAM(0)+XLAM(I)
+ 130 CONTINUE
+ IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGLUI
+C...Calculates gluino decay modes.
+
+ SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
+
+C...Local variables.
+ INTEGER KFIN,KCIN,KF
+ DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
+ &XMZ,XMZ2,AXMJ,AXMI
+ DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
+ DOUBLE PRECISION C1L,C1R,D1L,D1R
+ DOUBLE PRECISION C2L,C2R,D2L,D2R
+ DOUBLE PRECISION PYLAMF,XL
+ DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
+ DOUBLE PRECISION CA,CB,AL,AR,BL,BR
+ DOUBLE PRECISION ALFA,BETA
+ DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
+ DOUBLE PRECISION XLAM(0:200)
+ INTEGER IDLAM(200,3)
+ INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
+ DOUBLE PRECISION SR2
+ DOUBLE PRECISION GAM
+ DOUBLE PRECISION PYALEM,PI,PYALPS,EI
+ DOUBLE PRECISION PYGAUS
+ EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
+ DOUBLE PRECISION PREC
+ INTEGER KFNCHI(4),KFCCHI(2)
+ DATA PI/3.141592654D0/
+ DATA SR2/1.4142136D0/
+ DATA PREC/1D-2/
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+ DATA KFCCHI/1000024,1000037/
+
+C...COUNT THE NUMBER OF DECAY MODES
+ LKNT=0
+ IF(KFIN.NE.KSUSY1+21) RETURN
+ KCIN=PYCOMP(KFIN)
+
+ XMW=PMAS(24,1)
+ XMW2=XMW**2
+ XMZ=PMAS(23,1)
+ XMZ2=XMZ**2
+ XW=PARU(102)
+ TANW = SQRT(XW/(1D0-XW))
+
+ XMI=PMAS(KCIN,1)
+ AXMI=ABS(XMI)
+ XMI2=XMI**2
+ AEM=PYALEM(XMI2)
+ AS =PYALPS(XMI2)
+ C1=AEM/XW
+ XMI3=XMI**3
+ BETA=ATAN(RMSS(5))
+
+C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
+
+ IF(IMSS(11).EQ.1) THEN
+ XMP=RMSS(28)
+ IDG=39+KSUSY1
+ XMGR=PMAS(PYCOMP(IDG),1)
+ XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
+ IF(AXMI.GT.XMGR) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=21
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC
+ ENDIF
+ ENDIF
+
+C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
+
+ DO 110 IFL=1,6
+ DO 100 ILR=1,2
+ XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
+ AXMJ=ABS(XMJ)
+ XMF=PMAS(IFL,1)
+ IDU=3-(1+MOD(IFL,2))
+ IF(XMI.GE.AXMJ+XMF) THEN
+ AL=SFMIX(IFL,1)
+ BL=SFMIX(IFL,2)
+ AR=SFMIX(IFL,3)
+ BR=SFMIX(IFL,4)
+C...F1 -> F CHI
+ IF(ILR.EQ.1) THEN
+ CA=AL
+ CB=BL
+C...F2 -> F CHI
+ ELSE
+ CA=AR
+ CB=BR
+ ENDIF
+ LKNT=LKNT+1
+ XMA2=XMJ**2
+ XMB2=XMF**2
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
+ & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
+ IDLAM(LKNT,1)=ILR*KSUSY1+IFL
+ IDLAM(LKNT,2)=-IFL
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
+C...GLUINO -> NI Q QBAR
+ DO 160 IX=1,4
+ XMJ=SMZ(IX)
+ AXMJ=ABS(XMJ)
+ IF(XMI.GE.AXMJ) THEN
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
+ XXM(7)=1D6
+ XXM(8)=0D0
+ XXM(9)=0D0
+ XXM(10)=0D0
+ S12MIN=0D0
+ S12MAX=(XMI-AXMJ)**2
+C...D-TYPE QUARKS
+ XXM(11)=0D0
+ XXM(12)=0D0
+ XXM(13)=1D0
+ XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
+ XXM(15)=1D0
+ XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
+ IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-1
+ ENDIF
+ IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-3
+ ENDIF
+ 120 CONTINUE
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
+ IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
+ CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
+ LKNT=LKNT+1
+ XLAM(LKNT)=GAM
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=5
+ IDLAM(LKNT,3)=-5
+ ENDIF
+C...U-TYPE QUARKS
+ 130 CONTINUE
+ XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
+ XXM(13)=1D0
+ XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
+ XXM(15)=1D0
+ XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
+ IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=2
+ IDLAM(LKNT,3)=-2
+ ENDIF
+ IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=4
+ IDLAM(LKNT,3)=-4
+ ENDIF
+ 140 CONTINUE
+C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
+C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
+ IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
+ XMF=PMAS(6,1)
+ IF(XMI.GE.AXMJ+2D0*XMF) THEN
+ CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
+ LKNT=LKNT+1
+ XLAM(LKNT)=GAM
+ IDLAM(LKNT,1)=KFNCHI(IX)
+ IDLAM(LKNT,2)=6
+ IDLAM(LKNT,3)=-6
+ ENDIF
+ 150 CONTINUE
+ ENDIF
+ 160 CONTINUE
+
+C...GLUINO -> CI Q QBAR'
+ DO 190 IX=1,2
+ XMJ=SMW(IX)
+ AXMJ=ABS(XMJ)
+ IF(XMI.GE.AXMJ) THEN
+ S12MIN=0D0
+ S12MAX=(AXMI-AXMJ)**2
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(5)=0D0
+ XXM(6)=0D0
+ XXM(9)=1D6
+ XXM(10)=0D0
+ XXM(7)=UMIX(IX,1)*SR2
+ XXM(8)=VMIX(IX,1)*SR2
+ XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
+ IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
+ IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(IX)
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-2
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+ IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(IX)
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-4
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+ 170 CONTINUE
+
+ IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
+ IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
+ XMF=PMAS(6,1)
+ XMFP=PMAS(5,1)
+ IF(XMI.GE.AXMJ+XMF+XMFP) THEN
+ CALL PYTBBC(IX,80,AXMI,GAM)
+ LKNT=LKNT+1
+ XLAM(LKNT)=GAM
+ IDLAM(LKNT,1)=KFCCHI(IX)
+ IDLAM(LKNT,2)=5
+ IDLAM(LKNT,3)=-6
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+ 180 CONTINUE
+ ENDIF
+ 190 CONTINUE
+
+ IKNT=LKNT
+ XLAM(0)=0D0
+ DO 200 I=1,IKNT
+ IF(XLAM(I).LT.0D0) XLAM(I)=0D0
+ XLAM(0)=XLAM(0)+XLAM(I)
+ 200 CONTINUE
+ IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTBBN
+C...Calculates the three-body decay of gluinos into
+C...neutralinos and third generation fermions.
+
+ SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ EXTERNAL PYSIMP,PYLAMF
+ INTEGER LIN,NN
+ DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
+ DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
+ DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
+ DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
+ DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
+ DOUBLE PRECISION XLN1,XLN2,B1,B2
+ DOUBLE PRECISION E,XMGLU,GAM
+ DOUBLE PRECISION PYSIMP,PYLAMF
+ DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
+ SAVE HRB,HLB,FLB,FRB
+ DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
+ DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
+ SAVE HLT,HRT,FLT,FRT
+ DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
+ &FLD(4),FRD(4)
+ SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
+ DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
+ DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
+ SAVE AMSB,AMST
+ DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
+ DOUBLE PRECISION ROT1(4,4)
+ LOGICAL IFIRST
+ SAVE IFIRST
+ DATA IFIRST/.TRUE./
+
+ TANB=RMSS(5)
+ SINB=TANB/SQRT(1D0+TANB**2)
+ COSB=SINB/TANB
+ XW=PARU(102)
+ SINW=SQRT(XW)
+ COSW=SQRT(1D0-XW)
+ TANW=SINW/COSW
+ AMW=PMAS(24,1)
+ COSC=SFMIX(5,1)
+ SINC=SFMIX(5,3)
+ COSA=SFMIX(6,1)
+ SINA=SFMIX(6,3)
+ AMBOT=0D0
+ AMTOP=PYRNMT(PMAS(6,1))
+ W2=SQRT(2D0)
+ FAKT1=AMBOT/W2/AMW/COSB
+ FAKT2=AMTOP/W2/AMW/SINB
+ IF(IFIRST) THEN
+ DO 110 II=1,4
+ AMN(II)=SMZ(II)
+ DO 100 J=1,4
+ ROT1(II,J)=0D0
+ AN(II,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+ ROT1(1,1)=COSW
+ ROT1(1,2)=-SINW
+ ROT1(2,1)=-ROT1(1,2)
+ ROT1(2,2)=ROT1(1,1)
+ ROT1(3,3)=COSB
+ ROT1(3,4)=SINB
+ ROT1(4,3)=-ROT1(3,4)
+ ROT1(4,4)=ROT1(3,3)
+ DO 140 II=1,4
+ DO 130 J=1,4
+ DO 120 JJ=1,4
+ AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 150 J=1,4
+ ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
+ ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
+ ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
+ & XW)*AN(J,2)/COSW
+ HRT(J)=ZN(1)*COSA-ZN(3)*SINA
+ HLT(J)=ZN(1)*COSA+ZN(2)*SINA
+ FLT(J)=ZN(3)*COSA+ZN(1)*SINA
+ FRT(J)=ZN(2)*COSA-ZN(1)*SINA
+ FLU(J)=ZN(3)
+ FRU(J)=ZN(2)
+ ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
+ ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
+ ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
+ HRB(J)=ZN(1)*COSC-ZN(3)*SINC
+ HLB(J)=ZN(1)*COSC+ZN(2)*SINC
+ FLB(J)=ZN(3)*COSC+ZN(1)*SINC
+ FRB(J)=ZN(2)*COSC-ZN(1)*SINC
+ FLD(J)=ZN(3)
+ FRD(J)=ZN(2)
+ 150 CONTINUE
+ AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
+ AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
+ AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
+ AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
+ IFIRST=.FALSE.
+ ENDIF
+
+ IF(NINT(3D0*E).EQ.2) THEN
+ HL=HLT(I)
+ HR=HRT(I)
+ FL=FLT(I)
+ FR=FRT(I)
+ COSD=SFMIX(6,1)
+ SIND=SFMIX(6,3)
+ XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
+ XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
+ XM=PMAS(6,1)
+ ELSE
+ HL=HLB(I)
+ HR=HRB(I)
+ FL=FLB(I)
+ FR=FRB(I)
+ COSD=SFMIX(5,1)
+ SIND=SFMIX(5,3)
+ XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
+ XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
+ XM=PMAS(5,1)
+ ENDIF
+ COSD2=COSD*COSD
+ SIND2=SIND*SIND
+ COS2D=COSD2-SIND2
+ SIN2D=SIND*COSD*2D0
+ HL2=HL*HL
+ HR2=HR*HR
+ FL2=FL*FL
+ FR2=FR*FR
+ FF=FL*FR
+ HH=HL*HR
+ HFL=HL*FL
+ HFR=HR*FR
+ HRFL=HR*FL
+ HLFR=HL*FR
+ XM2=XM*XM
+ XMG=XMGLU
+ XMG2=XMG*XMG
+ ALPHAW=PYALEM(XMG2)
+ ALPHAS=PYALPS(XMG2)
+ XMR=AMN(I)
+ XMR2=XMR*XMR
+ XMQ4=XMG*XM2*XMR
+ XM24=(XMG2+XM2)*(XM2+XMR2)
+ SMIN=4D0*XM2
+ SMAX=(XMG-ABS(XMR))**2
+ XMQA=XMG2+2D0*XM2+XMR2
+ DO 170 LIN=1,NN-1
+ SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
+ GRS=SBAR-XMQA
+ W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
+ W=DSQRT(W)
+ XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
+ XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
+ B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
+ B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
+ G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
+ & +2D0*(FF*SIND2-HH*COSD2))*W
+ G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
+ & +4D0*HFL*XM*XMR)*XLN1
+ & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
+ & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
+ & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
+ & +8D0*HFL*XMQ4*SIN2D)*B1
+ G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
+ & +4D0*HFR*XMR*XM)*XLN2
+ & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
+ & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
+ & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
+ & -8D0*HFR*XMQ4*SIN2D)*B2
+ G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
+ & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
+ & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
+ & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
+ & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
+ G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
+ & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
+ & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
+ G(5)=(2D0*(HH*COSD2-FF*SIND2)
+ & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
+ & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
+ & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
+ & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
+ & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
+ & +COS2D*XM*(SBAR+XMG2-XMR2))
+ & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
+ & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
+ G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
+ & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
+ & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
+ & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
+ & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
+ SUMME(LIN)=0D0
+ DO 160 J=0,6
+ SUMME(LIN)=SUMME(LIN)+G(J)
+ 160 CONTINUE
+ 170 CONTINUE
+ SUMME(0)=0D0
+ SUMME(NN)=0D0
+ GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
+ &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTBBC
+C...Calculates the three-body decay of gluinos into
+C...charginos and third generation fermions.
+
+ SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ EXTERNAL PYSIMP,PYLAMF
+ INTEGER I,NN,LIN
+ DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
+ DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
+ DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
+ DOUBLE PRECISION SUMME(0:100),A(4,8)
+ DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
+ DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
+ DOUBLE PRECISION XMGLU,GAM
+ DOUBLE PRECISION PYSIMP,PYLAMF
+ DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
+ &DDD(2),EEE(2),FFF(2)
+ SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
+ DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
+ DOUBLE PRECISION AMC(2),AMN(4)
+ SAVE AMC,AMN
+ DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
+ DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
+ SAVE AMSB,AMST
+ DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
+ LOGICAL IFIRST
+ SAVE IFIRST
+ DATA IFIRST/.TRUE./
+
+ TANB=RMSS(5)
+ SINB=TANB/SQRT(1D0+TANB**2)
+ COSB=SINB/TANB
+ XW=PARU(102)
+ SINW=SQRT(XW)
+ COSW=SQRT(1D0-XW)
+ AMW=PMAS(24,1)
+ COSC=SFMIX(5,1)
+ SINC=SFMIX(5,3)
+ COSA=SFMIX(6,1)
+ SINA=SFMIX(6,3)
+ AMBOT=0D0
+ AMTOP=PYRNMT(PMAS(6,1))
+ W2=SQRT(2D0)
+ AMW=PMAS(24,1)
+ FAKT1=AMBOT/W2/AMW/COSB
+ FAKT2=AMTOP/W2/AMW/SINB
+ IF(IFIRST) THEN
+ AMC(1)=SMW(1)
+ AMC(2)=SMW(2)
+ DO 100 JJ=1,2
+ CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
+ EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
+ DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
+ FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
+ XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
+ AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
+ XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
+ BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
+ 100 CONTINUE
+ AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
+ AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
+ AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
+ AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
+ IFIRST=.FALSE.
+ ENDIF
+ AMTOP=PMAS(6,1)
+
+ ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
+ ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
+ VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
+ VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
+
+ COS2A=COSA**2-SINA**2
+ SIN2A=SINA*COSA*2D0
+ COS2C=COSC**2-SINC**2
+ SIN2C=SINC*COSC*2D0
+
+ XMG=XMGLU
+ XMT=AMTOP
+ XMB=0D0
+ XMR=AMC(I)
+ XMG2=XMG*XMG
+ ALPHAW=PYALEM(XMG2)
+ ALPHAS=PYALPS(XMG2)
+ XMT2=XMT*XMT
+ XMB2=XMB*XMB
+ XMR2=XMR*XMR
+ XMQ2=XMG2+XMT2+XMB2+XMR2
+ XMQ4=XMG*XMT*XMB*XMR
+ XMQ3=XMG2*XMR2+XMT2*XMB2
+ XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
+ XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
+
+ XMST(1)=AMST(1)*AMST(1)
+ XMST(2)=AMST(1)*AMST(1)
+ XMST(3)=AMST(2)*AMST(2)
+ XMST(4)=AMST(2)*AMST(2)
+ XMSB(1)=AMSB(1)*AMSB(1)
+ XMSB(2)=AMSB(2)*AMSB(2)
+ XMSB(3)=AMSB(1)*AMSB(1)
+ XMSB(4)=AMSB(2)*AMSB(2)
+
+ A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
+ A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
+ A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
+ A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
+ A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
+ A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
+ A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
+ A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
+
+ A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
+ A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
+ A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
+ A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
+ A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
+ A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
+ A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
+ A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
+
+ A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
+ A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
+ A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
+ A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
+ A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
+ A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
+ A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
+ A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
+
+ A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
+ A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
+ A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
+ A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
+ A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
+ A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
+ A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
+ A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
+
+ SMAX=(XMG-ABS(XMR))**2
+ SMIN=(XMB+XMT)**2+0.1D0
+
+ DO 120 LIN=0,NN-1
+ SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
+ AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
+ GRS=SBAR-XMQ2
+ W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
+ W=DSQRT(W)/2D0/SBAR
+ ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
+ ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
+ ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
+ ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
+ SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
+ & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
+ & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
+ & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
+ & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
+ & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
+ & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
+ SUMME(LIN)=SUMME(LIN)-ULR(2)*W
+ & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
+ & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
+ & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
+ & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
+ & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
+ & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
+ & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
+ SUMME(LIN)=SUMME(LIN)-VLR(1)*W
+ & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
+ & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
+ & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
+ & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
+ & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
+ & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
+ & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
+ SUMME(LIN)=SUMME(LIN)-VLR(2)*W
+ & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
+ & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
+ & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
+ & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
+ & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
+ & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
+ & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
+ SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
+ & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
+ & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
+ & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
+ SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
+ & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
+ & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
+ & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
+ DO 110 J=1,4
+ SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
+ & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
+ & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
+ & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
+ & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
+ & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
+ & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
+ & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
+ & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
+ & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
+ & -A(J,6)*(XMG2+XMR2-SBAR)
+ & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
+ & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
+ & /(GRS+XMSB(J)+XMST(J))
+ 110 CONTINUE
+ 120 CONTINUE
+ SUMME(NN)=0D0
+ GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
+ &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYNJDC
+C...Calculates decay widths for the neutralinos (admixtures of
+C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
+
+C...Input: KCIN = KF code for particle
+C...Output: XLAM = widths
+C... IDLAM = KF codes for decay particles
+C... IKNT = number of decay channels defined
+C...AUTHOR: STEPHEN MRENNA
+C...Last change:
+C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
+C...when CHIGAMMA .NE. 0
+C...10 FEB 96: Calculate this decay for small tan(beta)
+
+ SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
+
+C...Local variables.
+ INTEGER KFIN,KCIN
+ DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
+ &XMZ,XMZ2,AXMJ,AXMI
+ DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
+ DOUBLE PRECISION S12MIN,S12MAX
+ DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
+ DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
+ DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
+ DOUBLE PRECISION PYX2XH,PYX2XG
+ DOUBLE PRECISION XLAM(0:200)
+ INTEGER IDLAM(200,3)
+ INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
+ INTEGER ITH(3),KF1,KF2
+ INTEGER ITHC
+ DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
+ DOUBLE PRECISION SR2
+ DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
+ DOUBLE PRECISION GAMCON,XMT1,XMT2
+ DOUBLE PRECISION PYALEM,PI,PYALPS
+ DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
+ DOUBLE PRECISION RAT1,RAT2
+ DOUBLE PRECISION T3T,CA,CB,FCOL
+ DOUBLE PRECISION ALFA,BETA,TANB
+ DOUBLE PRECISION PYGAUS,PYXXGA
+ EXTERNAL PYXXW5,PYGAUS,PYXXZ5
+ DOUBLE PRECISION PREC
+ INTEGER KFNCHI(4),KFCCHI(2)
+ DATA ETAH/1D0,1D0,-1D0/
+ DATA ITH/25,35,36/
+ DATA ITHC/37/
+ DATA PREC/1D-2/
+ DATA PI/3.141592654D0/
+ DATA SR2/1.4142136D0/
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+ DATA KFCCHI/1000024,1000037/
+
+C...COUNT THE NUMBER OF DECAY MODES
+ LKNT=0
+
+ XMW=PMAS(24,1)
+ XMW2=XMW**2
+ XMZ=PMAS(23,1)
+ XMZ2=XMZ**2
+ XW=1D0-XMW2/XMZ2
+ TANW = SQRT(XW/(1D0-XW))
+
+C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
+ KCIN=PYCOMP(KFIN)
+ IX=1
+ IF(KFIN.EQ.KFNCHI(2)) IX=2
+ IF(KFIN.EQ.KFNCHI(3)) IX=3
+ IF(KFIN.EQ.KFNCHI(4)) IX=4
+
+ XMI=SMZ(IX)
+ XMI2=XMI**2
+ AXMI=ABS(XMI)
+ AEM=PYALEM(XMI2)
+ AS =PYALPS(XMI2)
+ C1=AEM/XW
+ XMI3=ABS(XMI**3)
+
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ ALFA=RMSS(18)
+ CBETA=COS(BETA)
+ SBETA=TANB*CBETA
+ CALFA=COS(ALFA)
+ SALFA=SIN(ALFA)
+
+C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
+ IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
+ RETURN
+ ENDIF
+
+C...FORCE CHI0_2 -> CHI0_1 + GAMMA
+ IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
+ XMJ=SMZ(1)
+ AXMJ=ABS(XMJ)
+ LKNT=LKNT+1
+ GAMCON=AEM**3/8D0/PI/XMW2/XW
+ XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
+ XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
+ XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
+ IDLAM(LKNT,1)=KSUSY1+22
+ IDLAM(LKNT,2)=22
+ IDLAM(LKNT,3)=0
+ WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
+ GOTO 290
+ ENDIF
+
+C...GRAVITINO DECAY MODES
+
+ IF(IMSS(11).EQ.1) THEN
+ XMP=RMSS(28)
+ IDG=39+KSUSY1
+ XMGR=PMAS(PYCOMP(IDG),1)
+ SINW=SQRT(XW)
+ COSW=SQRT(1D0-XW)
+ XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
+ IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=22
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
+ ENDIF
+ IF(AXMI.GT.XMGR+XMZ) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=23
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
+ $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
+ ENDIF
+ IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=25
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
+ $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
+ ENDIF
+ IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=35
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
+ $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
+ ENDIF
+ IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=36
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
+ $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
+ ENDIF
+ ENDIF
+
+ DO 180 IJ=1,IX-1
+ XMJ=SMZ(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+
+C...CHI0_I -> CHI0_J + GAMMA
+ IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
+ RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
+ RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
+ RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
+ RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
+ IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
+ & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=22
+ IDLAM(LKNT,3)=0
+ GAMCON=AEM**3/8D0/PI/XMW2/XW
+ XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
+ XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
+ XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
+ ENDIF
+ ENDIF
+
+C...CHI0_I -> CHI0_J + Z0
+ IF(AXMI.GE.AXMJ+XMZ) THEN
+ LKNT=LKNT+1
+ GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
+ GR=-GL
+ XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=23
+ IDLAM(LKNT,3)=0
+ ELSEIF(AXMI.GE.AXMJ) THEN
+ FID=11
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
+ XXM(7)=XMZ
+ XXM(8)=PMAS(23,2)
+ XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
+ XXM(10)=-XXM(9)
+ XXM(11)=(T3-EI*XW)/(1D0-XW)
+ XXM(12)=-EI*XW/(1D0-XW)
+ XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
+ XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
+ XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
+ XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
+ S12MIN=0D0
+ S12MAX=(AXMI-AXMJ)**2
+
+C...CHARGED LEPTONS
+ IF( XXM(5).LT.AXMI ) THEN
+ XXM(5)=1D6
+ ENDIF
+ IF(XXM(6).LT.AXMI ) THEN
+ XXM(6)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=11
+ IDLAM(LKNT,3)=-11
+ IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=13
+ IDLAM(LKNT,3)=-13
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+ IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
+ XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
+ ELSE
+ XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
+ XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
+ ENDIF
+ IF( XXM(5).LT.AXMI ) THEN
+ XXM(5)=1D6
+ ENDIF
+ IF(XXM(6).LT.AXMI ) THEN
+ XXM(6)=1D6
+ ENDIF
+
+ IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=15
+ IDLAM(LKNT,3)=-15
+ ENDIF
+
+C...NEUTRINOS
+ 110 CONTINUE
+ FID=12
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+ XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
+ XXM(6)=1D6
+ XXM(11)=(T3-EI*XW)/(1D0-XW)
+ XXM(12)=-EI*XW/(1D0-XW)
+ XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
+ XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
+ XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
+ XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
+
+ IF( XXM(5).LT.AXMI ) THEN
+ XXM(5)=1D6
+ ENDIF
+
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=12
+ IDLAM(LKNT,3)=-12
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=14
+ IDLAM(LKNT,3)=-14
+ 120 CONTINUE
+ XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
+ IF( XXM(5).LT.AXMI ) THEN
+ XXM(5)=1D6
+ ENDIF
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=16
+ IDLAM(LKNT,3)=-16
+
+C...D-TYPE QUARKS
+ 130 CONTINUE
+ XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
+ FID=1
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+
+ XXM(11)=(T3-EI*XW)/(1D0-XW)
+ XXM(12)=-EI*XW/(1D0-XW)
+ XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
+ XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
+ XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
+ XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
+
+ IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
+ IF( XXM(5).LT.AXMI ) THEN
+ XXM(5)=1D6
+ ELSEIF( XXM(6).LT.AXMI ) THEN
+ XXM(6)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-1
+ IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-3
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+ IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
+ XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
+ ELSE
+ XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
+ XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
+ ENDIF
+ IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
+ IF(XXM(5).LT.AXMI) THEN
+ XXM(5)=1D6
+ ELSEIF(XXM(6).LT.AXMI) THEN
+ XXM(6)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=5
+ IDLAM(LKNT,3)=-5
+ ENDIF
+
+C...U-TYPE QUARKS
+ 150 CONTINUE
+ XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
+ FID=2
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+
+ XXM(11)=(T3-EI*XW)/(1D0-XW)
+ XXM(12)=-EI*XW/(1D0-XW)
+ XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
+ XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
+ XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
+ XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
+
+ IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
+ IF(XXM(5).LT.AXMI) THEN
+ XXM(5)=1D6
+ ELSEIF(XXM(6).LT.AXMI) THEN
+ XXM(6)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=2
+ IDLAM(LKNT,3)=-2
+ IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=4
+ IDLAM(LKNT,3)=-4
+ ENDIF
+ ENDIF
+ 160 CONTINUE
+ ENDIF
+
+C...CHI0_I -> CHI0_J + H0_K
+ EH(1)=SIN(ALFA)
+ EH(2)=COS(ALFA)
+ EH(3)=-SIN(BETA)
+ DH(1)=COS(ALFA)
+ DH(2)=-SIN(ALFA)
+ DH(3)=COS(BETA)
+
+ QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
+ & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
+ RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
+ & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
+
+ DO 170 IH=1,3
+ XMH=PMAS(ITH(IH),1)
+ XMH2=XMH**2
+ IF(AXMI.GE.AXMJ+XMH) THEN
+ LKNT=LKNT+1
+ XL=PYLAMF(XMI2,XMJ2,XMH2)
+ F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
+ F12K=F21K
+C...SIGN OF MASSES I,J
+ XMK=XMJ
+ IF(IH.EQ.3) XMK=-XMK
+ XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=ITH(IH)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 170 CONTINUE
+ 180 CONTINUE
+
+C...CHI0_I -> CHI+_J + W-
+ DO 220 IJ=1,2
+ XMJ=SMW(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+ IF(AXMI.GE.AXMJ+XMW) THEN
+ LKNT=LKNT+1
+ GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
+ GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
+ XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=-24
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-KFCCHI(IJ)
+ IDLAM(LKNT,2)=24
+ IDLAM(LKNT,3)=0
+ ELSEIF(AXMI.GE.AXMJ) THEN
+ S12MIN=0D0
+ S12MAX=(AXMI-AXMJ)**2
+ XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
+ XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
+
+C...LEPTONS
+ FID=11
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+ XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
+ FID=12
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+ XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
+
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(9)=PMAS(24,1)
+ XXM(10)=PMAS(24,2)
+ XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
+ IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ELSEIF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=11
+ IDLAM(LKNT,3)=-12
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=13
+ IDLAM(LKNT,3)=-14
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+ ENDIF
+ 190 CONTINUE
+ IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
+ XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
+ ELSE
+ XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
+ ENDIF
+
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ENDIF
+ IF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=15
+ IDLAM(LKNT,3)=-16
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+
+C...NOW, DO THE QUARKS
+ 200 CONTINUE
+ FID=1
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+ XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
+ FID=2
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+ XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
+
+ XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
+ IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ELSEIF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-2
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-4
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ENDIF
+ ENDIF
+ 210 CONTINUE
+ ENDIF
+ 220 CONTINUE
+ 230 CONTINUE
+
+C...CHI0_I -> CHI+_I + H-
+ DO 240 IJ=1,2
+ XMJ=SMW(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+ XMHP=PMAS(ITHC,1)
+ XMHP2=XMHP**2
+ IF(AXMI.GE.AXMJ+XMHP) THEN
+ LKNT=LKNT+1
+ GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
+ & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
+ GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
+ & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
+ XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=-ITHC
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
+ ELSE
+
+ ENDIF
+ 240 CONTINUE
+
+C...2-BODY DECAYS TO FERMION SFERMION
+ DO 250 J=1,16
+ IF(J.GE.7.AND.J.LE.10) GOTO 250
+ KF1=KSUSY1+J
+ KF2=KSUSY2+J
+ XMSF1=PMAS(PYCOMP(KF1),1)
+ XMSF2=PMAS(PYCOMP(KF2),1)
+ XMF=PMAS(J,1)
+ IF(J.LE.6) THEN
+ FCOL=3D0
+ ELSE
+ FCOL=1D0
+ ENDIF
+
+ EI=KCHG(J,1)/3D0
+ T3T=SIGN(1D0,EI)
+ IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
+ IF(MOD(J,2).EQ.0) THEN
+ BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
+ AL=XMF*ZMIX(IX,4)/XMW/SBETA
+ AR=-2D0*EI*TANW*ZMIX(IX,1)
+ BR=AL
+ ELSE
+ BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
+ AL=XMF*ZMIX(IX,3)/XMW/CBETA
+ AR=-2D0*EI*TANW*ZMIX(IX,1)
+ BR=AL
+ ENDIF
+
+C...D~ D_L
+ IF(AXMI.GE.XMF+XMSF1) THEN
+ LKNT=LKNT+1
+ XMA2=XMSF1**2
+ XMB2=XMF**2
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
+ CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
+ XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
+ & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
+ IDLAM(LKNT,1)=KF1
+ IDLAM(LKNT,2)=-J
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...D~ D_R
+ IF(AXMI.GE.XMF+XMSF2) THEN
+ LKNT=LKNT+1
+ XMA2=XMSF2**2
+ XMB2=XMF**2
+ CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
+ CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
+ & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
+ IDLAM(LKNT,1)=KF2
+ IDLAM(LKNT,2)=-J
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
+ IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 250 CONTINUE
+
+C...3-BODY DECAY TO Q Q~ GLUINO
+ XMJ=PMAS(PYCOMP(KSUSY1+21),1)
+ IF(AXMI.GE.XMJ) THEN
+ AXMJ=ABS(XMJ)
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
+ XXM(7)=1D6
+ XXM(8)=0D0
+ XXM(9)=0D0
+ XXM(10)=0D0
+ S12MIN=0D0
+ S12MAX=(AXMI-AXMJ)**2
+C...ALL QUARKS BUT T
+ XXM(11)=0D0
+ XXM(12)=0D0
+ XXM(13)=1D0
+ XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
+ XXM(15)=1D0
+ XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
+ IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-1
+ IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-3
+ ENDIF
+ ENDIF
+ 260 CONTINUE
+ IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
+ XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
+ ELSE
+ XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
+ XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
+ ENDIF
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
+ IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=5
+ IDLAM(LKNT,3)=-5
+ ENDIF
+C...U-TYPE QUARKS
+ 270 CONTINUE
+ XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
+ XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
+ XXM(13)=1D0
+ XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
+ XXM(15)=1D0
+ XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
+ IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
+ IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=2
+ IDLAM(LKNT,3)=-2
+ IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=4
+ IDLAM(LKNT,3)=-4
+ ENDIF
+ ENDIF
+ 280 CONTINUE
+ ENDIF
+
+ 290 IKNT=LKNT
+ XLAM(0)=0D0
+ DO 300 I=1,IKNT
+ IF(XLAM(I).LT.0D0) XLAM(I)=0D0
+ XLAM(0)=XLAM(0)+XLAM(I)
+ 300 CONTINUE
+ IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCJDC
+C...Calculate decay widths for the charginos (admixtures of
+C...charged Wino and charged Higgsino.
+
+C...Input: KCIN = KF code for particle
+C...Output: XLAM = widths
+C... IDLAM = KF codes for decay particles
+C... IKNT = number of decay channels defined
+C...AUTHOR: STEPHEN MRENNA
+C...Last change:
+C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
+C...when CHIENU .NE. 0
+
+ SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
+
+C...Local variables.
+ INTEGER KFIN,KCIN
+ DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
+ &XMZ,XMZ2,AXMJ,AXMI
+ DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
+ DOUBLE PRECISION S12MIN,S12MAX
+ DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
+ DOUBLE PRECISION PYLAMF,XL
+ DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
+ DOUBLE PRECISION PYX2XH,PYX2XG
+ DOUBLE PRECISION XLAM(0:200)
+ INTEGER IDLAM(200,3)
+ INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
+ INTEGER ITH(3)
+ INTEGER ITHC
+ DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
+ DOUBLE PRECISION SR2
+ DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
+
+ DOUBLE PRECISION PYALEM,PI,PYALPS
+ DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
+ DOUBLE PRECISION CA,CB,FCOL
+ INTEGER KF1,KF2,ISF
+ INTEGER KFNCHI(4),KFCCHI(2)
+
+ DOUBLE PRECISION TEMP
+ DOUBLE PRECISION PYGAUS
+ EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
+ DOUBLE PRECISION PREC
+ DATA ITH/25,35,36/
+ DATA ITHC/37/
+ DATA ETAH/1D0,1D0,-1D0/
+ DATA SR2/1.4142136D0/
+ DATA PI/3.141592654D0/
+ DATA PREC/1D-2/
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+ DATA KFCCHI/1000024,1000037/
+
+C...COUNT THE NUMBER OF DECAY MODES
+ LKNT=0
+ XMW=PMAS(24,1)
+ XMW2=XMW**2
+ XMZ=PMAS(23,1)
+ XMZ2=XMZ**2
+ XW=1D0-XMW2/XMZ2
+ TANW = SQRT(XW/(1D0-XW))
+
+C...1 OR 2 DEPENDING ON CHARGINO TYPE
+ IX=1
+ IF(KFIN.EQ.KFCCHI(2)) IX=2
+ KCIN=PYCOMP(KFIN)
+
+ XMI=SMW(IX)
+ XMI2=XMI**2
+ AXMI=ABS(XMI)
+ AEM=PYALEM(XMI2)
+ AS =PYALPS(XMI2)
+ C1=AEM/XW
+ XMI3=ABS(XMI**3)
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ CBETA=COS(BETA)
+ SBETA=TANB*CBETA
+ ALFA=RMSS(18)
+
+C...GRAVITINO DECAY MODES
+
+ IF(IMSS(11).EQ.1) THEN
+ XMP=RMSS(28)
+ IDG=39+KSUSY1
+ XMGR=PMAS(PYCOMP(IDG),1)
+ SINW=SQRT(XW)
+ COSW=SQRT(1D0-XW)
+ XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
+ IF(AXMI.GT.XMGR+XMW) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=24
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
+ & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
+ & (1D0-XMW2/XMI2)**4
+ ENDIF
+ IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=IDG
+ IDLAM(LKNT,2)=37
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
+ & (UMIX(IX,2)*SBETA)**2))
+ & *(1D0-PMAS(37,1)**2/XMI2)**4
+ ENDIF
+ ENDIF
+
+C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
+ IF(IX.EQ.1) GOTO 150
+ XMJ=SMW(1)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+
+C...CHI_2+ -> CHI_1+ + Z0
+ IF(AXMI.GE.AXMJ+XMZ) THEN
+ LKNT=LKNT+1
+ GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
+ GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
+ XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=23
+ IDLAM(LKNT,3)=0
+
+C...CHARGED LEPTONS
+ ELSEIF(AXMI.GE.AXMJ) THEN
+ XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
+ XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
+ XXM(9)=XMZ
+ XXM(10)=PMAS(23,2)
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ S12MIN=0D0
+ S12MAX=(AXMJ-AXMI)**2
+ XXM(7)= (-0.5D0+XW)/(1D0-XW)
+ XXM(8)= XW/(1D0-XW)
+ XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
+ XXM(12)=VMIX(2,1)*VMIX(1,1)
+ IF( XXM(11).LT.AXMI ) THEN
+ XXM(11)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=11
+ IDLAM(LKNT,3)=-11
+ IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=13
+ IDLAM(LKNT,3)=-13
+ IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=15
+ IDLAM(LKNT,3)=-15
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...NEUTRINOS
+ 100 CONTINUE
+ XXM(7)= (0.5D0)/(1D0-XW)
+ XXM(8)= 0D0
+ XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
+ XXM(12)=UMIX(2,1)*UMIX(1,1)
+ IF( XXM(11).LT.AXMI ) THEN
+ XXM(11)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=12
+ IDLAM(LKNT,3)=-12
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=14
+ IDLAM(LKNT,3)=-14
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=16
+ IDLAM(LKNT,3)=-16
+ ENDIF
+
+C...D-TYPE QUARKS
+ 110 CONTINUE
+ XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
+ XXM(8)= XW/3D0/(1D0-XW)
+ XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
+ XXM(12)=VMIX(2,1)*VMIX(1,1)
+ IF( XXM(11).LT.AXMI ) GOTO 120
+ IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=1
+ IDLAM(LKNT,3)=-1
+ IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=3
+ IDLAM(LKNT,3)=-3
+ IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=5
+ IDLAM(LKNT,3)=-5
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...U-TYPE QUARKS
+ 120 CONTINUE
+ XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
+ XXM(8)= -2D0*XW/3D0/(1D0-XW)
+ XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(12)=UMIX(2,1)*UMIX(1,1)
+ IF( XXM(11).LT.AXMI ) GOTO 130
+ IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=2
+ IDLAM(LKNT,3)=-2
+ IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=4
+ IDLAM(LKNT,3)=-4
+ ENDIF
+ ENDIF
+ 130 CONTINUE
+ ENDIF
+
+C...CHI_2+ -> CHI_1+ + H0_K
+ EH(2)=COS(ALFA)
+ EH(1)=SIN(ALFA)
+ EH(3)=-SBETA
+ DH(2)=-SIN(ALFA)
+ DH(1)=COS(ALFA)
+ DH(3)=COS(BETA)
+ DO 140 IH=1,3
+ XMH=PMAS(ITH(IH),1)
+ XMH2=XMH**2
+C...NO 3-BODY OPTION
+ IF(AXMI.GE.AXMJ+XMH) THEN
+ LKNT=LKNT+1
+ XL=PYLAMF(XMI2,XMJ2,XMH2)
+ F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
+ & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
+ F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
+ & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
+ XMK=XMJ*ETAH(IH)
+ XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
+ IDLAM(LKNT,1)=KFCCHI(1)
+ IDLAM(LKNT,2)=ITH(IH)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 140 CONTINUE
+
+C...CHI1 JUMPS TO HERE
+ 150 CONTINUE
+
+C...CHI+_I -> CHI0_J + W+
+ DO 180 IJ=1,4
+ XMJ=SMZ(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+ IF(AXMI.GE.AXMJ+XMW) THEN
+ LKNT=LKNT+1
+ GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
+ GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
+ XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=24
+ IDLAM(LKNT,3)=0
+
+C...LEPTONS
+ ELSEIF(AXMI.GE.AXMJ) THEN
+ XMF1=0D0
+ XMF2=0D0
+ S12MIN=(XMF1+XMF2)**2
+ S12MAX=(AXMJ-AXMI)**2
+ XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
+ XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
+ FID=11
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+ XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
+ FID=12
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+ XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
+
+ XXM(4)=XMI
+ XXM(1)=XMF1
+ XXM(2)=XMJ
+ XXM(3)=XMF2
+ XXM(9)=PMAS(24,1)
+ XXM(10)=PMAS(24,2)
+ XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
+
+C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
+C...--> 1/(16PI)/M**3*(AEM/XW)**2
+
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ENDIF
+ IF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
+ LKNT=LKNT+1
+ TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=-11
+ IDLAM(LKNT,3)=12
+
+C...ONLY DECAY CHI+1 -> E+ NU_E
+ IF( IMSS(12).NE. 0 ) GOTO 220
+ IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
+ LKNT=LKNT+1
+ XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ELSEIF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=-13
+ IDLAM(LKNT,3)=14
+ IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
+ LKNT=LKNT+1
+ IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
+ XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
+ ELSE
+ XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
+ ENDIF
+ XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ENDIF
+ IF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=-15
+ IDLAM(LKNT,3)=16
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...NOW, DO THE QUARKS
+ 160 CONTINUE
+ FID=1
+ EI=KCHG(FID,1)/3D0
+ T3=-0.5D0
+ XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
+ FID=1
+ EI=KCHG(FID,1)/3D0
+ T3=0.5D0
+ XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
+
+ XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
+ IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
+ IF(XXM(11).LT.AXMI) THEN
+ XXM(11)=1D6
+ ELSEIF(XXM(12).LT.AXMI) THEN
+ XXM(12)=1D6
+ ENDIF
+ IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=-1
+ IDLAM(LKNT,3)=2
+ IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=-3
+ IDLAM(LKNT,3)=4
+ ENDIF
+ ENDIF
+ 170 CONTINUE
+ ENDIF
+ 180 CONTINUE
+
+C...CHI+_I -> CHI0_J + H+
+ DO 190 IJ=1,4
+ XMJ=SMZ(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+ XMHP=PMAS(ITHC,1)
+ XMHP2=XMHP**2
+ IF(AXMI.GE.AXMJ+XMHP) THEN
+ LKNT=LKNT+1
+ GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
+ & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
+ GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
+ & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
+ XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=ITHC
+ IDLAM(LKNT,3)=0
+ ELSE
+
+ ENDIF
+ 190 CONTINUE
+
+C...2-BODY DECAYS TO FERMION SFERMION
+ DO 200 J=1,16
+ IF(J.GE.7.AND.J.LE.10) GOTO 200
+ IF(MOD(J,2).EQ.0) THEN
+ KF1=KSUSY1+J-1
+ ELSE
+ KF1=KSUSY1+J+1
+ ENDIF
+ KF2=KF1+KSUSY1
+ XMSF1=PMAS(PYCOMP(KF1),1)
+ XMSF2=PMAS(PYCOMP(KF2),1)
+ XMF=PMAS(J,1)
+ IF(J.LE.6) THEN
+ FCOL=3D0
+ ELSE
+ FCOL=1D0
+ ENDIF
+
+C...U~ D_L
+ IF(MOD(J,2).EQ.0) THEN
+ XMFP=PMAS(J-1,1)
+ AL=UMIX(IX,1)
+ BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
+ AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
+ BR=0D0
+ ISF=J-1
+ ELSE
+ XMFP=PMAS(J+1,1)
+ AL=VMIX(IX,1)
+ BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
+ BR=0D0
+ AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
+ ISF=J+1
+ ENDIF
+
+C...~U_L D
+ IF(AXMI.GE.XMF+XMSF1) THEN
+ LKNT=LKNT+1
+ XMA2=XMSF1**2
+ XMB2=XMF**2
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
+ CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
+ XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
+ & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
+ IDLAM(LKNT,3)=0
+ IF(MOD(J,2).EQ.0) THEN
+ IDLAM(LKNT,1)=-KF1
+ IDLAM(LKNT,2)=J
+ ELSE
+ IDLAM(LKNT,1)=KF1
+ IDLAM(LKNT,2)=-J
+ ENDIF
+ ENDIF
+
+C...U~ D_R
+ IF(AXMI.GE.XMF+XMSF2) THEN
+ LKNT=LKNT+1
+ XMA2=XMSF2**2
+ XMB2=XMF**2
+ CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
+ CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
+ XL=PYLAMF(XMI2,XMA2,XMB2)
+ XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
+ & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
+ IDLAM(LKNT,3)=0
+ IF(MOD(J,2).EQ.0) THEN
+ IDLAM(LKNT,1)=-KF2
+ IDLAM(LKNT,2)=J
+ ELSE
+ IDLAM(LKNT,1)=KF2
+ IDLAM(LKNT,2)=-J
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+
+C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
+C...A 2-BODY -- 2-BODY CHAIN
+ XMJ=PMAS(PYCOMP(KSUSY1+21),1)
+ IF(AXMI.GE.XMJ) THEN
+ AXMJ=ABS(XMJ)
+ S12MIN=0D0
+ S12MAX=(AXMI-AXMJ)**2
+ XXM(1)=0D0
+ XXM(2)=XMJ
+ XXM(3)=0D0
+ XXM(4)=XMI
+ XXM(5)=0D0
+ XXM(6)=0D0
+ XXM(9)=1D6
+ XXM(10)=0D0
+ XXM(7)=UMIX(IX,1)*SR2
+ XXM(8)=VMIX(IX,1)*SR2
+ XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
+ XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
+ IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
+ IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
+ & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=-1
+ IDLAM(LKNT,3)=2
+ IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=XLAM(LKNT-1)
+ IDLAM(LKNT,1)=KSUSY1+21
+ IDLAM(LKNT,2)=-3
+ IDLAM(LKNT,3)=4
+ ENDIF
+ ENDIF
+ 210 CONTINUE
+ ENDIF
+
+ 220 IKNT=LKNT
+ XLAM(0)=0D0
+ DO 230 I=1,IKNT
+ XLAM(0)=XLAM(0)+XLAM(I)
+ IF(XLAM(I).LT.0D0) THEN
+ WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
+ & (IDLAM(I,J),J=1,3)
+ XLAM(I)=0D0
+ ENDIF
+ 230 CONTINUE
+ IF(XLAM(0).EQ.0D0) THEN
+ XLAM(0)=1D-6
+ WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
+ WRITE(MSTU(11),*) LKNT
+ WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXXZ5
+C...Calculates chi0 -> chi0 + f + ~f.
+
+ FUNCTION PYXXZ5(X)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYINTS/
+
+C...Local variables.
+ DOUBLE PRECISION PYXXZ5,X
+ DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
+ DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
+ DOUBLE PRECISION SIJ
+ DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
+ DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
+ DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
+ INTEGER I
+ DATA SR2/1.4142136D0/
+
+C...Statement functions.
+C...Integral from x to y of (t-a)(b-t) dt.
+ TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
+C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
+ TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
+ &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
+C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
+ TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
+C...Integral from x to y of (t-a)/(b-t) dt.
+ UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
+C...Integral from x to y of 1/(t-a) dt.
+ TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
+
+ XM12=XXM(1)**2
+ XM22=XXM(2)**2
+ XM32=XXM(3)**2
+ S=XXM(4)**2
+ S13=X
+
+ S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
+ S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
+ &( (X-XM22-S)**2 -4D0*XM22*S ) )
+
+ S23MIN=(S23AVE-S23DEL)
+ S23MAX=(S23AVE+S23DEL)
+
+ XMV=XXM(7)
+ XMG=XXM(8)
+ XMSD=XXM(5)**2
+ XMSU=XXM(6)**2
+ OL=XXM(9)
+ OR=XXM(10)
+ OL2=OL**2
+ OR2=OR**2
+ LE=XXM(11)
+ RE=XXM(12)
+ LE2=LE**2
+ RE2=RE**2
+ FLI=XXM(13)
+ FLJ=XXM(14)
+ FRI=XXM(15)
+ FRJ=XXM(16)
+
+ WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
+ SIJ=2D0*XXM(2)*XXM(4)*S13
+
+ IF(XMV.LE.1000D0) THEN
+ WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
+ & +SIJ*(S23MAX-S23MIN) )/WPROP2
+ IF(XXM(5).LE.10000D0) THEN
+ WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
+ & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
+ WFL1=WFL1*(S13-XMV**2)/WPROP2
+ ELSE
+ WFL1=0D0
+ ENDIF
+ IF(XXM(6).LE.10000D0) THEN
+ WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
+ & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
+ WFL2=WFL2*(S13-XMV**2)/WPROP2
+ ELSE
+ WFL2=0D0
+ ENDIF
+ ELSE
+ WW=0D0
+ WFL1=0D0
+ WFL2=0D0
+ ENDIF
+ IF(XXM(5).LE.10000D0) THEN
+ WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
+ & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
+ ELSE
+ WF1=0D0
+ ENDIF
+ IF(XXM(6).LE.10000D0) THEN
+ WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
+ & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
+ ELSE
+ WF2=0D0
+ ENDIF
+
+C...WFL1=0.0
+C...WFL2=0.0
+ PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
+ IF(PYXXZ5.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
+ WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
+ WRITE(MSTU(11),*) (XXM(I),I=5,8)
+ WRITE(MSTU(11),*) (XXM(I),I=9,12)
+ WRITE(MSTU(11),*) (XXM(I),I=13,16)
+ WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
+ WRITE(MSTU(11),*) S23MIN,S23MAX
+ PYXXZ5=0D0
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXXW5
+C...Calculates chi0(+) -> chi+(0) + f + ~f'.
+
+ FUNCTION PYXXW5(X)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYINTS/
+
+C...Local variables.
+ DOUBLE PRECISION PYXXW5,X
+ DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
+ DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
+ DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
+ DOUBLE PRECISION SIJ
+ DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
+ INTEGER IK
+ SAVE IK
+ DATA IK/0/
+ DATA SR2/1.4142136D0/
+
+C...Statement functions.
+C...Integral from x to y of (t-a)(b-t) dt.
+ TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
+C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
+ TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
+ &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
+C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
+ TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
+C...Integral from x to y of (t-a)/(b-t) dt.
+ UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
+C...Integral from x to y of 1/(t-a) dt.
+ TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
+
+ XM12=XXM(1)**2
+ XM22=XXM(2)**2
+ XM32=XXM(3)**2
+ S=XXM(4)**2
+ S13=X
+ IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
+ S23AVE=0.5D0*(XM22+S-S13)
+ S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
+ ELSE
+ S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
+ S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
+ & ( (X-XM22-S)**2 -4D0*XM22*S ) )
+ ENDIF
+ S23MIN=(S23AVE-S23DEL)
+ S23MAX=(S23AVE+S23DEL)
+ IF(S23DEL.LT.1D-3) THEN
+ PYXXW5=0D0
+ RETURN
+ ENDIF
+ XMV=XXM(9)
+ XMG=XXM(10)
+ XMSD=XXM(11)**2
+ XMSU=XXM(12)**2
+ OL=XXM(5)
+ OR=XXM(6)
+ FLD=XXM(7)
+ FLU=XXM(8)
+
+ WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
+ SIJ=S13*XXM(2)*XXM(4)
+ IF(XMV.LE.1000D0) THEN
+ WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
+ & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
+ WW=WW/WPROP2
+ IF(XXM(11).LE.10000D0) THEN
+ WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
+ & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
+ WWD=-WWD*SR2*FLD
+ WWD=WWD*(S13-XMV**2)/WPROP2
+ ELSE
+ WWD=0D0
+ ENDIF
+ IF(XXM(12).LE.10000D0) THEN
+ WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
+ & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
+ WWU=WWU*SR2*FLU
+ WWU=WWU*(S13-XMV**2)/WPROP2
+ ELSE
+ WWU=0D0
+ ENDIF
+ ELSE
+ WW=0D0
+ WWD=0D0
+ WWU=0D0
+ ENDIF
+ IF(XXM(12).LE.10000D0) THEN
+ WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
+ ELSE
+ WU=0D0
+ ENDIF
+ IF(XXM(11).LE.10000D0) THEN
+ WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
+ ELSE
+ WD=0D0
+ ENDIF
+ IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
+ WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
+ ELSE
+ WUD=0D0
+ ENDIF
+
+ PYXXW5=WW+WU+WD+WWU+WWD+WUD
+
+ IF(PYXXW5.LT.0D0) THEN
+ IF(IK.EQ.0) THEN
+ WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
+ WRITE(MSTU(11),*) WW,WU,WD
+ WRITE(MSTU(11),*) WWD,WWU,WUD
+ WRITE(MSTU(11),*) SQRT(S13)
+ WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
+ IK=1
+ ENDIF
+ PYXXW5=0D0
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXXGA
+C...Calculates chi0_i -> chi0_j + gamma.
+
+ FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
+ DOUBLE PRECISION F1,F2
+
+ F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
+ F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
+ PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
+ PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYX2XG
+C...Calculates the decay rate for ino -> ino + gauge boson.
+
+ FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
+ DOUBLE PRECISION XL,PYLAMF,C1
+ DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
+
+ XMI2=XM1**2
+ XMI3=ABS(XM1**3)
+ XMJ2=XM2**2
+ XMV2=XM3**2
+ XL=PYLAMF(XMI2,XMJ2,XMV2)
+ PYX2XG=C1/8D0/XMI3*SQRT(XL)
+ &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
+ &12D0*GL*GR*XM1*XM2*XMV2)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYX2XH
+C...Calculates the decay rate for ino -> ino + H.
+
+ FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
+ DOUBLE PRECISION XL,PYLAMF,C1
+ DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
+
+ XMI2=XM1**2
+ XMI3=ABS(XM1**3)
+ XMJ2=XM2**2
+ XMV2=XM3**2
+ XL=PYLAMF(XMI2,XMJ2,XMV2)
+ PYX2XH=C1/8D0/XMI3*SQRT(XL)
+ &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
+ &4D0*GL*GR*XM1*XM2)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXXZ2
+C...Calculates chi+ -> chi+ + f + ~f.
+
+ FUNCTION PYXXZ2(X)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINTS/XXM(20)
+ SAVE /PYDAT1/,/PYINTS/
+
+C...Local variables.
+ DOUBLE PRECISION PYXXZ2,X
+ DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
+ DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
+ DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
+ DOUBLE PRECISION SIJ
+ DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
+ DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
+ INTEGER I
+ DATA SR2/1.4142136D0/
+
+C...Statement functions.
+C...Integral from x to y of (t-a)(b-t) dt.
+ TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
+C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
+ TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
+ &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
+C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
+ TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
+C...Integral from x to y of 1/(t-a) dt.
+ TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
+
+ XM12=XXM(1)**2
+ XM22=XXM(2)**2
+ XM32=XXM(3)**2
+ S=XXM(4)**2
+ S13=X
+ IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
+ S23AVE=0.5D0*(XM22+S-S13)
+ S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
+ ELSE
+ S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
+ S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
+ & ( (X-XM22-S)**2 -4D0*XM22*S ) )
+ ENDIF
+ S23MIN=(S23AVE-S23DEL)
+ S23MAX=(S23AVE+S23DEL)
+ IF(S23DEL.LT.1D-3) THEN
+ PYXXZ2=0D0
+ RETURN
+ ENDIF
+
+ XMV=XXM(9)
+ XMG=XXM(10)
+ XMSL=XXM(11)**2
+ OL=XXM(5)
+ OR=XXM(6)
+ OL2=OL**2
+ OR2=OR**2
+ LE=XXM(7)
+ RE=XXM(8)
+ LE2=LE**2
+ RE2=RE**2
+ CT=XXM(12)
+
+ WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
+ SIJ=XXM(2)*XXM(4)*S13
+ WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
+ &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
+ WW=WW/WPROP2
+ IF(XMSL.GT.1D4*S) THEN
+ WD=0D0
+ WWD=0D0
+ ELSE
+ WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
+ WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
+ & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
+ WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
+ ENDIF
+
+ PYXXZ2=(WW+WD+WWD)
+ IF(PYXXZ2.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
+ WRITE(MSTU(11),*) WW,WD,WWD
+ WRITE(MSTU(11),*) S23MIN,S23MAX
+ WRITE(MSTU(11),*) (XXM(I),I=1,4)
+ WRITE(MSTU(11),*) (XXM(I),I=5,8)
+ WRITE(MSTU(11),*) (XXM(I),I=9,12)
+ PYXXZ2=0D0
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYHEXT
+C...Calculates the non-standard decay modes of the Higgs boson.
+
+ SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
+ &SFMIX(16,4)
+ SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
+
+C...Local variables.
+ INTEGER KFIN
+ DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
+ &XMZ,XMZ2,AXMJ,AXMI
+ DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
+ DOUBLE PRECISION S12MIN,S12MAX
+ DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
+ DOUBLE PRECISION PYLAMF,XL,CF,EI
+ INTEGER IDU,IC,ILR,IFL
+ DOUBLE PRECISION TANW,XW,AEM,C1,AS
+ DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
+ DOUBLE PRECISION XLAM(0:200)
+ INTEGER IDLAM(200,3)
+ INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
+ INTEGER ITH(4)
+ INTEGER KFNCHI(4),KFCCHI(2)
+ DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
+ DOUBLE PRECISION SR2
+ DOUBLE PRECISION BETA,ALFA
+ DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
+ DOUBLE PRECISION PYALEM,PI,PYALPS
+ DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
+ DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
+ DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
+ DOUBLE PRECISION XMJL,XMJR,XM1,XM2
+ DATA ITH/25,35,36,37/
+ DATA ETAH/1D0,1D0,-1D0/
+ DATA SR2/1.4142136D0/
+ DATA PI/3.141592654D0/
+ DATA KFNCHI/1000022,1000023,1000025,1000035/
+ DATA KFCCHI/1000024,1000037/
+
+C...COUNT THE NUMBER OF DECAY MODES
+ LKNT=IKNT
+
+ XMW=PMAS(24,1)
+ XMW2=XMW**2
+ XMZ=PMAS(23,1)
+ XMZ2=XMZ**2
+ XW=PARU(102)
+ TANW = SQRT(XW/(1D0-XW))
+ CW=SQRT(1D0-XW)
+
+C...1 - 4 DEPENDING ON Higgs species.
+ IH=1
+ IF(KFIN.EQ.ITH(2)) IH=2
+ IF(KFIN.EQ.ITH(3)) IH=3
+ IF(KFIN.EQ.ITH(4)) IH=4
+
+ XMI=PMAS(KFIN,1)
+ XMI2=XMI**2
+ AXMI=ABS(XMI)
+ AEM=PYALEM(XMI2)
+ AS =PYALPS(XMI2)
+ C1=AEM/XW
+ XMI3=ABS(XMI**3)
+
+ TANB=RMSS(5)
+ BETA=ATAN(TANB)
+ CBETA=COS(BETA)
+ SBETA=TANB*CBETA
+ ALFA=RMSS(18)
+ COSA=COS(ALFA)
+ SINA=SIN(ALFA)
+ ATRIT=RMSS(16)
+ ATRIB=RMSS(15)
+ ATRIL=RMSS(17)
+ XMUZ=-RMSS(4)
+
+ IF(IH.EQ.4) GOTO 180
+
+C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
+C...H0_K -> CHI0_I + CHI0_J
+ EH(1)=SINA
+ EH(2)=COSA
+ EH(3)=-SBETA
+ DH(1)=COSA
+ DH(2)=-SINA
+ DH(3)=CBETA
+ DO 110 IJ=1,4
+ XMJ=SMZ(IJ)
+ AXMJ=ABS(XMJ)
+ DO 100 IK=1,IJ
+ XMK=SMZ(IK)
+ AXMK=ABS(XMK)
+ IF(AXMI.GE.AXMJ+AXMK) THEN
+ LKNT=LKNT+1
+ F21K=0.5D0*
+ & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
+ & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
+ & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
+ & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
+ F12K=0.5D0*
+ & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
+ & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
+ & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
+ & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
+C...SIGN OF MASSES I,J
+ XML=XMK*ETAH(IH)
+ XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
+ IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=KFNCHI(IK)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...H0_K -> CHI+_I CHI-_J
+ DO 130 IJ=1,2
+ XMJ=SMW(IJ)
+ AXMJ=ABS(XMJ)
+ DO 120 IK=1,2
+ XMK=SMW(IK)
+ AXMK=ABS(XMK)
+ IF(AXMI.GE.AXMJ+AXMK) THEN
+ LKNT=LKNT+1
+ F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
+ & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
+ F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
+ & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
+ XML=-XMK*ETAH(IH)
+ XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
+ IDLAM(LKNT,1)=KFCCHI(IJ)
+ IDLAM(LKNT,2)=-KFCCHI(IK)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 120 CONTINUE
+ 130 CONTINUE
+
+C...HIGGS TO SFERMION SFERMION
+ DO 160 IFL=1,16
+ IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
+ IJ=KSUSY1+IFL
+ XMJL=PMAS(PYCOMP(IJ),1)
+ XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
+ IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
+ XMJ=XMJL
+ XMJ2=XMJ**2
+ XL=PYLAMF(XMI2,XMJ2,XMJ2)
+ XMF=PMAS(IFL,1)
+ EI=KCHG(IFL,1)/3D0
+ IDU=2-MOD(IFL,2)
+
+ IF(IH.EQ.1) THEN
+ IF(IDU.EQ.1) THEN
+ GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
+ & XMF**2/XMW*SINA/CBETA
+ GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
+ & XMF**2/XMW*SINA/CBETA
+ IF(IFL.EQ.5) THEN
+ GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
+ & ATRIB*SINA)
+ ELSEIF(IFL.EQ.15) THEN
+ GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
+ & ATRIL*SINA)
+ ELSE
+ GHLR=0D0
+ ENDIF
+ ELSE
+ GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
+ & XMF**2/XMW*COSA/SBETA
+ GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
+ & XMF**2/XMW*COSA/SBETA
+ IF(IFL.EQ.6) THEN
+ GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
+ & ATRIT*COSA)
+ ELSE
+ GHLR=0D0
+ ENDIF
+ ENDIF
+
+ ELSEIF(IH.EQ.2) THEN
+ IF(IDU.EQ.1) THEN
+ GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
+ & XMF**2/XMW*COSA/CBETA
+ GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
+ & XMF**2/XMW*COSA/CBETA
+ IF(IFL.EQ.5) THEN
+ GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
+ & ATRIB*COSA)
+ ELSEIF(IFL.EQ.15) THEN
+ GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
+ & ATRIL*COSA)
+ ELSE
+ GHLR=0D0
+ ENDIF
+ ELSE
+ GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
+ & XMF**2/XMW*SINA/SBETA
+ GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
+ & XMF**2/XMW*SINA/SBETA
+ IF(IFL.EQ.6) THEN
+ GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
+ & ATRIT*SINA)
+ ELSE
+ GHLR=0D0
+ ENDIF
+ ENDIF
+
+ ELSEIF(IH.EQ.3) THEN
+ GHLL=0D0
+ GHRR=0D0
+ GHLR=0D0
+ IF(IDU.EQ.1) THEN
+ IF(IFL.EQ.5) THEN
+ GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
+ ELSEIF(IFL.EQ.15) THEN
+ GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
+ ENDIF
+ ELSE
+ IF(IFL.EQ.6) THEN
+ GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IH.EQ.3) GOTO 140
+
+ AL=SFMIX(IFL,1)**2
+ AR=SFMIX(IFL,2)**2
+ ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
+ IF(IFL.LE.6) THEN
+ CF=3D0
+ ELSE
+ CF=1D0
+ ENDIF
+
+ IF(AXMI.GE.2D0*XMJ) THEN
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GHLL*AL+GHRR*AR
+ & +2D0*GHLR*ALR)**2
+ IDLAM(LKNT,1)=IJ
+ IDLAM(LKNT,2)=-IJ
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+ IF(AXMI.GE.2D0*XMJR) THEN
+ LKNT=LKNT+1
+ AL=SFMIX(IFL,3)**2
+ AR=SFMIX(IFL,4)**2
+ ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
+ XMJ=XMJR
+ XMJ2=XMJ**2
+ XL=PYLAMF(XMI2,XMJ2,XMJ2)
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GHLL*AL+GHRR*AR
+ & +2D0*GHLR*ALR)**2
+ IDLAM(LKNT,1)=IJ+KSUSY1
+ IDLAM(LKNT,2)=-(IJ+KSUSY1)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 140 CONTINUE
+
+ IF(AXMI.GE.XMJL+XMJR) THEN
+ LKNT=LKNT+1
+ AL=SFMIX(IFL,1)*SFMIX(IFL,3)
+ AR=SFMIX(IFL,2)*SFMIX(IFL,4)
+ ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
+ XMJ=XMJR
+ XMJ2=XMJ**2
+ XL=PYLAMF(XMI2,XMJ2,XMJL**2)
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GHLL*AL+GHRR*AR)**2
+ IDLAM(LKNT,1)=IJ
+ IDLAM(LKNT,2)=-(IJ+KSUSY1)
+ IDLAM(LKNT,3)=0
+ LKNT=LKNT+1
+ IDLAM(LKNT,1)=-IJ
+ IDLAM(LKNT,2)=IJ+KSUSY1
+ IDLAM(LKNT,3)=0
+ XLAM(LKNT)=XLAM(LKNT-1)
+ ENDIF
+ ENDIF
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+
+ GOTO 230
+ 180 CONTINUE
+
+C...H+ -> CHI+_I + CHI0_J
+ DO 200 IJ=1,4
+ XMJ=SMZ(IJ)
+ AXMJ=ABS(XMJ)
+ XMJ2=XMJ**2
+ DO 190 IK=1,2
+ XMK=SMW(IK)
+ AXMK=ABS(XMK)
+ XMK2=XMK**2
+ IF(AXMI.GE.AXMJ+AXMK) THEN
+ LKNT=LKNT+1
+ GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
+ & TANW)*VMIX(IK,2)/SR2)
+ GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
+ & TANW)*UMIX(IK,2)/SR2)
+ XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
+ IDLAM(LKNT,1)=KFNCHI(IJ)
+ IDLAM(LKNT,2)=KFCCHI(IK)
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 190 CONTINUE
+ 200 CONTINUE
+
+ GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
+ GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
+ AL=0D0
+ AR=0D0
+ CF=3D0
+
+C...H+ -> T_1 B_1~
+ XM1=PMAS(PYCOMP(KSUSY1+6),1)
+ XM2=PMAS(PYCOMP(KSUSY1+5),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
+ IDLAM(LKNT,1)=KSUSY1+6
+ IDLAM(LKNT,2)=-(KSUSY1+5)
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...H+ -> T_2 B_1~
+ XM1=PMAS(PYCOMP(KSUSY2+6),1)
+ XM2=PMAS(PYCOMP(KSUSY1+5),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
+ IDLAM(LKNT,1)=KSUSY2+6
+ IDLAM(LKNT,2)=-(KSUSY1+5)
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...H+ -> T_1 B_2~
+ XM1=PMAS(PYCOMP(KSUSY1+6),1)
+ XM2=PMAS(PYCOMP(KSUSY2+5),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
+ IDLAM(LKNT,1)=KSUSY1+6
+ IDLAM(LKNT,2)=-(KSUSY2+5)
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...H+ -> T_2 B_2~
+ XM1=PMAS(PYCOMP(KSUSY2+6),1)
+ XM2=PMAS(PYCOMP(KSUSY2+5),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
+ & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
+ IDLAM(LKNT,1)=KSUSY2+6
+ IDLAM(LKNT,2)=-(KSUSY2+5)
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...H+ -> UL DL~
+ GL=-XMW/SR2*SIN(2D0*BETA)
+ DO 210 IJ=1,3,2
+ XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
+ XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
+ IDLAM(LKNT,1)=-(KSUSY1+IJ)
+ IDLAM(LKNT,2)=KSUSY1+IJ+1
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 210 CONTINUE
+
+C...H+ -> EL~ NUL
+ CF=1D0
+ DO 220 IJ=11,13,2
+ XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
+ XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
+ IDLAM(LKNT,1)=-(KSUSY1+IJ)
+ IDLAM(LKNT,2)=KSUSY1+IJ+1
+ IDLAM(LKNT,3)=0
+ ENDIF
+ 220 CONTINUE
+
+C...H+ -> TAU1 NUTAUL
+ XM1=PMAS(PYCOMP(KSUSY1+15),1)
+ XM2=PMAS(PYCOMP(KSUSY1+16),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
+ IDLAM(LKNT,1)=-(KSUSY1+15)
+ IDLAM(LKNT,2)= KSUSY1+16
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+C...H+ -> TAU2 NUTAUL
+ XM1=PMAS(PYCOMP(KSUSY2+15),1)
+ XM2=PMAS(PYCOMP(KSUSY1+16),1)
+ IF(XMI.GE.XM1+XM2) THEN
+ XL=PYLAMF(XMI2,XM1**2,XM2**2)
+ LKNT=LKNT+1
+ XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
+ IDLAM(LKNT,1)=-(KSUSY2+15)
+ IDLAM(LKNT,2)= KSUSY1+16
+ IDLAM(LKNT,3)=0
+ ENDIF
+
+ 230 CONTINUE
+ IKNT=LKNT
+ XLAM(0)=0D0
+ DO 240 I=1,IKNT
+ IF(XLAM(I).LE.0D0) XLAM(I)=0D0
+ XLAM(0)=XLAM(0)+XLAM(I)
+ 240 CONTINUE
+ IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYH2XX
+C...Calculates the decay rate for a Higgs to an ino pair.
+
+ FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+C...Local variables.
+ DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
+ DOUBLE PRECISION XL,PYLAMF,C1
+ DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
+
+ XMI2=XM1**2
+ XMI3=ABS(XM1**3)
+ XMJ2=XM2**2
+ XMK2=XM3**2
+ XL=PYLAMF(XMI2,XMJ2,XMK2)
+ PYH2XX=C1/4D0/XMI3*SQRT(XL)
+ &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
+ &4D0*GL*GR*XM3*XM2)
+ IF(PYH2XX.LT.0D0) THEN
+ WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
+ WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
+ STOP
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGAUS
+C...Integration by adaptive Gaussian quadrature.
+C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
+
+ FUNCTION PYGAUS(F, A, B, EPS)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local declarations.
+ EXTERNAL F
+ DOUBLE PRECISION W(12), X(12)
+ DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
+ DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
+ DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
+ DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
+ DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
+ DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
+ DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
+ DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
+ DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
+ DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
+ DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
+ DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
+
+C...The Gaussian quadrature algorithm.
+ H = 0D0
+ IF(B .EQ. A) GO TO 140
+ CONST = 5D-3 / ABS(B-A)
+ BB = A
+ 100 CONTINUE
+ AA = BB
+ BB = B
+ 110 CONTINUE
+ C1 = 0.5D0*(BB+AA)
+ C2 = 0.5D0*(BB-AA)
+ S8 = 0D0
+ DO 120 I = 1, 4
+ U = C2*X(I)
+ S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
+ 120 CONTINUE
+ S16 = 0D0
+ DO 130 I = 5, 12
+ U = C2*X(I)
+ S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
+ 130 CONTINUE
+ S16 = C2*S16
+ IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
+ H = H + S16
+ IF(BB .NE. B) GO TO 100
+ ELSE
+ BB = C1
+ IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
+ H = 0D0
+ CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
+ GO TO 140
+ ENDIF
+ 140 CONTINUE
+ PYGAUS = H
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSIMP
+C...Simpson formula for an integral.
+
+ FUNCTION PYSIMP(Y,X0,X1,N)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION Y,X0,X1,H,S
+ DIMENSION Y(0:N)
+
+ S=0D0
+ H=(X1-X0)/N
+ DO 100 I=0,N-2,2
+ S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
+ 100 CONTINUE
+ PYSIMP=S*H/3D0
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYLAMF
+C...The standard lambda function.
+
+ FUNCTION PYLAMF(X,Y,Z)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+
+C...Local variables.
+ DOUBLE PRECISION PYLAMF,X,Y,Z
+
+ PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
+ IF(PYLAMF.LT.0D0) PYLAMF=0D0
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTBDY
+C...Generates 3-body decays of gauginos.
+
+ SUBROUTINE PYTBDY(XM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
+
+C...Local variables.
+ DOUBLE PRECISION XM(5)
+ DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
+ DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
+ DOUBLE PRECISION CPHI1,SPHI1
+ DOUBLE PRECISION S23DEL,EPS
+ DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
+ PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
+ DOUBLE PRECISION F1,F2,X0,X1,X2,X3
+ DATA EPS/1D-6/
+
+C...GENERATE S12
+ S12MIN=(XM(1)+XM(2))**2
+ S12MAX=(XM(5)-XM(3))**2
+ YJACO1=S12MAX-S12MIN
+
+C...FIND S12*
+ AX=S12MIN
+ CX=S12MAX
+ BX=S12MIN+0.5D0*YJACO1
+ X0=AX
+ X3=CX
+ IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
+ X1=BX
+ X2=BX+C*(CX-BX)
+ ELSE
+ X2=BX
+ X1=BX-C*(BX-AX)
+ ENDIF
+
+C...SOLVE FOR F1 AND F2
+ S23DF1=(X1-XM(2)**2-XM(1)**2)**2
+ &-(2D0*XM(1)*XM(2))**2
+ S23DF2=(X1-XM(3)**2-XM(5)**2)**2
+ &-(2D0*XM(3)*XM(5))**2
+ S23DF1=S23DF1*EPS
+ S23DF2=S23DF2*EPS
+ S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
+ F1=-2D0*S23DEL/EPS
+ S23DF1=(X2-XM(2)**2-XM(1)**2)**2
+ &-(2D0*XM(1)*XM(2))**2
+ S23DF2=(X2-XM(3)**2-XM(5)**2)**2
+ &-(2D0*XM(3)*XM(5))**2
+ S23DF1=S23DF1*EPS
+ S23DF2=S23DF2*EPS
+ S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
+ F2=-2D0*S23DEL/EPS
+
+ 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
+ IF(F2.LT.F1)THEN
+ X0=X1
+ X1=X2
+ X2=R*X1+C*X3
+ F1=F2
+ S23DF1=(X2-XM(2)**2-XM(1)**2)**2
+ & -(2D0*XM(1)*XM(2))**2
+ S23DF2=(X2-XM(3)**2-XM(5)**2)**2
+ & -(2D0*XM(3)*XM(5))**2
+ S23DF1=S23DF1*EPS
+ S23DF2=S23DF2*EPS
+ S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
+ F2=-2D0*S23DEL/EPS
+ ELSE
+ X3=X2
+ X2=X1
+ X1=R*X2+C*X0
+ F2=F1
+ S23DF1=(X1-XM(2)**2-XM(1)**2)**2
+ & -(2D0*XM(1)*XM(2))**2
+ S23DF2=(X1-XM(3)**2-XM(5)**2)**2
+ & -(2D0*XM(3)*XM(5))**2
+ S23DF1=S23DF1*EPS
+ S23DF2=S23DF2*EPS
+ S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
+ F1=-2D0*S23DEL/EPS
+ ENDIF
+ GOTO 100
+ ENDIF
+C...WE WANT THE MAXIMUM, NOT THE MINIMUM
+ IF(F1.LT.F2)THEN
+ GOLDEN=-F1
+ XMIN=X1
+ ELSE
+ GOLDEN=-F2
+ XMIN=X2
+ ENDIF
+
+ IKNT=0
+ 110 S12=S12MIN+PYR(0)*YJACO1
+ IKNT=IKNT+1
+C...GENERATE S23
+ S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
+ &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
+ S23DF1=(S12-XM(2)**2-XM(1)**2)**2
+ &-(2D0*XM(1)*XM(2))**2
+ S23DF2=(S12-XM(3)**2-XM(5)**2)**2
+ &-(2D0*XM(3)*XM(5))**2
+ S23DF1=S23DF1*EPS
+ S23DF2=S23DF2*EPS
+ S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
+ S23DEL=S23DEL/EPS
+ S23MIN=S23AVE-S23DEL
+ S23MAX=S23AVE+S23DEL
+ YJACO2=S23MAX-S23MIN
+ S23=S23MIN+PYR(0)*YJACO2
+
+C...CHECK THE SAMPLING
+ IF(IKNT.GT.100) THEN
+ WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
+ GOTO 120
+ ENDIF
+ IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
+ 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
+ D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
+ D2=XM(5)-D1-D3
+ P1=SQRT(D1*D1-XM(1)**2)
+ P2=SQRT(D2*D2-XM(2)**2)
+ P3=SQRT(D3*D3-XM(3)**2)
+ CTHE1=2D0*PYR(0)-1D0
+ ANG1=2D0*PYR(0)*PARU(1)
+ CPHI1=COS(ANG1)
+ SPHI1=SIN(ANG1)
+ ARG=1D0-CTHE1**2
+ IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
+ STHE1=SQRT(ARG)
+ P(N+1,1)=P1*STHE1*CPHI1
+ P(N+1,2)=P1*STHE1*SPHI1
+ P(N+1,3)=P1*CTHE1
+ P(N+1,4)=D1
+
+C...GET CPHI3
+ ANG3=2D0*PYR(0)*PARU(1)
+ CPHI3=COS(ANG3)
+ SPHI3=SIN(ANG3)
+ CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
+ ARG=1D0-CTHE3**2
+ IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
+ STHE3=SQRT(ARG)
+ P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
+ &+P3*STHE3*SPHI3*SPHI1
+ &+P3*CTHE3*STHE1*CPHI1
+ P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
+ &-P3*STHE3*SPHI3*CPHI1
+ &+P3*CTHE3*STHE1*SPHI1
+ P(N+3,3)=P3*STHE3*CPHI3*STHE1
+ &+P3*CTHE3*CTHE1
+ P(N+3,4)=D3
+
+ DO 130 I=1,3
+ P(N+2,I)=-P(N+1,I)-P(N+3,I)
+ 130 CONTINUE
+ P(N+2,4)=D2
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PY1ENT
+C...Stores one parton/particle in commonblock PYJETS.
+
+ SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Standard checks.
+ MSTU(28)=0
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IPA=MAX(1,IABS(IP))
+ IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
+ &'(PY1ENT:) writing outside PYJETS memory')
+ KC=PYCOMP(KF)
+ IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
+
+C...Find mass. Reset K, P and V vectors.
+ PM=0D0
+ IF(MSTU(10).EQ.1) PM=P(IPA,5)
+ IF(MSTU(10).GE.2) PM=PYMASS(KF)
+ DO 100 J=1,5
+ K(IPA,J)=0
+ P(IPA,J)=0D0
+ V(IPA,J)=0D0
+ 100 CONTINUE
+
+C...Store parton/particle in K and P vectors.
+ K(IPA,1)=1
+ IF(IP.LT.0) K(IPA,1)=2
+ K(IPA,2)=KF
+ P(IPA,5)=PM
+ P(IPA,4)=MAX(PE,PM)
+ PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
+ P(IPA,1)=PA*SIN(THE)*COS(PHI)
+ P(IPA,2)=PA*SIN(THE)*SIN(PHI)
+ P(IPA,3)=PA*COS(THE)
+
+C...Set N. Optionally fragment/decay.
+ N=IPA
+ IF(IP.EQ.0) CALL PYEXEC
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PY2ENT
+C...Stores two partons/particles in their CM frame,
+C...with the first along the +z axis.
+
+ SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Standard checks.
+ MSTU(28)=0
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IPA=MAX(1,IABS(IP))
+ IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
+ &'(PY2ENT:) writing outside PYJETS memory')
+ KC1=PYCOMP(KF1)
+ KC2=PYCOMP(KF2)
+ IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
+ &'(PY2ENT:) unknown flavour code')
+
+C...Find masses. Reset K, P and V vectors.
+ PM1=0D0
+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
+ PM2=0D0
+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
+ DO 110 I=IPA,IPA+1
+ DO 100 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Check flavours.
+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
+ IF(MSTU(19).EQ.1) THEN
+ MSTU(19)=0
+ ELSE
+ IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
+ & '(PY2ENT:) unphysical flavour combination')
+ ENDIF
+ K(IPA,2)=KF1
+ K(IPA+1,2)=KF2
+
+C...Store partons/particles in K vectors for normal case.
+ IF(IP.GE.0) THEN
+ K(IPA,1)=1
+ IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
+ K(IPA+1,1)=1
+
+C...Store partons in K vectors for parton shower evolution.
+ ELSE
+ K(IPA,1)=3
+ K(IPA+1,1)=3
+ K(IPA,4)=MSTU(5)*(IPA+1)
+ K(IPA,5)=K(IPA,4)
+ K(IPA+1,4)=MSTU(5)*IPA
+ K(IPA+1,5)=K(IPA+1,4)
+ ENDIF
+
+C...Check kinematics and store partons/particles in P vectors.
+ IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
+ &'(PY2ENT:) energy smaller than sum of masses')
+ PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
+ &(2D0*PECM)
+ P(IPA,3)=PA
+ P(IPA,4)=SQRT(PM1**2+PA**2)
+ P(IPA,5)=PM1
+ P(IPA+1,3)=-PA
+ P(IPA+1,4)=SQRT(PM2**2+PA**2)
+ P(IPA+1,5)=PM2
+
+C...Set N. Optionally fragment/decay.
+ N=IPA+1
+ IF(IP.EQ.0) CALL PYEXEC
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PY3ENT
+C...Stores three partons or particles in their CM frame,
+C...with the first along the +z axis and the third in the (x,z)
+C...plane with x > 0.
+
+ SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Standard checks.
+ MSTU(28)=0
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IPA=MAX(1,IABS(IP))
+ IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
+ &'(PY3ENT:) writing outside PYJETS memory')
+ KC1=PYCOMP(KF1)
+ KC2=PYCOMP(KF2)
+ KC3=PYCOMP(KF3)
+ IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
+ &'(PY3ENT:) unknown flavour code')
+
+C...Find masses. Reset K, P and V vectors.
+ PM1=0D0
+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
+ PM2=0D0
+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
+ PM3=0D0
+ IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
+ IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
+ DO 110 I=IPA,IPA+2
+ DO 100 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Check flavours.
+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
+ KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
+ IF(MSTU(19).EQ.1) THEN
+ MSTU(19)=0
+ ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
+ ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
+ & KQ1+KQ3.EQ.4)) THEN
+ ELSE
+ CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
+ ENDIF
+ K(IPA,2)=KF1
+ K(IPA+1,2)=KF2
+ K(IPA+2,2)=KF3
+
+C...Store partons/particles in K vectors for normal case.
+ IF(IP.GE.0) THEN
+ K(IPA,1)=1
+ IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
+ K(IPA+1,1)=1
+ IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
+ K(IPA+2,1)=1
+
+C...Store partons in K vectors for parton shower evolution.
+ ELSE
+ K(IPA,1)=3
+ K(IPA+1,1)=3
+ K(IPA+2,1)=3
+ KCS=4
+ IF(KQ1.EQ.-1) KCS=5
+ K(IPA,KCS)=MSTU(5)*(IPA+1)
+ K(IPA,9-KCS)=MSTU(5)*(IPA+2)
+ K(IPA+1,KCS)=MSTU(5)*(IPA+2)
+ K(IPA+1,9-KCS)=MSTU(5)*IPA
+ K(IPA+2,KCS)=MSTU(5)*IPA
+ K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
+ ENDIF
+
+C...Check kinematics.
+ MKERR=0
+ IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
+ &0.5D0*X3*PECM.LE.PM3) MKERR=1
+ PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
+ PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
+ PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
+ CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
+ CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
+ IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
+ CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
+ IF(MKERR.NE.0) CALL PYERRM(13,
+ &'(PY3ENT:) unphysical kinematical variable setup')
+
+C...Store partons/particles in P vectors.
+ P(IPA,3)=PA1
+ P(IPA,4)=SQRT(PA1**2+PM1**2)
+ P(IPA,5)=PM1
+ P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
+ P(IPA+2,3)=PA3*CTHE3
+ P(IPA+2,4)=SQRT(PA3**2+PM3**2)
+ P(IPA+2,5)=PM3
+ P(IPA+1,1)=-P(IPA+2,1)
+ P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
+ P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
+ P(IPA+1,5)=PM2
+
+C...Set N. Optionally fragment/decay.
+ N=IPA+2
+ IF(IP.EQ.0) CALL PYEXEC
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PY4ENT
+C...Stores four partons or particles in their CM frame, with
+C...the first along the +z axis, the last in the xz plane with x > 0
+C...and the second having y < 0 and y > 0 with equal probability.
+
+ SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Standard checks.
+ MSTU(28)=0
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IPA=MAX(1,IABS(IP))
+ IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
+ &'(PY4ENT:) writing outside PYJETS momory')
+ KC1=PYCOMP(KF1)
+ KC2=PYCOMP(KF2)
+ KC3=PYCOMP(KF3)
+ KC4=PYCOMP(KF4)
+ IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
+ &'(PY4ENT:) unknown flavour code')
+
+C...Find masses. Reset K, P and V vectors.
+ PM1=0D0
+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
+ PM2=0D0
+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
+ PM3=0D0
+ IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
+ IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
+ PM4=0D0
+ IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
+ IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
+ DO 110 I=IPA,IPA+3
+ DO 100 J=1,5
+ K(I,J)=0
+ P(I,J)=0D0
+ V(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Check flavours.
+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
+ KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
+ KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
+ IF(MSTU(19).EQ.1) THEN
+ MSTU(19)=0
+ ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
+ ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
+ & KQ1+KQ4.EQ.4)) THEN
+ ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
+ & THEN
+ ELSE
+ CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
+ ENDIF
+ K(IPA,2)=KF1
+ K(IPA+1,2)=KF2
+ K(IPA+2,2)=KF3
+ K(IPA+3,2)=KF4
+
+C...Store partons/particles in K vectors for normal case.
+ IF(IP.GE.0) THEN
+ K(IPA,1)=1
+ IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
+ K(IPA+1,1)=1
+ IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
+ & K(IPA+1,1)=2
+ K(IPA+2,1)=1
+ IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
+ K(IPA+3,1)=1
+
+C...Store partons for parton shower evolution from q-g-g-qbar or
+C...g-g-g-g event.
+ ELSEIF(KQ1+KQ2.NE.0) THEN
+ K(IPA,1)=3
+ K(IPA+1,1)=3
+ K(IPA+2,1)=3
+ K(IPA+3,1)=3
+ KCS=4
+ IF(KQ1.EQ.-1) KCS=5
+ K(IPA,KCS)=MSTU(5)*(IPA+1)
+ K(IPA,9-KCS)=MSTU(5)*(IPA+3)
+ K(IPA+1,KCS)=MSTU(5)*(IPA+2)
+ K(IPA+1,9-KCS)=MSTU(5)*IPA
+ K(IPA+2,KCS)=MSTU(5)*(IPA+3)
+ K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
+ K(IPA+3,KCS)=MSTU(5)*IPA
+ K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
+
+C...Store partons for parton shower evolution from q-qbar-q-qbar event.
+ ELSE
+ K(IPA,1)=3
+ K(IPA+1,1)=3
+ K(IPA+2,1)=3
+ K(IPA+3,1)=3
+ K(IPA,4)=MSTU(5)*(IPA+1)
+ K(IPA,5)=K(IPA,4)
+ K(IPA+1,4)=MSTU(5)*IPA
+ K(IPA+1,5)=K(IPA+1,4)
+ K(IPA+2,4)=MSTU(5)*(IPA+3)
+ K(IPA+2,5)=K(IPA+2,4)
+ K(IPA+3,4)=MSTU(5)*(IPA+2)
+ K(IPA+3,5)=K(IPA+3,4)
+ ENDIF
+
+C...Check kinematics.
+ MKERR=0
+ IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
+ &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
+ &MKERR=1
+ PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
+ PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
+ PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
+ X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
+ CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
+ IF(ABS(CTHE4).GE.1.002D0) MKERR=1
+ CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
+ STHE4=SQRT(1D0-CTHE4**2)
+ CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
+ IF(ABS(CTHE2).GE.1.002D0) MKERR=1
+ CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
+ STHE2=SQRT(1D0-CTHE2**2)
+ CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
+ &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
+ IF(ABS(CPHI2).GE.1.05D0) MKERR=1
+ CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
+ IF(MKERR.EQ.1) CALL PYERRM(13,
+ &'(PY4ENT:) unphysical kinematical variable setup')
+
+C...Store partons/particles in P vectors.
+ P(IPA,3)=PA1
+ P(IPA,4)=SQRT(PA1**2+PM1**2)
+ P(IPA,5)=PM1
+ P(IPA+3,1)=PA4*STHE4
+ P(IPA+3,3)=PA4*CTHE4
+ P(IPA+3,4)=SQRT(PA4**2+PM4**2)
+ P(IPA+3,5)=PM4
+ P(IPA+1,1)=PA2*STHE2*CPHI2
+ P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
+ P(IPA+1,3)=PA2*CTHE2
+ P(IPA+1,4)=SQRT(PA2**2+PM2**2)
+ P(IPA+1,5)=PM2
+ P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
+ P(IPA+2,2)=-P(IPA+1,2)
+ P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
+ P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
+ P(IPA+2,5)=PM3
+
+C...Set N. Optionally fragment/decay.
+ N=IPA+3
+ IF(IP.EQ.0) CALL PYEXEC
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYJOIN
+C...Connects a sequence of partons with colour flow indices,
+C...as required for subsequent shower evolution (or other operations).
+
+ SUBROUTINE PYJOIN(NJOIN,IJOIN)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local array.
+ DIMENSION IJOIN(*)
+
+C...Check that partons are of right types to be connected.
+ IF(NJOIN.LT.2) GOTO 120
+ KQSUM=0
+ DO 100 IJN=1,NJOIN
+ I=IJOIN(IJN)
+ IF(I.LE.0.OR.I.GT.N) GOTO 120
+ IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 120
+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
+ IF(KQ.EQ.0) GOTO 120
+ IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
+ IF(IJN.EQ.1) KQS=KQ
+ 100 CONTINUE
+ IF(KQSUM.NE.0) GOTO 120
+
+C...Connect the partons sequentially (closing for gluon loop).
+ KCS=(9-KQS)/2
+ IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
+ DO 110 IJN=1,NJOIN
+ I=IJOIN(IJN)
+ K(I,1)=3
+ IF(IJN.NE.1) IP=IJOIN(IJN-1)
+ IF(IJN.EQ.1) IP=IJOIN(NJOIN)
+ IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
+ IF(IJN.EQ.NJOIN) IN=IJOIN(1)
+ K(I,KCS)=MSTU(5)*IN
+ K(I,9-KCS)=MSTU(5)*IP
+ IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
+ IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
+ 110 CONTINUE
+
+C...Error exit: no action taken.
+ RETURN
+ 120 CALL PYERRM(12,
+ &'(PYJOIN:) given entries can not be joined by one string')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYGIVE
+C...Sets values of commonblock variables.
+
+ SUBROUTINE PYGIVE(CHIN)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
+ COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
+ &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
+ &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
+C...Local arrays and character variables.
+ CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
+ &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
+ &CHINR*16
+ DIMENSION MSVAR(49,8)
+
+C...For each variable to be translated give: name,
+C...integer/real/character, no. of indices, lower&upper index bounds.
+ DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
+ &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
+ &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
+ &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
+ &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
+ &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
+ DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
+ &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
+ &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
+ &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
+ &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
+ &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
+ &1,1,1,6,4*0, 2,1,1,100,4*0,
+ &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
+ &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
+ &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
+ &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
+ &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
+ &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
+ &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
+ &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
+ &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
+ DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
+ &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+
+C...Length of character variable. Subdivide it into instructions.
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ CHBIT=CHIN//' '
+ LBIT=101
+ 100 LBIT=LBIT-1
+ IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
+ LTOT=0
+ DO 110 LCOM=1,LBIT
+ IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
+ LTOT=LTOT+1
+ CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
+ 110 CONTINUE
+ LLOW=0
+ 120 LHIG=LLOW+1
+ 130 LHIG=LHIG+1
+ IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
+ LBIT=LHIG-LLOW-1
+ CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
+
+C...Identify commonblock variable.
+ LNAM=1
+ 140 LNAM=LNAM+1
+ IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
+ &LNAM.LE.6) GOTO 140
+ CHNAM=CHBIT(1:LNAM-1)//' '
+ DO 160 LCOM=1,LNAM-1
+ DO 150 LALP=1,26
+ IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
+ & CHALP(2)(LALP:LALP)
+ 150 CONTINUE
+ 160 CONTINUE
+ IVAR=0
+ DO 170 IV=1,49
+ IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
+ 170 CONTINUE
+ IF(IVAR.EQ.0) THEN
+ CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
+ LLOW=LHIG
+ IF(LLOW.LT.LTOT) GOTO 120
+ RETURN
+ ENDIF
+
+C...Identify any indices.
+ I1=0
+ I2=0
+ I3=0
+ NINDX=0
+ IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
+ LIND=LNAM
+ 180 LIND=LIND+1
+ IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
+ CHIND=' '
+ IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
+ & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
+ & THEN
+ CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
+ READ(CHIND,'(I8)') KF
+ I1=PYCOMP(KF)
+ ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
+ & 'c') THEN
+ CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
+ & CHNAM)
+ LLOW=LHIG
+ IF(LLOW.LT.LTOT) GOTO 120
+ RETURN
+ ELSE
+ CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
+ READ(CHIND,'(I8)') I1
+ ENDIF
+ LNAM=LIND
+ IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
+ NINDX=1
+ ENDIF
+ IF(CHBIT(LNAM:LNAM).EQ.',') THEN
+ LIND=LNAM
+ 190 LIND=LIND+1
+ IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
+ CHIND=' '
+ CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
+ READ(CHIND,'(I8)') I2
+ LNAM=LIND
+ IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
+ NINDX=2
+ ENDIF
+ IF(CHBIT(LNAM:LNAM).EQ.',') THEN
+ LIND=LNAM
+ 200 LIND=LIND+1
+ IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
+ CHIND=' '
+ CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
+ READ(CHIND,'(I8)') I3
+ LNAM=LIND+1
+ NINDX=3
+ ENDIF
+
+C...Check that indices allowed.
+ IERR=0
+ IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
+ IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
+ &IERR=2
+ IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
+ &IERR=3
+ IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
+ &IERR=4
+ IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
+ IF(IERR.GE.1) THEN
+ CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
+ & CHBIT(1:LNAM-1))
+ LLOW=LHIG
+ IF(LLOW.LT.LTOT) GOTO 120
+ RETURN
+ ENDIF
+
+C...Save old value of variable.
+ IF(IVAR.EQ.1) THEN
+ IOLD=N
+ ELSEIF(IVAR.EQ.2) THEN
+ IOLD=K(I1,I2)
+ ELSEIF(IVAR.EQ.3) THEN
+ ROLD=P(I1,I2)
+ ELSEIF(IVAR.EQ.4) THEN
+ ROLD=V(I1,I2)
+ ELSEIF(IVAR.EQ.5) THEN
+ IOLD=MSTU(I1)
+ ELSEIF(IVAR.EQ.6) THEN
+ ROLD=PARU(I1)
+ ELSEIF(IVAR.EQ.7) THEN
+ IOLD=MSTJ(I1)
+ ELSEIF(IVAR.EQ.8) THEN
+ ROLD=PARJ(I1)
+ ELSEIF(IVAR.EQ.9) THEN
+ IOLD=KCHG(I1,I2)
+ ELSEIF(IVAR.EQ.10) THEN
+ ROLD=PMAS(I1,I2)
+ ELSEIF(IVAR.EQ.11) THEN
+ ROLD=PARF(I1)
+ ELSEIF(IVAR.EQ.12) THEN
+ ROLD=VCKM(I1,I2)
+ ELSEIF(IVAR.EQ.13) THEN
+ IOLD=MDCY(I1,I2)
+ ELSEIF(IVAR.EQ.14) THEN
+ IOLD=MDME(I1,I2)
+ ELSEIF(IVAR.EQ.15) THEN
+ ROLD=BRAT(I1)
+ ELSEIF(IVAR.EQ.16) THEN
+ IOLD=KFDP(I1,I2)
+ ELSEIF(IVAR.EQ.17) THEN
+ CHOLD=CHAF(I1,I2)
+ ELSEIF(IVAR.EQ.18) THEN
+ IOLD=MRPY(I1)
+ ELSEIF(IVAR.EQ.19) THEN
+ ROLD=RRPY(I1)
+ ELSEIF(IVAR.EQ.20) THEN
+ IOLD=MSEL
+ ELSEIF(IVAR.EQ.21) THEN
+ IOLD=MSUB(I1)
+ ELSEIF(IVAR.EQ.22) THEN
+ IOLD=KFIN(I1,I2)
+ ELSEIF(IVAR.EQ.23) THEN
+ ROLD=CKIN(I1)
+ ELSEIF(IVAR.EQ.24) THEN
+ IOLD=MSTP(I1)
+ ELSEIF(IVAR.EQ.25) THEN
+ ROLD=PARP(I1)
+ ELSEIF(IVAR.EQ.26) THEN
+ IOLD=MSTI(I1)
+ ELSEIF(IVAR.EQ.27) THEN
+ ROLD=PARI(I1)
+ ELSEIF(IVAR.EQ.28) THEN
+ IOLD=MINT(I1)
+ ELSEIF(IVAR.EQ.29) THEN
+ ROLD=VINT(I1)
+ ELSEIF(IVAR.EQ.30) THEN
+ IOLD=ISET(I1)
+ ELSEIF(IVAR.EQ.31) THEN
+ IOLD=KFPR(I1,I2)
+ ELSEIF(IVAR.EQ.32) THEN
+ ROLD=COEF(I1,I2)
+ ELSEIF(IVAR.EQ.33) THEN
+ IOLD=ICOL(I1,I2,I3)
+ ELSEIF(IVAR.EQ.34) THEN
+ ROLD=XSFX(I1,I2)
+ ELSEIF(IVAR.EQ.35) THEN
+ IOLD=ISIG(I1,I2)
+ ELSEIF(IVAR.EQ.36) THEN
+ ROLD=SIGH(I1)
+ ELSEIF(IVAR.EQ.37) THEN
+ IOLD=MWID(I1)
+ ELSEIF(IVAR.EQ.38) THEN
+ ROLD=WIDS(I1,I2)
+ ELSEIF(IVAR.EQ.39) THEN
+ IOLD=NGEN(I1,I2)
+ ELSEIF(IVAR.EQ.40) THEN
+ ROLD=XSEC(I1,I2)
+ ELSEIF(IVAR.EQ.41) THEN
+ CHOLD2=PROC(I1)
+ ELSEIF(IVAR.EQ.42) THEN
+ ROLD=SIGT(I1,I2,I3)
+ ELSEIF(IVAR.EQ.43) THEN
+ ROLD=XPVMD(I1)
+ ELSEIF(IVAR.EQ.44) THEN
+ ROLD=XPANL(I1)
+ ELSEIF(IVAR.EQ.45) THEN
+ ROLD=XPANH(I1)
+ ELSEIF(IVAR.EQ.46) THEN
+ ROLD=XPBEH(I1)
+ ELSEIF(IVAR.EQ.47) THEN
+ ROLD=XPDIR(I1)
+ ELSEIF(IVAR.EQ.48) THEN
+ IOLD=IMSS(I1)
+ ELSEIF(IVAR.EQ.49) THEN
+ ROLD=RMSS(I1)
+ ENDIF
+
+C...Print current value of variable. Loop back.
+ IF(LNAM.GE.LBIT) THEN
+ CHBIT(LNAM:14)=' '
+ CHBIT(15:60)=' has the value '
+ IF(MSVAR(IVAR,1).EQ.1) THEN
+ WRITE(CHBIT(51:60),'(I10)') IOLD
+ ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
+ WRITE(CHBIT(47:60),'(F14.5)') ROLD
+ ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
+ CHBIT(53:60)=CHOLD
+ ELSE
+ CHBIT(33:60)=CHOLD
+ ENDIF
+ IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
+ LLOW=LHIG
+ IF(LLOW.LT.LTOT) GOTO 120
+ RETURN
+ ENDIF
+
+C...Read in new variable value.
+ IF(MSVAR(IVAR,1).EQ.1) THEN
+ CHINI=' '
+ CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
+ READ(CHINI,'(I10)') INEW
+ ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
+ CHINR=' '
+ CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
+ READ(CHINR,*) RNEW
+ ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
+ CHNEW=CHBIT(LNAM+1:LBIT)//' '
+ ELSE
+ CHNEW2=CHBIT(LNAM+1:LBIT)//' '
+ ENDIF
+
+C...Store new variable value.
+ IF(IVAR.EQ.1) THEN
+ N=INEW
+ ELSEIF(IVAR.EQ.2) THEN
+ K(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.3) THEN
+ P(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.4) THEN
+ V(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.5) THEN
+ MSTU(I1)=INEW
+ ELSEIF(IVAR.EQ.6) THEN
+ PARU(I1)=RNEW
+ ELSEIF(IVAR.EQ.7) THEN
+ MSTJ(I1)=INEW
+ ELSEIF(IVAR.EQ.8) THEN
+ PARJ(I1)=RNEW
+ ELSEIF(IVAR.EQ.9) THEN
+ KCHG(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.10) THEN
+ PMAS(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.11) THEN
+ PARF(I1)=RNEW
+ ELSEIF(IVAR.EQ.12) THEN
+ VCKM(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.13) THEN
+ MDCY(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.14) THEN
+ MDME(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.15) THEN
+ BRAT(I1)=RNEW
+ ELSEIF(IVAR.EQ.16) THEN
+ KFDP(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.17) THEN
+ CHAF(I1,I2)=CHNEW
+ ELSEIF(IVAR.EQ.18) THEN
+ MRPY(I1)=INEW
+ ELSEIF(IVAR.EQ.19) THEN
+ RRPY(I1)=RNEW
+ ELSEIF(IVAR.EQ.20) THEN
+ MSEL=INEW
+ ELSEIF(IVAR.EQ.21) THEN
+ MSUB(I1)=INEW
+ ELSEIF(IVAR.EQ.22) THEN
+ KFIN(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.23) THEN
+ CKIN(I1)=RNEW
+ ELSEIF(IVAR.EQ.24) THEN
+ MSTP(I1)=INEW
+ ELSEIF(IVAR.EQ.25) THEN
+ PARP(I1)=RNEW
+ ELSEIF(IVAR.EQ.26) THEN
+ MSTI(I1)=INEW
+ ELSEIF(IVAR.EQ.27) THEN
+ PARI(I1)=RNEW
+ ELSEIF(IVAR.EQ.28) THEN
+ MINT(I1)=INEW
+ ELSEIF(IVAR.EQ.29) THEN
+ VINT(I1)=RNEW
+ ELSEIF(IVAR.EQ.30) THEN
+ ISET(I1)=INEW
+ ELSEIF(IVAR.EQ.31) THEN
+ KFPR(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.32) THEN
+ COEF(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.33) THEN
+ ICOL(I1,I2,I3)=INEW
+ ELSEIF(IVAR.EQ.34) THEN
+ XSFX(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.35) THEN
+ ISIG(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.36) THEN
+ SIGH(I1)=RNEW
+ ELSEIF(IVAR.EQ.37) THEN
+ MWID(I1)=INEW
+ ELSEIF(IVAR.EQ.38) THEN
+ WIDS(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.39) THEN
+ NGEN(I1,I2)=INEW
+ ELSEIF(IVAR.EQ.40) THEN
+ XSEC(I1,I2)=RNEW
+ ELSEIF(IVAR.EQ.41) THEN
+ PROC(I1)=CHNEW2
+ ELSEIF(IVAR.EQ.42) THEN
+ SIGT(I1,I2,I3)=RNEW
+ ELSEIF(IVAR.EQ.43) THEN
+ XPVMD(I1)=RNEW
+ ELSEIF(IVAR.EQ.44) THEN
+ XPANL(I1)=RNEW
+ ELSEIF(IVAR.EQ.45) THEN
+ XPANH(I1)=RNEW
+ ELSEIF(IVAR.EQ.46) THEN
+ XPBEH(I1)=RNEW
+ ELSEIF(IVAR.EQ.47) THEN
+ XPDIR(I1)=RNEW
+ ELSEIF(IVAR.EQ.48) THEN
+ IMSS(I1)=INEW
+ ELSEIF(IVAR.EQ.49) THEN
+ RMSS(I1)=RNEW
+ ENDIF
+
+C...Write old and new value. Loop back.
+ CHBIT(LNAM:14)=' '
+ CHBIT(15:60)=' changed from to '
+ IF(MSVAR(IVAR,1).EQ.1) THEN
+ WRITE(CHBIT(33:42),'(I10)') IOLD
+ WRITE(CHBIT(51:60),'(I10)') INEW
+ IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
+ ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
+ WRITE(CHBIT(29:42),'(F14.5)') ROLD
+ WRITE(CHBIT(47:60),'(F14.5)') RNEW
+ IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
+ ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
+ CHBIT(35:42)=CHOLD
+ CHBIT(53:60)=CHNEW
+ IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
+ ELSE
+ CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
+ IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
+ ENDIF
+ LLOW=LHIG
+ IF(LLOW.LT.LTOT) GOTO 120
+
+C...Format statement for output on unit MSTU(11) (by default 6).
+ 5000 FORMAT(5X,A60)
+ 5100 FORMAT(5X,A88)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEXEC
+C...Administrates the fragmentation and decay chain.
+
+ SUBROUTINE PYEXEC
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
+C...Local array.
+ DIMENSION PS(2,6),IJOIN(100)
+
+C...Initialize and reset.
+ MSTU(24)=0
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ MSTU(31)=MSTU(31)+1
+ MSTU(1)=0
+ MSTU(2)=0
+ MSTU(3)=0
+ IF(MSTU(17).LE.0) MSTU(90)=0
+ MCONS=1
+
+C...Sum up momentum, energy and charge for starting entries.
+ NSAV=N
+ DO 110 I=1,2
+ DO 100 J=1,6
+ PS(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 130 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
+ DO 120 J=1,4
+ PS(1,J)=PS(1,J)+P(I,J)
+ 120 CONTINUE
+ PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
+ 130 CONTINUE
+ PARU(21)=PS(1,4)
+
+C...Prepare system for subsequent fragmentation/decay.
+ CALL PYPREP(0)
+
+C...Loop through jet fragmentation and particle decays.
+ MBE=0
+ 140 MBE=MBE+1
+ IP=0
+ 150 IP=IP+1
+ KC=0
+ IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
+ IF(KC.EQ.0) THEN
+
+C...Deal with any remaining undecayed resonance
+C...(normally the task of PYEVNT, so seldom used).
+ ELSEIF(MWID(KC).NE.0) THEN
+ IBEG=IP
+ IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
+ IBEG=IP+1
+ 160 IBEG=IBEG-1
+ IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
+ IF(K(IBEG,1).NE.2) IBEG=IBEG+1
+ IEND=IP-1
+ 170 IEND=IEND+1
+ IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
+ IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
+ NJOIN=0
+ DO 180 I=IBEG,IEND
+ IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
+ NJOIN=NJOIN+1
+ IJOIN(NJOIN)=I
+ ENDIF
+ 180 CONTINUE
+ ENDIF
+ CALL PYRESD(IP)
+ CALL PYPREP(IBEG)
+
+C...Particle decay if unstable and allowed. Save long-lived particle
+C...decays until second pass after Bose-Einstein effects.
+ ELSEIF(KCHG(KC,2).EQ.0) THEN
+ IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
+ & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
+ & CALL PYDECY(IP)
+
+C...Decay products may develop a shower.
+ IF(MSTJ(92).GT.0) THEN
+ IP1=MSTJ(92)
+ QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
+ & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
+ CALL PYSHOW(IP1,IP1+1,QMAX)
+ CALL PYPREP(IP1)
+ MSTJ(92)=0
+ ELSEIF(MSTJ(92).LT.0) THEN
+ IP1=-MSTJ(92)
+ CALL PYSHOW(IP1,-3,P(IP,5))
+ CALL PYPREP(IP1)
+ MSTJ(92)=0
+ ENDIF
+
+C...Jet fragmentation: string or independent fragmentation.
+ ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
+ MFRAG=MSTJ(1)
+ IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
+ IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
+ IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
+ & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
+ IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
+ ENDIF
+ ENDIF
+ IF(MFRAG.EQ.1) CALL PYSTRF(IP)
+ IF(MFRAG.EQ.2) CALL PYINDF(IP)
+ IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
+ IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
+ ENDIF
+
+C...Loop back if enough space left in PYJETS and no error abort.
+ IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
+ ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
+ GOTO 150
+ ELSEIF(IP.LT.N) THEN
+ CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
+ ENDIF
+
+C...Include simple Bose-Einstein effect parametrization if desired.
+ IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
+ CALL PYBOEI(NSAV)
+ GOTO 140
+ ENDIF
+
+C...Check that momentum, energy and charge were conserved.
+ DO 200 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
+ DO 190 J=1,4
+ PS(2,J)=PS(2,J)+P(I,J)
+ 190 CONTINUE
+ PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
+ 200 CONTINUE
+ PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
+ &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
+ IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
+ &'(PYEXEC:) four-momentum was not conserved')
+ IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
+ &'(PYEXEC:) charge was not conserved')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPREP
+C...Rearranges partons along strings. Allows small systems
+C...to collapse into one or two particles and checks flavours.
+
+ SUBROUTINE PYPREP(IP)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
+C...Local arrays.
+ DIMENSION DPS(5),DPC(5),UE(3)
+
+C...Rearrange parton shower product listing along strings: begin loop.
+ I1=N
+ DO 130 MQGST=1,2
+ DO 120 I=MAX(1,IP),N
+ IF(K(I,1).NE.3) GOTO 120
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 120
+ KQ=KCHG(KC,2)
+ IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
+
+C...Pick up loose string end.
+ KCS=4
+ IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
+ IA=I
+ NSTP=0
+ 100 NSTP=NSTP+1
+ IF(NSTP.GT.4*N) THEN
+ CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
+ RETURN
+ ENDIF
+
+C...Copy undecayed parton.
+ IF(K(IA,1).EQ.3) THEN
+ IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
+ RETURN
+ ENDIF
+ I1=I1+1
+ K(I1,1)=2
+ IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
+ K(I1,2)=K(IA,2)
+ K(I1,3)=IA
+ K(I1,4)=0
+ K(I1,5)=0
+ DO 110 J=1,5
+ P(I1,J)=P(IA,J)
+ V(I1,J)=V(IA,J)
+ 110 CONTINUE
+ K(IA,1)=K(IA,1)+10
+ IF(K(I1,1).EQ.1) GOTO 120
+ ENDIF
+
+C...Go to next parton in colour space.
+ IB=IA
+ IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
+ & .NE.0) THEN
+ IA=MOD(K(IB,KCS),MSTU(5))
+ K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
+ MREV=0
+ ELSE
+ IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
+ & MSTU(5)).EQ.0) KCS=9-KCS
+ IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
+ K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
+ MREV=1
+ ENDIF
+ IF(IA.LE.0.OR.IA.GT.N) THEN
+ CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
+ RETURN
+ ENDIF
+ IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
+ & MSTU(5)).EQ.IB) THEN
+ IF(MREV.EQ.1) KCS=9-KCS
+ IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
+ K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
+ ELSE
+ IF(MREV.EQ.0) KCS=9-KCS
+ IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
+ K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
+ ENDIF
+ IF(IA.NE.I) GOTO 100
+ K(I1,1)=1
+ 120 CONTINUE
+ 130 CONTINUE
+ N=I1
+ IF(MSTJ(14).LT.0) RETURN
+
+C...Find lowest-mass colour singlet jet system, OK if above threshold.
+ IF(MSTJ(14).EQ.0) GOTO 320
+ NS=N
+ 140 NSIN=N-NS
+ PDM=1D0+PARJ(32)
+ IC=0
+ DO 190 I=MAX(1,IP),NS
+ IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
+ ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
+ NSIN=NSIN+1
+ IC=I
+ DO 150 J=1,4
+ DPS(J)=P(I,J)
+ 150 CONTINUE
+ MSTJ(93)=1
+ DPS(5)=PYMASS(K(I,2))
+ ELSEIF(K(I,1).EQ.2) THEN
+ DO 160 J=1,4
+ DPS(J)=DPS(J)+P(I,J)
+ 160 CONTINUE
+ ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
+ DO 170 J=1,4
+ DPS(J)=DPS(J)+P(I,J)
+ 170 CONTINUE
+ MSTJ(93)=1
+ DPS(5)=DPS(5)+PYMASS(K(I,2))
+ PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
+ & DPS(5)
+ IF(PD.LT.PDM) THEN
+ PDM=PD
+ DO 180 J=1,5
+ DPC(J)=DPS(J)
+ 180 CONTINUE
+ IC1=IC
+ IC2=I
+ ENDIF
+ IC=0
+ ELSE
+ NSIN=NSIN+1
+ ENDIF
+ 190 CONTINUE
+ IF(PDM.GE.PARJ(32)) GOTO 320
+
+C...Fill small-mass system as cluster.
+ NSAV=N
+ PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
+ K(N+1,1)=11
+ K(N+1,2)=91
+ K(N+1,3)=IC1
+ K(N+1,4)=N+2
+ K(N+1,5)=N+3
+ P(N+1,1)=DPC(1)
+ P(N+1,2)=DPC(2)
+ P(N+1,3)=DPC(3)
+ P(N+1,4)=DPC(4)
+ P(N+1,5)=PECM
+
+C...Form two particles from flavours of lowest-mass system, if feasible.
+ K(N+2,1)=1
+ K(N+3,1)=1
+ IF(MSTU(16).NE.2) THEN
+ K(N+2,3)=N+1
+ K(N+3,3)=N+1
+ ELSE
+ K(N+2,3)=IC1
+ K(N+3,3)=IC2
+ ENDIF
+ K(N+2,4)=0
+ K(N+3,4)=0
+ K(N+2,5)=0
+ K(N+3,5)=0
+ IF(IABS(K(IC1,2)).NE.21) THEN
+ KC1=PYCOMP(K(IC1,2))
+ KC2=PYCOMP(K(IC2,2))
+ IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
+ KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
+ KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
+ IF(KQ1+KQ2.NE.0) GOTO 320
+C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
+ 200 K1=K(IC1,2)
+ IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
+ MSTU(125)=0
+ CALL PYDCYK(K1,0,KFLN,K(N+2,2))
+ CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
+ IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
+ ELSE
+ IF(IABS(K(IC2,2)).NE.21) GOTO 320
+C.. No room for popcorn mesons in closed string -> 2 hadrons.
+ MSTU(125)=0
+ 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
+ CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
+ CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
+ IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
+ ENDIF
+ P(N+2,5)=PYMASS(K(N+2,2))
+ P(N+3,5)=PYMASS(K(N+3,2))
+ IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
+ IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
+
+C...Perform two-particle decay of jet system, if possible.
+ IF(PECM.GE.0.02D0*DPC(4)) THEN
+ PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
+ & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
+ UE(3)=2D0*PYR(0)-1D0
+ PHI=PARU(2)*PYR(0)
+ UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
+ UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
+ DO 220 J=1,3
+ P(N+2,J)=PA*UE(J)
+ P(N+3,J)=-PA*UE(J)
+ 220 CONTINUE
+ P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
+ P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
+ MSTU(33)=1
+ CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
+ & DPC(3)/DPC(4))
+ ELSE
+ NP=0
+ DO 230 I=IC1,IC2
+ IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
+ 230 CONTINUE
+ HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
+ & P(IC1,3)*P(IC2,3)
+ IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
+ HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
+ HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
+ HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
+ & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
+ HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
+ HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
+ HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
+ DO 240 J=1,4
+ P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
+ P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
+ 240 CONTINUE
+ ENDIF
+ DO 250 J=1,4
+ V(N+1,J)=V(IC1,J)
+ V(N+2,J)=V(IC1,J)
+ V(N+3,J)=V(IC2,J)
+ 250 CONTINUE
+ V(N+1,5)=0D0
+ V(N+2,5)=0D0
+ V(N+3,5)=0D0
+ N=N+3
+ GOTO 300
+
+C...Else form one particle from the flavours available, if possible.
+ 260 K(N+1,5)=N+2
+ IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
+ GOTO 320
+ ELSEIF(IABS(K(IC1,2)).NE.21) THEN
+ CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
+ ELSE
+ KFLN=1+INT((2D0+PARJ(2))*PYR(0))
+ CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
+ ENDIF
+ IF(K(N+2,2).EQ.0) GOTO 260
+ P(N+2,5)=PYMASS(K(N+2,2))
+
+C...Find parton/particle which combines to largest extra mass.
+ IR=0
+ HA=0D0
+ HSM=0D0
+ DO 280 MCOMB=1,3
+ IF(IR.NE.0) GOTO 280
+ DO 270 I=MAX(1,IP),N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
+ & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
+ IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
+ IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
+ IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
+ IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
+ & GOTO 270
+ HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
+ HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
+ IF(HSR.GT.HSM) THEN
+ IR=I
+ HA=HCR
+ HSM=HSR
+ ENDIF
+ 270 CONTINUE
+ 280 CONTINUE
+
+C...Shuffle energy and momentum to put new particle on mass shell.
+ IF(IR.NE.0) THEN
+ HB=PECM**2+HA
+ HC=P(N+2,5)**2+HA
+ HD=P(IR,5)**2+HA
+ HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
+ & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
+ HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
+ DO 290 J=1,4
+ P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
+ P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
+ V(N+1,J)=V(IC1,J)
+ V(N+2,J)=V(IC1,J)
+ 290 CONTINUE
+ V(N+1,5)=0D0
+ V(N+2,5)=0D0
+ N=N+2
+ ELSE
+ CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
+ RETURN
+ ENDIF
+
+C...Mark collapsed system and store daughter pointers. Iterate.
+ 300 DO 310 I=IC1,IC2
+ IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
+ & THEN
+ K(I,1)=K(I,1)+10
+ IF(MSTU(16).NE.2) THEN
+ K(I,4)=NSAV+1
+ K(I,5)=NSAV+1
+ ELSE
+ K(I,4)=NSAV+2
+ K(I,5)=N
+ ENDIF
+ ENDIF
+ 310 CONTINUE
+ IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
+
+C...Check flavours and invariant masses in parton systems.
+ 320 NP=0
+ KFN=0
+ KQS=0
+ DO 330 J=1,5
+ DPS(J)=0D0
+ 330 CONTINUE
+ DO 360 I=MAX(1,IP),N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 360
+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
+ IF(KQ.EQ.0) GOTO 360
+ NP=NP+1
+ IF(KQ.NE.2) THEN
+ KFN=KFN+1
+ KQS=KQS+KQ
+ MSTJ(93)=1
+ DPS(5)=DPS(5)+PYMASS(K(I,2))
+ ENDIF
+ DO 340 J=1,4
+ DPS(J)=DPS(J)+P(I,J)
+ 340 CONTINUE
+ IF(K(I,1).EQ.1) THEN
+ IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
+ & PYERRM(2,'(PYPREP:) unphysical flavour combination')
+ IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
+ & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
+ & '(PYPREP:) too small mass in jet system')
+**sr
+C IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
+C & (0.9D0*PARJ(32)+DPS(5))**2)
+C & WRITE(*,*) 'I,DPS',I,DPS
+**
+ NP=0
+ KFN=0
+ KQS=0
+ DO 350 J=1,5
+ DPS(J)=0D0
+ 350 CONTINUE
+ ENDIF
+ 360 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSTRF
+C...Handles the fragmentation of an arbitrary colour singlet
+C...jet system according to the Lund string fragmentation model.
+
+ SUBROUTINE PYSTRF(IP)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays. All MOPS variables ends with MO
+ DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
+ &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
+ &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
+ &INMO(9),PM2QMO(2),XTMO(2)
+
+C...Function: four-product of two vectors.
+ FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
+ DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
+ &DP(I,3)*DP(J,3)
+
+C...Reset counters. Identify parton system.
+ MSTJ(91)=0
+ NSAV=N
+ MSTU90=MSTU(90)
+ NP=0
+ KQSUM=0
+ DO 100 J=1,5
+ DPS(J)=0D0
+ 100 CONTINUE
+ MJU(1)=0
+ MJU(2)=0
+ I=IP-1
+ 110 I=I+1
+ IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
+ CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 110
+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
+ IF(KQ.EQ.0) GOTO 110
+ IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Take copy of partons to be considered. Check flavour sum.
+ NP=NP+1
+ DO 120 J=1,5
+ K(N+NP,J)=K(I,J)
+ P(N+NP,J)=P(I,J)
+ IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
+ 120 CONTINUE
+ DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ K(N+NP,3)=I
+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
+ IF(K(I,1).EQ.41) THEN
+ KQSUM=KQSUM+2*KQ
+ IF(KQSUM.EQ.KQ) MJU(1)=N+NP
+ IF(KQSUM.NE.KQ) MJU(2)=N+NP
+ ENDIF
+ IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
+ IF(KQSUM.NE.0) THEN
+ CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Boost copied system to CM frame (for better numerical precision).
+ IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
+ MBST=0
+ MSTU(33)=1
+ CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
+ & -DPS(3)/DPS(4))
+ ELSE
+ MBST=1
+ HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
+ DO 130 I=N+1,N+NP
+ HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
+ IF(P(I,3).GT.0D0) THEN
+ HHPEZ=(P(I,4)+P(I,3))/HHBZ
+ P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
+ ELSE
+ HHPEZ=(P(I,4)-P(I,3))*HHBZ
+ P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
+ ENDIF
+ 130 CONTINUE
+ ENDIF
+
+C...Search for very nearby partons that may be recombined.
+ NTRYR=0
+ PARU12=PARU(12)
+ PARU13=PARU(13)
+ MJU(3)=MJU(1)
+ MJU(4)=MJU(2)
+ NR=NP
+ 140 IF(NR.GE.3) THEN
+ PDRMIN=2D0*PARU12
+ DO 150 I=N+1,N+NR
+ IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
+ I1=I+1
+ IF(I.EQ.N+NR) I1=N+1
+ IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
+ IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
+ & GOTO 150
+ IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
+ & GOTO 150
+ PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
+ & P(I1,2)**2+P(I1,3)**2))
+ PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
+ PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
+ IF(PDR.LT.PDRMIN) THEN
+ IR=I
+ PDRMIN=PDR
+ ENDIF
+ 150 CONTINUE
+
+C...Recombine very nearby partons to avoid machine precision problems.
+ IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
+ DO 160 J=1,4
+ P(N+1,J)=P(N+1,J)+P(N+NR,J)
+ 160 CONTINUE
+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
+ & P(N+1,3)**2))
+ NR=NR-1
+ GOTO 140
+ ELSEIF(PDRMIN.LT.PARU12) THEN
+ DO 170 J=1,4
+ P(IR,J)=P(IR,J)+P(IR+1,J)
+ 170 CONTINUE
+ P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
+ & P(IR,3)**2))
+ DO 190 I=IR+1,N+NR-1
+ K(I,2)=K(I+1,2)
+ DO 180 J=1,5
+ P(I,J)=P(I+1,J)
+ 180 CONTINUE
+ 190 CONTINUE
+ IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
+ NR=NR-1
+ IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
+ IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
+ GOTO 140
+ ENDIF
+ ENDIF
+ NTRYR=NTRYR+1
+
+C...Reset particle counter. Skip ahead if no junctions are present;
+C...this is usually the case!
+ NRS=MAX(5*NR+11,NP)
+ NTRY=0
+ 200 NTRY=NTRY+1
+ IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
+ PARU12=4D0*PARU12
+ PARU13=2D0*PARU13
+ GOTO 140
+ ELSEIF(NTRY.GT.100) THEN
+ CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ I=N+NRS
+ MSTU(90)=MSTU90
+ IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
+ IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
+ & ' junction strings not handled by MSTJ(12)>3 options')
+ DO 570 JT=1,2
+ NJS(JT)=0
+ IF(MJU(JT).EQ.0) GOTO 570
+ JS=3-2*JT
+
+C...Find and sum up momentum on three sides of junction. Check flavours.
+ DO 220 IU=1,3
+ IJU(IU)=0
+ DO 210 J=1,5
+ PJU(IU,J)=0D0
+ 210 CONTINUE
+ 220 CONTINUE
+ IU=0
+ DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
+ IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
+ IU=IU+1
+ IJU(IU)=I1
+ ENDIF
+ DO 230 J=1,4
+ PJU(IU,J)=PJU(IU,J)+P(I1,J)
+ 230 CONTINUE
+ 240 CONTINUE
+ DO 250 IU=1,3
+ PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
+ 250 CONTINUE
+ IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
+ & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
+ CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Calculate (approximate) boost to rest frame of junction.
+ T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
+ & (PJU(1,5)*PJU(2,5))
+ T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
+ & (PJU(1,5)*PJU(3,5))
+ T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
+ & (PJU(2,5)*PJU(3,5))
+ T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
+ T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
+ TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
+ T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
+ T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
+ DO 260 J=1,3
+ TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
+ 260 CONTINUE
+ TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
+ DO 270 IU=1,3
+ PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
+ & TJU(3)*PJU(IU,3)
+ 270 CONTINUE
+
+C...Put junction at rest if motion could give inconsistencies.
+ IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
+ DO 280 J=1,3
+ TJU(J)=0D0
+ 280 CONTINUE
+ TJU(4)=1D0
+ PJU(1,5)=PJU(1,4)
+ PJU(2,5)=PJU(2,4)
+ PJU(3,5)=PJU(3,4)
+ ENDIF
+
+C...Start preparing for fragmentation of two strings from junction.
+ ISTA=I
+ DO 550 IU=1,2
+ NS=IJU(IU+1)-IJU(IU)
+
+C...Junction strings: find longitudinal string directions.
+ DO 310 IS=1,NS
+ IS1=IJU(IU)+IS-1
+ IS2=IJU(IU)+IS
+ DO 290 J=1,5
+ DP(1,J)=0.5D0*P(IS1,J)
+ IF(IS.EQ.1) DP(1,J)=P(IS1,J)
+ DP(2,J)=0.5D0*P(IS2,J)
+ IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
+ 290 CONTINUE
+ IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
+ & PJU(IU,3)**2)
+ IF(IS.EQ.NS) DP(2,5)=0D0
+ DP(3,5)=DFOUR(1,1)
+ DP(4,5)=DFOUR(2,2)
+ DHKC=DFOUR(1,2)
+ IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
+ DP(3,5)=0D0
+ DP(4,5)=0D0
+ DHKC=DFOUR(1,2)
+ ENDIF
+ DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
+ DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
+ DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
+ IN1=N+NR+4*IS-3
+ P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
+ DO 300 J=1,4
+ P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
+ P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
+ 300 CONTINUE
+ 310 CONTINUE
+
+C...Junction strings: initialize flavour, momentum and starting pos.
+ ISAV=I
+ MSTU91=MSTU(90)
+ 320 NTRY=NTRY+1
+ IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
+ PARU12=4D0*PARU12
+ PARU13=2D0*PARU13
+ GOTO 140
+ ELSEIF(NTRY.GT.100) THEN
+ CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ I=ISAV
+ MSTU(90)=MSTU91
+ IRANKJ=0
+ IE(1)=K(N+1+(JT/2)*(NP-1),3)
+ IN(4)=N+NR+1
+ IN(5)=IN(4)+1
+ IN(6)=N+NR+4*NS+1
+ DO 340 JQ=1,2
+ DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
+ P(IN1,1)=2-JQ
+ P(IN1,2)=JQ-1
+ P(IN1,3)=1D0
+ 330 CONTINUE
+ 340 CONTINUE
+ KFL(1)=K(IJU(IU),2)
+ PX(1)=0D0
+ PY(1)=0D0
+ GAM(1)=0D0
+ DO 350 J=1,5
+ PJU(IU+3,J)=0D0
+ 350 CONTINUE
+
+C...Junction strings: find initial transverse directions.
+ DO 360 J=1,4
+ DP(1,J)=P(IN(4),J)
+ DP(2,J)=P(IN(4)+1,J)
+ DP(3,J)=0D0
+ DP(4,J)=0D0
+ 360 CONTINUE
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
+ DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
+ DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
+ DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
+ IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
+ IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
+ IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
+ IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
+ DHC12=DFOUR(1,2)
+ DHCX1=DFOUR(3,1)/DHC12
+ DHCX2=DFOUR(3,2)/DHC12
+ DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
+ DHCY1=DFOUR(4,1)/DHC12
+ DHCY2=DFOUR(4,2)/DHC12
+ DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
+ DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
+ DO 370 J=1,4
+ DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
+ P(IN(6),J)=DP(3,J)
+ P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
+ & DHCYX*DP(3,J))
+ 370 CONTINUE
+
+C...Junction strings: produce new particle, origin.
+ 380 I=I+1
+ IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IRANKJ=IRANKJ+1
+ K(I,1)=1
+ K(I,3)=IE(1)
+ K(I,4)=0
+ K(I,5)=0
+
+C...Junction strings: generate flavour, hadron, pT, z and Gamma.
+ 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
+ IF(K(I,2).EQ.0) GOTO 320
+ IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
+ & IABS(KFL(3)).GT.10) THEN
+ IF(PYR(0).GT.PARJ(19)) GOTO 390
+ ENDIF
+ P(I,5)=PYMASS(K(I,2))
+ CALL PYPTDI(KFL(1),PX(3),PY(3))
+ PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
+ CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
+ IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
+ & MSTU(90).LT.8) THEN
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I
+ PARU(90+MSTU(90))=Z
+ ENDIF
+ GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
+ DO 400 J=1,3
+ IN(J)=IN(3+J)
+ 400 CONTINUE
+
+C...Junction strings: stepping within or from 'low' string region easy.
+ IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
+ & P(IN(1),5)**2.GE.PR(1)) THEN
+ P(IN(1)+2,4)=Z*P(IN(1)+2,3)
+ P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
+ DO 410 J=1,4
+ P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
+ 410 CONTINUE
+ GOTO 500
+ ELSEIF(IN(1)+1.EQ.IN(2)) THEN
+ P(IN(2)+2,4)=P(IN(2)+2,3)
+ P(IN(2)+2,1)=1D0
+ IN(2)=IN(2)+4
+ IF(IN(2).GT.N+NR+4*NS) GOTO 320
+ IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
+ P(IN(1)+2,4)=P(IN(1)+2,3)
+ P(IN(1)+2,1)=0D0
+ IN(1)=IN(1)+4
+ ENDIF
+ ENDIF
+
+C...Junction strings: find new transverse directions.
+ 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
+ & IN(1).GT.IN(2)) GOTO 320
+ IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
+ DO 430 J=1,4
+ DP(1,J)=P(IN(1),J)
+ DP(2,J)=P(IN(2),J)
+ DP(3,J)=0D0
+ DP(4,J)=0D0
+ 430 CONTINUE
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
+ DHC12=DFOUR(1,2)
+ IF(DHC12.LE.1D-2) THEN
+ P(IN(1)+2,4)=P(IN(1)+2,3)
+ P(IN(1)+2,1)=0D0
+ IN(1)=IN(1)+4
+ GOTO 420
+ ENDIF
+ IN(3)=N+NR+4*NS+5
+ DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
+ DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
+ DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
+ IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
+ IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
+ IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
+ IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
+ DHCX1=DFOUR(3,1)/DHC12
+ DHCX2=DFOUR(3,2)/DHC12
+ DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
+ DHCY1=DFOUR(4,1)/DHC12
+ DHCY2=DFOUR(4,2)/DHC12
+ DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
+ DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
+ DO 440 J=1,4
+ DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
+ P(IN(3),J)=DP(3,J)
+ P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
+ & DHCYX*DP(3,J))
+ 440 CONTINUE
+C...Express pT with respect to new axes, if sensible.
+ PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
+ PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
+ IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
+ PX(3)=PXP
+ PY(3)=PYP
+ ENDIF
+ ENDIF
+
+C...Junction strings: sum up known four-momentum, coefficients for m2.
+ DO 470 J=1,4
+ DHG(J)=0D0
+ P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
+ & PY(3)*P(IN(3)+1,J)
+ DO 450 IN1=IN(4),IN(1)-4,4
+ P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
+ 450 CONTINUE
+ DO 460 IN2=IN(5),IN(2)-4,4
+ P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
+ 460 CONTINUE
+ 470 CONTINUE
+ DHM(1)=FOUR(I,I)
+ DHM(2)=2D0*FOUR(I,IN(1))
+ DHM(3)=2D0*FOUR(I,IN(2))
+ DHM(4)=2D0*FOUR(IN(1),IN(2))
+
+C...Junction strings: find coefficients for Gamma expression.
+ DO 490 IN2=IN(1)+1,IN(2),4
+ DO 480 IN1=IN(1),IN2-1,4
+ DHC=2D0*FOUR(IN1,IN2)
+ DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
+ IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
+ IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
+ IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
+ 480 CONTINUE
+ 490 CONTINUE
+
+C...Junction strings: solve (m2, Gamma) equation system for energies.
+ DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
+ IF(ABS(DHS1).LT.1D-4) GOTO 320
+ DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
+ & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
+ DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
+ P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
+ & ABS(DHS1)-DHS2/DHS1)
+ IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
+ P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
+ & (DHM(2)+DHM(4)*P(IN(2)+2,4))
+
+C...Junction strings: step to new region if necessary.
+ IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
+ P(IN(2)+2,4)=P(IN(2)+2,3)
+ P(IN(2)+2,1)=1D0
+ IN(2)=IN(2)+4
+ IF(IN(2).GT.N+NR+4*NS) GOTO 320
+ IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
+ P(IN(1)+2,4)=P(IN(1)+2,3)
+ P(IN(1)+2,1)=0D0
+ IN(1)=IN(1)+4
+ ENDIF
+ GOTO 420
+ ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
+ P(IN(1)+2,4)=P(IN(1)+2,3)
+ P(IN(1)+2,1)=0D0
+ IN(1)=IN(1)+JS
+ GOTO 890
+ ENDIF
+
+C...Junction strings: particle four-momentum, remainder, loop back.
+ 500 DO 510 J=1,4
+ P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
+ & P(IN(2)+2,4)*P(IN(2),J)
+ PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
+ 510 CONTINUE
+ IF(P(I,4).LT.P(I,5)) GOTO 320
+ PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
+ & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
+ IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
+ KFL(1)=-KFL(3)
+ PX(1)=-PX(3)
+ PY(1)=-PY(3)
+ GAM(1)=GAM(3)
+ IF(IN(3).NE.IN(6)) THEN
+ DO 520 J=1,4
+ P(IN(6),J)=P(IN(3),J)
+ P(IN(6)+1,J)=P(IN(3)+1,J)
+ 520 CONTINUE
+ ENDIF
+ DO 530 JQ=1,2
+ IN(3+JQ)=IN(JQ)
+ P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
+ P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
+ 530 CONTINUE
+ GOTO 380
+ ENDIF
+
+C...Junction strings: save quantities left after each string.
+ IF(IABS(KFL(1)).GT.10) GOTO 320
+ I=I-1
+ KFJH(IU)=KFL(1)
+ DO 540 J=1,4
+ PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
+ 540 CONTINUE
+ 550 CONTINUE
+
+C...Junction strings: put together to new effective string endpoint.
+ NJS(JT)=I-ISTA
+ KFJS(JT)=K(K(MJU(JT+2),3),2)
+ KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
+ IF(KFJH(1).EQ.KFJH(2)) KFLS=3
+ IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
+ & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
+ & KFLS,KFJH(1))
+ DO 560 J=1,4
+ PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
+ PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
+ 560 CONTINUE
+ PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
+ & PJS(JT,3)**2))
+ 570 CONTINUE
+
+C...Open versus closed strings. Choose breakup region for latter.
+ 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
+ NS=MJU(2)-MJU(1)
+ NB=MJU(1)-N
+ ELSEIF(MJU(1).NE.0) THEN
+ NS=N+NR-MJU(1)
+ NB=MJU(1)-N
+ ELSEIF(MJU(2).NE.0) THEN
+ NS=MJU(2)-N
+ NB=1
+ ELSEIF(IABS(K(N+1,2)).NE.21) THEN
+ NS=NR-1
+ NB=1
+ ELSE
+ NS=NR+1
+ W2SUM=0D0
+ DO 590 IS=1,NR
+ P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
+ W2SUM=W2SUM+P(N+NR+IS,1)
+ 590 CONTINUE
+ W2RAN=PYR(0)*W2SUM
+ NB=0
+ 600 NB=NB+1
+ W2SUM=W2SUM-P(N+NR+NB,1)
+ IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
+ ENDIF
+
+C...Find longitudinal string directions (i.e. lightlike four-vectors).
+ DO 630 IS=1,NS
+ IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
+ IS2=N+IS+NB-NR*((IS+NB-1)/NR)
+ DO 610 J=1,5
+ DP(1,J)=P(IS1,J)
+ IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
+ IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
+ DP(2,J)=P(IS2,J)
+ IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
+ IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
+ 610 CONTINUE
+ DP(3,5)=DFOUR(1,1)
+ DP(4,5)=DFOUR(2,2)
+ DHKC=DFOUR(1,2)
+ IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
+ DP(3,5)=DP(1,5)**2
+ DP(4,5)=DP(2,5)**2
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
+ DHKC=DFOUR(1,2)
+ ENDIF
+ DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
+ DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
+ DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
+ IN1=N+NR+4*IS-3
+ P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
+ DO 620 J=1,4
+ P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
+ P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
+ 620 CONTINUE
+ 630 CONTINUE
+
+C...Begin initialization: sum up energy, set starting position.
+ ISAV=I
+ MSTU91=MSTU(90)
+ 640 NTRY=NTRY+1
+ IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
+ PARU12=4D0*PARU12
+ PARU13=2D0*PARU13
+ GOTO 140
+ ELSEIF(NTRY.GT.100) THEN
+ CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ I=ISAV
+ MSTU(90)=MSTU91
+ DO 660 J=1,4
+ P(N+NRS,J)=0D0
+ DO 650 IS=1,NR
+ P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
+ 650 CONTINUE
+ 660 CONTINUE
+ DO 680 JT=1,2
+ IRANK(JT)=0
+ IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
+ IF(NS.GT.NR) IRANK(JT)=1
+ IE(JT)=K(N+1+(JT/2)*(NP-1),3)
+ IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
+ IN(3*JT+2)=IN(3*JT+1)+1
+ IN(3*JT+3)=N+NR+4*NS+2*JT-1
+ DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
+ P(IN1,1)=2-JT
+ P(IN1,2)=JT-1
+ P(IN1,3)=1D0
+ 670 CONTINUE
+ 680 CONTINUE
+C.. MOPS variables and switches
+ NRVMO=0
+ XBMO=1D0
+ MSTU(121)=0
+ MSTU(122)=0
+
+C...Initialize flavour and pT variables for open string.
+ IF(NS.LT.NR) THEN
+ PX(1)=0D0
+ PY(1)=0D0
+ IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
+ PX(2)=-PX(1)
+ PY(2)=-PY(1)
+ DO 690 JT=1,2
+ KFL(JT)=K(IE(JT),2)
+ IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
+ MSTJ(93)=1
+ PMQ(JT)=PYMASS(KFL(JT))
+ GAM(JT)=0D0
+ 690 CONTINUE
+
+C...Closed string: random initial breakup flavour, pT and vertex.
+ ELSE
+ KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
+ IBMO=0
+ 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
+C.. Closed string: first vertex diq attempt => enforced second
+C.. vertex diq
+ IF(IABS(KFL(1)).GT.10)THEN
+ IBMO=1
+ MSTU(121)=0
+ GOTO 700
+ ENDIF
+ IF(IBMO.EQ.1) MSTU(121)=-1
+ KFL(2)=-KFL(1)
+ CALL PYPTDI(KFL(1),PX(1),PY(1))
+ PX(2)=-PX(1)
+ PY(2)=-PY(1)
+ PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
+ 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
+ ZR=PR3/(Z*P(N+NR+1,5)**2)
+ IF(ZR.GE.1D0) GOTO 710
+ DO 720 JT=1,2
+ MSTJ(93)=1
+ PMQ(JT)=PYMASS(KFL(JT))
+ GAM(JT)=PR3*(1D0-Z)/Z
+ IN1=N+NR+3+4*(JT/2)*(NS-1)
+ P(IN1,JT)=1D0-Z
+ P(IN1,3-JT)=JT-1
+ P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
+ P(IN1+1,JT)=ZR
+ P(IN1+1,3-JT)=2-JT
+ P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
+ 720 CONTINUE
+ ENDIF
+C.. MOPS variables
+ DO 730 JT=1,2
+ XTMO(JT)=1D0
+ PM2QMO(JT)=PMQ(JT)**2
+ IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
+ 730 CONTINUE
+
+C...Find initial transverse directions (i.e. spacelike four-vectors).
+ DO 770 JT=1,2
+ IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
+ IN1=IN(3*JT+1)
+ IN3=IN(3*JT+3)
+ DO 740 J=1,4
+ DP(1,J)=P(IN1,J)
+ DP(2,J)=P(IN1+1,J)
+ DP(3,J)=0D0
+ DP(4,J)=0D0
+ 740 CONTINUE
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
+ DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
+ DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
+ DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
+ IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
+ IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
+ IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
+ IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
+ DHC12=DFOUR(1,2)
+ DHCX1=DFOUR(3,1)/DHC12
+ DHCX2=DFOUR(3,2)/DHC12
+ DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
+ DHCY1=DFOUR(4,1)/DHC12
+ DHCY2=DFOUR(4,2)/DHC12
+ DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
+ DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
+ DO 750 J=1,4
+ DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
+ P(IN3,J)=DP(3,J)
+ P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
+ & DHCYX*DP(3,J))
+ 750 CONTINUE
+ ELSE
+ DO 760 J=1,4
+ P(IN3+2,J)=P(IN3,J)
+ P(IN3+3,J)=P(IN3+1,J)
+ 760 CONTINUE
+ ENDIF
+ 770 CONTINUE
+
+C...Remove energy used up in junction string fragmentation.
+ IF(MJU(1)+MJU(2).GT.0) THEN
+ DO 790 JT=1,2
+ IF(NJS(JT).EQ.0) GOTO 790
+ DO 780 J=1,4
+ P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
+ 780 CONTINUE
+ 790 CONTINUE
+ ENDIF
+
+C...Produce new particle: side, origin.
+ 800 I=I+1
+ IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+C.. New side priority for popcorn systems
+ IF(MSTU(121).LE.0)THEN
+ JT=1.5D0+PYR(0)
+ IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
+ IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
+ ENDIF
+ JR=3-JT
+ JS=3-2*JT
+ IRANK(JT)=IRANK(JT)+1
+ K(I,1)=1
+ K(I,3)=IE(JT)
+ K(I,4)=0
+ K(I,5)=0
+
+C...Generate flavour, hadron and pT.
+ 810 CONTINUE
+ CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
+ IF(K(I,2).EQ.0) GOTO 640
+ MU90MO=MSTU(90)
+ IF(MSTU(121).EQ.-1) GOTO 840
+ IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
+ &IABS(KFL(3)).GT.10) THEN
+ IF(PYR(0).GT.PARJ(19)) GOTO 810
+ ENDIF
+ P(I,5)=PYMASS(K(I,2))
+ CALL PYPTDI(KFL(JT),PX(3),PY(3))
+ PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
+
+C...Final hadrons for small invariant mass.
+ MSTJ(93)=1
+ PMQ(3)=PYMASS(KFL(3))
+ PARJST=PARJ(33)
+ IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
+ WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
+ IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
+ &WMIN-0.5D0*PARJ(36)*PMQ(3)
+ WREM2=FOUR(N+NRS,N+NRS)
+ IF(WREM2.LT.0.10D0) GOTO 640
+ IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
+ &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
+
+C...Choose z, which gives Gamma. Shift z for heavy flavours.
+ CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
+ IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
+ &MSTU(90).LT.8) THEN
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I
+ PARU(90+MSTU(90))=Z
+ ENDIF
+ KFL1A=IABS(KFL(1))
+ KFL2A=IABS(KFL(2))
+ IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
+ &MOD(KFL2A/1000,10)).GE.4) THEN
+ PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
+ PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
+ Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
+ PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
+ IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
+ ENDIF
+ GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
+
+C.. MOPS baryon model modification
+ XTMO3=(1D0-Z)*XTMO(JT)
+ IF(IABS(KFL(3)).LE.10) NRVMO=0
+ IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
+ GTSTMO=1D0
+ PTSTMO=1D0
+ RTSTMO=PYR(0)
+ IF(IABS(KFL(JT)).LE.10)THEN
+ XBMO=MIN(XTMO3,1D0-(2D-10))
+ GBMO=GAM(3)
+ PMMO=0D0
+ PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
+ GTSTMO=1D0-PARF(192)**PGMO
+ ELSE
+ IF(IRANK(JT).EQ.1) THEN
+ GBMO=GAM(JT)
+ PMMO=0D0
+ XBMO=1D0
+ ENDIF
+ IF(XBMO.LT.1D0-(1D-10))THEN
+ PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
+ GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
+ PGMO=PGNMO
+ ENDIF
+ IF(MSTJ(12).GE.5)THEN
+ PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
+ PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
+ PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
+ PMMO=PMNMO
+ ENDIF
+ ENDIF
+
+C.. MOPS Accepting popcorn system hadron.
+ IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
+ IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
+ NRVMO=I-N-NR
+ IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,
+ & '(PYSTRF:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IMO=I
+ KFLMO=KFL(JT)
+ PMQMO=PMQ(JT)
+ PXMO=PX(JT)
+ PYMO=PY(JT)
+ GAMMO=GAM(JT)
+ IRMO=IRANK(JT)
+ XMO=XTMO(JT)
+ DO 830 J=1,9
+ IF(J.LE.5) THEN
+ DO 820 LINE=1,I-N-NR
+ P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
+ K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
+ 820 CONTINUE
+ ENDIF
+ INMO(J)=IN(J)
+ 830 CONTINUE
+ ENDIF
+ ELSE
+C..Reject popcorn system, flag=-1 if enforcing new one
+ MSTU(121)=-1
+ IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
+ ENDIF
+ ENDIF
+
+
+C..Lift restoring string outside MOPS block
+ 840 IF(MSTU(121).LT.0) THEN
+ IF(MSTU(121).EQ.-2) MSTU(121)=0
+ MSTU(90)=MU90MO
+ NRVMO=0
+ IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
+ I=IMO
+ KFL(JT)=KFLMO
+ PMQ(JT)=PMQMO
+ PX(JT)=PXMO
+ PY(JT)=PYMO
+ GAM(JT)=GAMMO
+ IRANK(JT)=IRMO
+ XTMO(JT)=XMO
+ DO 860 J=1,9
+ IF(J.LE.5) THEN
+ DO 850 LINE=1,I-N-NR
+ P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
+ K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
+ 850 CONTINUE
+ ENDIF
+ IN(J)=INMO(J)
+ 860 CONTINUE
+ GOTO 810
+ ENDIF
+ XTMO(JT)=XTMO3
+C.. MOPS end of modification
+
+ DO 870 J=1,3
+ IN(J)=IN(3*JT+J)
+ 870 CONTINUE
+
+C...Stepping within or from 'low' string region easy.
+ IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
+ &P(IN(1),5)**2.GE.PR(JT)) THEN
+ P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
+ P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
+ DO 880 J=1,4
+ P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
+ 880 CONTINUE
+ GOTO 970
+ ELSEIF(IN(1)+1.EQ.IN(2)) THEN
+ P(IN(JR)+2,4)=P(IN(JR)+2,3)
+ P(IN(JR)+2,JT)=1D0
+ IN(JR)=IN(JR)+4*JS
+ IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
+ IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
+ P(IN(JT)+2,4)=P(IN(JT)+2,3)
+ P(IN(JT)+2,JT)=0D0
+ IN(JT)=IN(JT)+4*JS
+ ENDIF
+ ENDIF
+
+C...Find new transverse directions (i.e. spacelike string vectors).
+ 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
+ &IN(1).GT.IN(2)) GOTO 640
+ IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
+ DO 900 J=1,4
+ DP(1,J)=P(IN(1),J)
+ DP(2,J)=P(IN(2),J)
+ DP(3,J)=0D0
+ DP(4,J)=0D0
+ 900 CONTINUE
+ DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
+ DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
+ DHC12=DFOUR(1,2)
+ IF(DHC12.LE.1D-2) THEN
+ P(IN(JT)+2,4)=P(IN(JT)+2,3)
+ P(IN(JT)+2,JT)=0D0
+ IN(JT)=IN(JT)+4*JS
+ GOTO 890
+ ENDIF
+ IN(3)=N+NR+4*NS+5
+ DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
+ DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
+ DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
+ IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
+ IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
+ IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
+ IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
+ DHCX1=DFOUR(3,1)/DHC12
+ DHCX2=DFOUR(3,2)/DHC12
+ DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
+ DHCY1=DFOUR(4,1)/DHC12
+ DHCY2=DFOUR(4,2)/DHC12
+ DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
+ DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
+ DO 910 J=1,4
+ DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
+ P(IN(3),J)=DP(3,J)
+ P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
+ & DHCYX*DP(3,J))
+ 910 CONTINUE
+C...Express pT with respect to new axes, if sensible.
+ PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
+ & FOUR(IN(3*JT+3)+1,IN(3)))
+ PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
+ & FOUR(IN(3*JT+3)+1,IN(3)+1))
+ IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
+ PX(3)=PXP
+ PY(3)=PYP
+ ENDIF
+ ENDIF
+
+C...Sum up known four-momentum. Gives coefficients for m2 expression.
+ DO 940 J=1,4
+ DHG(J)=0D0
+ P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
+ & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
+ DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
+ P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
+ 920 CONTINUE
+ DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
+ P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
+ 930 CONTINUE
+ 940 CONTINUE
+ DHM(1)=FOUR(I,I)
+ DHM(2)=2D0*FOUR(I,IN(1))
+ DHM(3)=2D0*FOUR(I,IN(2))
+ DHM(4)=2D0*FOUR(IN(1),IN(2))
+
+C...Find coefficients for Gamma expression.
+ DO 960 IN2=IN(1)+1,IN(2),4
+ DO 950 IN1=IN(1),IN2-1,4
+ DHC=2D0*FOUR(IN1,IN2)
+ DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
+ IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
+ IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
+ IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
+ 950 CONTINUE
+ 960 CONTINUE
+
+C...Solve (m2, Gamma) equation system for energies taken.
+ DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
+ IF(ABS(DHS1).LT.1D-4) GOTO 640
+ DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
+ &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
+ DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
+ P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
+ &ABS(DHS1)-DHS2/DHS1)
+ IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
+ P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
+ &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
+
+C...Step to new region if necessary.
+ IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
+ P(IN(JR)+2,4)=P(IN(JR)+2,3)
+ P(IN(JR)+2,JT)=1D0
+ IN(JR)=IN(JR)+4*JS
+ IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
+ IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
+ P(IN(JT)+2,4)=P(IN(JT)+2,3)
+ P(IN(JT)+2,JT)=0D0
+ IN(JT)=IN(JT)+4*JS
+ ENDIF
+ GOTO 890
+ ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
+ P(IN(JT)+2,4)=P(IN(JT)+2,3)
+ P(IN(JT)+2,JT)=0D0
+ IN(JT)=IN(JT)+4*JS
+ GOTO 890
+ ENDIF
+
+C...Four-momentum of particle. Remaining quantities. Loop back.
+ 970 DO 980 J=1,4
+ P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
+ P(N+NRS,J)=P(N+NRS,J)-P(I,J)
+ 980 CONTINUE
+ IF(P(I,4).LT.P(I,5)) GOTO 640
+ KFL(JT)=-KFL(3)
+ PMQ(JT)=PMQ(3)
+ PX(JT)=-PX(3)
+ PY(JT)=-PY(3)
+ GAM(JT)=GAM(3)
+ IF(IN(3).NE.IN(3*JT+3)) THEN
+ DO 990 J=1,4
+ P(IN(3*JT+3),J)=P(IN(3),J)
+ P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
+ 990 CONTINUE
+ ENDIF
+ DO 1000 JQ=1,2
+ IN(3*JT+JQ)=IN(JQ)
+ P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
+ P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
+ 1000 CONTINUE
+ GOTO 800
+
+C...Final hadron: side, flavour, hadron, mass.
+ 1010 I=I+1
+ K(I,1)=1
+ K(I,3)=IE(JR)
+ K(I,4)=0
+ K(I,5)=0
+ CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
+ IF(K(I,2).EQ.0) GOTO 640
+ P(I,5)=PYMASS(K(I,2))
+ PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
+
+C...Final two hadrons: find common setup of four-vectors.
+ JQ=1
+ IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
+ &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
+ DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
+ DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
+ DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
+ IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
+ PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
+ PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
+ PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
+ & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
+ ENDIF
+
+C...Solve kinematics for final two hadrons, if possible.
+ WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
+ FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
+ IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
+ IF(FD.GE.1D0) GOTO 640
+ FA=WREM2+PR(JT)-PR(JR)
+ IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
+ &(PR(1)+PR(2))**2))
+ IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
+ FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
+ KFL1A=IABS(KFL(1))
+ KFL2A=IABS(KFL(2))
+ IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
+ &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
+ &4D0*WREM2*PR(JT))),DBLE(JS))
+ DO 1020 J=1,4
+ P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
+ & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
+ & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
+ P(I,J)=P(N+NRS,J)-P(I-1,J)
+ 1020 CONTINUE
+ IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
+
+C...Mark jets as fragmented and give daughter pointers.
+ N=I-NRS+1
+ DO 1030 I=NSAV+1,NSAV+NP
+ IM=K(I,3)
+ K(IM,1)=K(IM,1)+10
+ IF(MSTU(16).NE.2) THEN
+ K(IM,4)=NSAV+1
+ K(IM,5)=NSAV+1
+ ELSE
+ K(IM,4)=NSAV+2
+ K(IM,5)=N
+ ENDIF
+ 1030 CONTINUE
+
+C...Document string system. Move up particles.
+ NSAV=NSAV+1
+ K(NSAV,1)=11
+ K(NSAV,2)=92
+ K(NSAV,3)=IP
+ K(NSAV,4)=NSAV+1
+ K(NSAV,5)=N
+ DO 1040 J=1,4
+ P(NSAV,J)=DPS(J)
+ V(NSAV,J)=V(IP,J)
+ 1040 CONTINUE
+ P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
+ V(NSAV,5)=0D0
+ DO 1060 I=NSAV+1,N
+ DO 1050 J=1,5
+ K(I,J)=K(I+NRS-1,J)
+ P(I,J)=P(I+NRS-1,J)
+ V(I,J)=0D0
+ 1050 CONTINUE
+ 1060 CONTINUE
+ MSTU91=MSTU(90)
+ DO 1070 IZ=MSTU90+1,MSTU91
+ MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
+ PARU9T(IZ)=PARU(90+IZ)
+ 1070 CONTINUE
+ MSTU(90)=MSTU90
+
+C...Order particles in rank along the chain. Update mother pointer.
+ DO 1090 I=NSAV+1,N
+ DO 1080 J=1,5
+ K(I-NSAV+N,J)=K(I,J)
+ P(I-NSAV+N,J)=P(I,J)
+ 1080 CONTINUE
+ 1090 CONTINUE
+ I1=NSAV
+ DO 1120 I=N+1,2*N-NSAV
+ IF(K(I,3).NE.IE(1)) GOTO 1120
+ I1=I1+1
+ DO 1100 J=1,5
+ K(I1,J)=K(I,J)
+ P(I1,J)=P(I,J)
+ 1100 CONTINUE
+ IF(MSTU(16).NE.2) K(I1,3)=NSAV
+ DO 1110 IZ=MSTU90+1,MSTU91
+ IF(MSTU9T(IZ).EQ.I) THEN
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I1
+ PARU(90+MSTU(90))=PARU9T(IZ)
+ ENDIF
+ 1110 CONTINUE
+ 1120 CONTINUE
+ DO 1150 I=2*N-NSAV,N+1,-1
+ IF(K(I,3).EQ.IE(1)) GOTO 1150
+ I1=I1+1
+ DO 1130 J=1,5
+ K(I1,J)=K(I,J)
+ P(I1,J)=P(I,J)
+ 1130 CONTINUE
+ IF(MSTU(16).NE.2) K(I1,3)=NSAV
+ DO 1140 IZ=MSTU90+1,MSTU91
+ IF(MSTU9T(IZ).EQ.I) THEN
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I1
+ PARU(90+MSTU(90))=PARU9T(IZ)
+ ENDIF
+ 1140 CONTINUE
+ 1150 CONTINUE
+
+C...Boost back particle system. Set production vertices.
+ IF(MBST.EQ.0) THEN
+ MSTU(33)=1
+ CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
+ & DPS(3)/DPS(4))
+ ELSE
+ DO 1160 I=NSAV+1,N
+ HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
+ IF(P(I,3).GT.0D0) THEN
+ HHPEZ=(P(I,4)+P(I,3))*HHBZ
+ P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
+ ELSE
+ HHPEZ=(P(I,4)-P(I,3))/HHBZ
+ P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
+ ENDIF
+ 1160 CONTINUE
+ ENDIF
+ DO 1180 I=NSAV+1,N
+ DO 1170 J=1,4
+ V(I,J)=V(IP,J)
+ 1170 CONTINUE
+ 1180 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYINDF
+C...Handles the fragmentation of a jet system (or a single
+C...jet) according to independent fragmentation models.
+
+ SUBROUTINE PYINDF(IP)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
+ &KFLO(2),PXO(2),PYO(2),WO(2)
+
+C.. MOPS error message
+ IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
+ &' are not treated as expected in independent fragmentation')
+
+C...Reset counters. Identify parton system and take copy. Check flavour.
+ NSAV=N
+ MSTU90=MSTU(90)
+ NJET=0
+ KQSUM=0
+ DO 100 J=1,5
+ DPS(J)=0D0
+ 100 CONTINUE
+ I=IP-1
+ 110 I=I+1
+ IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
+ CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 110
+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
+ IF(KQ.EQ.0) GOTO 110
+ NJET=NJET+1
+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
+ DO 120 J=1,5
+ K(NSAV+NJET,J)=K(I,J)
+ P(NSAV+NJET,J)=P(I,J)
+ DPS(J)=DPS(J)+P(I,J)
+ 120 CONTINUE
+ K(NSAV+NJET,3)=I
+ IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
+ &K(I+1,1).EQ.2)) GOTO 110
+ IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
+ CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Boost copied system to CM frame. Find CM energy and sum flavours.
+ IF(NJET.NE.1) THEN
+ MSTU(33)=1
+ CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
+ & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
+ ENDIF
+ PECM=0D0
+ DO 130 J=1,3
+ NFI(J)=0
+ 130 CONTINUE
+ DO 140 I=NSAV+1,NSAV+NJET
+ PECM=PECM+P(I,4)
+ KFA=IABS(K(I,2))
+ IF(KFA.LE.3) THEN
+ NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
+ ELSEIF(KFA.GT.1000) THEN
+ KFLA=MOD(KFA/1000,10)
+ KFLB=MOD(KFA/100,10)
+ IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
+ IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
+ ENDIF
+ 140 CONTINUE
+
+C...Loop over attempts made. Reset counters.
+ NTRY=0
+ 150 NTRY=NTRY+1
+ IF(NTRY.GT.200) THEN
+ CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ N=NSAV+NJET
+ MSTU(90)=MSTU90
+ DO 160 J=1,3
+ NFL(J)=NFI(J)
+ IFET(J)=0
+ KFLF(J)=0
+ 160 CONTINUE
+
+C...Loop over jets to be fragmented.
+ DO 230 IP1=NSAV+1,NSAV+NJET
+ MSTJ(91)=0
+ NSAV1=N
+ MSTU91=MSTU(90)
+
+C...Initial flavour and momentum values. Jet along +z axis.
+ KFLH=IABS(K(IP1,2))
+ IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
+ KFLO(2)=0
+ WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
+
+C...Initial values for quark or diquark jet.
+ 170 IF(IABS(K(IP1,2)).NE.21) THEN
+ NSTR=1
+ KFLO(1)=K(IP1,2)
+ CALL PYPTDI(0,PXO(1),PYO(1))
+ WO(1)=WF
+
+C...Initial values for gluon treated like random quark jet.
+ ELSEIF(MSTJ(2).LE.2) THEN
+ NSTR=1
+ IF(MSTJ(2).EQ.2) MSTJ(91)=1
+ KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
+ CALL PYPTDI(0,PXO(1),PYO(1))
+ WO(1)=WF
+
+C...Initial values for gluon treated like quark-antiquark jet pair,
+C...sharing energy according to Altarelli-Parisi splitting function.
+ ELSE
+ NSTR=2
+ IF(MSTJ(2).EQ.4) MSTJ(91)=1
+ KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
+ KFLO(2)=-KFLO(1)
+ CALL PYPTDI(0,PXO(1),PYO(1))
+ PXO(2)=-PXO(1)
+ PYO(2)=-PYO(1)
+ WO(1)=WF*PYR(0)**(1D0/3D0)
+ WO(2)=WF-WO(1)
+ ENDIF
+
+C...Initial values for rank, flavour, pT and W+.
+ DO 220 ISTR=1,NSTR
+ 180 I=N
+ MSTU(90)=MSTU91
+ IRANK=0
+ KFL1=KFLO(ISTR)
+ PX1=PXO(ISTR)
+ PY1=PYO(ISTR)
+ W=WO(ISTR)
+
+C...New hadron. Generate flavour and hadron species.
+ 190 I=I+1
+ IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
+ CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IRANK=IRANK+1
+ K(I,1)=1
+ K(I,3)=IP1
+ K(I,4)=0
+ K(I,5)=0
+ 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
+ IF(K(I,2).EQ.0) GOTO 180
+ IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
+ IF(PYR(0).GT.PARJ(19)) GOTO 200
+ ENDIF
+
+C...Find hadron mass. Generate four-momentum.
+ P(I,5)=PYMASS(K(I,2))
+ CALL PYPTDI(KFL1,PX2,PY2)
+ P(I,1)=PX1+PX2
+ P(I,2)=PY1+PY2
+ PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
+ CALL PYZDIS(KFL1,KFL2,PR,Z)
+ MZSAV=0
+ IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
+ MZSAV=1
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I
+ PARU(90+MSTU(90))=Z
+ ENDIF
+ P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
+ P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
+ IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
+ & P(I,3).LE.0.001D0) THEN
+ IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
+ P(I,3)=0.0001D0
+ P(I,4)=SQRT(PR)
+ Z=P(I,4)/W
+ ENDIF
+
+C...Remaining flavour and momentum.
+ KFL1=-KFL2
+ PX1=-PX2
+ PY1=-PY2
+ W=(1D0-Z)*W
+ DO 210 J=1,5
+ V(I,J)=0D0
+ 210 CONTINUE
+
+C...Check if pL acceptable. Go back for new hadron if enough energy.
+ IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
+ I=I-1
+ IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
+ ENDIF
+ IF(W.GT.PARJ(31)) GOTO 190
+ N=I
+ 220 CONTINUE
+ IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
+ IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
+
+C...Rotate jet to new direction.
+ THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
+ PHI=PYANGL(P(IP1,1),P(IP1,2))
+ MSTU(33)=1
+ CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
+ K(K(IP1,3),4)=NSAV1+1
+ K(K(IP1,3),5)=N
+
+C...End of jet generation loop. Skip conservation in some cases.
+ 230 CONTINUE
+ IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
+ IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
+
+C...Subtract off produced hadron flavours, finished if zero.
+ DO 240 I=NSAV+NJET+1,N
+ KFA=IABS(K(I,2))
+ KFLA=MOD(KFA/1000,10)
+ KFLB=MOD(KFA/100,10)
+ KFLC=MOD(KFA/10,10)
+ IF(KFLA.EQ.0) THEN
+ IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
+ IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
+ ELSE
+ IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
+ IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
+ IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
+ ENDIF
+ 240 CONTINUE
+ NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
+ IF(NREQ.EQ.0) GOTO 320
+
+C...Take away flavour of low-momentum particles until enough freedom.
+ NREM=0
+ 250 IREM=0
+ P2MIN=PECM**2
+ DO 260 I=NSAV+NJET+1,N
+ P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
+ IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
+ IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
+ 260 CONTINUE
+ IF(IREM.EQ.0) GOTO 150
+ K(IREM,1)=7
+ KFA=IABS(K(IREM,2))
+ KFLA=MOD(KFA/1000,10)
+ KFLB=MOD(KFA/100,10)
+ KFLC=MOD(KFA/10,10)
+ IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
+ IF(K(IREM,1).EQ.8) GOTO 250
+ IF(KFLA.EQ.0) THEN
+ ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
+ IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
+ IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
+ ELSE
+ IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
+ IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
+ IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
+ ENDIF
+ NREM=NREM+1
+ NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
+ IF(NREQ.GT.NREM) GOTO 250
+ DO 270 I=NSAV+NJET+1,N
+ IF(K(I,1).EQ.8) K(I,1)=1
+ 270 CONTINUE
+
+C...Find combination of existing and new flavours for hadron.
+ 280 NFET=2
+ IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
+ IF(NREQ.LT.NREM) NFET=1
+ IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
+ DO 290 J=1,NFET
+ IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
+ KFLF(J)=ISIGN(1,NFL(1))
+ IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
+ IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
+ 290 CONTINUE
+ IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
+ &GOTO 280
+ IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
+ &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
+ &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
+ IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
+ IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
+ IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
+ IF(NFET.LE.2) KFLF(3)=0
+ IF(KFLF(3).NE.0) THEN
+ KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
+ & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
+ IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
+ & KFLFC=KFLFC+ISIGN(2,KFLFC)
+ ELSE
+ KFLFC=KFLF(1)
+ ENDIF
+ CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
+ IF(KF.EQ.0) GOTO 280
+ DO 300 J=1,MAX(2,NFET)
+ NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
+ 300 CONTINUE
+
+C...Store hadron at random among free positions.
+ NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
+ DO 310 I=NSAV+NJET+1,N
+ IF(K(I,1).EQ.7) NPOS=NPOS-1
+ IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
+ K(I,1)=1
+ K(I,2)=KF
+ P(I,5)=PYMASS(K(I,2))
+ P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ 310 CONTINUE
+ NREM=NREM-1
+ NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
+ IF(NREM.GT.0) GOTO 280
+
+C...Compensate for missing momentum in global scheme (3 options).
+ 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
+ DO 340 J=1,3
+ PSI(J)=0D0
+ DO 330 I=NSAV+NJET+1,N
+ PSI(J)=PSI(J)+P(I,J)
+ 330 CONTINUE
+ 340 CONTINUE
+ PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
+ PWS=0D0
+ DO 350 I=NSAV+NJET+1,N
+ IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
+ IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
+ IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
+ 350 CONTINUE
+ DO 370 I=NSAV+NJET+1,N
+ IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
+ IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
+ IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
+ DO 360 J=1,3
+ P(I,J)=P(I,J)-PSI(J)*PW/PWS
+ 360 CONTINUE
+ P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ 370 CONTINUE
+
+C...Compensate for missing momentum withing each jet separately.
+ ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
+ DO 390 I=N+1,N+NJET
+ K(I,1)=0
+ DO 380 J=1,5
+ P(I,J)=0D0
+ 380 CONTINUE
+ 390 CONTINUE
+ DO 410 I=NSAV+NJET+1,N
+ IR1=K(I,3)
+ IR2=N+IR1-NSAV
+ K(IR2,1)=K(IR2,1)+1
+ PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
+ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
+ DO 400 J=1,3
+ P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
+ 400 CONTINUE
+ P(IR2,4)=P(IR2,4)+P(I,4)
+ P(IR2,5)=P(IR2,5)+PLS
+ 410 CONTINUE
+ PSS=0D0
+ DO 420 I=N+1,N+NJET
+ IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
+ 420 CONTINUE
+ DO 440 I=NSAV+NJET+1,N
+ IR1=K(I,3)
+ IR2=N+IR1-NSAV
+ PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
+ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
+ DO 430 J=1,3
+ P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
+ & PLS*P(IR1,J)
+ 430 CONTINUE
+ P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ 440 CONTINUE
+ ENDIF
+
+C...Scale momenta for energy conservation.
+ IF(MOD(MSTJ(3),5).NE.0) THEN
+ PMS=0D0
+ PES=0D0
+ PQS=0D0
+ DO 450 I=NSAV+NJET+1,N
+ PMS=PMS+P(I,5)
+ PES=PES+P(I,4)
+ PQS=PQS+P(I,5)**2/P(I,4)
+ 450 CONTINUE
+ IF(PMS.GE.PECM) GOTO 150
+ NECO=0
+ 460 NECO=NECO+1
+ PFAC=(PECM-PQS)/(PES-PQS)
+ PES=0D0
+ PQS=0D0
+ DO 480 I=NSAV+NJET+1,N
+ DO 470 J=1,3
+ P(I,J)=PFAC*P(I,J)
+ 470 CONTINUE
+ P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
+ PES=PES+P(I,4)
+ PQS=PQS+P(I,5)**2/P(I,4)
+ 480 CONTINUE
+ IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
+ ENDIF
+
+C...Origin of produced particles and parton daughter pointers.
+ 490 DO 500 I=NSAV+NJET+1,N
+ IF(MSTU(16).NE.2) K(I,3)=NSAV+1
+ IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
+ 500 CONTINUE
+ DO 510 I=NSAV+1,NSAV+NJET
+ I1=K(I,3)
+ K(I1,1)=K(I1,1)+10
+ IF(MSTU(16).NE.2) THEN
+ K(I1,4)=NSAV+1
+ K(I1,5)=NSAV+1
+ ELSE
+ K(I1,4)=K(I1,4)-NJET+1
+ K(I1,5)=K(I1,5)-NJET+1
+ IF(K(I1,5).LT.K(I1,4)) THEN
+ K(I1,4)=0
+ K(I1,5)=0
+ ENDIF
+ ENDIF
+ 510 CONTINUE
+
+C...Document independent fragmentation system. Remove copy of jets.
+ NSAV=NSAV+1
+ K(NSAV,1)=11
+ K(NSAV,2)=93
+ K(NSAV,3)=IP
+ K(NSAV,4)=NSAV+1
+ K(NSAV,5)=N-NJET+1
+ DO 520 J=1,4
+ P(NSAV,J)=DPS(J)
+ V(NSAV,J)=V(IP,J)
+ 520 CONTINUE
+ P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
+ V(NSAV,5)=0D0
+ DO 540 I=NSAV+NJET,N
+ DO 530 J=1,5
+ K(I-NJET+1,J)=K(I,J)
+ P(I-NJET+1,J)=P(I,J)
+ V(I-NJET+1,J)=V(I,J)
+ 530 CONTINUE
+ 540 CONTINUE
+ N=N-NJET+1
+ DO 550 IZ=MSTU90+1,MSTU(90)
+ MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
+ 550 CONTINUE
+
+C...Boost back particle system. Set production vertices.
+ IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
+ &DPS(2)/DPS(4),DPS(3)/DPS(4))
+ DO 570 I=NSAV+1,N
+ DO 560 J=1,4
+ V(I,J)=V(IP,J)
+ 560 CONTINUE
+ 570 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYDECY
+C...Handles the decay of unstable particles.
+
+ SUBROUTINE PYDECY(IP)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
+C...Local arrays.
+ DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
+ &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
+ CHARACTER CIDC*4
+ DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
+
+C...Functions: momentum in two-particle decays and four-product.
+ PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
+ FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
+
+C...Initial values.
+ NTRY=0
+ NSAV=N
+ KFA=IABS(K(IP,2))
+ KFS=ISIGN(1,K(IP,2))
+ KC=PYCOMP(KFA)
+ MSTJ(92)=0
+
+C...Choose lifetime and determine decay vertex.
+ IF(K(IP,1).EQ.5) THEN
+ V(IP,5)=0D0
+ ELSEIF(K(IP,1).NE.4) THEN
+ V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
+ ENDIF
+ DO 100 J=1,4
+ VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
+ 100 CONTINUE
+
+C...Determine whether decay allowed or not.
+ MOUT=0
+ IF(MSTJ(22).EQ.2) THEN
+ IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
+ ELSEIF(MSTJ(22).EQ.3) THEN
+ IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
+ ELSEIF(MSTJ(22).EQ.4) THEN
+ IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
+ IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
+ ENDIF
+ IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
+ K(IP,1)=4
+ RETURN
+ ENDIF
+
+C...Interface to external tau decay library (for tau polarization).
+ IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
+
+C...Starting values for pointers and momenta.
+ ITAU=IP
+ DO 110 J=1,4
+ PTAU(J)=P(ITAU,J)
+ PCMTAU(J)=P(ITAU,J)
+ 110 CONTINUE
+
+C...Iterate to find position and code of mother of tau.
+ IMTAU=ITAU
+ 120 IMTAU=K(IMTAU,3)
+
+ IF(IMTAU.EQ.0) THEN
+C...If no known origin then impossible to do anything further.
+ KFORIG=0
+ IORIG=0
+
+ ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
+C...If tau -> tau + gamma then add gamma energy and loop.
+ IF(K(K(IMTAU,4),2).EQ.22) THEN
+ DO 130 J=1,4
+ PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
+ 130 CONTINUE
+ ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
+ DO 140 J=1,4
+ PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
+ 140 CONTINUE
+ ENDIF
+ GOTO 120
+
+ ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
+C...If coming from weak decay of hadron then W is not stored in record,
+C...but can be reconstructed by adding neutrino momentum.
+ KFORIG=-ISIGN(24,K(ITAU,2))
+ IORIG=0
+ DO 160 II=K(IMTAU,4),K(IMTAU,5)
+ IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
+ DO 150 J=1,4
+ PCMTAU(J)=PCMTAU(J)+P(II,J)
+ 150 CONTINUE
+ ENDIF
+ 160 CONTINUE
+
+ ELSE
+C...If coming from resonance decay then find latest copy of this
+C...resonance (may not completely agree).
+ KFORIG=K(IMTAU,2)
+ IORIG=IMTAU
+ DO 170 II=IMTAU+1,IP-1
+ IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
+ & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
+ 170 CONTINUE
+ DO 180 J=1,4
+ PCMTAU(J)=P(IORIG,J)
+ 180 CONTINUE
+ ENDIF
+
+C...Boost tau to rest frame of production process (where known)
+C...and rotate it to sit along +z axis.
+ DO 190 J=1,3
+ DBETAU(J)=PCMTAU(J)/PCMTAU(4)
+ 190 CONTINUE
+ IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
+ & -DBETAU(2),-DBETAU(3))
+ PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
+ CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
+ THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
+ CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
+
+C...Call tau decay routine (if meaningful) and fill extra info.
+ IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
+ CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
+ DO 200 II=NSAV+1,NSAV+NDECAY
+ K(II,1)=1
+ K(II,3)=IP
+ K(II,4)=0
+ K(II,5)=0
+ 200 CONTINUE
+ N=NSAV+NDECAY
+ ENDIF
+
+C...Boost back decay tau and decay products.
+ DO 210 J=1,4
+ P(ITAU,J)=PTAU(J)
+ 210 CONTINUE
+ IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
+ CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
+ IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
+ & DBETAU(2),DBETAU(3))
+
+C...Skip past ordinary tau decay treatment.
+ MMAT=0
+ MBST=0
+ ND=0
+ GOTO 630
+ ENDIF
+ ENDIF
+
+C...B-Bbar mixing: flip sign of meson appropriately.
+ MMIX=0
+ IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
+ XBBMIX=PARJ(76)
+ IF(KFA.EQ.531) XBBMIX=PARJ(77)
+ IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
+ IF(MMIX.EQ.1) KFS=-KFS
+ ENDIF
+
+C...Check existence of decay channels. Particle/antiparticle rules.
+ KCA=KC
+ IF(MDCY(KC,2).GT.0) THEN
+ MDMDCY=MDME(MDCY(KC,2),2)
+ IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
+ ENDIF
+ IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
+ CALL PYERRM(9,'(PYDECY:) no decay channel defined')
+ RETURN
+ ENDIF
+ IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
+ IF(KCHG(KC,3).EQ.0) THEN
+ KFSP=1
+ KFSN=0
+ IF(PYR(0).GT.0.5D0) KFS=-KFS
+ ELSEIF(KFS.GT.0) THEN
+ KFSP=1
+ KFSN=0
+ ELSE
+ KFSP=0
+ KFSN=1
+ ENDIF
+
+C...Sum branching ratios of allowed decay channels.
+ 220 NOPE=0
+ BRSU=0D0
+ DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
+ IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
+ & KFSN*MDME(IDL,1).NE.3) GOTO 230
+ IF(MDME(IDL,2).GT.100) GOTO 230
+ NOPE=NOPE+1
+ BRSU=BRSU+BRAT(IDL)
+ 230 CONTINUE
+ IF(NOPE.EQ.0) THEN
+ CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
+ RETURN
+ ENDIF
+
+C...Select decay channel among allowed ones.
+ 240 RBR=BRSU*PYR(0)
+ IDL=MDCY(KCA,2)-1
+ 250 IDL=IDL+1
+ IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
+ &KFSN*MDME(IDL,1).NE.3) THEN
+ IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
+ ELSEIF(MDME(IDL,2).GT.100) THEN
+ IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
+ ELSE
+ IDC=IDL
+ RBR=RBR-BRAT(IDL)
+ IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
+ ENDIF
+
+C...Start readout of decay channel: matrix element, reset counters.
+ MMAT=MDME(IDC,2)
+ 260 NTRY=NTRY+1
+ IF(MOD(NTRY,200).EQ.0) THEN
+ WRITE(CIDC,'(I4)') IDC
+ CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
+ & CIDC)
+ GOTO 240
+ ENDIF
+ IF(NTRY.GT.1000) THEN
+ CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ I=N
+ NP=0
+ NQ=0
+ MBST=0
+ IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
+ DO 270 J=1,4
+ PV(1,J)=0D0
+ IF(MBST.EQ.0) PV(1,J)=P(IP,J)
+ 270 CONTINUE
+ IF(MBST.EQ.1) PV(1,4)=P(IP,5)
+ PV(1,5)=P(IP,5)
+ PS=0D0
+ PSQ=0D0
+ MREM=0
+ MHADDY=0
+ IF(KFA.GT.80) MHADDY=1
+C.. Random flavour and popcorn system memory.
+ IRNDMO=0
+ JTMO=0
+ MSTU(121)=0
+ MSTU(125)=10
+
+C...Read out decay products. Convert to standard flavour code.
+ JTMAX=5
+ IF(MDME(IDC+1,2).EQ.101) JTMAX=10
+ DO 280 JT=1,JTMAX
+ IF(JT.LE.5) KP=KFDP(IDC,JT)
+ IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
+ IF(KP.EQ.0) GOTO 280
+ KPA=IABS(KP)
+ KCP=PYCOMP(KPA)
+ IF(KPA.GT.80) MHADDY=1
+ IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
+ KFP=KP
+ ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
+ KFP=KFS*KP
+ ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
+ KFP=-KFS*MOD(KFA/10,10)
+ ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
+ KFP=KFS*(100*MOD(KFA/10,100)+3)
+ ELSEIF(KPA.EQ.81) THEN
+ KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
+ ELSEIF(KP.EQ.82) THEN
+ CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
+ IF(KFP.EQ.0) GOTO 260
+ KFP=-KFP
+ IRNDMO=1
+ MSTJ(93)=1
+ IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
+ ELSEIF(KP.EQ.-82) THEN
+ KFP=MSTU(124)
+ ENDIF
+ IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
+
+C...Add decay product to event record or to quark flavour list.
+ KFPA=IABS(KFP)
+ KQP=KCHG(KCP,2)
+ IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
+ NQ=NQ+1
+ KFLO(NQ)=KFP
+C...set rndmflav popcorn system pointer
+ IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
+ MSTJ(93)=2
+ PSQ=PSQ+PYMASS(KFLO(NQ))
+ ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
+ & MOD(NQ,2).EQ.1) THEN
+ NQ=NQ-1
+ PS=PS-P(I,5)
+ K(I,1)=1
+ KFI=K(I,2)
+ CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
+ IF(K(I,2).EQ.0) GOTO 260
+ MSTJ(93)=1
+ P(I,5)=PYMASS(K(I,2))
+ PS=PS+P(I,5)
+ ELSE
+ I=I+1
+ NP=NP+1
+ IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
+ IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
+ K(I,1)=1+MOD(NQ,2)
+ IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
+ IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
+ K(I,2)=KFP
+ K(I,3)=IP
+ K(I,4)=0
+ K(I,5)=0
+ P(I,5)=PYMASS(KFP)
+ PS=PS+P(I,5)
+ ENDIF
+ 280 CONTINUE
+
+C...Check masses for resonance decays.
+ IF(MHADDY.EQ.0) THEN
+ IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
+ ENDIF
+
+C...Choose decay multiplicity in phase space model.
+ 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
+ PSP=PS
+ CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
+ IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
+ 300 NTRY=NTRY+1
+C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
+ IF(IRNDMO.EQ.0) THEN
+ MSTU(121)=0
+ JTMO=0
+ ELSEIF(IRNDMO.EQ.1) THEN
+ IRNDMO=2
+ ELSE
+ GOTO 260
+ ENDIF
+ IF(NTRY.GT.1000) THEN
+ CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(MMAT.LE.20) THEN
+ GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
+ & SIN(PARU(2)*PYR(0))
+ ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
+ IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
+ IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
+ IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
+ IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
+ ELSE
+ ND=MMAT-20
+ ENDIF
+C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
+ MSTU(125)=ND-NQ/2
+ IF(MSTU(121).GT.MSTU(125)) GOTO 300
+
+C...Form hadrons from flavour content.
+ DO 310 JT=1,4
+ KFL1(JT)=KFLO(JT)
+ 310 CONTINUE
+ IF(ND.EQ.NP+NQ/2) GOTO 330
+ DO 320 I=N+NP+1,N+ND-NQ/2
+C.. Stick to started popcorn system, else pick side at random
+ JT=JTMO
+ IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
+ CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
+ IF(K(I,2).EQ.0) GOTO 300
+ MSTU(125)=MSTU(125)-1
+ JTMO=0
+ IF(MSTU(121).GT.0) JTMO=JT
+ KFL1(JT)=-KFL2
+ 320 CONTINUE
+ 330 JT=2
+ JT2=3
+ JT3=4
+ IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
+ IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
+ & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
+ IF(JT.EQ.3) JT2=2
+ IF(JT.EQ.4) JT3=2
+ CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
+ IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
+ IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
+ IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
+
+C...Check that sum of decay product masses not too large.
+ PS=PSP
+ DO 340 I=N+NP+1,N+ND
+ K(I,1)=1
+ K(I,3)=IP
+ K(I,4)=0
+ K(I,5)=0
+ P(I,5)=PYMASS(K(I,2))
+ PS=PS+P(I,5)
+ 340 CONTINUE
+ IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
+
+C...Rescale energy to subtract off spectator quark mass.
+ ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
+ & .AND.NP.GE.3) THEN
+ PS=PS-P(N+NP,5)
+ PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
+ DO 350 J=1,5
+ P(N+NP,J)=PQT*PV(1,J)
+ PV(1,J)=(1D0-PQT)*PV(1,J)
+ 350 CONTINUE
+ IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
+ ND=NP-1
+ MREM=1
+
+C...Fully specified final state: check mass broadening effects.
+ ELSE
+ IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
+ ND=NP
+ ENDIF
+
+C...Determine position of grandmother, number of sisters.
+ NM=0
+ KFAS=0
+ MSGN=0
+ IF(MMAT.EQ.3) THEN
+ IM=K(IP,3)
+ IF(IM.LT.0.OR.IM.GE.IP) IM=0
+ IF(IM.NE.0) KFAM=IABS(K(IM,2))
+ IF(IM.NE.0) THEN
+ DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
+ IF(K(IL,3).EQ.IM) NM=NM+1
+ IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
+ 360 CONTINUE
+ IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
+ & MOD(KFAM/1000,10).NE.0) NM=0
+ IF(NM.EQ.2) THEN
+ KFAS=IABS(K(ISIS,2))
+ IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
+ & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...Kinematics of one-particle decays.
+ IF(ND.EQ.1) THEN
+ DO 370 J=1,4
+ P(N+1,J)=P(IP,J)
+ 370 CONTINUE
+ GOTO 630
+ ENDIF
+
+C...Calculate maximum weight ND-particle decay.
+ PV(ND,5)=P(N+ND,5)
+ IF(ND.GE.3) THEN
+ WTMAX=1D0/WTCOR(ND-2)
+ PMAX=PV(1,5)-PS+P(N+ND,5)
+ PMIN=0D0
+ DO 380 IL=ND-1,1,-1
+ PMAX=PMAX+P(N+IL,5)
+ PMIN=PMIN+P(N+IL+1,5)
+ WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
+ 380 CONTINUE
+ ENDIF
+
+C...Find virtual gamma mass in Dalitz decay.
+ 390 IF(ND.EQ.2) THEN
+ ELSEIF(MMAT.EQ.2) THEN
+ PMES=4D0*PMAS(11,1)**2
+ PMRHO2=PMAS(131,1)**2
+ PGRHO2=PMAS(131,2)**2
+ 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
+ WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
+ & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
+ & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
+ IF(WT.LT.PYR(0)) GOTO 400
+ PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
+
+C...M-generator gives weight. If rejected, try again.
+ ELSE
+ 410 RORD(1)=1D0
+ DO 440 IL1=2,ND-1
+ RSAV=PYR(0)
+ DO 420 IL2=IL1-1,1,-1
+ IF(RSAV.LE.RORD(IL2)) GOTO 430
+ RORD(IL2+1)=RORD(IL2)
+ 420 CONTINUE
+ 430 RORD(IL2+1)=RSAV
+ 440 CONTINUE
+ RORD(ND)=0D0
+ WT=1D0
+ DO 450 IL=ND-1,1,-1
+ PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
+ & (PV(1,5)-PS)
+ WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
+ 450 CONTINUE
+ IF(WT.LT.PYR(0)*WTMAX) GOTO 410
+ ENDIF
+
+C...Perform two-particle decays in respective CM frame.
+ 460 DO 480 IL=1,ND-1
+ PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
+ UE(3)=2D0*PYR(0)-1D0
+ PHI=PARU(2)*PYR(0)
+ UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
+ UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
+ DO 470 J=1,3
+ P(N+IL,J)=PA*UE(J)
+ PV(IL+1,J)=-PA*UE(J)
+ 470 CONTINUE
+ P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
+ PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
+ 480 CONTINUE
+
+C...Lorentz transform decay products to lab frame.
+ DO 490 J=1,4
+ P(N+ND,J)=PV(ND,J)
+ 490 CONTINUE
+ DO 530 IL=ND-1,1,-1
+ DO 500 J=1,3
+ BE(J)=PV(IL,J)/PV(IL,4)
+ 500 CONTINUE
+ GA=PV(IL,4)/PV(IL,5)
+ DO 520 I=N+IL,N+ND
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO 510 J=1,3
+ P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
+ 510 CONTINUE
+ P(I,4)=GA*(P(I,4)+BEP)
+ 520 CONTINUE
+ 530 CONTINUE
+
+C...Check that no infinite loop in matrix element weight.
+ NTRY=NTRY+1
+ IF(NTRY.GT.800) GOTO 560
+
+C...Matrix elements for omega and phi decays.
+ IF(MMAT.EQ.1) THEN
+ WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
+ & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
+ & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
+ IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
+
+C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
+ ELSEIF(MMAT.EQ.2) THEN
+ FOUR12=FOUR(N+1,N+2)
+ FOUR13=FOUR(N+1,N+3)
+ WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
+ & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
+ IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
+
+C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
+C...V vector), of form cos**2(theta02) in V1 rest frame, and for
+C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
+ ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
+ FOUR10=FOUR(IP,IM)
+ FOUR12=FOUR(IP,N+1)
+ FOUR02=FOUR(IM,N+1)
+ PMS1=P(IP,5)**2
+ PMS0=P(IM,5)**2
+ PMS2=P(N+1,5)**2
+ IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
+ IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
+ & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
+ HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
+ HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
+ IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
+
+C...Matrix element for "onium" -> g + g + g or gamma + g + g.
+ ELSEIF(MMAT.EQ.4) THEN
+ HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
+ HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
+ HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
+ WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
+ & ((1D0-HX3)/(HX1*HX2))**2
+ IF(WT.LT.2D0*PYR(0)) GOTO 390
+ IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
+ & GOTO 390
+
+C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
+ ELSEIF(MMAT.EQ.41) THEN
+ HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
+ HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
+ IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
+
+C...Matrix elements for weak decays (only semileptonic for c and b)
+ ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
+ & .AND.ND.EQ.3) THEN
+ IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
+ IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
+ IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
+ ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
+ DO 550 J=1,4
+ P(N+NP+1,J)=0D0
+ DO 540 IS=N+3,N+NP
+ P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
+ 540 CONTINUE
+ 550 CONTINUE
+ IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
+ IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
+ IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
+ ENDIF
+
+C...Scale back energy and reattach spectator.
+ 560 IF(MREM.EQ.1) THEN
+ DO 570 J=1,5
+ PV(1,J)=PV(1,J)/(1D0-PQT)
+ 570 CONTINUE
+ ND=ND+1
+ MREM=0
+ ENDIF
+
+C...Low invariant mass for system with spectator quark gives particle,
+C...not two jets. Readjust momenta accordingly.
+ IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
+ MSTJ(93)=1
+ PM2=PYMASS(K(N+2,2))
+ MSTJ(93)=1
+ PM3=PYMASS(K(N+3,2))
+ IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
+ & (PARJ(32)+PM2+PM3)**2) GOTO 630
+ K(N+2,1)=1
+ KFTEMP=K(N+2,2)
+ CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
+ IF(K(N+2,2).EQ.0) GOTO 260
+ P(N+2,5)=PYMASS(K(N+2,2))
+ PS=P(N+1,5)+P(N+2,5)
+ PV(2,5)=P(N+2,5)
+ MMAT=0
+ ND=2
+ GOTO 460
+ ELSEIF(MMAT.EQ.44) THEN
+ MSTJ(93)=1
+ PM3=PYMASS(K(N+3,2))
+ MSTJ(93)=1
+ PM4=PYMASS(K(N+4,2))
+ IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
+ & (PARJ(32)+PM3+PM4)**2) GOTO 600
+ K(N+3,1)=1
+ KFTEMP=K(N+3,2)
+ CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
+ IF(K(N+3,2).EQ.0) GOTO 260
+ P(N+3,5)=PYMASS(K(N+3,2))
+ DO 580 J=1,3
+ P(N+3,J)=P(N+3,J)+P(N+4,J)
+ 580 CONTINUE
+ P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
+ HA=P(N+1,4)**2-P(N+2,4)**2
+ HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
+ HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
+ & (P(N+1,3)-P(N+2,3))**2
+ HD=(PV(1,4)-P(N+3,4))**2
+ HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
+ HF=HD*HC-HB**2
+ HG=HD*HC-HA*HB
+ HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
+ DO 590 J=1,3
+ PCOR=HH*(P(N+1,J)-P(N+2,J))
+ P(N+1,J)=P(N+1,J)+PCOR
+ P(N+2,J)=P(N+2,J)-PCOR
+ 590 CONTINUE
+ P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
+ P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
+ ND=ND-1
+ ENDIF
+
+C...Check invariant mass of W jets. May give one particle or start over.
+ 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
+ &.AND.IABS(K(N+1,2)).LT.10) THEN
+ PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
+ MSTJ(93)=1
+ PM1=PYMASS(K(N+1,2))
+ MSTJ(93)=1
+ PM2=PYMASS(K(N+2,2))
+ IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
+ KFLDUM=INT(1.5D0+PYR(0))
+ CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
+ CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
+ IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
+ PSM=PYMASS(KF1)+PYMASS(KF2)
+ IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
+ IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
+ IF(MMAT.EQ.48) GOTO 390
+ IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
+ K(N+1,1)=1
+ KFTEMP=K(N+1,2)
+ CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
+ IF(K(N+1,2).EQ.0) GOTO 260
+ P(N+1,5)=PYMASS(K(N+1,2))
+ K(N+2,2)=K(N+3,2)
+ P(N+2,5)=P(N+3,5)
+ PS=P(N+1,5)+P(N+2,5)
+ IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
+ PV(2,5)=P(N+3,5)
+ MMAT=0
+ ND=2
+ GOTO 460
+ ENDIF
+
+C...Phase space decay of partons from W decay.
+ 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
+ KFLO(1)=K(N+1,2)
+ KFLO(2)=K(N+2,2)
+ K(N+1,1)=K(N+3,1)
+ K(N+1,2)=K(N+3,2)
+ DO 620 J=1,5
+ PV(1,J)=P(N+1,J)+P(N+2,J)
+ P(N+1,J)=P(N+3,J)
+ 620 CONTINUE
+ PV(1,5)=PMR
+ N=N+1
+ NP=0
+ NQ=2
+ PS=0D0
+ MSTJ(93)=2
+ PSQ=PYMASS(KFLO(1))
+ MSTJ(93)=2
+ PSQ=PSQ+PYMASS(KFLO(2))
+ MMAT=11
+ GOTO 290
+ ENDIF
+
+C...Boost back for rapidly moving particle.
+ 630 N=N+ND
+ IF(MBST.EQ.1) THEN
+ DO 640 J=1,3
+ BE(J)=P(IP,J)/P(IP,4)
+ 640 CONTINUE
+ GA=P(IP,4)/P(IP,5)
+ DO 660 I=NSAV+1,N
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO 650 J=1,3
+ P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
+ 650 CONTINUE
+ P(I,4)=GA*(P(I,4)+BEP)
+ 660 CONTINUE
+ ENDIF
+
+C...Fill in position of decay vertex.
+ DO 680 I=NSAV+1,N
+ DO 670 J=1,4
+ V(I,J)=VDCY(J)
+ 670 CONTINUE
+ V(I,5)=0D0
+ 680 CONTINUE
+
+C...Set up for parton shower evolution from jets.
+ IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
+ K(NSAV+1,1)=3
+ K(NSAV+2,1)=3
+ K(NSAV+3,1)=3
+ K(NSAV+1,4)=MSTU(5)*(NSAV+2)
+ K(NSAV+1,5)=MSTU(5)*(NSAV+3)
+ K(NSAV+2,4)=MSTU(5)*(NSAV+3)
+ K(NSAV+2,5)=MSTU(5)*(NSAV+1)
+ K(NSAV+3,4)=MSTU(5)*(NSAV+1)
+ K(NSAV+3,5)=MSTU(5)*(NSAV+2)
+ MSTJ(92)=-(NSAV+1)
+ ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
+ K(NSAV+2,1)=3
+ K(NSAV+3,1)=3
+ K(NSAV+2,4)=MSTU(5)*(NSAV+3)
+ K(NSAV+2,5)=MSTU(5)*(NSAV+3)
+ K(NSAV+3,4)=MSTU(5)*(NSAV+2)
+ K(NSAV+3,5)=MSTU(5)*(NSAV+2)
+ MSTJ(92)=NSAV+2
+ ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
+ & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
+ K(NSAV+1,1)=3
+ K(NSAV+2,1)=3
+ K(NSAV+1,4)=MSTU(5)*(NSAV+2)
+ K(NSAV+1,5)=MSTU(5)*(NSAV+2)
+ K(NSAV+2,4)=MSTU(5)*(NSAV+1)
+ K(NSAV+2,5)=MSTU(5)*(NSAV+1)
+ MSTJ(92)=NSAV+1
+ ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
+ & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
+ MSTJ(92)=NSAV+1
+ ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
+ & THEN
+ K(NSAV+1,1)=3
+ K(NSAV+2,1)=3
+ K(NSAV+3,1)=3
+ KCP=PYCOMP(K(NSAV+1,2))
+ KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
+ JCON=4
+ IF(KQP.LT.0) JCON=5
+ K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
+ K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
+ K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
+ K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
+ MSTJ(92)=NSAV+1
+ ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
+ K(NSAV+1,1)=3
+ K(NSAV+3,1)=3
+ K(NSAV+1,4)=MSTU(5)*(NSAV+3)
+ K(NSAV+1,5)=MSTU(5)*(NSAV+3)
+ K(NSAV+3,4)=MSTU(5)*(NSAV+1)
+ K(NSAV+3,5)=MSTU(5)*(NSAV+1)
+ MSTJ(92)=NSAV+1
+ ENDIF
+
+C...Mark decayed particle; special option for B-Bbar mixing.
+ IF(K(IP,1).EQ.5) K(IP,1)=15
+ IF(K(IP,1).LE.10) K(IP,1)=11
+ IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
+ K(IP,4)=NSAV+1
+ K(IP,5)=N
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYDCYK
+C...Handles flavour production in the decay of unstable particles
+C...and small string clusters.
+
+ SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+
+C.. Call PYKFDI directly if no popcorn option is on
+ IF(MSTJ(12).LT.2) THEN
+ CALL PYKFDI(KFL1,KFL2,KFL3,KF)
+ MSTU(124)=KFL3
+ RETURN
+ ENDIF
+
+ KFL3=0
+ KF=0
+ IF(KFL1.EQ.0) RETURN
+ KF1A=IABS(KFL1)
+ KF2A=IABS(KFL2)
+
+ NSTO=130
+ NMAX=MIN(MSTU(125),10)
+
+C.. Identify rank 0 cluster qq
+ IRANK=1
+ IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
+
+ IF(KF2A.GT.0)THEN
+C.. Join jets: Fails if store not empty
+ IF(MSTU(121).GT.0) THEN
+ MSTU(121)=0
+ RETURN
+ ENDIF
+ CALL PYKFDI(KFL1,KFL2,KFL3,KF)
+ ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
+C.. Pick popcorn meson from store, return same qq, decrease store
+ KF=MSTU(NSTO+MSTU(121))
+ KFL3=-KFL1
+ MSTU(121)=MSTU(121)-1
+ ELSE
+C.. Generate new flavour. Then done if no diquark is generated
+ 100 CALL PYKFDI(KFL1,0,KFL3,KF)
+ IF(MSTU(121).EQ.-1) GOTO 100
+ MSTU(124)=KFL3
+ IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
+
+C.. Simple case if no dynamical popcorn suppressions are considered
+ IF(MSTJ(12).LT.4) THEN
+ IF(MSTU(121).EQ.0) RETURN
+ NMES=1
+ KFPREV=-KFL3
+ CALL PYKFDI(KFPREV,0,KFL3,KFM)
+C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
+ IF(IABS(KFL3).LE.10)THEN
+ KFL3=-KFPREV
+ RETURN
+ ENDIF
+ GOTO 120
+ ENDIF
+
+C test output qq against fake Gamma, then return if no popcorn.
+ GB=2D0
+ IF(IRANK.NE.0)THEN
+ CALL PYZDIS(1,2103,5D0,Z)
+ GB=3D0*(1D0-Z)/Z
+ IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
+ MSTU(121)=0
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF(MSTU(121).EQ.0) RETURN
+
+C..Set store size memory. Pick fake dynamical variables of qq.
+ NMES=MSTU(121)
+ CALL PYPTDI(1,PX3,PY3)
+ X=1D0
+ POPM=0D0
+ G=GB
+ POPG=GB
+
+C.. Pick next popcorn meson, test with fake dynamical variables
+ 110 KFPREV=-KFL3
+ PX1=-PX3
+ PY1=-PY3
+ CALL PYKFDI(KFPREV,0,KFL3,KFM)
+ IF(MSTU(121).EQ.-1) GOTO 100
+ CALL PYPTDI(KFL3,PX3,PY3)
+ PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
+ CALL PYZDIS(KFPREV,KFL3,PM,Z)
+ G=(1D0-Z)*(G+PM/Z)
+ X=(1D0-Z)*X
+
+ PTST=1D0
+ GTST=1D0
+ RTST=PYR(0)
+ IF(MSTJ(12).GT.4)THEN
+ POPMN=SQRT((1D0-X)*(G/X-GB))
+ POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
+ PTST=EXP((POPM-POPMN)*PARF(193))
+ POPM=POPMN
+ ENDIF
+ IF(IRANK.NE.0)THEN
+ POPGN=X*GB
+ GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
+ POPG=POPGN
+ ENDIF
+ IF(RTST.GT.PTST*GTST)THEN
+ MSTU(121)=0
+ IF(RTST.GT.PTST) MSTU(121)=-1
+ GOTO 100
+ ENDIF
+
+C.. Store meson
+ 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
+ IF(MSTU(121).GT.0) GOTO 110
+
+C.. Test accepted system size. If OK set global popcorn size variable.
+ IF(NMES.GT.NMAX)THEN
+ KF=0
+ KFL3=0
+ RETURN
+ ENDIF
+ MSTU(121)=NMES
+ ENDIF
+
+ RETURN
+ END
+
+C********************************************************************
+
+C...PYKFDI
+C...Generates a new flavour pair and combines off a hadron
+
+ SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION PD(7)
+
+ IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
+
+C...Default flavour values. Input consistency checks.
+ KF1A=IABS(KFL1)
+ KF2A=IABS(KFL2)
+ KFL3=0
+ KF=0
+ IF(KF1A.EQ.0) RETURN
+ IF(KF2A.NE.0)THEN
+ IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
+ IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
+ IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
+ ENDIF
+
+C...Check if tabulated flavour probabilities are to be used.
+ IF(MSTJ(15).EQ.1) THEN
+ IF(MSTJ(12).GE.5) CALL PYERRM(29,
+ & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
+ & ' together with MSTJ(12)>=5 modification')
+ KTAB1=-1
+ IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
+ KFL1A=MOD(KF1A/1000,10)
+ KFL1B=MOD(KF1A/100,10)
+ KFL1S=MOD(KF1A,10)
+ IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
+ & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
+ IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
+ IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
+ KTAB2=0
+ IF(KF2A.NE.0) THEN
+ KTAB2=-1
+ IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
+ KFL2A=MOD(KF2A/1000,10)
+ KFL2B=MOD(KF2A/100,10)
+ KFL2S=MOD(KF2A,10)
+ IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
+ & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
+ IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
+ ENDIF
+ IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
+ ENDIF
+
+C.. Recognize rank 0 diquark case
+ 100 IRANK=1
+ KFDIQ=MAX(KF1A,KF2A)
+ IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
+
+C.. Join two flavours to meson or baryon. Test for popcorn.
+ IF(KF2A.GT.0)THEN
+ MBARY=0
+ IF(KFDIQ.GT.10) THEN
+ IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
+ & CALL PYNMES(KFDIQ)
+ IF(MSTU(121).NE.0) RETURN
+ MBARY=2
+ ENDIF
+ KFQOLD=KF1A
+ KFQVER=KF2A
+ GOTO 130
+ ENDIF
+
+C.. Separate incoming flavours, curtain flavour consistency check
+ KFIN=KFL1
+ KFQOLD=KF1A
+ KFQPOP=KF1A/10000
+ IF(KF1A.GT.10)THEN
+ KFIN=-KFL1
+ KFL1A=MOD(KF1A/1000,10)
+ KFL1B=MOD(KF1A/100,10)
+ IF(IRANK.EQ.0)THEN
+ QAWT=1D0
+ IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
+ IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
+ KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
+ ENDIF
+ IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
+ KFQOLD=KFL1A+KFL1B-KFQPOP
+ ENDIF
+
+C...Meson/baryon choice. Set number of mesons if starting a popcorn
+C...system.
+ 110 MBARY=0
+ IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
+ IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
+ MBARY=1
+ CALL PYNMES(0)
+ ENDIF
+ ELSEIF(KF1A.GT.10)THEN
+ MBARY=2
+ IF(IRANK.EQ.0) CALL PYNMES(KF1A)
+ IF(MSTU(121).GT.0) MBARY=-1
+ ENDIF
+
+C..x->H+q: Choose single vertex quark. Jump to form hadron.
+ IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
+ KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
+ KFL3=ISIGN(KFQVER,-KFIN)
+ GOTO 130
+ ENDIF
+
+C..x->H+qq: (IDW=proper PARF position for diquark weights)
+ IDW=160
+C.. q->B+qq: Get curtain quark, different weights for q->B+B and
+C.. q->B+M+...
+ IF(MBARY.EQ.1)THEN
+ IF(MSTU(121).EQ.0) IDW=150
+ SQWT=PARF(IDW+1)
+ IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
+ KFQPOP=1+INT((2D0+SQWT)*PYR(0))
+C.. Shift to s-curtain parameters if needed
+ IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
+ PARF(194)=PARF(138)*PARF(139)
+ PARF(193)=PARJ(8)+PARJ(9)
+ ENDIF
+ ENDIF
+
+C.. x->H+qq: Get vertex quark
+ IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
+ IDW=MSTU(122)
+ MSTU(121)=MSTU(121)-1
+ IF(IDW.EQ.170) THEN
+ IF(MSTU(121).EQ.0)THEN
+ IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
+ ELSE
+ IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
+ ENDIF
+ ELSE
+ IF(MSTU(121).EQ.0)THEN
+ IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
+ ELSE
+ IPOS=3*5+5*4+MIN(KFQOLD-1,4)
+ ENDIF
+ ENDIF
+ IPOS=200+30*IPOS+1
+
+ IMES=-1
+ RMES=PYR(0)*PARF(194)
+ 120 IMES=IMES+1
+ RMES=RMES-PARF(IPOS+IMES)
+ IF(IMES.EQ.30) THEN
+ MSTU(121)=-1
+ KF=-111
+ RETURN
+ ENDIF
+ IF(RMES.GT.0D0) GOTO 120
+ KMUL=IMES/5
+ KFJ=2*KMUL+1
+ IF(KMUL.EQ.2) KFJ=10003
+ IF(KMUL.EQ.3) KFJ=10001
+ IF(KMUL.EQ.4) KFJ=20003
+ IF(KMUL.EQ.5) KFJ=5
+ IDIAG=0
+ KFQVER=MOD(IMES,5)+1
+ IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
+ IF(KFQVER.GT.3)THEN
+ IDIAG=KFQVER-3
+ KFQVER=KFQOLD
+ ENDIF
+ ELSE
+ IF(MBARY.EQ.-1) IDW=170
+ SQWT=PARF(IDW+2)
+ IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
+ IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
+ KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
+ IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
+ KFQVER=KFQPOP
+ IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
+ ENDIF
+ ENDIF
+
+C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
+ KFLDS=3
+ IF(KFQPOP.NE.KFQVER)THEN
+ SWT=PARF(IDW+7)
+ IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
+ IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
+ IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
+ ENDIF
+ KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
+ & +10000*KFQPOP
+ KFL3=ISIGN(KFDIQ,KFIN)
+
+C..x->M+y: flavour for meson.
+ 130 IF(MBARY.LE.0)THEN
+ KFLA=MAX(KFQOLD,KFQVER)
+ KFLB=MIN(KFQOLD,KFQVER)
+ KFS=ISIGN(1,KFL1)
+ IF(KFLA.NE.KFQOLD) KFS=-KFS
+C... Form meson, with spin and flavour mixing for diagonal states.
+ IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
+ IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
+ IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
+ RETURN
+ ENDIF
+ IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
+ IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
+ IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
+ IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
+ IF(PYR(0).LT.PARJ(14)) KMUL=2
+ ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
+ RMUL=PYR(0)
+ IF(RMUL.LT.PARJ(15)) KMUL=3
+ IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
+ IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
+ ENDIF
+ KFLS=3
+ IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
+ IF(KMUL.EQ.5) KFLS=5
+ IF(KFLA.NE.KFLB)THEN
+ KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
+ ELSE
+ RMIX=PYR(0)
+ IMIX=2*KFLA+10*KMUL
+ IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
+ & INT(RMIX+PARF(IMIX)))+KFLS
+ IF(KFLA.GE.4) KF=110*KFLA+KFLS
+ ENDIF
+ IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
+ IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
+
+C..Optional extra suppression of eta and eta'.
+C..Allow shift to qq->B+q in old version (set IRANK to 0)
+ IF(KF.EQ.221.OR.KF.EQ.331)THEN
+ IF(PYR(0).GT.PARJ(25+KF/300))THEN
+ IF(KF2A.GT.0) GOTO 130
+ IF(MSTJ(12).LT.4) IRANK=0
+ GOTO 110
+ ENDIF
+ ENDIF
+ MSTU(121)=0
+
+C.. x->B+y: Flavour for baryon
+ ELSE
+ KFLA=KFQVER
+ IF(KF1A.LE.10) KFLA=KFQOLD
+ KFLB=MOD(KFDIQ/1000,10)
+ KFLC=MOD(KFDIQ/100,10)
+ KFLDS=MOD(KFDIQ,10)
+ KFLD=MAX(KFLA,KFLB,KFLC)
+ KFLF=MIN(KFLA,KFLB,KFLC)
+ KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
+
+C... SU(6) factors for formation of baryon.
+ KBARY=3
+ KDMAX=5
+ KFLG=KFLB
+ IF(KFLB.NE.KFLC)THEN
+ KBARY=2*KFLDS-1
+ KDMAX=1+KFLDS/2
+ IF(KFLB.GT.2) KDMAX=KDMAX+2
+ ENDIF
+ IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
+ KBARY=KBARY+1
+ KFLG=KFLA
+ ENDIF
+
+ SU6MAX=PARF(140+KDMAX)
+ SU6DEC=PARJ(18)
+ SU6S =PARF(146)
+ IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
+ SU6MAX=1D0
+ SU6DEC=1D0
+ SU6S =1D0
+ ENDIF
+ SU6OCT=PARF(60+KBARY)
+ IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
+ SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
+ IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
+ ELSE
+ IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
+ ENDIF
+ SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
+
+C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
+ IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
+ MSTU(121)=0
+ IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
+ GOTO 110
+ ENDIF
+
+C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
+ KSIG=1
+ KFLS=2
+ IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
+ IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
+ KSIG=KFLDS/3
+ IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
+ ENDIF
+ KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
+ IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
+ ENDIF
+ RETURN
+
+C...Use tabulated probabilities to select new flavour and hadron.
+ 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
+ KT3L=1
+ KT3U=6
+ ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
+ KT3L=1
+ KT3U=6
+ ELSEIF(KTAB2.EQ.0) THEN
+ KT3L=1
+ KT3U=22
+ ELSE
+ KT3L=KTAB2
+ KT3U=KTAB2
+ ENDIF
+ RFL=0D0
+ DO 160 KTS=0,2
+ DO 150 KT3=KT3L,KT3U
+ RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
+ 150 CONTINUE
+ 160 CONTINUE
+ RFL=PYR(0)*RFL
+ DO 180 KTS=0,2
+ KTABS=KTS
+ DO 170 KT3=KT3L,KT3U
+ KTAB3=KT3
+ RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
+ IF(RFL.LE.0D0) GOTO 190
+ 170 CONTINUE
+ 180 CONTINUE
+ 190 CONTINUE
+
+C...Reconstruct flavour of produced quark/diquark.
+ IF(KTAB3.LE.6) THEN
+ KFL3A=KTAB3
+ KFL3B=0
+ KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
+ ELSE
+ KFL3A=1
+ IF(KTAB3.GE.8) KFL3A=2
+ IF(KTAB3.GE.11) KFL3A=3
+ IF(KTAB3.GE.16) KFL3A=4
+ KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
+ KFL3=1000*KFL3A+100*KFL3B+1
+ IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
+ & KFL3+2
+ KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
+ ENDIF
+
+C...Reconstruct meson code.
+ IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
+ &KFL3B.NE.0)) THEN
+ RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
+ & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
+ KF=110+2*KTABS+1
+ IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
+ IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
+ & 25*KTABS)) KF=330+2*KTABS+1
+ ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
+ KFLA=MAX(KTAB1,KTAB3)
+ KFLB=MIN(KTAB1,KTAB3)
+ KFS=ISIGN(1,KFL1)
+ IF(KFLA.NE.KF1A) KFS=-KFS
+ KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
+ ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
+ KFS=ISIGN(1,KFL1)
+ IF(KFL1A.EQ.KFL3A) THEN
+ KFLA=MAX(KFL1B,KFL3B)
+ KFLB=MIN(KFL1B,KFL3B)
+ IF(KFLA.NE.KFL1B) KFS=-KFS
+ ELSEIF(KFL1A.EQ.KFL3B) THEN
+ KFLA=KFL3A
+ KFLB=KFL1B
+ KFS=-KFS
+ ELSEIF(KFL1B.EQ.KFL3A) THEN
+ KFLA=KFL1A
+ KFLB=KFL3B
+ ELSEIF(KFL1B.EQ.KFL3B) THEN
+ KFLA=MAX(KFL1A,KFL3A)
+ KFLB=MIN(KFL1A,KFL3A)
+ IF(KFLA.NE.KFL1A) KFS=-KFS
+ ELSE
+ CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
+ GOTO 100
+ ENDIF
+ KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
+
+C...Reconstruct baryon code.
+ ELSE
+ IF(KTAB1.GE.7) THEN
+ KFLA=KFL3A
+ KFLB=KFL1A
+ KFLC=KFL1B
+ ELSE
+ KFLA=KFL1A
+ KFLB=KFL3A
+ KFLC=KFL3B
+ ENDIF
+ KFLD=MAX(KFLA,KFLB,KFLC)
+ KFLF=MIN(KFLA,KFLB,KFLC)
+ KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
+ IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
+ IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
+ ENDIF
+
+C...Check that constructed flavour code is an allowed one.
+ IF(KFL2.NE.0) KFL3=0
+ KC=PYCOMP(KF)
+ IF(KC.EQ.0) THEN
+ CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
+ & 'failed')
+ GOTO 100
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYNMES
+C...Generates number of popcorn mesons and stores some relevant
+C...parameters.
+
+ SUBROUTINE PYNMES(KFDIQ)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+ MSTU(121)=0
+ IF(MSTJ(12).LT.2) RETURN
+
+C..Old version: Get 1 or 0 popcorn mesons
+ IF(MSTJ(12).LT.5)THEN
+ POPWT=PARF(131)
+ IF(KFDIQ.NE.0) THEN
+ KFDIQA=IABS(KFDIQ)
+ KFA=MOD(KFDIQA/1000,10)
+ KFB=MOD(KFDIQA/100,10)
+ KFS=MOD(KFDIQA,10)
+ POPWT=PARF(132)
+ IF(KFA.EQ.3) POPWT=PARF(133)
+ IF(KFB.EQ.3) POPWT=PARF(134)
+ IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
+ ENDIF
+ MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
+ RETURN
+ ENDIF
+
+C..New version: Store popcorn- or rank 0 diquark parameters
+ MSTU(122)=170
+ PARF(193)=PARJ(8)
+ PARF(194)=PARF(139)
+ IF(KFDIQ.NE.0) THEN
+ MSTU(122)=180
+ PARF(193)=PARJ(10)
+ PARF(194)=PARF(140)
+ ENDIF
+ IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
+ IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
+ & '(PYNMES:) Neglecting too large popcorn possibility')
+ RETURN
+ ENDIF
+
+C..New version: Get number of popcorn mesons
+ 100 RTST=PYR(0)
+ MSTU(121)=-1
+ 110 MSTU(121)=MSTU(121)+1
+ RTST=RTST/PARF(194)
+ IF(RTST.LT.1D0) GOTO 110
+ IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
+ & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYKFIN
+C...Precalculates a set of diquark and popcorn weights.
+C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
+
+ SUBROUTINE PYKFIN
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+ DIMENSION SU6(12),SU6M(7)
+
+ MSTU(123)=1
+C..Curtain tunneling factor T(D,q)/T(ud0,u).
+ IF(MSTJ(12).GE.5) THEN
+ PMUD0=PYMASS(2101)
+ PMUD1=PYMASS(2103)-PMUD0
+ PMUS0=PYMASS(3201)-PMUD0
+ PMUS1=PYMASS(3203)-PMUS0-PMUD0
+ PMSS1=PYMASS(3303)-PMUS0-PMUD0
+ PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
+ PARF(152)=EXP(-PARJ(8)*PMUS0)
+ PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
+ PARF(154)=EXP(-PARJ(8)*PMUD1)
+ PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
+ PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
+ PARF(157)=PARF(154)
+ ELSE
+ PAR2M=SQRT(PARJ(2))
+ PAR3M=SQRT(PARJ(3))
+ PAR4M=SQRT(PARJ(4))
+ PARF(151)=PAR2M*PAR3M
+ PARF(152)=PAR3M
+ PARF(153)=PAR2M*PARJ(3)*PAR4M
+ PARF(154)=PAR4M
+ PARF(155)=PAR4M*PARF(151)
+ PARF(156)=PAR4M*PARF(152)
+ PARF(157)=PAR4M
+ ENDIF
+
+C.. Total tunneling factor tau(D,q)=T*vertex*spin.
+ PARF(161)=PARF(151)
+ PARF(162)=PARJ(2)*PARF(152)
+ PARF(163)=PARJ(2)*6D0*PARF(153)
+ PARF(164)=6D0*PARF(154)
+ PARF(165)=3D0*PARF(155)
+ PARF(166)=PARJ(2)*3D0*PARF(156)
+ PARF(167)=3D0*PARF(157)
+
+ DO 100 I=1,7
+ PARF(150+I)=PARF(150+I)*PARF(160+I)
+ 100 CONTINUE
+
+C..Modified SU(6) factors.
+ PARF(146)=1D0
+ IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
+ IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
+ & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
+ DO 110 I=1,6
+ SU6(I)=PARF(60+I)
+ SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
+ 110 CONTINUE
+ SU6(8)=SU6(2)*4/(3*PARF(146)+1)
+ SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
+ DO 120 I=1,6
+ SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
+ SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
+ 120 CONTINUE
+
+C..Total diquark quark*SU(6).
+ PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
+ PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
+ PARF(172)=PARF(171)
+ PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
+ PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
+ PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
+ PARF(176)=PARF(175)
+ PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
+
+C..SU(6)max q q' s,c,b
+ SU6MUD =MAX(SU6(1) , SU6(8) )
+ SU6M(7)=MAX(SU6(5) , SU6(12))
+ SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
+ SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
+ SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
+ SU6M(2)=SU6M(1)
+ SU6M(3)=SU6M(4)
+ SU6M(6)=SU6M(5)
+
+ IF(MSTJ(12).GE.5)THEN
+C..New version: tau for rank 0 diquark.
+ PARF(181)=EXP(-PARJ(10)*PMUS0)
+ PARF(182)=PARJ(2)*PARF(181)
+ PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
+ PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
+ PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
+ PARF(186)=PARJ(2)*PARF(185)
+ PARF(187)=2D0*PARF(184)
+
+C..New version: s/u curtain ratios.
+ WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
+ PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
+ WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
+ PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
+ PARF(137)=(PARF(181)+PARF(185))*
+ & (2D0+PARF(183)/(2D0*PARF(185)))/WU
+ ELSE
+C..Old version: Shuffle PARJ(7) into tau
+ PARF(162)=PARF(162)*PARJ(7)
+ PARF(163)=PARF(163)*PARJ(7)
+ PARF(166)=PARF(166)*PARJ(7)
+
+C..Old version: s/u curtain ratios.
+ WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
+ PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
+ PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
+ PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
+ ENDIF
+
+C..Combine SU(6), SU(6)max, tau and T into proper products
+ DO 140 I=1,7
+ PARF(180+I)=PARF(180+I)*PARF(170+I)
+ PARF(170+I)=PARF(170+I)*PARF(160+I)
+ PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
+ PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
+ 140 CONTINUE
+
+C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
+ PARF(141)=SU6MUD
+ PARF(142)=SU6M(7)
+ PARF(143)=SU6M(1)
+ PARF(144)=SU6M(5)
+ PARF(145)=SU6M(3)
+
+ IF(MSTJ(12).LT.5)THEN
+C.. Old version: Resulting popcorn weights.
+ PARF(138)=PARJ(6)
+ WS=PARF(135)*PARF(138)
+ WQ=WU*PARJ(5)/3D0
+ PARF(132)=WQ*PARF(167)/PARF(157)
+ PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
+ PARF(134)=WQ*WS*PARF(163)/PARF(153)
+ PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
+ & PARF(164)+WS*PARF(163)/2D0)/
+ & ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
+ ELSE
+C..New version: Store weights for popcorn mesons,
+C..get prel. popcorn weights.
+ DO 150 IPOS=201,1400
+ PARF(IPOS)=0D0
+ 150 CONTINUE
+ DO 160 I=138,140
+ PARF(I)=0D0
+ 160 CONTINUE
+ IPOS=200
+ PARF(193)=PARJ(8)
+ DO 240 MR=170,180,10
+ IF(MR.EQ.180) PARF(193)=PARJ(10)
+ SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
+ QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
+ DO 230 NMES=0,1
+ IF(NMES.EQ.1) SQWT=PARJ(2)
+ DO 220 KFQPOP=1,4
+ IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
+ IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
+ SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
+ QQWT=0.5D0
+ IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
+ IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
+ ENDIF
+ DO 210 KFQOLD =1,5
+ IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
+ IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
+ IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
+ WTTOT=0D0
+ WTFAIL=0D0
+ DO 190 KMUL=0,5
+ PJWT=PARJ(12+KMUL)
+ IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
+ IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
+ IF(PJWT.LE.0D0) GOTO 190
+ IF(PJWT.GT.1D0) PJWT=1D0
+ IMES=5*KMUL
+ IMIX=2*KFQOLD+10*KMUL
+ KFJ=2*KMUL+1
+ IF(KMUL.EQ.2) KFJ=10003
+ IF(KMUL.EQ.3) KFJ=10001
+ IF(KMUL.EQ.4) KFJ=20003
+ IF(KMUL.EQ.5) KFJ=5
+ DO 180 KFQVER =1,3
+ KFLA=MAX(KFQOLD,KFQVER)
+ KFLB=MIN(KFQOLD,KFQVER)
+ SWT=PARJ(11+KFLA/3+KFLA/4)
+ IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
+ SWT=SWT*PJWT
+ QWT=SQWT/(2D0+SQWT)
+ IF(KFQVER.LT.3)THEN
+ IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
+ IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
+ ENDIF
+ IF(KFQVER.NE.KFQOLD)THEN
+ IMES=IMES+1
+ KFM=100*KFLA+10*KFLB+KFJ
+ PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
+ PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
+ WTTOT=WTTOT+PARF(IPOS+IMES)
+ ELSE
+ DO 170 ID=3,5
+ IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
+ IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
+ IF(ID.EQ.5) DWT=PARF(IMIX)
+ KFM=110*(ID-2)+KFJ
+ PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
+ PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
+ IF(KMUL.EQ.0.AND.ID.GT.3) THEN
+ WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
+ PARF(IPOS+5*KMUL+ID)=
+ & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
+ ENDIF
+ WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
+ 170 CONTINUE
+ ENDIF
+ 180 CONTINUE
+ 190 CONTINUE
+ DO 200 IMES=1,30
+ PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
+ 200 CONTINUE
+ IF(MR.EQ.180) PARF(140)=
+ & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
+ IF(MR.EQ.170) PARF(139-KFQPOP/3)=
+ & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
+ IPOS=IPOS+30
+ 210 CONTINUE
+ 220 CONTINUE
+ 230 CONTINUE
+ 240 CONTINUE
+ IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
+ MSTU(121)=0
+
+ PARF(186)=PARF(186)/PARF(182)
+ PARF(185)=PARF(185)/PARF(181)
+ ENDIF
+
+C..Recombine diquark weights to flavour and spin ratios
+ DO 250 I=150,170,10
+ WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
+ & (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
+ WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
+ WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
+ WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
+ PARF(I+5)=PARF(I+5)/PARF(I+1)
+ PARF(I+6)=PARF(I+6)/PARF(I+2)
+ PARF(I+1)=WSWQ
+ PARF(I+2)=WQSWQQ
+ PARF(I+3)=WSSWSQ
+ PARF(I+4)=WUUWQQ
+ 250 CONTINUE
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPTDI
+C...Generates transverse momentum according to a Gaussian.
+
+ SUBROUTINE PYPTDI(KFL,PX,PY)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+C...Generate p_T and azimuthal angle, gives p_x and p_y.
+ KFLA=IABS(KFL)
+ PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
+ IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
+ IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
+ IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
+ PHI=PARU(2)*PYR(0)
+ PX=PT*COS(PHI)
+ PY=PT*SIN(PHI)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYZDIS
+C...Generates the longitudinal splitting variable z.
+
+ SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Check if heavy flavour fragmentation.
+ KFLA=IABS(KFL1)
+ KFLB=IABS(KFL2)
+ KFLH=KFLA
+ IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
+
+C...Lund symmetric scaling function: determine parameters of shape.
+ IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
+ &MSTJ(11).GE.4) THEN
+ FA=PARJ(41)
+ IF(MSTJ(91).EQ.1) FA=PARJ(43)
+ IF(KFLB.GE.10) FA=FA+PARJ(45)
+ FBB=PARJ(42)
+ IF(MSTJ(91).EQ.1) FBB=PARJ(44)
+ FB=FBB*PR
+ FC=1D0
+ IF(KFLA.GE.10) FC=FC-PARJ(45)
+ IF(KFLB.GE.10) FC=FC+PARJ(45)
+ IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
+ FRED=PARJ(46)
+ IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
+ FC=FC+FRED*FBB*PARF(100+KFLH)**2
+ ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
+ FRED=PARJ(46)
+ IF(MSTJ(11).EQ.5) FRED=PARJ(48)
+ FC=FC+FRED*FBB*PMAS(KFLH,1)**2
+ ENDIF
+ MC=1
+ IF(ABS(FC-1D0).GT.0.01D0) MC=2
+
+C...Determine position of maximum. Special cases for a = 0 or a = c.
+ IF(FA.LT.0.02D0) THEN
+ MA=1
+ ZMAX=1D0
+ IF(FC.GT.FB) ZMAX=FB/FC
+ ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
+ MA=2
+ ZMAX=FB/(FB+FC)
+ ELSE
+ MA=3
+ ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
+ IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
+ ENDIF
+
+C...Subdivide z range if distribution very peaked near endpoint.
+ MMAX=2
+ IF(ZMAX.LT.0.1D0) THEN
+ MMAX=1
+ ZDIV=2.75D0*ZMAX
+ IF(MC.EQ.1) THEN
+ FINT=1D0-LOG(ZDIV)
+ ELSE
+ ZDIVC=ZDIV**(1D0-FC)
+ FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
+ ENDIF
+ ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
+ MMAX=3
+ FSCB=SQRT(4D0+(FC/FB)**2)
+ ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
+ IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
+ ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
+ FINT=1D0+FB*(1D0-ZDIV)
+ ENDIF
+
+C...Choice of z, preweighted for peaks at low or high z.
+ 100 Z=PYR(0)
+ FPRE=1D0
+ IF(MMAX.EQ.1) THEN
+ IF(FINT*PYR(0).LE.1D0) THEN
+ Z=ZDIV*Z
+ ELSEIF(MC.EQ.1) THEN
+ Z=ZDIV**Z
+ FPRE=ZDIV/Z
+ ELSE
+ Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
+ FPRE=(ZDIV/Z)**FC
+ ENDIF
+ ELSEIF(MMAX.EQ.3) THEN
+ IF(FINT*PYR(0).LE.1D0) THEN
+ Z=ZDIV+LOG(Z)/FB
+ FPRE=EXP(FB*(Z-ZDIV))
+ ELSE
+ Z=ZDIV+Z*(1D0-ZDIV)
+ ENDIF
+ ENDIF
+
+C...Weighting according to correct formula.
+ IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
+ FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
+ IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
+ FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
+ IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
+
+C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
+ ELSE
+ FC=PARJ(50+MAX(1,KFLH))
+ IF(MSTJ(91).EQ.1) FC=PARJ(59)
+ 110 Z=PYR(0)
+ IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
+ IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
+ ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
+ IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
+ & GOTO 110
+ ELSE
+ IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
+ IF(FC.LT.0D0) Z=Z**(-1D0/FC)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSHOW
+C...Generates timelike parton showers from given partons.
+
+ SUBROUTINE PYSHOW(IP1,IP2,QMAX)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
+ &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
+ &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
+ &ISII(2)
+
+C...Initialization of cutoff masses etc.
+ IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
+ &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
+ DO 100 IFL=0,40
+ KSH(IFL)=0
+ 100 CONTINUE
+ KSH(21)=1
+ PMTH(1,21)=PYMASS(21)
+ PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
+ PMTH(3,21)=2D0*PMTH(2,21)
+ PMTH(4,21)=PMTH(3,21)
+ PMTH(5,21)=PMTH(3,21)
+ PMTH(1,22)=PYMASS(22)
+ PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
+ PMTH(3,22)=2D0*PMTH(2,22)
+ PMTH(4,22)=PMTH(3,22)
+ PMTH(5,22)=PMTH(3,22)
+ PMQTH1=PARJ(82)
+ IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
+ PMQTH2=PMTH(2,21)
+ IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
+ DO 110 IFL=1,8
+ KSH(IFL)=1
+ PMTH(1,IFL)=PYMASS(IFL)
+ PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
+ PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
+ PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
+ PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
+ 110 CONTINUE
+ DO 120 IFL=11,17,2
+ IF(MSTJ(41).GE.2) KSH(IFL)=1
+ PMTH(1,IFL)=PYMASS(IFL)
+ PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
+ PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
+ PMTH(4,IFL)=PMTH(3,IFL)
+ PMTH(5,IFL)=PMTH(3,IFL)
+ 120 CONTINUE
+ PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
+ ALAMS=PARJ(81)**2
+ ALFM=LOG(PT2MIN/ALAMS)
+
+C...Store positions of shower initiating partons.
+ IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
+ NPA=1
+ IPA(1)=IP1
+ ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
+ & MSTU(32))) THEN
+ NPA=2
+ IPA(1)=IP1
+ IPA(2)=IP2
+ ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
+ & .AND.IP2.GE.-3) THEN
+ NPA=IABS(IP2)
+ DO 130 I=1,NPA
+ IPA(I)=IP1+I-1
+ 130 CONTINUE
+ ELSE
+ CALL PYERRM(12,
+ & '(PYSHOW:) failed to reconstruct showering system')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Check on phase space available for emission.
+ IREJ=0
+ DO 140 J=1,5
+ PS(J)=0D0
+ 140 CONTINUE
+ PM=0D0
+ DO 160 I=1,NPA
+ KFLA(I)=IABS(K(IPA(I),2))
+ PMA(I)=P(IPA(I),5)
+C...Special cutoff masses for t, l, h with variable masses.
+ IFLA=KFLA(I)
+ IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
+ IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
+ PMTH(1,IFLA)=PMA(I)
+ PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
+ PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
+ PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
+ & PMTH(2,21)
+ PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
+ & PMTH(2,22)
+ ENDIF
+ IF(KFLA(I).LE.40) THEN
+ IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
+ ENDIF
+ PM=PM+PMA(I)
+ IF(KFLA(I).GT.40) THEN
+ IREJ=IREJ+1
+ ELSE
+ IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
+ ENDIF
+ DO 150 J=1,4
+ PS(J)=PS(J)+P(IPA(I),J)
+ 150 CONTINUE
+ 160 CONTINUE
+ IF(IREJ.EQ.NPA) RETURN
+ PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
+ IF(NPA.EQ.1) PS(5)=PS(4)
+ IF(PS(5).LE.PM+PMQTH1) RETURN
+
+C...Check if 3-jet matrix elements to be used.
+ M3JC=0
+ IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
+ IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
+ & KFLA(2).LE.8) M3JC=1
+ IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
+ & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
+ IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
+ & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
+ IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
+ & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
+ IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
+ M3JCM=0
+ IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
+ M3JCM=1
+ QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
+ ENDIF
+ ENDIF
+
+C...Find if interference with initial state partons.
+ MIIS=0
+ IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
+ IF(MIIS.NE.0) THEN
+ DO 180 I=1,2
+ KCII(I)=0
+ KCA=PYCOMP(KFLA(I))
+ IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
+ NIIS(I)=0
+ IF(KCII(I).NE.0) THEN
+ DO 170 J=1,2
+ ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
+ IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
+ & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
+ NIIS(I)=NIIS(I)+1
+ IIIS(I,NIIS(I))=ICSI
+ ENDIF
+ 170 CONTINUE
+ ENDIF
+ 180 CONTINUE
+ IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
+ ENDIF
+
+C...Boost interfering initial partons to rest frame
+C...and reconstruct their polar and azimuthal angles.
+ IF(MIIS.NE.0) THEN
+ DO 200 I=1,2
+ DO 190 J=1,5
+ K(N+I,J)=K(IPA(I),J)
+ P(N+I,J)=P(IPA(I),J)
+ V(N+I,J)=0D0
+ 190 CONTINUE
+ 200 CONTINUE
+ DO 220 I=3,2+NIIS(1)
+ DO 210 J=1,5
+ K(N+I,J)=K(IIIS(1,I-2),J)
+ P(N+I,J)=P(IIIS(1,I-2),J)
+ V(N+I,J)=0D0
+ 210 CONTINUE
+ 220 CONTINUE
+ DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
+ DO 230 J=1,5
+ K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
+ P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
+ V(N+I,J)=0D0
+ 230 CONTINUE
+ 240 CONTINUE
+ CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
+ & -PS(2)/PS(4),-PS(3)/PS(4))
+ PHI=PYANGL(P(N+1,1),P(N+1,2))
+ CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
+ THE=PYANGL(P(N+1,3),P(N+1,1))
+ CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
+ DO 250 I=3,2+NIIS(1)
+ THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
+ PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
+ 250 CONTINUE
+ DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
+ THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
+ & SQRT(P(N+I,1)**2+P(N+I,2)**2))
+ PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
+ 260 CONTINUE
+ ENDIF
+
+C...Define imagined single initiator of shower for parton system.
+ NS=N
+ IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(NPA.GE.2) THEN
+ K(N+1,1)=11
+ K(N+1,2)=21
+ K(N+1,3)=0
+ K(N+1,4)=0
+ K(N+1,5)=0
+ P(N+1,1)=0D0
+ P(N+1,2)=0D0
+ P(N+1,3)=0D0
+ P(N+1,4)=PS(5)
+ P(N+1,5)=PS(5)
+ V(N+1,5)=PS(5)**2
+ N=N+1
+ ENDIF
+
+C...Loop over partons that may branch.
+ NEP=NPA
+ IM=NS
+ IF(NPA.EQ.1) IM=NS-1
+ 270 IM=IM+1
+ IF(N.GT.NS) THEN
+ IF(IM.GT.N) GOTO 510
+ KFLM=IABS(K(IM,2))
+ IF(KFLM.GT.40) GOTO 270
+ IF(KSH(KFLM).EQ.0) GOTO 270
+ IFLM=KFLM
+ IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
+ IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
+ IGM=K(IM,3)
+ ELSE
+ IGM=-1
+ ENDIF
+ IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Position of aunt (sister to branching parton).
+C...Origin and flavour of daughters.
+ IAU=0
+ IF(IGM.GT.0) THEN
+ IF(K(IM-1,3).EQ.IGM) IAU=IM-1
+ IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
+ ENDIF
+ IF(IGM.GE.0) THEN
+ K(IM,4)=N+1
+ DO 280 I=1,NEP
+ K(N+I,3)=IM
+ 280 CONTINUE
+ ELSE
+ K(N+1,3)=IPA(1)
+ ENDIF
+ IF(IGM.LE.0) THEN
+ DO 290 I=1,NEP
+ K(N+I,2)=K(IPA(I),2)
+ 290 CONTINUE
+ ELSEIF(KFLM.NE.21) THEN
+ K(N+1,2)=K(IM,2)
+ K(N+2,2)=K(IM,5)
+ ELSEIF(K(IM,5).EQ.21) THEN
+ K(N+1,2)=21
+ K(N+2,2)=21
+ ELSE
+ K(N+1,2)=K(IM,5)
+ K(N+2,2)=-K(IM,5)
+ ENDIF
+
+C...Reset flags on daughers and tries made.
+ DO 300 IP=1,NEP
+ K(N+IP,1)=3
+ K(N+IP,4)=0
+ K(N+IP,5)=0
+ KFLD(IP)=IABS(K(N+IP,2))
+ IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
+ ITRY(IP)=0
+ ISL(IP)=0
+ ISI(IP)=0
+ IF(KFLD(IP).LE.40) THEN
+ IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
+ ENDIF
+ 300 CONTINUE
+ ISLM=0
+
+C...Maximum virtuality of daughters.
+ IF(IGM.LE.0) THEN
+ DO 310 I=1,NPA
+ IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
+ & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
+ P(N+I,5)=MIN(QMAX,PS(5))
+ IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
+ IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
+ 310 CONTINUE
+ ELSE
+ IF(MSTJ(43).LE.2) PEM=V(IM,2)
+ IF(MSTJ(43).GE.3) PEM=P(IM,4)
+ P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
+ P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
+ IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
+ ENDIF
+ DO 320 I=1,NEP
+ PMSD(I)=P(N+I,5)
+ IF(ISI(I).EQ.1) THEN
+ IFLD=KFLD(I)
+ IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
+ & ISIGN(2,K(N+I,2))
+ IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
+ ENDIF
+ V(N+I,5)=P(N+I,5)**2
+ 320 CONTINUE
+
+C...Choose one of the daughters for evolution.
+ 330 INUM=0
+ IF(NEP.EQ.1) INUM=1
+ DO 340 I=1,NEP
+ IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
+ 340 CONTINUE
+ DO 350 I=1,NEP
+ IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
+ IFLD=KFLD(I)
+ IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
+ & ISIGN(2,K(N+I,2))
+ IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
+ ENDIF
+ 350 CONTINUE
+ IF(INUM.EQ.0) THEN
+ RMAX=0D0
+ DO 360 I=1,NEP
+ IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
+ RPM=P(N+I,5)/PMSD(I)
+ IFLD=KFLD(I)
+ IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
+ & ISIGN(2,K(N+I,2))
+ IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
+ RMAX=RPM
+ INUM=I
+ ENDIF
+ ENDIF
+ 360 CONTINUE
+ ENDIF
+
+C...Store information on choice of evolving daughter.
+ INUM=MAX(1,INUM)
+ IEP(1)=N+INUM
+ DO 370 I=2,NEP
+ IEP(I)=IEP(I-1)+1
+ IF(IEP(I).GT.N+NEP) IEP(I)=N+1
+ 370 CONTINUE
+ DO 380 I=1,NEP
+ KFL(I)=IABS(K(IEP(I),2))
+ 380 CONTINUE
+ ITRY(INUM)=ITRY(INUM)+1
+ IF(ITRY(INUM).GT.200) THEN
+ CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ Z=0.5D0
+ IF(KFL(1).GT.40) GOTO 430
+ IF(KSH(KFL(1)).EQ.0) GOTO 430
+ IFL=KFL(1)
+ IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
+ &ISIGN(2,K(IEP(1),2))
+ IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
+
+C...Select side for interference with initial state partons.
+ IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
+ III=IEP(1)-NS-1
+ ISII(III)=0
+ IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
+ ISII(III)=1
+ ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
+ IF(PYR(0).GT.0.5D0) ISII(III)=1
+ ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
+ ISII(III)=1
+ IF(PYR(0).GT.0.5D0) ISII(III)=2
+ ENDIF
+ ENDIF
+
+C...Calculate allowed z range.
+ IF(NEP.EQ.1) THEN
+ PMED=PS(4)
+ ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
+ PMED=P(IM,5)
+ ELSE
+ IF(INUM.EQ.1) PMED=V(IM,1)*PEM
+ IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
+ ENDIF
+ IF(MOD(MSTJ(43),2).EQ.1) THEN
+ ZC=PMTH(2,21)/PMED
+ ZCE=PMTH(2,22)/PMED
+ ELSE
+ ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
+ IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
+ ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
+ IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
+ ENDIF
+ ZC=MIN(ZC,0.491D0)
+ ZCE=MIN(ZCE,0.491D0)
+ IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
+ &MIN(ZC,ZCE).GT.0.49D0)) THEN
+ P(IEP(1),5)=PMTH(1,IFL)
+ V(IEP(1),5)=P(IEP(1),5)**2
+ GOTO 430
+ ENDIF
+
+C...Integral of Altarelli-Parisi z kernel for QCD.
+ IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
+ FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
+ ELSEIF(MSTJ(49).EQ.0) THEN
+ FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
+
+C...Integral of Altarelli-Parisi z kernel for scalar gluon.
+ ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
+ FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
+ ELSEIF(MSTJ(49).EQ.1) THEN
+ FBR=(1D0-2D0*ZC)/3D0
+ IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
+
+C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
+ ELSEIF(KFL(1).EQ.21) THEN
+ FBR=6D0*MSTJ(45)*(0.5D0-ZC)
+ ELSE
+ FBR=2D0*LOG((1D0-ZC)/ZC)
+ ENDIF
+
+C...Reset QCD probability for lepton.
+ IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
+
+C...Integral of Altarelli-Parisi kernel for photon emission.
+ IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
+ FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
+ IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
+ ENDIF
+
+C...Inner veto algorithm starts. Find maximum mass for evolution.
+ 390 PMS=V(IEP(1),5)
+ IF(IGM.GE.0) THEN
+ PM2=0D0
+ DO 400 I=2,NEP
+ PM=P(IEP(I),5)
+ IF(KFL(I).LE.40) THEN
+ IFLI=KFL(I)
+ IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
+ & ISIGN(2,K(IEP(I),2))
+ IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
+ ENDIF
+ PM2=PM2+PM
+ 400 CONTINUE
+ PMS=MIN(PMS,(P(IM,5)-PM2)**2)
+ ENDIF
+
+C...Select mass for daughter in QCD evolution.
+ B0=27D0/6D0
+ DO 410 IFF=4,MSTJ(45)
+ IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
+ 410 CONTINUE
+ IF(FBR.LT.1D-3) THEN
+ PMSQCD=0D0
+ ELSEIF(MSTJ(44).LE.0) THEN
+ PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
+ ELSEIF(MSTJ(44).EQ.1) THEN
+ PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
+ ELSE
+ PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
+ ENDIF
+ IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
+ V(IEP(1),5)=PMSQCD
+ MCE=1
+
+C...Select mass for daughter in QED evolution.
+ IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
+ PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
+ IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
+ & PMTH(2,IFL)**2
+ IF(PMSQED.GT.PMSQCD) THEN
+ V(IEP(1),5)=PMSQED
+ MCE=2
+ ENDIF
+ ENDIF
+
+C...Check whether daughter mass below cutoff.
+ P(IEP(1),5)=SQRT(V(IEP(1),5))
+ IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
+ P(IEP(1),5)=PMTH(1,IFL)
+ V(IEP(1),5)=P(IEP(1),5)**2
+ GOTO 430
+ ENDIF
+
+C...Select z value of branching: q -> qgamma.
+ IF(MCE.EQ.2) THEN
+ Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
+ IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
+ K(IEP(1),5)=22
+
+C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
+ ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
+ Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
+ IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
+ K(IEP(1),5)=21
+ ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
+ Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
+ IF(PYR(0).GT.0.5D0) Z=1D0-Z
+ IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
+ K(IEP(1),5)=21
+ ELSEIF(MSTJ(49).NE.1) THEN
+ Z=ZC+(1D0-2D0*ZC)*PYR(0)
+ IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
+ KFLB=1+INT(MSTJ(45)*PYR(0))
+ PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
+ IF(PMQ.GE.1D0) GOTO 390
+ PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
+ IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
+ & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
+ K(IEP(1),5)=KFLB
+
+C...Ditto for scalar gluon model.
+ ELSEIF(KFL(1).NE.21) THEN
+ Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
+ K(IEP(1),5)=21
+ ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
+ Z=ZC+(1D0-2D0*ZC)*PYR(0)
+ K(IEP(1),5)=21
+ ELSE
+ Z=ZC+(1D0-2D0*ZC)*PYR(0)
+ KFLB=1+INT(MSTJ(45)*PYR(0))
+ PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
+ IF(PMQ.GE.1D0) GOTO 390
+ K(IEP(1),5)=KFLB
+ ENDIF
+ IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
+ IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
+ IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
+ ENDIF
+
+C...Check if z consistent with chosen m.
+ IF(KFL(1).EQ.21) THEN
+ KFLGD1=IABS(K(IEP(1),5))
+ KFLGD2=KFLGD1
+ ELSE
+ KFLGD1=KFL(1)
+ KFLGD2=IABS(K(IEP(1),5))
+ ENDIF
+ IF(NEP.EQ.1) THEN
+ PED=PS(4)
+ ELSEIF(NEP.GE.3) THEN
+ PED=P(IEP(1),4)
+ ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
+ PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
+ ELSE
+ IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
+ IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
+ ENDIF
+ IF(MOD(MSTJ(43),2).EQ.1) THEN
+ IFLGD1=KFLGD1
+ IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
+ PMQTH3=0.5D0*PARJ(82)
+ IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
+ PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
+ PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
+ ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
+ & 4D0*PMQ1*PMQ2)))
+ ZH=1D0+PMQ1-PMQ2
+ ELSE
+ ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
+ ZH=1D0
+ ENDIF
+ ZL=0.5D0*(ZH-ZD)
+ ZU=0.5D0*(ZH+ZD)
+ IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
+ IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
+ &(1D0-ZU)))
+ IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
+
+C...Width suppression for q -> q + g.
+ IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
+ IF(IGM.EQ.0) THEN
+ EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
+ ELSE
+ EGLU=PMED*(1D0-Z)
+ ENDIF
+ CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
+ IF(MSTJ(40).EQ.1) THEN
+ IF(CHI.LT.PYR(0)) GOTO 390
+ ELSEIF(MSTJ(40).EQ.2) THEN
+ IF(1D0-CHI.LT.PYR(0)) GOTO 390
+ ENDIF
+ ENDIF
+
+C...Three-jet matrix element correction.
+ IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
+ X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
+ X2=1D0-V(IEP(1),5)/V(NS+1,5)
+ X3=(1D0-X1)+(1D0-X2)
+ IF(MCE.EQ.2) THEN
+ KI1=K(IPA(INUM),2)
+ KI2=K(IPA(3-INUM),2)
+ QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
+ QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
+ WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
+ & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
+ WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
+ ELSEIF(MSTJ(49).NE.1) THEN
+ WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
+ & (1D0-X2)/X3*(X2/(2D0-X1))**2
+ WME=X1**2+X2**2
+ IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
+ & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
+ & (1D0-X1)/MAX(1D-7,1D0-X2))
+ ELSE
+ WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
+ WME=X3**2
+ IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
+ & PARJ(171)
+ ENDIF
+ IF(WME.LT.PYR(0)*WSHOW) GOTO 390
+
+C...Impose angular ordering by rejection of nonordered emission.
+ ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
+ MAOM=1
+ ZM=V(IM,1)
+ IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
+ THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
+ IAOM=IM
+ 420 IF(K(IAOM,5).EQ.22) THEN
+ IAOM=K(IAOM,3)
+ IF(K(IAOM,3).LE.NS) MAOM=0
+ IF(MAOM.EQ.1) GOTO 420
+ ENDIF
+ IF(MAOM.EQ.1) THEN
+ THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
+ IF(THE2ID.LT.THE2IM) GOTO 390
+ ENDIF
+ ENDIF
+
+C...Impose user-defined maximum angle at first branching.
+ IF(MSTJ(48).EQ.1) THEN
+ IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
+ THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
+ IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
+ ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
+ THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
+ IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
+ ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
+ THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
+ IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
+ ENDIF
+ ENDIF
+
+C...Impose angular constraint in first branching from interference
+C...with initial state partons.
+ IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
+ THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
+ IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
+ IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
+ ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
+ IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
+ ENDIF
+ ENDIF
+
+C...End of inner veto algorithm. Check if only one leg evolved so far.
+ 430 V(IEP(1),1)=Z
+ ISL(1)=0
+ ISL(2)=0
+ IF(NEP.EQ.1) GOTO 460
+ IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
+ DO 440 I=1,NEP
+ IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
+ IF(KSH(KFLD(I)).EQ.1) THEN
+ IFLD=KFLD(I)
+ IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
+ & ISIGN(2,K(N+I,2))
+ IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
+ ENDIF
+ ENDIF
+ 440 CONTINUE
+
+C...Check if chosen multiplet m1,m2,z1,z2 is physical.
+ IF(NEP.EQ.3) THEN
+ PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
+ PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
+ PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
+ PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
+ & PA1S**2-PA2S**2-PA3S**2)/PA1S
+ IF(PTS.LE.0D0) GOTO 330
+ ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
+ DO 450 I1=N+1,N+2
+ KFLDA=IABS(K(I1,2))
+ IF(KFLDA.GT.40) GOTO 450
+ IF(KSH(KFLDA).EQ.0) GOTO 450
+ IFLDA=KFLDA
+ IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
+ & ISIGN(2,K(I1,2))
+ IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
+ IF(KFLDA.EQ.21) THEN
+ KFLGD1=IABS(K(I1,5))
+ KFLGD2=KFLGD1
+ ELSE
+ KFLGD1=KFLDA
+ KFLGD2=IABS(K(I1,5))
+ ENDIF
+ I2=2*N+3-I1
+ IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
+ PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
+ ELSE
+ IF(I1.EQ.N+1) ZM=V(IM,1)
+ IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
+ PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
+ & 4D0*V(N+1,5)*V(N+2,5))
+ PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
+ ENDIF
+ IF(MOD(MSTJ(43),2).EQ.1) THEN
+ PMQTH3=0.5D0*PARJ(82)
+ IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
+ IFLGD1=KFLGD1
+ IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
+ PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
+ PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
+ ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
+ & 4D0*PMQ1*PMQ2)))
+ ZH=1D0+PMQ1-PMQ2
+ ELSE
+ ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
+ ZH=1D0
+ ENDIF
+ ZL=0.5D0*(ZH-ZD)
+ ZU=0.5D0*(ZH+ZD)
+ IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
+ IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
+ IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
+ & ZL*(1D0-ZU)))
+ IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
+ 450 CONTINUE
+ IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
+ ISL(3-ISLM)=0
+ ISLM=3-ISLM
+ ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
+ ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
+ ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
+ IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
+ IF(ISL(1).EQ.1) ISL(2)=0
+ IF(ISL(1).EQ.0) ISLM=1
+ IF(ISL(2).EQ.0) ISLM=2
+ ENDIF
+ IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
+ ENDIF
+ IFLD1=KFLD(1)
+ IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
+ &ISIGN(2,K(N+1,2))
+ IFLD2=KFLD(2)
+ IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
+ &ISIGN(2,K(N+2,2))
+ IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
+ &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
+ PMQ1=V(N+1,5)/V(IM,5)
+ PMQ2=V(N+2,5)/V(IM,5)
+ ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
+ & 4D0*PMQ1*PMQ2)))
+ ZH=1D0+PMQ1-PMQ2
+ ZL=0.5D0*(ZH-ZD)
+ ZU=0.5D0*(ZH+ZD)
+ IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
+ ENDIF
+
+C...Accepted branch. Construct four-momentum for initial partons.
+ 460 MAZIP=0
+ MAZIC=0
+ IF(NEP.EQ.1) THEN
+ P(N+1,1)=0D0
+ P(N+1,2)=0D0
+ P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
+ & P(N+1,5))))
+ P(N+1,4)=P(IPA(1),4)
+ V(N+1,2)=P(N+1,4)
+ ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
+ PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
+ P(N+1,1)=0D0
+ P(N+1,2)=0D0
+ P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
+ P(N+1,4)=PED1
+ P(N+2,1)=0D0
+ P(N+2,2)=0D0
+ P(N+2,3)=-P(N+1,3)
+ P(N+2,4)=P(IM,5)-PED1
+ V(N+1,2)=P(N+1,4)
+ V(N+2,2)=P(N+2,4)
+ ELSEIF(NEP.EQ.3) THEN
+ P(N+1,1)=0D0
+ P(N+1,2)=0D0
+ P(N+1,3)=SQRT(MAX(0D0,PA1S))
+ P(N+2,1)=SQRT(PTS)
+ P(N+2,2)=0D0
+ P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
+ P(N+3,1)=-P(N+2,1)
+ P(N+3,2)=0D0
+ P(N+3,3)=-(P(N+1,3)+P(N+2,3))
+ V(N+1,2)=P(N+1,4)
+ V(N+2,2)=P(N+2,4)
+ V(N+3,2)=P(N+3,4)
+
+C...Construct transverse momentum for ordinary branching in shower.
+ ELSE
+ ZM=V(IM,1)
+ PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
+ PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
+ IF(PZM.LE.0D0) THEN
+ PTS=0D0
+ ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
+ PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
+ & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
+ ELSE
+ PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
+ ENDIF
+ PT=SQRT(MAX(0D0,PTS))
+
+C...Find coefficient of azimuthal asymmetry due to gluon polarization.
+ HAZIP=0D0
+ IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
+ & .AND.IAU.NE.0) THEN
+ IF(K(IGM,3).NE.0) MAZIP=1
+ ZAU=V(IGM,1)
+ IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
+ IF(MAZIP.EQ.0) ZAU=0D0
+ IF(K(IGM,2).NE.21) THEN
+ HAZIP=2D0*ZAU/(1D0+ZAU**2)
+ ELSE
+ HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
+ ENDIF
+ IF(K(N+1,2).NE.21) THEN
+ HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
+ ELSE
+ HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
+ ENDIF
+ ENDIF
+
+C...Find coefficient of azimuthal asymmetry due to soft gluon
+C...interference.
+ HAZIC=0D0
+ IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
+ & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
+ IF(K(IGM,3).NE.0) MAZIC=N+1
+ IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
+ IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
+ & ZM.GT.0.5D0) MAZIC=N+2
+ IF(K(IAU,2).EQ.22) MAZIC=0
+ ZS=ZM
+ IF(MAZIC.EQ.N+2) ZS=1D0-ZM
+ ZGM=V(IGM,1)
+ IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
+ IF(MAZIC.EQ.0) ZGM=1D0
+ IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
+ & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
+ HAZIC=MIN(0.95D0,HAZIC)
+ ENDIF
+ ENDIF
+
+C...Construct kinematics for ordinary branching in shower.
+ 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
+ IF(MOD(MSTJ(43),2).EQ.1) THEN
+ P(N+1,4)=PEM*V(IM,1)
+ ELSE
+ P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
+ & SQRT(PMLS)*ZM)/V(IM,5)
+ ENDIF
+ PHI=PARU(2)*PYR(0)
+ P(N+1,1)=PT*COS(PHI)
+ P(N+1,2)=PT*SIN(PHI)
+ IF(PZM.GT.0D0) THEN
+ P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
+ & 2D0*PEM*P(N+1,4))/PZM
+ ELSE
+ P(N+1,3)=0D0
+ ENDIF
+ P(N+2,1)=-P(N+1,1)
+ P(N+2,2)=-P(N+1,2)
+ P(N+2,3)=PZM-P(N+1,3)
+ P(N+2,4)=PEM-P(N+1,4)
+ IF(MSTJ(43).LE.2) THEN
+ V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
+ V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
+ ENDIF
+ ENDIF
+
+C...Rotate and boost daughters.
+ IF(IGM.GT.0) THEN
+ IF(MSTJ(43).LE.2) THEN
+ BEX=P(IGM,1)/P(IGM,4)
+ BEY=P(IGM,2)/P(IGM,4)
+ BEZ=P(IGM,3)/P(IGM,4)
+ GA=P(IGM,4)/P(IGM,5)
+ GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
+ & P(IM,4))
+ ELSE
+ BEX=0D0
+ BEY=0D0
+ BEZ=0D0
+ GA=1D0
+ GABEP=0D0
+ ENDIF
+ THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
+ & (P(IM,2)+GABEP*BEY)**2))
+ PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
+ DO 480 I=N+1,N+2
+ DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
+ & SIN(THE)*COS(PHI)*P(I,3)
+ DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
+ & SIN(THE)*SIN(PHI)*P(I,3)
+ DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
+ DP(4)=P(I,4)
+ DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
+ DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
+ P(I,1)=DP(1)+DGABP*BEX
+ P(I,2)=DP(2)+DGABP*BEY
+ P(I,3)=DP(3)+DGABP*BEZ
+ P(I,4)=GA*(DP(4)+DBP)
+ 480 CONTINUE
+ ENDIF
+
+C...Weight with azimuthal distribution, if required.
+ IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
+ DO 490 J=1,3
+ DPT(1,J)=P(IM,J)
+ DPT(2,J)=P(IAU,J)
+ DPT(3,J)=P(N+1,J)
+ 490 CONTINUE
+ DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
+ DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
+ DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
+ DO 500 J=1,3
+ DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
+ DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
+ 500 CONTINUE
+ DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
+ DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
+ IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
+ CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
+ & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
+ IF(MAZIP.NE.0) THEN
+ IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
+ & GOTO 470
+ ENDIF
+ IF(MAZIC.NE.0) THEN
+ IF(MAZIC.EQ.N+2) CAD=-CAD
+ IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
+ & .LT.PYR(0)) GOTO 470
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...Azimuthal anisotropy due to interference with initial state partons.
+ IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
+ &K(N+2,2).EQ.21)) THEN
+ III=IM-NS-1
+ IF(ISII(III).GE.1) THEN
+ IAZIID=N+1
+ IF(K(N+1,2).NE.21) IAZIID=N+2
+ IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
+ & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
+ THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
+ IF(III.EQ.2) THEIID=PARU(1)-THEIID
+ PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
+ HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
+ CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
+ PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
+ IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
+ IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
+ & .LT.PYR(0)) GOTO 470
+ ENDIF
+ ENDIF
+
+C...Continue loop over partons that may branch, until none left.
+ IF(IGM.GE.0) K(IM,1)=14
+ N=N+NEP
+ NEP=2
+ IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
+ IF(MSTU(21).GE.1) N=NS
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ GOTO 270
+
+C...Set information on imagined shower initiator.
+ 510 IF(NPA.GE.2) THEN
+ K(NS+1,1)=11
+ K(NS+1,2)=94
+ K(NS+1,3)=IP1
+ IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
+ K(NS+1,4)=NS+2
+ K(NS+1,5)=NS+1+NPA
+ IIM=1
+ ELSE
+ IIM=0
+ ENDIF
+
+C...Reconstruct string drawing information.
+ DO 520 I=NS+1+IIM,N
+ IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
+ K(I,1)=1
+ ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
+ & IABS(K(I,2)).LE.18) THEN
+ K(I,1)=1
+ ELSEIF(K(I,1).LE.10) THEN
+ K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
+ K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
+ ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
+ ID1=MOD(K(I,4),MSTU(5))
+ IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
+ ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
+ K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
+ K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
+ K(ID1,4)=K(ID1,4)+MSTU(5)*I
+ K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
+ K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
+ K(ID2,5)=K(ID2,5)+MSTU(5)*I
+ ELSE
+ ID1=MOD(K(I,4),MSTU(5))
+ ID2=ID1+1
+ K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
+ K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
+ IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
+ K(ID1,4)=K(ID1,4)+MSTU(5)*I
+ K(ID1,5)=K(ID1,5)+MSTU(5)*I
+ ELSE
+ K(ID1,4)=0
+ K(ID1,5)=0
+ ENDIF
+ K(ID2,4)=0
+ K(ID2,5)=0
+ ENDIF
+ 520 CONTINUE
+
+C...Transformation from CM frame.
+ IF(NPA.GE.2) THEN
+ BEX=PS(1)/PS(4)
+ BEY=PS(2)/PS(4)
+ BEZ=PS(3)/PS(4)
+ GA=PS(4)/PS(5)
+ GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
+ & /(1D0+GA)-P(IPA(1),4))
+ ELSE
+ BEX=0D0
+ BEY=0D0
+ BEZ=0D0
+ GABEP=0D0
+ ENDIF
+ THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
+ &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
+ PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
+ IF(NPA.EQ.3) THEN
+ CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
+ & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
+ & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
+ & GABEP*BEY))
+ MSTU(33)=1
+ CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
+ ENDIF
+ MSTU(33)=1
+ CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
+
+C...Decay vertex of shower.
+ DO 540 I=NS+1,N
+ DO 530 J=1,5
+ V(I,J)=V(IP1,J)
+ 530 CONTINUE
+ 540 CONTINUE
+
+C...Delete trivial shower, else connect initiators.
+ IF(N.EQ.NS+NPA+IIM) THEN
+ N=NS
+ ELSE
+ DO 550 IP=1,NPA
+ K(IPA(IP),1)=14
+ K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
+ K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
+ K(NS+IIM+IP,3)=IPA(IP)
+ IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
+ IF(K(NS+IIM+IP,1).NE.1) THEN
+ K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
+ K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
+ ENDIF
+ 550 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYBOEI
+C...Modifies an event so as to approximately take into account
+C...Bose-Einstein effects according to a simple phenomenological
+C...parametrization.
+
+ SUBROUTINE PYBOEI(NSAV)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYJETS/,/PYDAT1/
+C...Local arrays and data.
+ DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
+ DATA KFBE/211,-211,111,321,-321,130,310,221,331/
+
+C...Boost event to overall CM frame. Calculate CM energy.
+ IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
+ DO 100 J=1,4
+ DPS(J)=0D0
+ 100 CONTINUE
+ DO 120 I=1,N
+ KFA=IABS(K(I,2))
+ IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
+ & .AND.K(I,3).GT.0) THEN
+ KFMA=IABS(K(K(I,3),2))
+ IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
+ ENDIF
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
+ DO 110 J=1,4
+ DPS(J)=DPS(J)+P(I,J)
+ 110 CONTINUE
+ 120 CONTINUE
+ CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
+ &-DPS(3)/DPS(4))
+ PECM=0D0
+ DO 130 I=1,N
+ IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
+ 130 CONTINUE
+
+C...Reserve copy of particles by species at end of record.
+ NBE(0)=N+MSTU(3)
+ DO 160 IBE=1,MIN(9,MSTJ(52))
+ NBE(IBE)=NBE(IBE-1)
+ DO 150 I=NSAV+1,N
+ IF(K(I,2).NE.KFBE(IBE)) GOTO 150
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
+ IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
+ RETURN
+ ENDIF
+ NBE(IBE)=NBE(IBE)+1
+ K(NBE(IBE),1)=I
+ DO 140 J=1,3
+ P(NBE(IBE),J)=0D0
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+ IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
+
+C...Tabulate integral for subsequent momentum shift.
+ DO 220 IBE=1,MIN(9,MSTJ(52))
+ IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
+ IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
+ & .LE.1) GOTO 180
+ IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
+ & NBE(7)-NBE(6)).LE.1) GOTO 180
+ IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
+ IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
+ IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
+ IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
+ IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
+ QDEL=0.1D0*MIN(PMHQ,PARJ(93))
+ IF(MSTJ(51).EQ.1) THEN
+ NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
+ BEEX=EXP(0.5D0*QDEL/PARJ(93))
+ BERT=EXP(-QDEL/PARJ(93))
+ ELSE
+ NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
+ ENDIF
+ DO 170 IBIN=1,NBIN
+ QBIN=QDEL*(IBIN-0.5D0)
+ BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
+ IF(MSTJ(51).EQ.1) THEN
+ BEEX=BEEX*BERT
+ BEI(IBIN)=BEI(IBIN)*BEEX
+ ELSE
+ BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
+ ENDIF
+ IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
+ 170 CONTINUE
+
+C...Loop through particle pairs and find old relative momentum.
+ 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
+ I1=K(I1M,1)
+ DO 200 I2M=I1M+1,NBE(IBE)
+ I2=K(I2M,1)
+ Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
+ & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
+ & (P(I1,5)+P(I2,5))**2)
+ QOLD=SQRT(Q2OLD)
+
+C...Calculate new relative momentum.
+ IF(QOLD.LT.1D-3*QDEL) THEN
+ GOTO 200
+ ELSEIF(QOLD.LE.QDEL) THEN
+ QMOV=QOLD/3D0
+ ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
+ RBIN=QOLD/QDEL
+ IBIN=RBIN
+ RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
+ QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
+ & SQRT(Q2OLD+PMHQ**2)/Q2OLD
+ ELSE
+ QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
+ ENDIF
+ Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
+
+C...Calculate and save shift to be performed on three-momenta.
+ HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
+ HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
+ HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
+ DO 190 J=1,3
+ PD=HA*(P(I2,J)-P(I1,J))
+ P(I1M,J)=P(I1M,J)+PD
+ P(I2M,J)=P(I2M,J)-PD
+ 190 CONTINUE
+ 200 CONTINUE
+ 210 CONTINUE
+ 220 CONTINUE
+
+C...Shift momenta and recalculate energies.
+ DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
+ I=K(IM,1)
+ DO 230 J=1,3
+ P(I,J)=P(I,J)+P(IM,J)
+ 230 CONTINUE
+ P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ 240 CONTINUE
+
+C...Rescale all momenta for energy conservation.
+ PES=0D0
+ PQS=0D0
+ DO 250 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
+ PES=PES+P(I,4)
+ PQS=PQS+P(I,5)**2/P(I,4)
+ 250 CONTINUE
+ FAC=(PECM-PQS)/(PES-PQS)
+ DO 270 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
+ DO 260 J=1,3
+ P(I,J)=FAC*P(I,J)
+ 260 CONTINUE
+ P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ 270 CONTINUE
+
+C...Boost back to correct reference frame.
+ 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
+ DO 290 I=1,N
+ IF(K(I,1).LT.0) K(I,1)=-K(I,1)
+ 290 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYMASS
+C...Gives the mass of a particle/parton.
+
+ FUNCTION PYMASS(KF)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Reset variables. Compressed code. Special case for popcorn diquarks.
+ PYMASS=0D0
+ KFA=IABS(KF)
+ KC=PYCOMP(KF)
+ IF(KC.EQ.0) THEN
+ MSTJ(93)=0
+ RETURN
+ ENDIF
+
+C...Guarantee use of constituent masses for internal checks.
+ IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
+ &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
+ PARF(106)=PMAS(6,1)
+ PARF(107)=PMAS(7,1)
+ PARF(108)=PMAS(8,1)
+ IF(KFA.LE.10) THEN
+ PYMASS=PARF(100+KFA)
+ IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
+ ELSEIF(MSTJ(93).EQ.1) THEN
+ PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
+ ELSE
+ PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
+ ENDIF
+
+C...Other masses can be read directly off table.
+ ELSE
+ PYMASS=PMAS(KC,1)
+ ENDIF
+
+C...Optional mass broadening according to truncated Breit-Wigner
+C...(either in m or in m^2).
+ IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
+ IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
+ PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
+ & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
+ ELSE
+ PM0=PYMASS
+ PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
+ & (PM0*PMAS(KC,2)))
+ PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
+ PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
+ & (PMUPP-PMLOW)*PYR(0))))
+ ENDIF
+ ENDIF
+ MSTJ(93)=0
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYNAME
+C...Gives the particle/parton name as a character string.
+
+ SUBROUTINE PYNAME(KF,CHAU)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
+C...Local character variable.
+ CHARACTER CHAU*16
+
+C...Read out code with distinction particle/antiparticle.
+ CHAU=' '
+ KC=PYCOMP(KF)
+ IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
+
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCHGE
+C...Gives three times the charge for a particle/parton.
+
+ FUNCTION PYCHGE(KF)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT2/
+
+C...Read out charge and change sign for antiparticle.
+ PYCHGE=0
+ KC=PYCOMP(KF)
+ IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCOMP
+C...Compress the standard KF codes for use in mass and decay arrays;
+C...also checks whether a given code actually is defined.
+
+ FUNCTION PYCOMP(KF)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+C...Local arrays and saved data.
+ DIMENSION KFORD(100:500),KCORD(101:500)
+ SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
+
+C...Whenever necessary reorder codes for faster search.
+ IF(MSTU(20).EQ.0) THEN
+ NFORD=100
+ KFORD(100)=0
+ DO 120 I=101,500
+ KFA=KCHG(I,4)
+ IF(KFA.LE.100) GOTO 120
+ NFORD=NFORD+1
+ DO 100 I1=NFORD-1,0,-1
+ IF(KFA.GE.KFORD(I1)) GOTO 110
+ KFORD(I1+1)=KFORD(I1)
+ KCORD(I1+1)=KCORD(I1)
+ 100 CONTINUE
+ 110 KFORD(I1+1)=KFA
+ KCORD(I1+1)=I
+ 120 CONTINUE
+ MSTU(20)=1
+ KFLAST=0
+ KCLAST=0
+ ENDIF
+
+C...Fast action if same code as in latest call.
+ IF(KF.EQ.KFLAST) THEN
+ PYCOMP=KCLAST
+ RETURN
+ ENDIF
+
+C...Starting values. Remove internal diquark flags.
+ PYCOMP=0
+ KFA=IABS(KF)
+ IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
+ & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
+
+C...Simple cases: direct translation.
+ IF(KFA.GT.KFORD(NFORD)) THEN
+ ELSEIF(KFA.LE.100) THEN
+ PYCOMP=KFA
+
+C...Else binary search.
+ ELSE
+ IMIN=100
+ IMAX=NFORD+1
+ 130 IAVG=(IMIN+IMAX)/2
+ IF(KFORD(IAVG).GT.KFA) THEN
+ IMAX=IAVG
+ IF(IMAX.GT.IMIN+1) GOTO 130
+ ELSEIF(KFORD(IAVG).LT.KFA) THEN
+ IMIN=IAVG
+ IF(IMAX.GT.IMIN+1) GOTO 130
+ ELSE
+ PYCOMP=KCORD(IAVG)
+ ENDIF
+ ENDIF
+
+C...Check if antiparticle allowed.
+ IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
+ IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
+ ENDIF
+
+C...Save codes for possible future fast action.
+ KFLAST=KF
+ KCLAST=PYCOMP
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYERRM
+C...Informs user of errors in program execution.
+
+ SUBROUTINE PYERRM(MERR,CHMESS)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYJETS/,/PYDAT1/
+C...Local character variable.
+ CHARACTER CHMESS*(*)
+
+C...Write first few warnings, then be silent.
+ IF(MERR.LE.10) THEN
+ MSTU(27)=MSTU(27)+1
+ MSTU(28)=MERR
+ IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
+ & MERR,MSTU(31),CHMESS
+
+C...Write first few errors, then be silent or stop program.
+ ELSEIF(MERR.LE.20) THEN
+ MSTU(23)=MSTU(23)+1
+ MSTU(24)=MERR-10
+ IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
+ & MERR-10,MSTU(31),CHMESS
+ IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
+ WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
+ WRITE(MSTU(11),5200)
+ IF(MERR.NE.17) CALL PYLIST(2)
+ STOP
+ ENDIF
+
+C...Stop program in case of irreparable error.
+ ELSE
+ WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
+ STOP
+ ENDIF
+
+C...Formats for output.
+ 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
+ &' PYEXEC calls:'/5X,A)
+ 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
+ &' PYEXEC calls:'/5X,A)
+ 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
+ &'event!')
+ 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
+ &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYALEM
+C...Calculates the running alpha_electromagnetic.
+
+ FUNCTION PYALEM(Q2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+C...Calculate real part of photon vacuum polarization.
+C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
+C...For hadrons use parametrization of H. Burkhardt et al.
+C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
+ AEMPI=PARU(101)/(3D0*PARU(1))
+ IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
+ RPIGG=0D0
+ ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
+ RPIGG=0D0
+ ELSEIF(MSTU(101).EQ.2) THEN
+ RPIGG=1D0-PARU(101)/PARU(103)
+ ELSEIF(Q2.LT.0.09D0) THEN
+ RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
+ ELSEIF(Q2.LT.9D0) THEN
+ RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
+ & 0.00238D0*LOG(1D0+3.927D0*Q2)
+ ELSEIF(Q2.LT.1D4) THEN
+ RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
+ & 0.00299D0*LOG(1D0+Q2)
+ ELSE
+ RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
+ & 0.00293D0*LOG(1D0+Q2)
+ ENDIF
+
+C...Calculate running alpha_em.
+ PYALEM=PARU(101)/(1D0-RPIGG)
+ PARU(108)=PYALEM
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYALPS
+C...Gives the value of alpha_strong.
+
+ FUNCTION PYALPS(Q2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Constant alpha_strong trivial. Pick artificial Lambda.
+ IF(MSTU(111).LE.0) THEN
+ PYALPS=PARU(111)
+ MSTU(118)=MSTU(112)
+ PARU(117)=0.2D0
+ IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
+ & ((33D0-2D0*MSTU(112))*PARU(111)))
+ PARU(118)=PARU(111)
+ RETURN
+ ENDIF
+
+C...Find effective Q2, number of flavours and Lambda.
+ Q2EFF=Q2
+ IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
+ NF=MSTU(112)
+ ALAM2=PARU(112)**2
+ 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
+ Q2THR=PARU(113)*PMAS(NF,1)**2
+ IF(Q2EFF.LT.Q2THR) THEN
+ NF=NF-1
+ ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
+ GOTO 100
+ ENDIF
+ ENDIF
+ 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
+ Q2THR=PARU(113)*PMAS(NF+1,1)**2
+ IF(Q2EFF.GT.Q2THR) THEN
+ NF=NF+1
+ ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
+ GOTO 110
+ ENDIF
+ ENDIF
+ IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
+ PARU(117)=SQRT(ALAM2)
+
+C...Evaluate first or second order alpha_strong.
+ B0=(33D0-2D0*NF)/6D0
+ ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
+ IF(MSTU(111).EQ.1) THEN
+ PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
+ ELSE
+ B1=(153D0-19D0*NF)/6D0
+ PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
+ & (B0**2*ALGQ)))
+ ENDIF
+ MSTU(118)=NF
+ PARU(118)=PYALPS
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYANGL
+C...Reconstructs an angle from given x and y coordinates.
+
+ FUNCTION PYANGL(X,Y)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+ PYANGL=0D0
+ R=SQRT(X**2+Y**2)
+ IF(R.LT.1D-20) RETURN
+ IF(ABS(X)/R.LT.0.8D0) THEN
+ PYANGL=SIGN(ACOS(X/R),Y)
+ ELSE
+ PYANGL=ASIN(Y/R)
+ IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
+ PYANGL=PARU(1)-PYANGL
+ ELSEIF(X.LT.0D0) THEN
+ PYANGL=-PARU(1)-PYANGL
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYR
+C...Generates random numbers uniformly distributed between
+C...0 and 1, excluding the endpoints.
+
+**sr renamed for use of internal dpmjet3 random number generator
+ FUNCTION XPYR(IDUMMY)
+**
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ SAVE /PYDATR/
+C...Equivalence between commonblock and local variables.
+ EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
+ &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
+ &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
+
+C...Initialize generation from given seed.
+ IF(MRPY2.EQ.0) THEN
+ IJ=MOD(MRPY1/30082,31329)
+ KL=MOD(MRPY1,30082)
+ I=MOD(IJ/177,177)+2
+ J=MOD(IJ,177)+2
+ K=MOD(KL/169,178)+1
+ L=MOD(KL,169)
+ DO 110 II=1,97
+ S=0D0
+ T=0.5D0
+ DO 100 JJ=1,48
+ M=MOD(MOD(I*J,179)*K,179)
+ I=J
+ J=K
+ K=M
+ L=MOD(53*L+1,169)
+ IF(MOD(L*M,64).GE.32) S=S+T
+ T=0.5D0*T
+ 100 CONTINUE
+ RRPY(II)=S
+ 110 CONTINUE
+ TWOM24=1D0
+ DO 120 I24=1,24
+ TWOM24=0.5D0*TWOM24
+ 120 CONTINUE
+ RRPY98=362436D0*TWOM24
+ RRPY99=7654321D0*TWOM24
+ RRPY00=16777213D0*TWOM24
+ MRPY2=1
+ MRPY3=0
+ MRPY4=97
+ MRPY5=33
+ ENDIF
+
+C...Generate next random number.
+ 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
+ IF(RUNI.LT.0D0) RUNI=RUNI+1D0
+ RRPY(MRPY4)=RUNI
+ MRPY4=MRPY4-1
+ IF(MRPY4.EQ.0) MRPY4=97
+ MRPY5=MRPY5-1
+ IF(MRPY5.EQ.0) MRPY5=97
+ RRPY98=RRPY98-RRPY99
+ IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
+ RUNI=RUNI-RRPY98
+ IF(RUNI.LT.0D0) RUNI=RUNI+1D0
+ IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
+
+C...Update counters. Random number to output.
+ MRPY3=MRPY3+1
+ IF(MRPY3.EQ.1000000000) THEN
+ MRPY2=MRPY2+1
+ MRPY3=0
+ ENDIF
+ PYR=RUNI
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRGET
+C...Dumps the state of the random number generator on a file
+C...for subsequent startup from this state onwards.
+
+ SUBROUTINE PYRGET(LFN,MOVE)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ SAVE /PYDATR/
+C...Local character variable.
+ CHARACTER CHERR*8
+
+C...Backspace required number of records (or as many as there are).
+ IF(MOVE.LT.0) THEN
+ NBCK=MIN(MRPY(6),-MOVE)
+ DO 100 IBCK=1,NBCK
+ BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
+ 100 CONTINUE
+ MRPY(6)=MRPY(6)-NBCK
+ ENDIF
+
+C...Unformatted write on unit LFN.
+ WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
+ &(RRPY(I2),I2=1,100)
+ MRPY(6)=MRPY(6)+1
+ RETURN
+
+C...Write error.
+ 110 WRITE(CHERR,'(I8)') IERR
+ CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
+ &CHERR)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRSET
+C...Reads a state of the random number generator from a file
+C...for subsequent generation from this state onwards.
+
+ SUBROUTINE PYRSET(LFN,MOVE)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDATR/MRPY(6),RRPY(100)
+ SAVE /PYDATR/
+C...Local character variable.
+ CHARACTER CHERR*8
+
+C...Backspace required number of records (or as many as there are).
+ IF(MOVE.LT.0) THEN
+ NBCK=MIN(MRPY(6),-MOVE)
+ DO 100 IBCK=1,NBCK
+ BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
+ 100 CONTINUE
+ MRPY(6)=MRPY(6)-NBCK
+ ENDIF
+
+C...Unformatted read from unit LFN.
+ NFOR=1+MAX(0,MOVE)
+ DO 110 IFOR=1,NFOR
+ READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
+ & (RRPY(I2),I2=1,100)
+ 110 CONTINUE
+ MRPY(6)=MRPY(6)+NFOR
+ RETURN
+
+C...Write error.
+ 120 WRITE(CHERR,'(I8)') IERR
+ CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
+ &CHERR)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYROBO
+C...Performs rotations and boosts.
+
+ SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYJETS/,/PYDAT1/
+C...Local arrays.
+ DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
+
+C...Find and check range of rotation/boost.
+ IMIN=IMI
+ IF(IMIN.LE.0) IMIN=1
+ IF(MSTU(1).GT.0) IMIN=MSTU(1)
+ IMAX=IMA
+ IF(IMAX.LE.0) IMAX=N
+ IF(MSTU(2).GT.0) IMAX=MSTU(2)
+ IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
+ CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
+ RETURN
+ ENDIF
+
+C...Optional resetting of V (when not set before.)
+ IF(MSTU(33).NE.0) THEN
+ DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
+ DO 100 J=1,5
+ V(I,J)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+ MSTU(33)=0
+ ENDIF
+
+C...Rotate, typically from z axis to direction (theta,phi).
+ IF(THE**2+PHI**2.GT.1D-20) THEN
+ ROT(1,1)=COS(THE)*COS(PHI)
+ ROT(1,2)=-SIN(PHI)
+ ROT(1,3)=SIN(THE)*COS(PHI)
+ ROT(2,1)=COS(THE)*SIN(PHI)
+ ROT(2,2)=COS(PHI)
+ ROT(2,3)=SIN(THE)*SIN(PHI)
+ ROT(3,1)=-SIN(THE)
+ ROT(3,2)=0D0
+ ROT(3,3)=COS(THE)
+ DO 140 I=IMIN,IMAX
+ IF(K(I,1).LE.0) GOTO 140
+ DO 120 J=1,3
+ PR(J)=P(I,J)
+ VR(J)=V(I,J)
+ 120 CONTINUE
+ DO 130 J=1,3
+ P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
+ V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
+ 130 CONTINUE
+ 140 CONTINUE
+ ENDIF
+
+C...Boost, typically from rest to momentum/energy=beta.
+ IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
+ DBX=BEX
+ DBY=BEY
+ DBZ=BEZ
+ DB=SQRT(DBX**2+DBY**2+DBZ**2)
+ EPS1=1D0-1D-12
+ IF(DB.GT.EPS1) THEN
+C...Rescale boost vector if too close to unity.
+ CALL PYERRM(3,'(PYROBO:) boost vector too large')
+ DBX=DBX*(EPS1/DB)
+ DBY=DBY*(EPS1/DB)
+ DBZ=DBZ*(EPS1/DB)
+ DB=EPS1
+ ENDIF
+ DGA=1D0/SQRT(1D0-DB**2)
+ DO 160 I=IMIN,IMAX
+ IF(K(I,1).LE.0) GOTO 160
+ DO 150 J=1,4
+ DP(J)=P(I,J)
+ DV(J)=V(I,J)
+ 150 CONTINUE
+ DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
+ DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
+ P(I,1)=DP(1)+DGABP*DBX
+ P(I,2)=DP(2)+DGABP*DBY
+ P(I,3)=DP(3)+DGABP*DBZ
+ P(I,4)=DGA*(DP(4)+DBP)
+ DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
+ DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
+ V(I,1)=DV(1)+DGABV*DBX
+ V(I,2)=DV(2)+DGABV*DBY
+ V(I,3)=DV(3)+DGABV*DBZ
+ V(I,4)=DGA*(DV(4)+DBV)
+ 160 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEDIT
+C...Performs global manipulations on the event record, in particular
+C...to exclude unstable or undetectable partons/particles.
+
+ SUBROUTINE PYEDIT(MEDIT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION NS(2),PTS(2),PLS(2)
+
+C...Remove unwanted partons/particles.
+ IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
+ IMAX=N
+ IF(MSTU(2).GT.0) IMAX=MSTU(2)
+ I1=MAX(1,MSTU(1))-1
+ DO 110 I=MAX(1,MSTU(1)),IMAX
+ IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
+ IF(MEDIT.EQ.1) THEN
+ IF(K(I,1).GT.10) GOTO 110
+ ELSEIF(MEDIT.EQ.2) THEN
+ IF(K(I,1).GT.10) GOTO 110
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
+ & GOTO 110
+ ELSEIF(MEDIT.EQ.3) THEN
+ IF(K(I,1).GT.10) GOTO 110
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 110
+ IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
+ ELSEIF(MEDIT.EQ.5) THEN
+ IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0) GOTO 110
+ IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
+ ENDIF
+
+C...Pack remaining partons/particles. Origin no longer known.
+ I1=I1+1
+ DO 100 J=1,5
+ K(I1,J)=K(I,J)
+ P(I1,J)=P(I,J)
+ V(I1,J)=V(I,J)
+ 100 CONTINUE
+ K(I1,3)=0
+ 110 CONTINUE
+ IF(I1.LT.N) MSTU(3)=0
+ IF(I1.LT.N) MSTU(70)=0
+ N=I1
+
+C...Selective removal of class of entries. New position of retained.
+ ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
+ I1=0
+ DO 120 I=1,N
+ K(I,3)=MOD(K(I,3),MSTU(5))
+ IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
+ IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
+ IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
+ & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
+ IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
+ & K(I,2).EQ.94)) GOTO 120
+ IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
+ I1=I1+1
+ K(I,3)=K(I,3)+MSTU(5)*I1
+ 120 CONTINUE
+
+C...Find new event history information and replace old.
+ DO 140 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
+ & GOTO 140
+ ID=I
+ 130 IM=MOD(K(ID,3),MSTU(5))
+ IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
+ IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
+ & K(IM,2).NE.94) THEN
+ ID=IM
+ GOTO 130
+ ENDIF
+ ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
+ IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
+ ID=IM
+ GOTO 130
+ ENDIF
+ ENDIF
+ K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
+ IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
+ IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
+ IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
+ & K(K(I,4),3)/MSTU(5)
+ IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
+ & K(K(I,5),3)/MSTU(5)
+ ELSE
+ KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
+ IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
+ KCD=MOD(K(I,4),MSTU(5))
+ IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
+ K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
+ KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
+ IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
+ KCD=MOD(K(I,5),MSTU(5))
+ IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
+ K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
+ ENDIF
+ 140 CONTINUE
+
+C...Pack remaining entries.
+ I1=0
+ MSTU90=MSTU(90)
+ MSTU(90)=0
+ DO 170 I=1,N
+ IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
+ I1=I1+1
+ DO 150 J=1,5
+ K(I1,J)=K(I,J)
+ P(I1,J)=P(I,J)
+ V(I1,J)=V(I,J)
+ 150 CONTINUE
+ K(I1,3)=MOD(K(I1,3),MSTU(5))
+ DO 160 IZ=1,MSTU90
+ IF(I.EQ.MSTU(90+IZ)) THEN
+ MSTU(90)=MSTU(90)+1
+ MSTU(90+MSTU(90))=I1
+ PARU(90+MSTU(90))=PARU(90+IZ)
+ ENDIF
+ 160 CONTINUE
+ 170 CONTINUE
+ IF(I1.LT.N) MSTU(3)=0
+ IF(I1.LT.N) MSTU(70)=0
+ N=I1
+
+C...Fill in some missing daughter pointers (lost in colour flow).
+ ELSEIF(MEDIT.EQ.16) THEN
+ DO 220 I=1,N
+ IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
+ IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
+C...Find daughters who point to mother.
+ DO 180 I1=I+1,N
+ IF(K(I1,3).NE.I) THEN
+ ELSEIF(K(I,4).EQ.0) THEN
+ K(I,4)=I1
+ ELSE
+ K(I,5)=I1
+ ENDIF
+ 180 CONTINUE
+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
+ IF(K(I,4).NE.0) GOTO 220
+C...Find daughters who point to documentation version of mother.
+ IM=K(I,3)
+ IF(IM.LE.0.OR.IM.GE.I) GOTO 220
+ IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
+ IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
+ DO 190 I1=I+1,N
+ IF(K(I1,3).NE.IM) THEN
+ ELSEIF(K(I,4).EQ.0) THEN
+ K(I,4)=I1
+ ELSE
+ K(I,5)=I1
+ ENDIF
+ 190 CONTINUE
+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
+ IF(K(I,4).NE.0) GOTO 220
+C...Find daughters who point to documentation daughters who,
+C...in their turn, point to documentation mother.
+ ID1=IM
+ ID2=IM
+ DO 200 I1=IM+1,I-1
+ IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
+ ID2=I1
+ IF(ID1.EQ.IM) ID1=I1
+ ENDIF
+ 200 CONTINUE
+ DO 210 I1=I+1,N
+ IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
+ ELSEIF(K(I,4).EQ.0) THEN
+ K(I,4)=I1
+ ELSE
+ K(I,5)=I1
+ ENDIF
+ 210 CONTINUE
+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
+ 220 CONTINUE
+
+C...Save top entries at bottom of PYJETS commonblock.
+ ELSEIF(MEDIT.EQ.21) THEN
+ IF(2*N.GE.MSTU(4)) THEN
+ CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
+ RETURN
+ ENDIF
+ DO 240 I=1,N
+ DO 230 J=1,5
+ K(MSTU(4)-I,J)=K(I,J)
+ P(MSTU(4)-I,J)=P(I,J)
+ V(MSTU(4)-I,J)=V(I,J)
+ 230 CONTINUE
+ 240 CONTINUE
+ MSTU(32)=N
+
+C...Restore bottom entries of commonblock PYJETS to top.
+ ELSEIF(MEDIT.EQ.22) THEN
+ DO 260 I=1,MSTU(32)
+ DO 250 J=1,5
+ K(I,J)=K(MSTU(4)-I,J)
+ P(I,J)=P(MSTU(4)-I,J)
+ V(I,J)=V(MSTU(4)-I,J)
+ 250 CONTINUE
+ 260 CONTINUE
+ N=MSTU(32)
+
+C...Mark primary entries at top of commonblock PYJETS as untreated.
+ ELSEIF(MEDIT.EQ.23) THEN
+ I1=0
+ DO 270 I=1,N
+ KH=K(I,3)
+ IF(KH.GE.1) THEN
+ IF(K(KH,1).GT.20) KH=0
+ ENDIF
+ IF(KH.NE.0) GOTO 280
+ I1=I1+1
+ IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
+ 270 CONTINUE
+ 280 N=I1
+
+C...Place largest axis along z axis and second largest in xy plane.
+ ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
+ CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
+ & P(MSTU(61),2)),0D0,0D0,0D0)
+ CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
+ & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
+ CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
+ & P(MSTU(61)+1,2)),0D0,0D0,0D0)
+ IF(MEDIT.EQ.31) RETURN
+
+C...Rotate to put slim jet along +z axis.
+ DO 290 IS=1,2
+ NS(IS)=0
+ PTS(IS)=0D0
+ PLS(IS)=0D0
+ 290 CONTINUE
+ DO 300 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 300
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
+ & .EQ.0) GOTO 300
+ ENDIF
+ IS=2D0-SIGN(0.5D0,P(I,3))
+ NS(IS)=NS(IS)+1
+ PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
+ 300 CONTINUE
+ IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
+ & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
+
+C...Rotate to put second largest jet into -z,+x quadrant.
+ DO 310 I=1,N
+ IF(P(I,3).GE.0D0) GOTO 310
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 310
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
+ & .EQ.0) GOTO 310
+ ENDIF
+ IS=2D0-SIGN(0.5D0,P(I,1))
+ PLS(IS)=PLS(IS)-P(I,3)
+ 310 CONTINUE
+ IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
+ & 0D0,0D0,0D0)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYLIST
+C...Gives program heading, or lists an event, or particle
+C...data, or current parameter values.
+
+ SUBROUTINE PYLIST(MLIST)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter statement to help give large particle numbers.
+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
+C...Local arrays, character variables and data.
+ CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
+ DIMENSION PS(6)
+ DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
+
+C...Initialization printout: version number and date of last change.
+ IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
+ CALL PYLOGO
+ MSTU(12)=0
+ IF(MLIST.EQ.0) RETURN
+ ENDIF
+
+C...List event data, including additional lines after N.
+ IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
+ IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
+ IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
+ IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
+ LMX=12
+ IF(MLIST.GE.2) LMX=16
+ ISTR=0
+ IMAX=N
+ IF(MSTU(2).GT.0) IMAX=MSTU(2)
+ DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
+ IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
+
+C...Get particle name, pad it and check it is not too long.
+ CALL PYNAME(K(I,2),CHAP)
+ LEN=0
+ DO 100 LEM=1,16
+ IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
+ 100 CONTINUE
+ MDL=(K(I,1)+19)/10
+ LDL=0
+ IF(MDL.EQ.2.OR.MDL.GE.8) THEN
+ CHAC=CHAP
+ IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
+ ELSE
+ LDL=1
+ IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
+ IF(LEN.EQ.0) THEN
+ CHAC=CHDL(MDL)(1:2*LDL)//' '
+ ELSE
+ CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
+ & CHDL(MDL)(LDL+1:2*LDL)//' '
+ IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
+ ENDIF
+ ENDIF
+
+C...Add information on string connection.
+ IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
+ & THEN
+ KC=PYCOMP(K(I,2))
+ KCC=0
+ IF(KC.NE.0) KCC=KCHG(KC,2)
+ IF(IABS(K(I,2)).EQ.39) THEN
+ IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
+ ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
+ ISTR=1
+ IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
+ ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
+ IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
+ ELSEIF(KCC.NE.0) THEN
+ ISTR=0
+ IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
+ ENDIF
+ ENDIF
+
+C...Write data for particle/jet.
+ IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
+ WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
+ & (P(I,J2),J2=1,5)
+ ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
+ WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
+ & (P(I,J2),J2=1,5)
+ ELSEIF(MLIST.EQ.1) THEN
+ WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
+ & (P(I,J2),J2=1,5)
+ ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
+ & K(I,1).EQ.14)) THEN
+ WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
+ & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
+ & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
+ & (P(I,J2),J2=1,5)
+ ELSE
+ WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
+ & (P(I,J2),J2=1,5)
+ ENDIF
+ IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
+
+C...Insert extra separator lines specified by user.
+ IF(MSTU(70).GE.1) THEN
+ ISEP=0
+ DO 110 J=1,MIN(10,MSTU(70))
+ IF(I.EQ.MSTU(70+J)) ISEP=1
+ 110 CONTINUE
+ IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
+ IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
+ ENDIF
+ 120 CONTINUE
+
+C...Sum of charges and momenta.
+ DO 130 J=1,6
+ PS(J)=PYP(0,J)
+ 130 CONTINUE
+ IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
+ WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
+ ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
+ WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
+ ELSEIF(MLIST.EQ.1) THEN
+ WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
+ ELSE
+ WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
+ ENDIF
+
+C...Give simple list of KF codes defined in program.
+ ELSEIF(MLIST.EQ.11) THEN
+ WRITE(MSTU(11),6600)
+ DO 140 KF=1,80
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
+ IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 140 CONTINUE
+ DO 170 KFLS=1,3,2
+ DO 160 KFLA=1,5
+ DO 150 KFLB=1,KFLA-(3-KFLS)/2
+ KF=1000*KFLA+100*KFLB+KFLS
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ KF=130
+ CALL PYNAME(KF,CHAP)
+ WRITE(MSTU(11),6700) KF,CHAP
+ KF=310
+ CALL PYNAME(KF,CHAP)
+ WRITE(MSTU(11),6700) KF,CHAP
+ DO 200 KMUL=0,5
+ KFLS=3
+ IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
+ IF(KMUL.EQ.5) KFLS=5
+ KFLR=0
+ IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
+ IF(KMUL.EQ.4) KFLR=2
+ DO 190 KFLB=1,5
+ DO 180 KFLC=1,KFLB-1
+ KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 180 CONTINUE
+ KF=10000*KFLR+110*KFLB+KFLS
+ CALL PYNAME(KF,CHAP)
+ WRITE(MSTU(11),6700) KF,CHAP
+ 190 CONTINUE
+ 200 CONTINUE
+ KF=100443
+ CALL PYNAME(KF,CHAP)
+ WRITE(MSTU(11),6700) KF,CHAP
+ KF=100553
+ CALL PYNAME(KF,CHAP)
+ WRITE(MSTU(11),6700) KF,CHAP
+ DO 240 KFLSP=1,3
+ KFLS=2+2*(KFLSP/3)
+ DO 230 KFLA=1,5
+ DO 220 KFLB=1,KFLA
+ DO 210 KFLC=1,KFLB
+ IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
+ & GOTO 210
+ IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
+ IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
+ IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 210 CONTINUE
+ 220 CONTINUE
+ 230 CONTINUE
+ 240 CONTINUE
+ DO 250 KF=KSUSY1+1,KSUSY1+40
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
+ IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 250 CONTINUE
+ DO 260 KF=KSUSY2+1,KSUSY2+40
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
+ IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 260 CONTINUE
+ DO 270 KF=KEXCIT+1,KEXCIT+40
+ CALL PYNAME(KF,CHAP)
+ CALL PYNAME(-KF,CHAN)
+ IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
+ IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
+ 270 CONTINUE
+
+C...List parton/particle data table. Check whether to be listed.
+ ELSEIF(MLIST.EQ.12) THEN
+ WRITE(MSTU(11),6800)
+ DO 300 KC=1,MSTU(6)
+ KF=KCHG(KC,4)
+ IF(KF.EQ.0) GOTO 300
+ IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
+ & GOTO 300
+
+C...Find particle name and mass. Print information.
+ CALL PYNAME(KF,CHAP)
+ IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
+ CALL PYNAME(-KF,CHAN)
+ WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
+ & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
+
+C...Particle decay: channel number, branching ratios, matrix element,
+C...decay products.
+ DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
+ DO 280 J=1,5
+ CALL PYNAME(KFDP(IDC,J),CHAD(J))
+ 280 CONTINUE
+ WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
+ & (CHAD(J),J=1,5)
+ 290 CONTINUE
+ 300 CONTINUE
+
+C...List parameter value table.
+ ELSEIF(MLIST.EQ.13) THEN
+ WRITE(MSTU(11),7100)
+ DO 310 I=1,200
+ WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
+ 310 CONTINUE
+ ENDIF
+
+C...Format statements for output on unit MSTU(11) (by default 6).
+ 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
+ &5X,'KF orig p_x p_y p_z E m'/)
+ 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
+ &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
+ &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
+ 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
+ &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
+ &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
+ &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
+ 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
+ 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
+ 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
+ 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
+ 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
+ 5900 FORMAT(66X,5(1X,F12.3))
+ 6000 FORMAT(1X,78('='))
+ 6100 FORMAT(1X,130('='))
+ 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
+ 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
+ 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
+ 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
+ &5F13.5)
+ 6600 FORMAT(///20X,'List of KF codes in program'/)
+ 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
+ 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
+ &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
+ &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
+ &1X,'ME',3X,'Br.rat.',4X,'decay products')
+ 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
+ &1X,1P,E13.5,3X,I2)
+ 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
+ 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
+ &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
+ 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYLOGO
+C...Writes a logo for the program.
+
+ SUBROUTINE PYLOGO
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Parameter for length of information block.
+ PARAMETER (IREFER=17)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
+ SAVE /PYDAT1/,/PYPARS/
+C...Local arrays and character variables.
+ INTEGER IDATI(6)
+ CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
+ &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
+
+C...Data on months, logo, titles, and references.
+ DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
+ &'Oct','Nov','Dec'/
+ DATA (LOGO(J),J=1,19)/
+ &' *......* ',
+ &' *:::!!:::::::::::* ',
+ &' *::::::!!::::::::::::::* ',
+ &' *::::::::!!::::::::::::::::* ',
+ &' *:::::::::!!:::::::::::::::::* ',
+ &' *:::::::::!!:::::::::::::::::* ',
+ &' *::::::::!!::::::::::::::::*! ',
+ &' *::::::!!::::::::::::::* !! ',
+ &' !! *:::!!:::::::::::* !! ',
+ &' !! !* -><- * !! ',
+ &' !! !! !! ',
+ &' !! !! !! ',
+ &' !! !! ',
+ &' !! ep !! ',
+ &' !! !! ',
+ &' !! pp !! ',
+ &' !! e+e- !! ',
+ &' !! !! ',
+ &' !! '/
+ DATA (LOGO(J),J=20,38)/
+ &'Welcome to the Lund Monte Carlo!',
+ &' ',
+ &'PPP Y Y TTTTT H H III A ',
+ &'P P Y Y T H H I A A ',
+ &'PPP Y T HHHHH I AAAAA',
+ &'P Y T H H I A A',
+ &'P Y T H H III A A',
+ &' ',
+ &'This is PYTHIA version x.xxx ',
+ &'Last date of change: xx xxx 199x',
+ &' ',
+ &'Now is xx xxx 199x at xx:xx:xx ',
+ &' ',
+ &'Disclaimer: this program comes ',
+ &'without any guarantees. Beware ',
+ &'of errors and use common sense ',
+ &'when interpreting results. ',
+ &' ',
+ &'Copyright T. Sjostrand (1997) '/
+ DATA (REFER(J),J=1,18)/
+ &'An archive of program versions and d',
+ &'ocumentation is found on the web: ',
+ &'http://www.thep.lu.se/tf2/staff/torb',
+ &'jorn/Pythia.html ',
+ &' ',
+ &' ',
+ &'When you cite this program, currentl',
+ &'y the official reference is ',
+ &'T. Sjostrand, Computer Physics Commu',
+ &'n. 82 (1994) 74. ',
+ &'The supersymmetry extensions are des',
+ &'cribed in ',
+ &'S. Mrenna, Computer Physics Commun. ',
+ &'101 (1997) 232 ',
+ &'Also remember that the program, to a',
+ &' large extent, represents original ',
+ &'physics research. Other publications',
+ &' of special relevance to your '/
+ DATA (REFER(J),J=19,2*IREFER)/
+ &'studies may therefore deserve separa',
+ &'te mention. ',
+ &' ',
+ &' ',
+ &'Main author: Torbjorn Sjostrand; Dep',
+ &'artment of Theoretical Physics 2, ',
+ &' Lund University, Solvegatan 14A, S',
+ &'-223 62 Lund, Sweden; ',
+ &' phone: + 46 - 46 - 222 48 16; e-ma',
+ &'il: torbjorn@thep.lu.se ',
+ &'SUSY author: Stephen Mrenna, Argonne',
+ &' National Laboratory, ',
+ &' 9700 South Cass Avenue, Argonne, I',
+ &'L 60439, USA; ',
+ &' phone: + 1 - 630 - 252 - 7615; e-m',
+ &'ail: mrenna@hep.anl.gov '/
+
+C...Check that PYDATA linked.
+ IF(MSTP(183)/10.NE.199) THEN
+ WRITE(MSTU(11),'(1X,A)')
+ & 'Error: PYDATA has not been linked.'
+ WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
+ STOP
+
+C...Write current version number and current date+time.
+ ELSE
+ WRITE(VERS,'(I1)') MSTP(181)
+ LOGO(28)(24:24)=VERS
+ WRITE(SUBV,'(I3)') MSTP(182)
+ LOGO(28)(26:28)=SUBV
+ IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
+ WRITE(DATE,'(I2)') MSTP(185)
+ LOGO(29)(22:23)=DATE
+ LOGO(29)(25:27)=MONTH(MSTP(184))
+ WRITE(YEAR,'(I4)') MSTP(183)
+ LOGO(29)(29:32)=YEAR
+ CALL PYTIME(IDATI)
+ IF(IDATI(1).LE.0) THEN
+ LOGO(31)=' '
+ ELSE
+ WRITE(DATE,'(I2)') IDATI(3)
+ LOGO(31)(8:9)=DATE
+ LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
+ WRITE(YEAR,'(I4)') IDATI(1)
+ LOGO(31)(15:18)=YEAR
+ WRITE(HOUR,'(I2)') IDATI(4)
+ LOGO(31)(23:24)=HOUR
+ WRITE(MINU,'(I2)') IDATI(5)
+ LOGO(31)(26:27)=MINU
+ IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
+ WRITE(SECO,'(I2)') IDATI(6)
+ LOGO(31)(29:30)=SECO
+ IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
+ ENDIF
+ ENDIF
+
+C...Loop over lines in header. Define page feed and side borders.
+ DO 100 ILIN=1,29+IREFER
+ LINE=' '
+ IF(ILIN.EQ.1) THEN
+ LINE(1:1)='1'
+ ELSE
+ LINE(2:3)='**'
+ LINE(78:79)='**'
+ ENDIF
+
+C...Separator lines and logos.
+ IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
+ LINE(4:77)='***********************************************'//
+ & '***************************'
+ ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
+ LINE(6:37)=LOGO(ILIN-5)
+ LINE(44:75)=LOGO(ILIN+14)
+ ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
+ LINE(5:40)=REFER(2*ILIN-51)
+ LINE(41:76)=REFER(2*ILIN-50)
+ ENDIF
+
+C...Write lines to appropriate unit.
+ WRITE(MSTU(11),'(A79)') LINE
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYUPDA
+C...Facilitates the updating of particle and decay data
+C...by allowing it to be done in an external file.
+
+ SUBROUTINE PYUPDA(MUPDA,LFN)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ COMMON/PYDAT4/CHAF(500,2)
+ CHARACTER CHAF*16
+ COMMON/PYINT4/MWID(500),WIDS(500,5)
+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
+C...Local arrays, character variables and data.
+ CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
+ &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
+ DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
+ &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
+ &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
+ &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
+ &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
+
+C...Write header if not yet done.
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+
+C...Write information on file for editing.
+ IF(MUPDA.EQ.1) THEN
+ DO 110 KC=1,500
+ WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
+ & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
+ & MWID(KC),MDCY(KC,1)
+ DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
+ WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
+ & (KFDP(IDC,J),J=1,5)
+ 100 CONTINUE
+ 110 CONTINUE
+
+C...Read complete set of information from edited file or
+C...read partial set of new or updated information from edited file.
+ ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
+
+C...Reset counters.
+ KCC=100
+ NDC=0
+ CHKF=' '
+ IF(MUPDA.EQ.2) THEN
+ DO 120 I=1,MSTU(6)
+ KCHG(I,4)=0
+ 120 CONTINUE
+ ELSE
+ DO 130 KC=1,MSTU(6)
+ IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
+ NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
+ 130 CONTINUE
+ ENDIF
+
+C...Begin of loop: read new line; unknown whether particle or
+C...decay data.
+ 140 READ(LFN,5200,END=190) CHINL
+
+C...Identify particle code and whether already defined (for MUPDA=3).
+ IF(CHINL(2:10).NE.' ') THEN
+ CHKF=CHINL(2:10)
+ READ(CHKF,5300) KF
+ IF(MUPDA.EQ.2) THEN
+ IF(KF.LE.100) THEN
+ KC=KF
+ ELSE
+ KCC=KCC+1
+ KC=KCC
+ ENDIF
+ ELSE
+ KCREP=0
+ IF(KF.LE.100) THEN
+ KCREP=KF
+ ELSE
+ DO 150 KCR=101,KCC
+ IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
+ 150 CONTINUE
+ ENDIF
+C...Remove duplicate old decay data.
+ IF(KCREP.NE.0) THEN
+ IDCREP=MDCY(KCREP,2)
+ NDCREP=MDCY(KCREP,3)
+ DO 160 I=1,KCC
+ IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
+ 160 CONTINUE
+ DO 180 I=IDCREP,NDC-NDCREP
+ MDME(I,1)=MDME(I+NDCREP,1)
+ MDME(I,2)=MDME(I+NDCREP,2)
+ BRAT(I)=BRAT(I+NDCREP)
+ DO 170 J=1,5
+ KFDP(I,J)=KFDP(I+NDCREP,J)
+ 170 CONTINUE
+ 180 CONTINUE
+ NDC=NDC-NDCREP
+ KC=KCREP
+ ELSE
+ KCC=KCC+1
+ KC=KCC
+ ENDIF
+ ENDIF
+
+C...Study line with particle data.
+ IF(KC.GT.MSTU(6)) CALL PYERRM(27,
+ & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
+ READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
+ & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
+ & MWID(KC),MDCY(KC,1)
+ MDCY(KC,2)=0
+ MDCY(KC,3)=0
+
+C...Study line with decay data.
+ ELSE
+ NDC=NDC+1
+ IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
+ & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
+ IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
+ MDCY(KC,3)=MDCY(KC,3)+1
+ READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
+ & (KFDP(NDC,J),J=1,5)
+ ENDIF
+
+C...End of loop; ensure that PYCOMP tables are updated.
+ GOTO 140
+ 190 CONTINUE
+ MSTU(20)=0
+
+C...Perform possible tests that new information is consistent.
+ MSTJ24=MSTJ(24)
+ MSTJ(24)=0
+ DO 220 KC=1,MSTU(6)
+ KF=KCHG(KC,4)
+ IF(KF.EQ.0) GOTO 220
+ WRITE(CHKF,5300) KF
+ IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
+ & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
+ & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
+ BRSUM=0D0
+ DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
+ IF(MDME(IDC,2).GT.80) GOTO 210
+ KQ=KCHG(KC,1)
+ PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
+ MERR=0
+ DO 200 J=1,5
+ KP=KFDP(IDC,J)
+ IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
+ IF(KP.EQ.81) KQ=0
+ ELSEIF(PYCOMP(KP).EQ.0) THEN
+ MERR=3
+ ELSE
+ KQ=KQ-PYCHGE(KP)
+ PMS=PMS-PYMASS(KP)
+ KPC=PYCOMP(KP)
+ PMS=PMS-PMAS(KPC,1)
+ IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
+ & PMAS(KPC,3))
+ ENDIF
+ 200 CONTINUE
+ IF(KQ.NE.0) MERR=MAX(2,MERR)
+ IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
+ & MERR=MAX(1,MERR)
+ IF(MERR.EQ.3) CALL PYERRM(17,
+ & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
+ IF(MERR.EQ.2) CALL PYERRM(17,
+ & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
+ IF(MERR.EQ.1) CALL PYERRM(7,
+ & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
+ BRSUM=BRSUM+BRAT(IDC)
+ 210 CONTINUE
+ WRITE(CHTMP,5500) BRSUM
+ IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
+ & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
+ & CHTMP(9:16)//' for KF ='//CHKF)
+ 220 CONTINUE
+ MSTJ(24)=MSTJ24
+
+C...Write DATA statements for inclusion in program.
+ ELSEIF(MUPDA.EQ.4) THEN
+
+C...Find out how many codes and decay channels are actually used.
+ KCC=0
+ NDC=0
+ DO 230 I=1,MSTU(6)
+ IF(KCHG(I,4).NE.0) THEN
+ KCC=I
+ NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
+ ENDIF
+ 230 CONTINUE
+
+C...Initialize writing of DATA statements for inclusion in program.
+ DO 300 IVAR=1,22
+ NDIM=MSTU(6)
+ IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
+ NLIN=1
+ CHLIN=' '
+ CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
+ LLIN=35
+ CHOLD='START'
+
+C...Loop through variables for conversion to characters.
+ DO 280 IDIM=1,NDIM
+ IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
+ IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
+ IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
+ IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
+ IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
+ IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
+ IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
+ IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
+ IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
+ IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
+ IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
+ IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
+ IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
+ IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
+ IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
+ IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
+ IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
+ IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
+ IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
+ IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
+ IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
+ IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
+
+C...Replace variables beyond what is properly defined.
+ IF(IVAR.LE.4) THEN
+ IF(IDIM.GT.KCC) CHTMP=' 0'
+ ELSEIF(IVAR.LE.8) THEN
+ IF(IDIM.GT.KCC) CHTMP=' 0.0'
+ ELSEIF(IVAR.LE.11) THEN
+ IF(IDIM.GT.KCC) CHTMP=' 0'
+ ELSEIF(IVAR.LE.13) THEN
+ IF(IDIM.GT.NDC) CHTMP=' 0'
+ ELSEIF(IVAR.LE.14) THEN
+ IF(IDIM.GT.NDC) CHTMP=' 0.0'
+ ELSEIF(IVAR.LE.19) THEN
+ IF(IDIM.GT.NDC) CHTMP=' 0'
+ ELSEIF(IVAR.LE.21) THEN
+ IF(IDIM.GT.KCC) CHTMP=' '
+ ELSE
+ IF(IDIM.GT.KCC) CHTMP=' 0'
+ ENDIF
+
+C...Length of variable, trailing decimal zeros, quotation marks.
+ LLOW=1
+ LHIG=1
+ DO 240 LL=1,16
+ IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
+ IF(CHTMP(LL:LL).NE.' ') LHIG=LL
+ 240 CONTINUE
+ CHNEW=CHTMP(LLOW:LHIG)//' '
+ LNEW=1+LHIG-LLOW
+ IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
+ LNEW=LNEW+1
+ 250 LNEW=LNEW-1
+ IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
+ IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
+ IF(LNEW.EQ.0) THEN
+ CHNEW(1:3)='0D0'
+ LNEW=3
+ ELSE
+ CHNEW(LNEW+1:LNEW+2)='D0'
+ LNEW=LNEW+2
+ ENDIF
+ ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
+ DO 260 LL=LNEW,1,-1
+ IF(CHNEW(LL:LL).EQ.'''') THEN
+ CHTMP=CHNEW
+ CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
+ LNEW=LNEW+1
+ ENDIF
+ 260 CONTINUE
+ LNEW=MIN(14,LNEW)
+ CHTMP=CHNEW
+ CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
+ LNEW=LNEW+2
+ ENDIF
+
+C...Form composite character string, often including repetition counter.
+ IF(CHNEW.NE.CHOLD) THEN
+ NRPT=1
+ CHOLD=CHNEW
+ CHCOM=CHNEW
+ LCOM=LNEW
+ ELSE
+ LRPT=LNEW+1
+ IF(NRPT.GE.2) LRPT=LNEW+3
+ IF(NRPT.GE.10) LRPT=LNEW+4
+ IF(NRPT.GE.100) LRPT=LNEW+5
+ IF(NRPT.GE.1000) LRPT=LNEW+6
+ LLIN=LLIN-LRPT
+ NRPT=NRPT+1
+ WRITE(CHTMP,5400) NRPT
+ LRPT=1
+ IF(NRPT.GE.10) LRPT=2
+ IF(NRPT.GE.100) LRPT=3
+ IF(NRPT.GE.1000) LRPT=4
+ CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
+ LCOM=LRPT+1+LNEW
+ ENDIF
+
+C...Add characters to end of line, to new line (after storing old line),
+C...or to new block of lines (after writing old block).
+ IF(LLIN+LCOM.LE.70) THEN
+ CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
+ LLIN=LLIN+LCOM+1
+ ELSEIF(NLIN.LE.19) THEN
+ CHLIN(LLIN+1:72)=' '
+ CHBLK(NLIN)=CHLIN
+ NLIN=NLIN+1
+ CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
+ LLIN=6+LCOM+1
+ ELSE
+ CHLIN(LLIN:72)='/'//' '
+ CHBLK(NLIN)=CHLIN
+ WRITE(CHTMP,5400) IDIM-NRPT
+ CHBLK(1)(30:33)=CHTMP(13:16)
+ DO 270 ILIN=1,NLIN
+ WRITE(LFN,5700) CHBLK(ILIN)
+ 270 CONTINUE
+ NLIN=1
+ CHLIN=' '
+ CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
+ & ',I= , )/'//CHCOM(1:LCOM)//','
+ WRITE(CHTMP,5400) IDIM-NRPT+1
+ CHLIN(25:28)=CHTMP(13:16)
+ LLIN=35+LCOM+1
+ ENDIF
+ 280 CONTINUE
+
+C...Write final block of lines.
+ CHLIN(LLIN:72)='/'//' '
+ CHBLK(NLIN)=CHLIN
+ WRITE(CHTMP,5400) NDIM
+ CHBLK(1)(30:33)=CHTMP(13:16)
+ DO 290 ILIN=1,NLIN
+ WRITE(LFN,5700) CHBLK(ILIN)
+ 290 CONTINUE
+ 300 CONTINUE
+ ENDIF
+
+C...Formats for reading and writing particle data.
+ 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
+ 5100 FORMAT(10X,2I5,F12.6,5I10)
+ 5200 FORMAT(A120)
+ 5300 FORMAT(I9)
+ 5400 FORMAT(I16)
+ 5500 FORMAT(F16.5)
+ 5600 FORMAT(F16.6)
+ 5700 FORMAT(A72)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYK
+C...Provides various integer-valued event related data.
+
+ FUNCTION PYK(I,J)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Default value. For I=0 number of entries, number of stable entries
+C...or 3 times total charge.
+ PYK=0
+ IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
+ ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
+ PYK=N
+ ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
+ DO 100 I1=1,N
+ IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
+ IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
+ & PYCHGE(K(I1,2))
+ 100 CONTINUE
+ ELSEIF(I.EQ.0) THEN
+
+C...For I > 0 direct readout of K matrix or charge.
+ ELSEIF(J.LE.5) THEN
+ PYK=K(I,J)
+ ELSEIF(J.EQ.6) THEN
+ PYK=PYCHGE(K(I,2))
+
+C...Status (existing/fragmented/decayed), parton/hadron separation.
+ ELSEIF(J.LE.8) THEN
+ IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
+ IF(J.EQ.8) PYK=PYK*K(I,2)
+ ELSEIF(J.LE.12) THEN
+ KFA=IABS(K(I,2))
+ KC=PYCOMP(KFA)
+ KQ=0
+ IF(KC.NE.0) KQ=KCHG(KC,2)
+ IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
+ IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
+ IF(J.EQ.11) PYK=KC
+ IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
+
+C...Heaviest flavour in hadron/diquark.
+ ELSEIF(J.EQ.13) THEN
+ KFA=IABS(K(I,2))
+ PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
+ IF(KFA.LT.10) PYK=KFA
+ IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
+ PYK=PYK*ISIGN(1,K(I,2))
+
+C...Particle history: generation, ancestor, rank.
+ ELSEIF(J.LE.15) THEN
+ I2=I
+ I1=I
+ 110 PYK=PYK+1
+ I2=I1
+ I1=K(I1,3)
+ IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
+ IF(J.EQ.15) PYK=I2
+ ELSEIF(J.EQ.16) THEN
+ KFA=IABS(K(I,2))
+ IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
+ & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
+ I1=I
+ 120 I2=I1
+ I1=K(I1,3)
+ IF(I1.GT.0) THEN
+ KFAM=IABS(K(I1,2))
+ ILP=1
+ IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
+ IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
+ & ILP=0
+ IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
+ IF(ILP.EQ.1) GOTO 120
+ ENDIF
+ IF(K(I1,1).EQ.12) THEN
+ DO 130 I3=I1+1,I2
+ IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
+ & .AND.K(I3,2).NE.93) PYK=PYK+1
+ 130 CONTINUE
+ ELSE
+ I3=I2
+ 140 PYK=PYK+1
+ I3=I3+1
+ IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
+ ENDIF
+ ENDIF
+
+C...Particle coming from collapsing jet system or not.
+ ELSEIF(J.EQ.17) THEN
+ I1=I
+ 150 PYK=PYK+1
+ I3=I1
+ I1=K(I1,3)
+ I0=MAX(1,I1)
+ KC=PYCOMP(K(I0,2))
+ IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
+ IF(PYK.EQ.1) PYK=-1
+ IF(PYK.GT.1) PYK=0
+ RETURN
+ ENDIF
+ IF(KCHG(KC,2).EQ.0) GOTO 150
+ IF(K(I1,1).NE.12) PYK=0
+ IF(K(I1,1).NE.12) RETURN
+ I2=I1
+ 160 I2=I2+1
+ IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
+ K3M=K(I3-1,3)
+ IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
+ K3P=K(I3+1,3)
+ IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
+
+C...Number of decay products. Colour flow.
+ ELSEIF(J.EQ.18) THEN
+ IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
+ IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
+ ELSEIF(J.LE.22) THEN
+ IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
+ IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
+ IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
+ IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
+ IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
+ ELSE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYP
+C...Provides various real-valued event related data.
+
+ FUNCTION PYP(I,J)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local array.
+ DIMENSION PSUM(4)
+
+C...Set default value. For I = 0 sum of momenta or charges,
+C...or invariant mass of system.
+ PYP=0D0
+ IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
+ ELSEIF(I.EQ.0.AND.J.LE.4) THEN
+ DO 100 I1=1,N
+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
+ 100 CONTINUE
+ ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
+ DO 120 J1=1,4
+ PSUM(J1)=0D0
+ DO 110 I1=1,N
+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
+ & P(I1,J1)
+ 110 CONTINUE
+ 120 CONTINUE
+ PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
+ ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
+ DO 130 I1=1,N
+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
+ 130 CONTINUE
+ ELSEIF(I.EQ.0) THEN
+
+C...Direct readout of P matrix.
+ ELSEIF(J.LE.5) THEN
+ PYP=P(I,J)
+
+C...Charge, total momentum, transverse momentum, transverse mass.
+ ELSEIF(J.LE.12) THEN
+ IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
+ IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
+ IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
+ IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
+ IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
+
+C...Theta and phi angle in radians or degrees.
+ ELSEIF(J.LE.16) THEN
+ IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
+ IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
+ IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
+
+C...True rapidity, rapidity with pion mass, pseudorapidity.
+ ELSEIF(J.LE.19) THEN
+ PMR=0D0
+ IF(J.EQ.17) PMR=P(I,5)
+ IF(J.EQ.18) PMR=PYMASS(211)
+ PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
+ PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
+ & 1D20)),P(I,3))
+
+C...Energy and momentum fractions (only to be used in CM frame).
+ ELSEIF(J.LE.25) THEN
+ IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
+ IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
+ IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
+ IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
+ IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
+ IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYSPHE
+C...Performs sphericity tensor analysis to give sphericity,
+C...aplanarity and the related event axes.
+
+ SUBROUTINE PYSPHE(SPH,APL)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION SM(3,3),SV(3,3)
+
+C...Calculate matrix to be diagonalized.
+ NP=0
+ DO 110 J1=1,3
+ DO 100 J2=J1,3
+ SM(J1,J2)=0D0
+ 100 CONTINUE
+ 110 CONTINUE
+ PS=0D0
+ DO 140 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 140
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 140
+ ENDIF
+ NP=NP+1
+ PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ PWT=1D0
+ IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
+ & MAX(1D-10,PA)**(PARU(41)-2D0)
+ DO 130 J1=1,3
+ DO 120 J2=J1,3
+ SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
+ 120 CONTINUE
+ 130 CONTINUE
+ PS=PS+PWT*PA**2
+ 140 CONTINUE
+
+C...Very low multiplicities (0 or 1) not considered.
+ IF(NP.LE.1) THEN
+ CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
+ SPH=-1D0
+ APL=-1D0
+ RETURN
+ ENDIF
+ DO 160 J1=1,3
+ DO 150 J2=J1,3
+ SM(J1,J2)=SM(J1,J2)/PS
+ 150 CONTINUE
+ 160 CONTINUE
+
+C...Find eigenvalues to matrix (third degree equation).
+ SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
+ &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
+ SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
+ SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
+ P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
+ P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
+ P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
+ IF(P(N+2,4).LT.1D-5) THEN
+ CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
+ SPH=-1D0
+ APL=-1D0
+ RETURN
+ ENDIF
+
+C...Find first and last eigenvector by solving equation system.
+ DO 240 I=1,3,2
+ DO 180 J1=1,3
+ SV(J1,J1)=SM(J1,J1)-P(N+I,4)
+ DO 170 J2=J1+1,3
+ SV(J1,J2)=SM(J1,J2)
+ SV(J2,J1)=SM(J1,J2)
+ 170 CONTINUE
+ 180 CONTINUE
+ SMAX=0D0
+ DO 200 J1=1,3
+ DO 190 J2=1,3
+ IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
+ JA=J1
+ JB=J2
+ SMAX=ABS(SV(J1,J2))
+ 190 CONTINUE
+ 200 CONTINUE
+ SMAX=0D0
+ DO 220 J3=JA+1,JA+2
+ J1=J3-3*((J3-1)/3)
+ RL=SV(J1,JB)/SV(JA,JB)
+ DO 210 J2=1,3
+ SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
+ IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
+ JC=J1
+ SMAX=ABS(SV(J1,J2))
+ 210 CONTINUE
+ 220 CONTINUE
+ JB1=JB+1-3*(JB/3)
+ JB2=JB+2-3*((JB+1)/3)
+ P(N+I,JB1)=-SV(JC,JB2)
+ P(N+I,JB2)=SV(JC,JB1)
+ P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
+ & SV(JA,JB)
+ PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
+ DO 230 J=1,3
+ P(N+I,J)=SGN*P(N+I,J)/PA
+ 230 CONTINUE
+ 240 CONTINUE
+
+C...Middle axis orthogonal to other two. Fill other codes.
+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
+ P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
+ P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
+ P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
+ DO 260 I=1,3
+ K(N+I,1)=31
+ K(N+I,2)=95
+ K(N+I,3)=I
+ K(N+I,4)=0
+ K(N+I,5)=0
+ P(N+I,5)=0D0
+ DO 250 J=1,5
+ V(I,J)=0D0
+ 250 CONTINUE
+ 260 CONTINUE
+
+C...Calculate sphericity and aplanarity. Select storing option.
+ SPH=1.5D0*(P(N+2,4)+P(N+3,4))
+ APL=1.5D0*P(N+3,4)
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ IF(MSTU(43).LE.1) MSTU(3)=3
+ IF(MSTU(43).GE.2) N=N+3
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTHRU
+C...Performs thrust analysis to give thrust, oblateness
+C...and the related event axes.
+
+ SUBROUTINE PYTHRU(THR,OBL)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION TDI(3),TPR(3)
+
+C...Take copy of particles that are to be considered in thrust analysis.
+ NP=0
+ PS=0D0
+ DO 100 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 100
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 100
+ ENDIF
+ IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
+ THR=-2D0
+ OBL=-2D0
+ RETURN
+ ENDIF
+ NP=NP+1
+ K(N+NP,1)=23
+ P(N+NP,1)=P(I,1)
+ P(N+NP,2)=P(I,2)
+ P(N+NP,3)=P(I,3)
+ P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ P(N+NP,5)=1D0
+ IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
+ & P(N+NP,4)**(PARU(42)-1D0)
+ PS=PS+P(N+NP,4)*P(N+NP,5)
+ 100 CONTINUE
+
+C...Very low multiplicities (0 or 1) not considered.
+ IF(NP.LE.1) THEN
+ CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
+ THR=-1D0
+ OBL=-1D0
+ RETURN
+ ENDIF
+
+C...Loop over thrust and major. T axis along z direction in latter case.
+ DO 320 ILD=1,2
+ IF(ILD.EQ.2) THEN
+ K(N+NP+1,1)=31
+ PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
+ MSTU(33)=1
+ CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
+ THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
+ CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
+ ENDIF
+
+C...Find and order particles with highest p (pT for major).
+ DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
+ P(ILF,4)=0D0
+ 110 CONTINUE
+ DO 160 I=N+1,N+NP
+ IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
+ DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
+ IF(P(I,4).LE.P(ILF,4)) GOTO 140
+ DO 120 J=1,5
+ P(ILF+1,J)=P(ILF,J)
+ 120 CONTINUE
+ 130 CONTINUE
+ ILF=N+NP+3
+ 140 DO 150 J=1,5
+ P(ILF+1,J)=P(I,J)
+ 150 CONTINUE
+ 160 CONTINUE
+
+C...Find and order initial axes with highest thrust (major).
+ DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
+ P(ILG,4)=0D0
+ 170 CONTINUE
+ NC=2**(MIN(MSTU(44),NP)-1)
+ DO 250 ILC=1,NC
+ DO 180 J=1,3
+ TDI(J)=0D0
+ 180 CONTINUE
+ DO 200 ILF=1,MIN(MSTU(44),NP)
+ SGN=P(N+NP+ILF+3,5)
+ IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
+ DO 190 J=1,4-ILD
+ TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
+ 190 CONTINUE
+ 200 CONTINUE
+ TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
+ DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
+ IF(TDS.LE.P(ILG,4)) GOTO 230
+ DO 210 J=1,4
+ P(ILG+1,J)=P(ILG,J)
+ 210 CONTINUE
+ 220 CONTINUE
+ ILG=N+NP+MSTU(44)+4
+ 230 DO 240 J=1,3
+ P(ILG+1,J)=TDI(J)
+ 240 CONTINUE
+ P(ILG+1,4)=TDS
+ 250 CONTINUE
+
+C...Iterate direction of axis until stable maximum.
+ P(N+NP+ILD,4)=0D0
+ ILG=0
+ 260 ILG=ILG+1
+ THP=0D0
+ 270 THPS=THP
+ DO 280 J=1,3
+ IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
+ IF(THP.GT.1D-10) TDI(J)=TPR(J)
+ TPR(J)=0D0
+ 280 CONTINUE
+ DO 300 I=N+1,N+NP
+ SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
+ DO 290 J=1,4-ILD
+ TPR(J)=TPR(J)+SGN*P(I,J)
+ 290 CONTINUE
+ 300 CONTINUE
+ THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
+ IF(THP.GE.THPS+PARU(48)) GOTO 270
+
+C...Save good axis. Try new initial axis until a number of tries agree.
+ IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
+ IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
+ IAGR=0
+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
+ DO 310 J=1,3
+ P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
+ 310 CONTINUE
+ P(N+NP+ILD,4)=THP
+ P(N+NP+ILD,5)=0D0
+ ENDIF
+ IAGR=IAGR+1
+ IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
+ 320 CONTINUE
+
+C...Find minor axis and value by orthogonality.
+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
+ P(N+NP+3,1)=-SGN*P(N+NP+2,2)
+ P(N+NP+3,2)=SGN*P(N+NP+2,1)
+ P(N+NP+3,3)=0D0
+ THP=0D0
+ DO 330 I=N+1,N+NP
+ THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
+ 330 CONTINUE
+ P(N+NP+3,4)=THP/PS
+ P(N+NP+3,5)=0D0
+
+C...Fill axis information. Rotate back to original coordinate system.
+ DO 350 ILD=1,3
+ K(N+ILD,1)=31
+ K(N+ILD,2)=96
+ K(N+ILD,3)=ILD
+ K(N+ILD,4)=0
+ K(N+ILD,5)=0
+ DO 340 J=1,5
+ P(N+ILD,J)=P(N+NP+ILD,J)
+ V(N+ILD,J)=0D0
+ 340 CONTINUE
+ 350 CONTINUE
+ CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
+
+C...Calculate thrust and oblateness. Select storing option.
+ THR=P(N+1,4)
+ OBL=P(N+2,4)-P(N+3,4)
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ IF(MSTU(43).LE.1) MSTU(3)=3
+ IF(MSTU(43).GE.2) N=N+3
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCLUS
+C...Subdivides the particle content of an event into jets/clusters.
+
+ SUBROUTINE PYCLUS(NJET)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays and saved variables.
+ DIMENSION PS(5)
+ SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
+
+C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
+ R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
+ &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
+ R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
+ &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
+ R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
+ &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
+
+C...If first time, reset. If reentering, skip preliminaries.
+ IF(MSTU(48).LE.0) THEN
+ NP=0
+ DO 100 J=1,5
+ PS(J)=0D0
+ 100 CONTINUE
+ PSS=0D0
+ PIMASS=PMAS(PYCOMP(211),1)
+ ELSE
+ NJET=NSAV
+ IF(MSTU(43).GE.2) N=N-NJET
+ DO 110 I=N+1,N+NJET
+ P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ 110 CONTINUE
+ IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
+ R2ACC=PARU(44)**2
+ ELSE
+ R2ACC=PARU(45)*PS(5)**2
+ ENDIF
+ NLOOP=0
+ GOTO 300
+ ENDIF
+
+C...Find which particles are to be considered in cluster search.
+ DO 140 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 140
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 140
+ ENDIF
+ IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
+ NJET=-1
+ RETURN
+ ENDIF
+
+C...Take copy of these particles, with space left for jets later on.
+ NP=NP+1
+ K(N+NP,3)=I
+ DO 120 J=1,5
+ P(N+NP,J)=P(I,J)
+ 120 CONTINUE
+ IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
+ IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
+ P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ DO 130 J=1,4
+ PS(J)=PS(J)+P(N+NP,J)
+ 130 CONTINUE
+ PSS=PSS+P(N+NP,5)
+ 140 CONTINUE
+ DO 160 I=N+1,N+NP
+ K(I+NP,3)=K(I,3)
+ DO 150 J=1,5
+ P(I+NP,J)=P(I,J)
+ 150 CONTINUE
+ 160 CONTINUE
+ PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
+
+C...Very low multiplicities not considered.
+ IF(NP.LT.MSTU(47)) THEN
+ CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
+ NJET=-1
+ RETURN
+ ENDIF
+
+C...Find precluster configuration. If too few jets, make harder cuts.
+ NLOOP=0
+ IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
+ R2ACC=PARU(44)**2
+ ELSE
+ R2ACC=PARU(45)*PS(5)**2
+ ENDIF
+ RINIT=1.25D0*PARU(43)
+ IF(NP.LE.MSTU(47)+2) RINIT=0D0
+ 170 RINIT=0.8D0*RINIT
+ NPRE=0
+ NREM=NP
+ DO 180 I=N+NP+1,N+2*NP
+ K(I,4)=0
+ 180 CONTINUE
+
+C...Sum up small momentum region. Jet if enough absolute momentum.
+ IF(MSTU(46).LE.2) THEN
+ DO 190 J=1,4
+ P(N+1,J)=0D0
+ 190 CONTINUE
+ DO 210 I=N+NP+1,N+2*NP
+ IF(P(I,5).GT.2D0*RINIT) GOTO 210
+ NREM=NREM-1
+ K(I,4)=1
+ DO 200 J=1,4
+ P(N+1,J)=P(N+1,J)+P(I,J)
+ 200 CONTINUE
+ 210 CONTINUE
+ P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
+ IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
+ IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
+ IF(NREM.EQ.0) GOTO 170
+ ENDIF
+
+C...Find fastest remaining particle.
+ 220 NPRE=NPRE+1
+ PMAX=0D0
+ DO 230 I=N+NP+1,N+2*NP
+ IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
+ IMAX=I
+ PMAX=P(I,5)
+ 230 CONTINUE
+ DO 240 J=1,5
+ P(N+NPRE,J)=P(IMAX,J)
+ 240 CONTINUE
+ NREM=NREM-1
+ K(IMAX,4)=NPRE
+
+C...Sum up precluster around it according to pT separation.
+ IF(MSTU(46).LE.2) THEN
+ DO 260 I=N+NP+1,N+2*NP
+ IF(K(I,4).NE.0) GOTO 260
+ R2=R2T(I,IMAX)
+ IF(R2.GT.RINIT**2) GOTO 260
+ NREM=NREM-1
+ K(I,4)=NPRE
+ DO 250 J=1,4
+ P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
+ 250 CONTINUE
+ 260 CONTINUE
+ P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
+
+C...Sum up precluster around it according to mass or
+C...Durham pT separation.
+ ELSE
+ 270 IMIN=0
+ R2MIN=RINIT**2
+ DO 280 I=N+NP+1,N+2*NP
+ IF(K(I,4).NE.0) GOTO 280
+ IF(MSTU(46).LE.4) THEN
+ R2=R2M(I,N+NPRE)
+ ELSE
+ R2=R2D(I,N+NPRE)
+ ENDIF
+ IF(R2.GE.R2MIN) GOTO 280
+ IMIN=I
+ R2MIN=R2
+ 280 CONTINUE
+ IF(IMIN.NE.0) THEN
+ DO 290 J=1,4
+ P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
+ 290 CONTINUE
+ P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
+ NREM=NREM-1
+ K(IMIN,4)=NPRE
+ GOTO 270
+ ENDIF
+ ENDIF
+
+C...Check if more preclusters to be found. Start over if too few.
+ IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
+ IF(NREM.GT.0) GOTO 220
+ NJET=NPRE
+
+C...Reassign all particles to nearest jet. Sum up new jet momenta.
+ 300 TSAV=0D0
+ PSJT=0D0
+ 310 IF(MSTU(46).LE.1) THEN
+ DO 330 I=N+1,N+NJET
+ DO 320 J=1,4
+ V(I,J)=0D0
+ 320 CONTINUE
+ 330 CONTINUE
+ DO 360 I=N+NP+1,N+2*NP
+ R2MIN=PSS**2
+ DO 340 IJET=N+1,N+NJET
+ IF(P(IJET,5).LT.RINIT) GOTO 340
+ R2=R2T(I,IJET)
+ IF(R2.GE.R2MIN) GOTO 340
+ IMIN=IJET
+ R2MIN=R2
+ 340 CONTINUE
+ K(I,4)=IMIN-N
+ DO 350 J=1,4
+ V(IMIN,J)=V(IMIN,J)+P(I,J)
+ 350 CONTINUE
+ 360 CONTINUE
+ PSJT=0D0
+ DO 380 I=N+1,N+NJET
+ DO 370 J=1,4
+ P(I,J)=V(I,J)
+ 370 CONTINUE
+ P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ PSJT=PSJT+P(I,5)
+ 380 CONTINUE
+ ENDIF
+
+C...Find two closest jets.
+ R2MIN=2D0*MAX(R2ACC,PS(5)**2)
+ DO 400 ITRY1=N+1,N+NJET-1
+ DO 390 ITRY2=ITRY1+1,N+NJET
+ IF(MSTU(46).LE.2) THEN
+ R2=R2T(ITRY1,ITRY2)
+ ELSEIF(MSTU(46).LE.4) THEN
+ R2=R2M(ITRY1,ITRY2)
+ ELSE
+ R2=R2D(ITRY1,ITRY2)
+ ENDIF
+ IF(R2.GE.R2MIN) GOTO 390
+ IMIN1=ITRY1
+ IMIN2=ITRY2
+ R2MIN=R2
+ 390 CONTINUE
+ 400 CONTINUE
+
+C...If allowed, join two closest jets and start over.
+ IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
+ IREC=MIN(IMIN1,IMIN2)
+ IDEL=MAX(IMIN1,IMIN2)
+ DO 410 J=1,4
+ P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
+ 410 CONTINUE
+ P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
+ DO 430 I=IDEL+1,N+NJET
+ DO 420 J=1,5
+ P(I-1,J)=P(I,J)
+ 420 CONTINUE
+ 430 CONTINUE
+ IF(MSTU(46).GE.2) THEN
+ DO 440 I=N+NP+1,N+2*NP
+ IORI=N+K(I,4)
+ IF(IORI.EQ.IDEL) K(I,4)=IREC-N
+ IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
+ 440 CONTINUE
+ ENDIF
+ NJET=NJET-1
+ GOTO 300
+
+C...Divide up broad jet if empty cluster in list of final ones.
+ ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
+ DO 450 I=N+1,N+NJET
+ K(I,5)=0
+ 450 CONTINUE
+ DO 460 I=N+NP+1,N+2*NP
+ K(N+K(I,4),5)=K(N+K(I,4),5)+1
+ 460 CONTINUE
+ IEMP=0
+ DO 470 I=N+1,N+NJET
+ IF(K(I,5).EQ.0) IEMP=I
+ 470 CONTINUE
+ IF(IEMP.NE.0) THEN
+ NLOOP=NLOOP+1
+ ISPL=0
+ R2MAX=0D0
+ DO 480 I=N+NP+1,N+2*NP
+ IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
+ IJET=N+K(I,4)
+ R2=R2T(I,IJET)
+ IF(R2.LE.R2MAX) GOTO 480
+ ISPL=I
+ R2MAX=R2
+ 480 CONTINUE
+ IF(ISPL.NE.0) THEN
+ IJET=N+K(ISPL,4)
+ DO 490 J=1,4
+ P(IEMP,J)=P(ISPL,J)
+ P(IJET,J)=P(IJET,J)-P(ISPL,J)
+ 490 CONTINUE
+ P(IEMP,5)=P(ISPL,5)
+ P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
+ IF(NLOOP.LE.2) GOTO 300
+ ENDIF
+ ENDIF
+ ENDIF
+
+C...If generalized thrust has not yet converged, continue iteration.
+ IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
+ &THEN
+ TSAV=PSJT/PSS
+ GOTO 310
+ ENDIF
+
+C...Reorder jets according to energy.
+ DO 510 I=N+1,N+NJET
+ DO 500 J=1,5
+ V(I,J)=P(I,J)
+ 500 CONTINUE
+ 510 CONTINUE
+ DO 540 INEW=N+1,N+NJET
+ PEMAX=0D0
+ DO 520 ITRY=N+1,N+NJET
+ IF(V(ITRY,4).LE.PEMAX) GOTO 520
+ IMAX=ITRY
+ PEMAX=V(ITRY,4)
+ 520 CONTINUE
+ K(INEW,1)=31
+ K(INEW,2)=97
+ K(INEW,3)=INEW-N
+ K(INEW,4)=0
+ DO 530 J=1,5
+ P(INEW,J)=V(IMAX,J)
+ 530 CONTINUE
+ V(IMAX,4)=-1D0
+ K(IMAX,5)=INEW
+ 540 CONTINUE
+
+C...Clean up particle-jet assignments and jet information.
+ DO 550 I=N+NP+1,N+2*NP
+ IORI=K(N+K(I,4),5)
+ K(I,4)=IORI-N
+ IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
+ K(IORI,4)=K(IORI,4)+1
+ 550 CONTINUE
+ IEMP=0
+ PSJT=0D0
+ DO 570 I=N+1,N+NJET
+ K(I,5)=0
+ PSJT=PSJT+P(I,5)
+ P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
+ DO 560 J=1,5
+ V(I,J)=0D0
+ 560 CONTINUE
+ IF(K(I,4).EQ.0) IEMP=I
+ 570 CONTINUE
+
+C...Select storing option. Output variables. Check for failure.
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ MSTU(63)=NPRE
+ PARU(61)=PS(5)
+ PARU(62)=PSJT/PSS
+ PARU(63)=SQRT(R2MIN)
+ IF(NJET.LE.1) PARU(63)=0D0
+ IF(IEMP.NE.0) THEN
+ CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
+ NJET=-1
+ ENDIF
+ IF(MSTU(43).LE.1) MSTU(3)=NJET
+ IF(MSTU(43).GE.2) N=N+NJET
+ NSAV=NJET
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYCELL
+C...Provides a simple way of jet finding in eta-phi-ET coordinates,
+C...as used for calorimeters at hadron colliders.
+
+ SUBROUTINE PYCELL(NJET)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Loop over all particles. Find cell that was hit by given particle.
+ PTLRAT=1D0/SINH(PARU(51))**2
+ NP=0
+ NC=N
+ DO 110 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
+ IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 110
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 110
+ ENDIF
+ NP=NP+1
+ PT=SQRT(P(I,1)**2+P(I,2)**2)
+ ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
+ IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
+ & (ETA/PARU(51)+1D0))))
+ PHI=PYANGL(P(I,1),P(I,2))
+ IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
+ & (PHI/PARU(1)+1D0))))
+ IETPH=MSTU(52)*IETA+IPHI
+
+C...Add to cell already hit, or book new cell.
+ DO 100 IC=N+1,NC
+ IF(IETPH.EQ.K(IC,3)) THEN
+ K(IC,4)=K(IC,4)+1
+ P(IC,5)=P(IC,5)+PT
+ GOTO 110
+ ENDIF
+ 100 CONTINUE
+ IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
+ NJET=-2
+ RETURN
+ ENDIF
+ NC=NC+1
+ K(NC,3)=IETPH
+ K(NC,4)=1
+ K(NC,5)=2
+ P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
+ P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
+ P(NC,5)=PT
+ 110 CONTINUE
+
+C...Smear true bin content by calorimeter resolution.
+ IF(MSTU(53).GE.1) THEN
+ DO 130 IC=N+1,NC
+ PEI=P(IC,5)
+ IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
+ 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
+ & COS(PARU(2)*PYR(0))
+ IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
+ P(IC,5)=PEF
+ IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
+ 130 CONTINUE
+ ENDIF
+
+C...Remove cells below threshold.
+ IF(PARU(58).GT.0D0) THEN
+ NCC=NC
+ NC=N
+ DO 140 IC=N+1,NCC
+ IF(P(IC,5).GT.PARU(58)) THEN
+ NC=NC+1
+ K(NC,3)=K(IC,3)
+ K(NC,4)=K(IC,4)
+ K(NC,5)=K(IC,5)
+ P(NC,1)=P(IC,1)
+ P(NC,2)=P(IC,2)
+ P(NC,5)=P(IC,5)
+ ENDIF
+ 140 CONTINUE
+ ENDIF
+
+C...Find initiator cell: the one with highest pT of not yet used ones.
+ NJ=NC
+ 150 ETMAX=0D0
+ DO 160 IC=N+1,NC
+ IF(K(IC,5).NE.2) GOTO 160
+ IF(P(IC,5).LE.ETMAX) GOTO 160
+ ICMAX=IC
+ ETA=P(IC,1)
+ PHI=P(IC,2)
+ ETMAX=P(IC,5)
+ 160 CONTINUE
+ IF(ETMAX.LT.PARU(52)) GOTO 220
+ IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
+ NJET=-2
+ RETURN
+ ENDIF
+ K(ICMAX,5)=1
+ NJ=NJ+1
+ K(NJ,4)=0
+ K(NJ,5)=1
+ P(NJ,1)=ETA
+ P(NJ,2)=PHI
+ P(NJ,3)=0D0
+ P(NJ,4)=0D0
+ P(NJ,5)=0D0
+
+C...Sum up unused cells within required distance of initiator.
+ DO 170 IC=N+1,NC
+ IF(K(IC,5).EQ.0) GOTO 170
+ IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
+ DPHIA=ABS(P(IC,2)-PHI)
+ IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
+ PHIC=P(IC,2)
+ IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
+ IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
+ K(IC,5)=-K(IC,5)
+ K(NJ,4)=K(NJ,4)+K(IC,4)
+ P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
+ P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
+ P(NJ,5)=P(NJ,5)+P(IC,5)
+ 170 CONTINUE
+
+C...Reject cluster below minimum ET, else accept.
+ IF(P(NJ,5).LT.PARU(53)) THEN
+ NJ=NJ-1
+ DO 180 IC=N+1,NC
+ IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
+ 180 CONTINUE
+ ELSEIF(MSTU(54).LE.2) THEN
+ P(NJ,3)=P(NJ,3)/P(NJ,5)
+ P(NJ,4)=P(NJ,4)/P(NJ,5)
+ IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
+ & P(NJ,4))
+ DO 190 IC=N+1,NC
+ IF(K(IC,5).LT.0) K(IC,5)=0
+ 190 CONTINUE
+ ELSE
+ DO 200 J=1,4
+ P(NJ,J)=0D0
+ 200 CONTINUE
+ DO 210 IC=N+1,NC
+ IF(K(IC,5).GE.0) GOTO 210
+ P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
+ P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
+ P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
+ P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
+ K(IC,5)=0
+ 210 CONTINUE
+ ENDIF
+ GOTO 150
+
+C...Arrange clusters in falling ET sequence.
+ 220 DO 250 I=1,NJ-NC
+ ETMAX=0D0
+ DO 230 IJ=NC+1,NJ
+ IF(K(IJ,5).EQ.0) GOTO 230
+ IF(P(IJ,5).LT.ETMAX) GOTO 230
+ IJMAX=IJ
+ ETMAX=P(IJ,5)
+ 230 CONTINUE
+ K(IJMAX,5)=0
+ K(N+I,1)=31
+ K(N+I,2)=98
+ K(N+I,3)=I
+ K(N+I,4)=K(IJMAX,4)
+ K(N+I,5)=0
+ DO 240 J=1,5
+ P(N+I,J)=P(IJMAX,J)
+ V(N+I,J)=0D0
+ 240 CONTINUE
+ 250 CONTINUE
+ NJET=NJ-NC
+
+C...Convert to massless or massive four-vectors.
+ IF(MSTU(54).EQ.2) THEN
+ DO 260 I=N+1,N+NJET
+ ETA=P(I,3)
+ P(I,1)=P(I,5)*COS(P(I,4))
+ P(I,2)=P(I,5)*SIN(P(I,4))
+ P(I,3)=P(I,5)*SINH(ETA)
+ P(I,4)=P(I,5)*COSH(ETA)
+ P(I,5)=0D0
+ 260 CONTINUE
+ ELSEIF(MSTU(54).GE.3) THEN
+ DO 270 I=N+1,N+NJET
+ P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
+ 270 CONTINUE
+ ENDIF
+
+C...Information about storage.
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ MSTU(63)=NC-N
+ IF(MSTU(43).LE.1) MSTU(3)=NJET
+ IF(MSTU(43).GE.2) N=N+NJET
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYJMAS
+C...Determines, approximately, the two jet masses that minimize
+C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
+
+ SUBROUTINE PYJMAS(PMH,PML)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+C...Local arrays.
+ DIMENSION SM(3,3),SAX(3),PS(3,5)
+
+C...Reset.
+ NP=0
+ DO 120 J1=1,3
+ DO 100 J2=J1,3
+ SM(J1,J2)=0D0
+ 100 CONTINUE
+ DO 110 J2=1,4
+ PS(J1,J2)=0D0
+ 110 CONTINUE
+ 120 CONTINUE
+ PSS=0D0
+ PIMASS=PMAS(PYCOMP(211),1)
+
+C...Take copy of particles that are to be considered in mass analysis.
+ DO 170 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 170
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 170
+ ENDIF
+ IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
+ PMH=-2D0
+ PML=-2D0
+ RETURN
+ ENDIF
+ NP=NP+1
+ DO 130 J=1,5
+ P(N+NP,J)=P(I,J)
+ 130 CONTINUE
+ IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
+ IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
+ P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+
+C...Fill information in sphericity tensor and total momentum vector.
+ DO 150 J1=1,3
+ DO 140 J2=J1,3
+ SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
+ 140 CONTINUE
+ 150 CONTINUE
+ PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ DO 160 J=1,4
+ PS(3,J)=PS(3,J)+P(N+NP,J)
+ 160 CONTINUE
+ 170 CONTINUE
+
+C...Very low multiplicities (0 or 1) not considered.
+ IF(NP.LE.1) THEN
+ CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
+ PMH=-1D0
+ PML=-1D0
+ RETURN
+ ENDIF
+ PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
+ &PS(3,3)**2))
+
+C...Find largest eigenvalue to matrix (third degree equation).
+ DO 190 J1=1,3
+ DO 180 J2=J1,3
+ SM(J1,J2)=SM(J1,J2)/PSS
+ 180 CONTINUE
+ 190 CONTINUE
+ SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
+ &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
+ SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
+ SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
+ SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
+
+C...Find largest eigenvector by solving equation system.
+ DO 210 J1=1,3
+ SM(J1,J1)=SM(J1,J1)-SMA
+ DO 200 J2=J1+1,3
+ SM(J2,J1)=SM(J1,J2)
+ 200 CONTINUE
+ 210 CONTINUE
+ SMAX=0D0
+ DO 230 J1=1,3
+ DO 220 J2=1,3
+ IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
+ JA=J1
+ JB=J2
+ SMAX=ABS(SM(J1,J2))
+ 220 CONTINUE
+ 230 CONTINUE
+ SMAX=0D0
+ DO 250 J3=JA+1,JA+2
+ J1=J3-3*((J3-1)/3)
+ RL=SM(J1,JB)/SM(JA,JB)
+ DO 240 J2=1,3
+ SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
+ IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
+ JC=J1
+ SMAX=ABS(SM(J1,J2))
+ 240 CONTINUE
+ 250 CONTINUE
+ JB1=JB+1-3*(JB/3)
+ JB2=JB+2-3*((JB+1)/3)
+ SAX(JB1)=-SM(JC,JB2)
+ SAX(JB2)=SM(JC,JB1)
+ SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
+
+C...Divide particles into two initial clusters by hemisphere.
+ DO 270 I=N+1,N+NP
+ PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
+ IS=1
+ IF(PSAX.LT.0D0) IS=2
+ K(I,3)=IS
+ DO 260 J=1,4
+ PS(IS,J)=PS(IS,J)+P(I,J)
+ 260 CONTINUE
+ 270 CONTINUE
+ PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
+ &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
+
+C...Reassign one particle at a time; find maximum decrease of m^2 sum.
+ 280 PMD=0D0
+ IM=0
+ DO 290 J=1,4
+ PS(3,J)=PS(1,J)-PS(2,J)
+ 290 CONTINUE
+ DO 300 I=N+1,N+NP
+ PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
+ IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
+ IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
+ IF(PMDI.LT.PMD) THEN
+ PMD=PMDI
+ IM=I
+ ENDIF
+ 300 CONTINUE
+
+C...Loop back if significant reduction in sum of m^2.
+ IF(PMD.LT.-PARU(48)*PMS) THEN
+ PMS=PMS+PMD
+ IS=K(IM,3)
+ DO 310 J=1,4
+ PS(IS,J)=PS(IS,J)-P(IM,J)
+ PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
+ 310 CONTINUE
+ K(IM,3)=3-IS
+ GOTO 280
+ ENDIF
+
+C...Final masses and output.
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
+ PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
+ PMH=MAX(PS(1,5),PS(2,5))
+ PML=MIN(PS(1,5),PS(2,5))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFOWO
+C...Calculates the first few Fox-Wolfram moments.
+
+ SUBROUTINE PYFOWO(H10,H20,H30,H40)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Copy momenta for particles and calculate H0.
+ NP=0
+ H0=0D0
+ HD=0D0
+ DO 110 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 110
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
+ & GOTO 110
+ ENDIF
+ IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
+ CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
+ H10=-1D0
+ H20=-1D0
+ H30=-1D0
+ H40=-1D0
+ RETURN
+ ENDIF
+ NP=NP+1
+ DO 100 J=1,3
+ P(N+NP,J)=P(I,J)
+ 100 CONTINUE
+ P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ H0=H0+P(N+NP,4)
+ HD=HD+P(N+NP,4)**2
+ 110 CONTINUE
+ H0=H0**2
+
+C...Very low multiplicities (0 or 1) not considered.
+ IF(NP.LE.1) THEN
+ CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
+ H10=-1D0
+ H20=-1D0
+ H30=-1D0
+ H40=-1D0
+ RETURN
+ ENDIF
+
+C...Calculate H1 - H4.
+ H10=0D0
+ H20=0D0
+ H30=0D0
+ H40=0D0
+ DO 130 I1=N+1,N+NP
+ DO 120 I2=I1+1,N+NP
+ CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
+ & (P(I1,4)*P(I2,4))
+ H10=H10+P(I1,4)*P(I2,4)*CTHE
+ H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
+ H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
+ H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
+ & 0.375D0)
+ 120 CONTINUE
+ 130 CONTINUE
+
+C...Calculate H1/H0 - H4/H0. Output.
+ MSTU(61)=N+1
+ MSTU(62)=NP
+ H10=(HD+2D0*H10)/H0
+ H20=(HD+2D0*H20)/H0
+ H30=(HD+2D0*H30)/H0
+ H40=(HD+2D0*H40)/H0
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTABU
+C...Evaluates various properties of an event, with statistics
+C...accumulated during the course of the run and
+C...printed at the end.
+
+ SUBROUTINE PYTABU(MTABU)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
+C...Local arrays, character variables, saved variables and data.
+ DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
+ &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
+ &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
+ &KFDM(8),KFDC(200,0:8),NPDC(200)
+ SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
+ &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
+ &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
+ CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
+ DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
+ &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
+ &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
+ &NEVDC/0/,NKFDC/0/,NREDC/0/
+
+C...Reset statistics on initial parton state.
+ IF(MTABU.EQ.10) THEN
+ NEVIS=0
+ NKFIS=0
+
+C...Identify and order flavour content of initial state.
+ ELSEIF(MTABU.EQ.11) THEN
+ NEVIS=NEVIS+1
+ KFM1=2*IABS(MSTU(161))
+ IF(MSTU(161).GT.0) KFM1=KFM1-1
+ KFM2=2*IABS(MSTU(162))
+ IF(MSTU(162).GT.0) KFM2=KFM2-1
+ KFMN=MIN(KFM1,KFM2)
+ KFMX=MAX(KFM1,KFM2)
+ DO 100 I=1,NKFIS
+ IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
+ IKFIS=-I
+ GOTO 110
+ ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
+ & KFMX.LT.KFIS(I,2))) THEN
+ IKFIS=I
+ GOTO 110
+ ENDIF
+ 100 CONTINUE
+ IKFIS=NKFIS+1
+ 110 IF(IKFIS.LT.0) THEN
+ IKFIS=-IKFIS
+ ELSE
+ IF(NKFIS.GE.100) RETURN
+ DO 130 I=NKFIS,IKFIS,-1
+ KFIS(I+1,1)=KFIS(I,1)
+ KFIS(I+1,2)=KFIS(I,2)
+ DO 120 J=0,10
+ NPIS(I+1,J)=NPIS(I,J)
+ 120 CONTINUE
+ 130 CONTINUE
+ NKFIS=NKFIS+1
+ KFIS(IKFIS,1)=KFMN
+ KFIS(IKFIS,2)=KFMX
+ DO 140 J=0,10
+ NPIS(IKFIS,J)=0
+ 140 CONTINUE
+ ENDIF
+ NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
+
+C...Count number of partons in initial state.
+ NP=0
+ DO 160 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
+ ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
+ ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
+ & THEN
+ ELSE
+ IM=I
+ 150 IM=K(IM,3)
+ IF(IM.LE.0.OR.IM.GT.N) THEN
+ NP=NP+1
+ ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
+ NP=NP+1
+ ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
+ ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
+ & .NE.0) THEN
+ ELSE
+ GOTO 150
+ ENDIF
+ ENDIF
+ 160 CONTINUE
+ NPCO=MAX(NP,1)
+ IF(NP.GE.6) NPCO=6
+ IF(NP.GE.8) NPCO=7
+ IF(NP.GE.11) NPCO=8
+ IF(NP.GE.16) NPCO=9
+ IF(NP.GE.26) NPCO=10
+ NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
+ MSTU(62)=NP
+
+C...Write statistics on initial parton state.
+ ELSEIF(MTABU.EQ.12) THEN
+ FAC=1D0/MAX(1,NEVIS)
+ WRITE(MSTU(11),5000) NEVIS
+ DO 170 I=1,NKFIS
+ KFMN=KFIS(I,1)
+ IF(KFMN.EQ.0) KFMN=KFIS(I,2)
+ KFM1=(KFMN+1)/2
+ IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
+ CALL PYNAME(KFM1,CHAU)
+ CHIS(1)=CHAU(1:12)
+ IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
+ KFMX=KFIS(I,2)
+ IF(KFIS(I,1).EQ.0) KFMX=0
+ KFM2=(KFMX+1)/2
+ IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
+ CALL PYNAME(KFM2,CHAU)
+ CHIS(2)=CHAU(1:12)
+ IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
+ WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
+ & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
+ 170 CONTINUE
+
+C...Copy statistics on initial parton state into /PYJETS/.
+ ELSEIF(MTABU.EQ.13) THEN
+ FAC=1D0/MAX(1,NEVIS)
+ DO 190 I=1,NKFIS
+ KFMN=KFIS(I,1)
+ IF(KFMN.EQ.0) KFMN=KFIS(I,2)
+ KFM1=(KFMN+1)/2
+ IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
+ KFMX=KFIS(I,2)
+ IF(KFIS(I,1).EQ.0) KFMX=0
+ KFM2=(KFMX+1)/2
+ IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
+ K(I,1)=32
+ K(I,2)=99
+ K(I,3)=KFM1
+ K(I,4)=KFM2
+ K(I,5)=NPIS(I,0)
+ DO 180 J=1,5
+ P(I,J)=FAC*NPIS(I,J)
+ V(I,J)=FAC*NPIS(I,J+5)
+ 180 CONTINUE
+ 190 CONTINUE
+ N=NKFIS
+ DO 200 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 200 CONTINUE
+ K(N+1,1)=32
+ K(N+1,2)=99
+ K(N+1,5)=NEVIS
+ MSTU(3)=1
+
+C...Reset statistics on number of particles/partons.
+ ELSEIF(MTABU.EQ.20) THEN
+ NEVFS=0
+ NPRFS=0
+ NFIFS=0
+ NCHFS=0
+ NKFFS=0
+
+C...Identify whether particle/parton is primary or not.
+ ELSEIF(MTABU.EQ.21) THEN
+ NEVFS=NEVFS+1
+ MSTU(62)=0
+ DO 260 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
+ MSTU(62)=MSTU(62)+1
+ KC=PYCOMP(K(I,2))
+ MPRI=0
+ IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
+ MPRI=1
+ ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
+ MPRI=1
+ ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
+ MPRI=1
+ ELSEIF(KC.EQ.0) THEN
+ ELSEIF(K(K(I,3),1).EQ.13) THEN
+ IM=K(K(I,3),3)
+ IF(IM.LE.0.OR.IM.GT.N) THEN
+ MPRI=1
+ ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
+ MPRI=1
+ ENDIF
+ ELSEIF(KCHG(KC,2).EQ.0) THEN
+ KCM=PYCOMP(K(K(I,3),2))
+ IF(KCM.NE.0) THEN
+ IF(KCHG(KCM,2).NE.0) MPRI=1
+ ENDIF
+ ENDIF
+ IF(KC.NE.0.AND.MPRI.EQ.1) THEN
+ IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
+ ENDIF
+ IF(K(I,1).LE.10) THEN
+ NFIFS=NFIFS+1
+ IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
+ ENDIF
+
+C...Fill statistics on number of particles/partons in event.
+ KFA=IABS(K(I,2))
+ KFS=3-ISIGN(1,K(I,2))-MPRI
+ DO 210 IP=1,NKFFS
+ IF(KFA.EQ.KFFS(IP)) THEN
+ IKFFS=-IP
+ GOTO 220
+ ELSEIF(KFA.LT.KFFS(IP)) THEN
+ IKFFS=IP
+ GOTO 220
+ ENDIF
+ 210 CONTINUE
+ IKFFS=NKFFS+1
+ 220 IF(IKFFS.LT.0) THEN
+ IKFFS=-IKFFS
+ ELSE
+ IF(NKFFS.GE.400) RETURN
+ DO 240 IP=NKFFS,IKFFS,-1
+ KFFS(IP+1)=KFFS(IP)
+ DO 230 J=1,4
+ NPFS(IP+1,J)=NPFS(IP,J)
+ 230 CONTINUE
+ 240 CONTINUE
+ NKFFS=NKFFS+1
+ KFFS(IKFFS)=KFA
+ DO 250 J=1,4
+ NPFS(IKFFS,J)=0
+ 250 CONTINUE
+ ENDIF
+ NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
+ 260 CONTINUE
+
+C...Write statistics on particle/parton composition of events.
+ ELSEIF(MTABU.EQ.22) THEN
+ FAC=1D0/MAX(1,NEVFS)
+ WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
+ DO 270 I=1,NKFFS
+ CALL PYNAME(KFFS(I),CHAU)
+ KC=PYCOMP(KFFS(I))
+ MDCYF=0
+ IF(KC.NE.0) MDCYF=MDCY(KC,1)
+ WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
+ & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
+ 270 CONTINUE
+
+C...Copy particle/parton composition information into /PYJETS/.
+ ELSEIF(MTABU.EQ.23) THEN
+ FAC=1D0/MAX(1,NEVFS)
+ DO 290 I=1,NKFFS
+ K(I,1)=32
+ K(I,2)=99
+ K(I,3)=KFFS(I)
+ K(I,4)=0
+ K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
+ DO 280 J=1,4
+ P(I,J)=FAC*NPFS(I,J)
+ V(I,J)=0D0
+ 280 CONTINUE
+ P(I,5)=FAC*K(I,5)
+ V(I,5)=0D0
+ 290 CONTINUE
+ N=NKFFS
+ DO 300 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 300 CONTINUE
+ K(N+1,1)=32
+ K(N+1,2)=99
+ K(N+1,5)=NEVFS
+ P(N+1,1)=FAC*NPRFS
+ P(N+1,2)=FAC*NFIFS
+ P(N+1,3)=FAC*NCHFS
+ MSTU(3)=1
+
+C...Reset factorial moments statistics.
+ ELSEIF(MTABU.EQ.30) THEN
+ NEVFM=0
+ NMUFM=0
+ DO 330 IM=1,3
+ DO 320 IB=1,10
+ DO 310 IP=1,4
+ FM1FM(IM,IB,IP)=0D0
+ FM2FM(IM,IB,IP)=0D0
+ 310 CONTINUE
+ 320 CONTINUE
+ 330 CONTINUE
+
+C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
+ ELSEIF(MTABU.EQ.31) THEN
+ NEVFM=NEVFM+1
+ NLOW=N+MSTU(3)
+ NUPP=NLOW
+ DO 410 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 410
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
+ & PYCHGE(K(I,2)).EQ.0) GOTO 410
+ ENDIF
+ PMR=0D0
+ IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
+ IF(MSTU(42).GE.2) PMR=P(I,5)
+ PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
+ YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
+ & 1D20)),P(I,3))
+ IF(ABS(YETA).GT.PARU(57)) GOTO 410
+ PHI=PYANGL(P(I,1),P(I,2))
+ IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
+ IYETA=MAX(0,MIN(511,IYETA))
+ IPHI=512D0*(PHI+PARU(1))/PARU(2)
+ IPHI=MAX(0,MIN(511,IPHI))
+ IYEP=0
+ DO 340 IB=0,9
+ IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
+ 340 CONTINUE
+
+C...Order particles in (pseudo)rapidity and/or azimuth.
+ IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
+ CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
+ RETURN
+ ENDIF
+ NUPP=NUPP+1
+ IF(NUPP.EQ.NLOW+1) THEN
+ K(NUPP,1)=IYETA
+ K(NUPP,2)=IPHI
+ K(NUPP,3)=IYEP
+ ELSE
+ DO 350 I1=NUPP-1,NLOW+1,-1
+ IF(IYETA.GE.K(I1,1)) GOTO 360
+ K(I1+1,1)=K(I1,1)
+ 350 CONTINUE
+ 360 K(I1+1,1)=IYETA
+ DO 370 I1=NUPP-1,NLOW+1,-1
+ IF(IPHI.GE.K(I1,2)) GOTO 380
+ K(I1+1,2)=K(I1,2)
+ 370 CONTINUE
+ 380 K(I1+1,2)=IPHI
+ DO 390 I1=NUPP-1,NLOW+1,-1
+ IF(IYEP.GE.K(I1,3)) GOTO 400
+ K(I1+1,3)=K(I1,3)
+ 390 CONTINUE
+ 400 K(I1+1,3)=IYEP
+ ENDIF
+ 410 CONTINUE
+ K(NUPP+1,1)=2**10
+ K(NUPP+1,2)=2**10
+ K(NUPP+1,3)=4**10
+
+C...Calculate sum of factorial moments in event.
+ DO 480 IM=1,3
+ DO 430 IB=1,10
+ DO 420 IP=1,4
+ FEVFM(IB,IP)=0D0
+ 420 CONTINUE
+ 430 CONTINUE
+ DO 450 IB=1,10
+ IF(IM.LE.2) IBIN=2**(10-IB)
+ IF(IM.EQ.3) IBIN=4**(10-IB)
+ IAGR=K(NLOW+1,IM)/IBIN
+ NAGR=1
+ DO 440 I=NLOW+2,NUPP+1
+ ICUT=K(I,IM)/IBIN
+ IF(ICUT.EQ.IAGR) THEN
+ NAGR=NAGR+1
+ ELSE
+ IF(NAGR.EQ.1) THEN
+ ELSEIF(NAGR.EQ.2) THEN
+ FEVFM(IB,1)=FEVFM(IB,1)+2D0
+ ELSEIF(NAGR.EQ.3) THEN
+ FEVFM(IB,1)=FEVFM(IB,1)+6D0
+ FEVFM(IB,2)=FEVFM(IB,2)+6D0
+ ELSEIF(NAGR.EQ.4) THEN
+ FEVFM(IB,1)=FEVFM(IB,1)+12D0
+ FEVFM(IB,2)=FEVFM(IB,2)+24D0
+ FEVFM(IB,3)=FEVFM(IB,3)+24D0
+ ELSE
+ FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
+ FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
+ FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
+ & (NAGR-3D0)
+ FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
+ & (NAGR-3D0)*(NAGR-4D0)
+ ENDIF
+ IAGR=ICUT
+ NAGR=1
+ ENDIF
+ 440 CONTINUE
+ 450 CONTINUE
+
+C...Add results to total statistics.
+ DO 470 IB=10,1,-1
+ DO 460 IP=1,4
+ IF(FEVFM(1,IP).LT.0.5D0) THEN
+ FEVFM(IB,IP)=0D0
+ ELSEIF(IM.LE.2) THEN
+ FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
+ ELSE
+ FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
+ ENDIF
+ FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
+ FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
+ 460 CONTINUE
+ 470 CONTINUE
+ 480 CONTINUE
+ NMUFM=NMUFM+(NUPP-NLOW)
+ MSTU(62)=NUPP-NLOW
+
+C...Write accumulated statistics on factorial moments.
+ ELSEIF(MTABU.EQ.32) THEN
+ FAC=1D0/MAX(1,NEVFM)
+ IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
+ IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
+ IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
+ DO 510 IM=1,3
+ WRITE(MSTU(11),5500)
+ DO 500 IB=1,10
+ BYETA=2D0*PARU(57)
+ IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
+ BPHI=PARU(2)
+ IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
+ IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
+ IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
+ DO 490 IP=1,4
+ FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
+ FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
+ & FMOMA(IP)**2)))
+ 490 CONTINUE
+ WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
+ & IP=1,4)
+ 500 CONTINUE
+ 510 CONTINUE
+
+C...Copy statistics on factorial moments into /PYJETS/.
+ ELSEIF(MTABU.EQ.33) THEN
+ FAC=1D0/MAX(1,NEVFM)
+ DO 540 IM=1,3
+ DO 530 IB=1,10
+ I=10*(IM-1)+IB
+ K(I,1)=32
+ K(I,2)=99
+ K(I,3)=1
+ IF(IM.NE.2) K(I,3)=2**(IB-1)
+ K(I,4)=1
+ IF(IM.NE.1) K(I,4)=2**(IB-1)
+ K(I,5)=0
+ P(I,1)=2D0*PARU(57)/K(I,3)
+ V(I,1)=PARU(2)/K(I,4)
+ DO 520 IP=1,4
+ P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
+ V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
+ & P(I,IP+1)**2)))
+ 520 CONTINUE
+ 530 CONTINUE
+ 540 CONTINUE
+ N=30
+ DO 550 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 550 CONTINUE
+ K(N+1,1)=32
+ K(N+1,2)=99
+ K(N+1,5)=NEVFM
+ MSTU(3)=1
+
+C...Reset statistics on Energy-Energy Correlation.
+ ELSEIF(MTABU.EQ.40) THEN
+ NEVEE=0
+ DO 560 J=1,25
+ FE1EC(J)=0D0
+ FE2EC(J)=0D0
+ FE1EC(51-J)=0D0
+ FE2EC(51-J)=0D0
+ FE1EA(J)=0D0
+ FE2EA(J)=0D0
+ 560 CONTINUE
+
+C...Find particles to include, with proper assumed mass.
+ ELSEIF(MTABU.EQ.41) THEN
+ NEVEE=NEVEE+1
+ NLOW=N+MSTU(3)
+ NUPP=NLOW
+ ECM=0D0
+ DO 570 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
+ IF(MSTU(41).GE.2) THEN
+ KC=PYCOMP(K(I,2))
+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
+ & KC.EQ.18) GOTO 570
+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
+ & PYCHGE(K(I,2)).EQ.0) GOTO 570
+ ENDIF
+ PMR=0D0
+ IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
+ IF(MSTU(42).GE.2) PMR=P(I,5)
+ IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
+ CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
+ RETURN
+ ENDIF
+ NUPP=NUPP+1
+ P(NUPP,1)=P(I,1)
+ P(NUPP,2)=P(I,2)
+ P(NUPP,3)=P(I,3)
+ P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
+ P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
+ ECM=ECM+P(NUPP,4)
+ 570 CONTINUE
+ IF(NUPP.EQ.NLOW) RETURN
+
+C...Analyze Energy-Energy Correlation in event.
+ FAC=(2D0/ECM**2)*50D0/PARU(1)
+ DO 580 J=1,50
+ FEVEE(J)=0D0
+ 580 CONTINUE
+ DO 600 I1=NLOW+2,NUPP
+ DO 590 I2=NLOW+1,I1-1
+ CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
+ & (P(I1,5)*P(I2,5))
+ THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
+ ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
+ FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
+ 590 CONTINUE
+ 600 CONTINUE
+ DO 610 J=1,25
+ FE1EC(J)=FE1EC(J)+FEVEE(J)
+ FE2EC(J)=FE2EC(J)+FEVEE(J)**2
+ FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
+ FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
+ FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
+ FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
+ 610 CONTINUE
+ MSTU(62)=NUPP-NLOW
+
+C...Write statistics on Energy-Energy Correlation.
+ ELSEIF(MTABU.EQ.42) THEN
+ FAC=1D0/MAX(1,NEVEE)
+ WRITE(MSTU(11),5700) NEVEE
+ DO 620 J=1,25
+ FEEC1=FAC*FE1EC(J)
+ FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
+ FEEC2=FAC*FE1EC(51-J)
+ FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
+ FEECA=FAC*FE1EA(J)
+ FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
+ WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
+ & FEEC2,FEES2,FEECA,FEESA
+ 620 CONTINUE
+
+C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
+ ELSEIF(MTABU.EQ.43) THEN
+ FAC=1D0/MAX(1,NEVEE)
+ DO 630 I=1,25
+ K(I,1)=32
+ K(I,2)=99
+ K(I,3)=0
+ K(I,4)=0
+ K(I,5)=0
+ P(I,1)=FAC*FE1EC(I)
+ V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
+ P(I,2)=FAC*FE1EC(51-I)
+ V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
+ P(I,3)=FAC*FE1EA(I)
+ V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
+ P(I,4)=PARU(1)*(I-1)/50D0
+ P(I,5)=PARU(1)*I/50D0
+ V(I,4)=3.6D0*(I-1)
+ V(I,5)=3.6D0*I
+ 630 CONTINUE
+ N=25
+ DO 640 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 640 CONTINUE
+ K(N+1,1)=32
+ K(N+1,2)=99
+ K(N+1,5)=NEVEE
+ MSTU(3)=1
+
+C...Reset statistics on decay channels.
+ ELSEIF(MTABU.EQ.50) THEN
+ NEVDC=0
+ NKFDC=0
+ NREDC=0
+
+C...Identify and order flavour content of final state.
+ ELSEIF(MTABU.EQ.51) THEN
+ NEVDC=NEVDC+1
+ NDS=0
+ DO 670 I=1,N
+ IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
+ NDS=NDS+1
+ IF(NDS.GT.8) THEN
+ NREDC=NREDC+1
+ RETURN
+ ENDIF
+ KFM=2*IABS(K(I,2))
+ IF(K(I,2).LT.0) KFM=KFM-1
+ DO 650 IDS=NDS-1,1,-1
+ IIN=IDS+1
+ IF(KFM.LT.KFDM(IDS)) GOTO 660
+ KFDM(IDS+1)=KFDM(IDS)
+ 650 CONTINUE
+ IIN=1
+ 660 KFDM(IIN)=KFM
+ 670 CONTINUE
+
+C...Find whether old or new final state.
+ DO 690 IDC=1,NKFDC
+ IF(NDS.LT.KFDC(IDC,0)) THEN
+ IKFDC=IDC
+ GOTO 700
+ ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
+ DO 680 I=1,NDS
+ IF(KFDM(I).LT.KFDC(IDC,I)) THEN
+ IKFDC=IDC
+ GOTO 700
+ ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
+ GOTO 690
+ ENDIF
+ 680 CONTINUE
+ IKFDC=-IDC
+ GOTO 700
+ ENDIF
+ 690 CONTINUE
+ IKFDC=NKFDC+1
+ 700 IF(IKFDC.LT.0) THEN
+ IKFDC=-IKFDC
+ ELSEIF(NKFDC.GE.200) THEN
+ NREDC=NREDC+1
+ RETURN
+ ELSE
+ DO 720 IDC=NKFDC,IKFDC,-1
+ NPDC(IDC+1)=NPDC(IDC)
+ DO 710 I=0,8
+ KFDC(IDC+1,I)=KFDC(IDC,I)
+ 710 CONTINUE
+ 720 CONTINUE
+ NKFDC=NKFDC+1
+ KFDC(IKFDC,0)=NDS
+ DO 730 I=1,NDS
+ KFDC(IKFDC,I)=KFDM(I)
+ 730 CONTINUE
+ NPDC(IKFDC)=0
+ ENDIF
+ NPDC(IKFDC)=NPDC(IKFDC)+1
+
+C...Write statistics on decay channels.
+ ELSEIF(MTABU.EQ.52) THEN
+ FAC=1D0/MAX(1,NEVDC)
+ WRITE(MSTU(11),5900) NEVDC
+ DO 750 IDC=1,NKFDC
+ DO 740 I=1,KFDC(IDC,0)
+ KFM=KFDC(IDC,I)
+ KF=(KFM+1)/2
+ IF(2*KF.NE.KFM) KF=-KF
+ CALL PYNAME(KF,CHAU)
+ CHDC(I)=CHAU(1:12)
+ IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
+ 740 CONTINUE
+ WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
+ 750 CONTINUE
+ IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
+
+C...Copy statistics on decay channels into /PYJETS/.
+ ELSEIF(MTABU.EQ.53) THEN
+ FAC=1D0/MAX(1,NEVDC)
+ DO 780 IDC=1,NKFDC
+ K(IDC,1)=32
+ K(IDC,2)=99
+ K(IDC,3)=0
+ K(IDC,4)=0
+ K(IDC,5)=KFDC(IDC,0)
+ DO 760 J=1,5
+ P(IDC,J)=0D0
+ V(IDC,J)=0D0
+ 760 CONTINUE
+ DO 770 I=1,KFDC(IDC,0)
+ KFM=KFDC(IDC,I)
+ KF=(KFM+1)/2
+ IF(2*KF.NE.KFM) KF=-KF
+ IF(I.LE.5) P(IDC,I)=KF
+ IF(I.GE.6) V(IDC,I-5)=KF
+ 770 CONTINUE
+ V(IDC,5)=FAC*NPDC(IDC)
+ 780 CONTINUE
+ N=NKFDC
+ DO 790 J=1,5
+ K(N+1,J)=0
+ P(N+1,J)=0D0
+ V(N+1,J)=0D0
+ 790 CONTINUE
+ K(N+1,1)=32
+ K(N+1,2)=99
+ K(N+1,5)=NEVDC
+ V(N+1,5)=FAC*NREDC
+ MSTU(3)=1
+ ENDIF
+
+C...Format statements for output on unit MSTU(11) (default 6).
+ 5000 FORMAT(///20X,'Event statistics - initial state'/
+ &20X,'based on an analysis of ',I6,' events'//
+ &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
+ &'according to fragmenting system multiplicity'/
+ &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
+ &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
+ 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
+ 5200 FORMAT(///20X,'Event statistics - final state'/
+ &20X,'based on an analysis of ',I7,' events'//
+ &5X,'Mean primary multiplicity =',F10.4/
+ &5X,'Mean final multiplicity =',F10.4/
+ &5X,'Mean charged multiplicity =',F10.4//
+ &5X,'Number of particles produced per event (directly and via ',
+ &'decays/branchings)'/
+ &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
+ &8X,'Total'/35X,'prim seco prim seco'/)
+ 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
+ 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
+ &20X,'based on an analysis of ',I6,' events'//
+ &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
+ &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
+ 5500 FORMAT(10X)
+ 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
+ 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
+ &20X,'based on an analysis of ',I6,' events'//
+ &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
+ &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
+ 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
+ 5900 FORMAT(///20X,'Decay channel analysis - final state'/
+ &20X,'based on an analysis of ',I6,' events'//
+ &2X,'Probability',10X,'Complete final state'/)
+ 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
+ 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
+ &'or table overflow)')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEEVT
+C...Handles the generation of an e+e- annihilation jet event.
+
+ SUBROUTINE PYEEVT(KFL,ECM)
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Check input parameters.
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IF(KFL.LT.0.OR.KFL.GT.8) THEN
+ CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
+ IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
+ IF(ECM.LT.ECMMIN) THEN
+ CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Check consistency of MSTJ options set.
+ IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
+ CALL PYERRM(6,
+ & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
+ MSTJ(110)=1
+ ENDIF
+ IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
+ CALL PYERRM(6,
+ & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
+ MSTJ(111)=0
+ ENDIF
+
+C...Initialize alpha_strong and total cross-section.
+ MSTU(111)=MSTJ(108)
+ IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
+ &MSTU(111)=1
+ PARU(112)=PARJ(121)
+ IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
+ IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
+ &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
+ &XTOT)
+ IF(MSTJ(116).GE.3) MSTJ(116)=1
+ PARJ(171)=0D0
+
+C...Add initial e+e- to event record (documentation only).
+ NTRY=0
+ 100 NTRY=NTRY+1
+ IF(NTRY.GT.100) THEN
+ CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
+ RETURN
+ ENDIF
+ MSTU(24)=0
+ NC=0
+ IF(MSTJ(115).GE.2) THEN
+ NC=NC+2
+ CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
+ K(NC-1,1)=21
+ CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
+ K(NC,1)=21
+ ENDIF
+
+C...Radiative photon (in initial state).
+ MK=0
+ ECMC=ECM
+ IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
+ &THEK,PHIK,ALPK)
+ IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
+ IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
+ NC=NC+1
+ CALL PY1ENT(NC,22,PAK,THEK,PHIK)
+ K(NC,3)=MIN(MSTJ(115)/2,1)
+ ENDIF
+
+C...Virtual exchange boson (gamma or Z0).
+ IF(MSTJ(115).GE.3) THEN
+ NC=NC+1
+ KF=22
+ IF(MSTJ(102).EQ.2) KF=23
+ MSTU10=MSTU(10)
+ MSTU(10)=1
+ P(NC,5)=ECMC
+ CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
+ K(NC,1)=21
+ K(NC,3)=1
+ MSTU(10)=MSTU10
+ ENDIF
+
+C...Choice of flavour and jet configuration.
+ CALL PYXKFL(KFL,ECM,ECMC,KFLC)
+ IF(KFLC.EQ.0) GOTO 100
+ CALL PYXJET(ECMC,NJET,CUT)
+ KFLN=21
+ IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
+ &X12,X14)
+ IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
+ IF(NJET.EQ.2) MSTJ(120)=1
+
+C...Fill jet configuration and origin.
+ IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
+ IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
+ &ECMC)
+ IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
+ IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
+ &-KFLC,ECMC,X1,X2,X4,X12,X14)
+ IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
+ &-KFLC,ECMC,X1,X2,X4,X12,X14)
+ IF(MSTU(24).NE.0) GOTO 100
+ DO 110 IP=NC+1,N
+ K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
+ 110 CONTINUE
+
+C...Angular orientation according to matrix element.
+ IF(MSTJ(106).EQ.1) THEN
+ CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
+ CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
+ CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
+ ENDIF
+
+C...Rotation and boost from radiative photon.
+ IF(MK.EQ.1) THEN
+ DBEK=-PAK/(ECM-PAK)
+ NMIN=NC+1-MSTJ(115)/3
+ CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
+ CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
+ CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
+ ENDIF
+
+C...Generate parton shower. Rearrange along strings and check.
+ IF(MSTJ(101).EQ.5) THEN
+ CALL PYSHOW(N-1,N,ECMC)
+ MSTJ14=MSTJ(14)
+ IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
+ IF(MSTJ(105).GE.0) MSTU(28)=0
+ CALL PYPREP(0)
+ MSTJ(14)=MSTJ14
+ IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
+ ENDIF
+
+C...Fragmentation/decay generation. Information for PYTABU.
+ IF(MSTJ(105).EQ.1) CALL PYEXEC
+ MSTU(161)=KFLC
+ MSTU(162)=-KFLC
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXTEE
+C...Calculates total cross-section, including initial state
+C...radiation effects.
+
+ SUBROUTINE PYXTEE(KFL,ECM,XTOT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Status, (optimized) Q^2 scale, alpha_strong.
+ PARJ(151)=ECM
+ MSTJ(119)=10*MSTJ(102)+KFL
+ IF(MSTJ(111).EQ.0) THEN
+ Q2R=ECM**2
+ ELSEIF(MSTU(111).EQ.0) THEN
+ PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
+ & ((33D0-2D0*MSTU(112))*PARU(111)))))
+ Q2R=PARJ(168)*ECM**2
+ ELSE
+ PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
+ & (2D0*PARU(112)/ECM)**2))
+ Q2R=PARJ(168)*ECM**2
+ ENDIF
+ ALSPI=PYALPS(Q2R)/PARU(1)
+
+C...QCD corrections factor in R.
+ IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
+ RQCD=1D0
+ ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
+ RQCD=1D0+ALSPI
+ ELSEIF(MSTJ(109).EQ.0) THEN
+ RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
+ IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
+ & LOG(PARJ(168))*ALSPI**2)
+ ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
+ RQCD=1D0+(3D0/4D0)*ALSPI
+ ELSE
+ RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
+ ENDIF
+
+C...Calculate Z0 width if default value not acceptable.
+ IF(MSTJ(102).GE.3) THEN
+ RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
+ & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
+ DO 100 KFLC=5,6
+ VQ=1D0
+ IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
+ & (2D0*PYMASS(KFLC)/ ECM)**2))
+ IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
+ IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
+ RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
+ 100 CONTINUE
+ PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
+ & (1D0-PARU(102)))
+ ENDIF
+
+C...Calculate propagator and related constants for QFD case.
+ POLL=1D0-PARJ(131)*PARJ(132)
+ IF(MSTJ(102).GE.2) THEN
+ SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
+ SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
+ SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
+ VE=4D0*PARU(102)-1D0
+ SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
+ SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
+ HF1I=SFI*SF1I
+ HF1W=SFW*SF1W
+ ENDIF
+
+C...Loop over different flavours: charge, velocity.
+ RTOT=0D0
+ RQQ=0D0
+ RQV=0D0
+ RVA=0D0
+ DO 110 KFLC=1,MAX(MSTJ(104),KFL)
+ IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
+ MSTJ(93)=1
+ PMQ=PYMASS(KFLC)
+ IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
+ QF=KCHG(KFLC,1)/3D0
+ VQ=1D0
+ IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
+
+C...Calculate R and sum of charges for QED or QFD case.
+ RQQ=RQQ+3D0*QF**2*POLL
+ IF(MSTJ(102).LE.1) THEN
+ RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
+ ELSE
+ VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
+ RQV=RQV-6D0*QF*VF*SF1I
+ RVA=RVA+3D0*(VF**2+1D0)*SF1W
+ RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
+ & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
+ ENDIF
+ 110 CONTINUE
+ RSUM=RQQ
+ IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
+
+C...Calculate cross-section, including QCD corrections.
+ PARJ(141)=RQQ
+ PARJ(142)=RTOT
+ PARJ(143)=RTOT*RQCD
+ PARJ(144)=PARJ(143)
+ PARJ(145)=PARJ(141)*86.8D0/ECM**2
+ PARJ(146)=PARJ(142)*86.8D0/ECM**2
+ PARJ(147)=PARJ(143)*86.8D0/ECM**2
+ PARJ(148)=PARJ(147)
+ PARJ(157)=RSUM*RQCD
+ PARJ(158)=0D0
+ PARJ(159)=0D0
+ XTOT=PARJ(147)
+ IF(MSTJ(107).LE.0) RETURN
+
+C...Virtual cross-section.
+ XKL=PARJ(135)
+ XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
+ ALE=2D0*LOG(ECM/PYMASS(11))-1D0
+ SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
+ &1.526D0*LOG(ECM**2/0.932D0)
+
+C...Soft and hard radiative cross-section in QED case.
+ IF(MSTJ(102).LE.1) THEN
+ SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
+ SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
+ SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
+
+C...Soft and hard radiative cross-section in QFD case.
+ ELSE
+ SZM=1D0-(PARJ(123)/ECM)**2
+ SZW=PARJ(123)*PARJ(124)/ECM**2
+ PARJ(161)=-RQQ/RSUM
+ PARJ(162)=-(RQQ+RQV+RVA)/RSUM
+ PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
+ PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
+ & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
+ SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
+ & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
+ SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
+ & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
+ & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
+ SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
+ & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
+ & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
+ & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
+ ENDIF
+
+C...Total cross-section and fraction of hard photon events.
+ PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
+ PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
+ PARJ(144)=PARJ(157)
+ PARJ(148)=PARJ(144)*86.8D0/ECM**2
+ XTOT=PARJ(148)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYRADK
+C...Generates initial state photon radiation.
+
+ SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+
+C...Function: cumulative hard photon spectrum in QFD case.
+ FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
+ &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
+
+C...Determine whether radiative photon or not.
+ MK=0
+ PAK=0D0
+ IF(PARJ(160).LT.PYR(0)) RETURN
+ MK=1
+
+C...Photon energy range. Find photon momentum in QED case.
+ XKL=PARJ(135)
+ XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
+ IF(MSTJ(102).LE.1) THEN
+ 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
+ IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
+
+C...Ditto in QFD case, by numerical inversion of integrated spectrum.
+ ELSE
+ SZM=1D0-(PARJ(123)/ECM)**2
+ SZW=PARJ(123)*PARJ(124)/ECM**2
+ FXKL=FXK(XKL)
+ FXKU=FXK(XKU)
+ FXKD=1D-4*(FXKU-FXKL)
+ FXKR=FXKL+PYR(0)*(FXKU-FXKL)
+ NXK=0
+ 110 NXK=NXK+1
+ XK=0.5D0*(XKL+XKU)
+ FXKV=FXK(XK)
+ IF(FXKV.GT.FXKR) THEN
+ XKU=XK
+ FXKU=FXKV
+ ELSE
+ XKL=XK
+ FXKL=FXKV
+ ENDIF
+ IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
+ XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
+ ENDIF
+ PAK=0.5D0*ECM*XK
+
+C...Photon polar and azimuthal angle.
+ PME=2D0*(PYMASS(11)/ECM)**2
+ 120 CTHM=PME*(2D0/PME)**PYR(0)
+ IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
+ &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
+ CTHE=1D0-CTHM
+ IF(PYR(0).GT.0.5D0) CTHE=-CTHE
+ STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
+ THEK=PYANGL(CTHE,STHE)
+ PHIK=PARU(2)*PYR(0)
+
+C...Rotation angle for hadronic system.
+ SGN=1D0
+ IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
+ &PYR(0)) SGN=-1D0
+ ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
+ &(2D0-XK*(1D0-SGN*CTHE)))
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXKFL
+C...Selects flavour for produced qqbar pair.
+
+ SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYDAT1/,/PYDAT2/
+
+C...Calculate maximum weight in QED or QFD case.
+ IF(MSTJ(102).LE.1) THEN
+ RFMAX=4D0/9D0
+ ELSE
+ POLL=1D0-PARJ(131)*PARJ(132)
+ SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
+ SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
+ SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
+ VE=4D0*PARU(102)-1D0
+ HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
+ HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
+ RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
+ & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
+ & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
+ & 1D0)*HF1W)
+ ENDIF
+
+C...Choose flavour. Gives charge and velocity.
+ NTRY=0
+ 100 NTRY=NTRY+1
+ IF(NTRY.GT.100) THEN
+ CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
+ KFLC=0
+ RETURN
+ ENDIF
+ KFLC=KFL
+ IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
+ MSTJ(93)=1
+ PMQ=PYMASS(KFLC)
+ IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
+ QF=KCHG(KFLC,1)/3D0
+ VQ=1D0
+ IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
+
+C...Calculate weight in QED or QFD case.
+ IF(MSTJ(102).LE.1) THEN
+ RF=QF**2
+ RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
+ ELSE
+ VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
+ RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
+ RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
+ & VQ**3*HF1W
+ IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
+ ENDIF
+
+C...Weighting or new event (radiative photon). Cross-section update.
+ IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
+ PARJ(158)=PARJ(158)+1D0
+ IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
+ IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
+ IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
+ PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
+ PARJ(148)=PARJ(144)*86.8D0/ECM**2
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXJET
+C...Selects number of jets in matrix element approach.
+
+ SUBROUTINE PYXJET(ECM,NJET,CUT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+C...Local array and data.
+ DIMENSION ZHUT(5)
+ DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
+
+C...Trivial result for two-jets only, including parton shower.
+ IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
+ CUT=0D0
+
+C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
+ ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
+ CF=4D0/3D0
+ IF(MSTJ(109).EQ.2) CF=1D0
+ IF(MSTJ(111).EQ.0) THEN
+ Q2=ECM**2
+ Q2R=ECM**2
+ ELSEIF(MSTU(111).EQ.0) THEN
+ PARJ(169)=MIN(1D0,PARJ(129))
+ Q2=PARJ(169)*ECM**2
+ PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
+ & ((33D0-2D0*MSTU(112))*PARU(111)))))
+ Q2R=PARJ(168)*ECM**2
+ ELSE
+ PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
+ Q2=PARJ(169)*ECM**2
+ PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
+ & (2D0*PARU(112)/ECM)**2))
+ Q2R=PARJ(168)*ECM**2
+ ENDIF
+
+C...alpha_strong for R and R itself.
+ ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
+ IF(IABS(MSTJ(101)).EQ.1) THEN
+ RQCD=1D0+ALSPI
+ ELSEIF(MSTJ(109).EQ.0) THEN
+ RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
+ IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
+ ELSE
+ RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
+ ENDIF
+
+C...alpha_strong for jet rate. Initial value for y cut.
+ ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
+ CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
+ IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
+ & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
+ IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
+
+C...Parametrization of first order three-jet cross-section.
+ 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
+ PARJ(152)=0D0
+ ELSE
+ PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
+ & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
+ & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
+ & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
+ IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
+ & PARJ(152)=0D0
+ ENDIF
+
+C...Parametrization of second order three-jet cross-section.
+ IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
+ & CUT.GE.0.25D0) THEN
+ PARJ(153)=0D0
+ ELSEIF(MSTJ(110).LE.1) THEN
+ CT=LOG(1D0/CUT-2D0)
+ PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
+ & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
+
+C...Interpolation in second/first order ratio for Zhu parametrization.
+ ELSEIF(MSTJ(110).EQ.2) THEN
+ IZA=0
+ DO 110 IY=1,5
+ IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
+ 110 CONTINUE
+ IF(IZA.NE.0) THEN
+ ZHURAT=ZHUT(IZA)
+ ELSE
+ IZ=100D0*CUT
+ ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
+ ENDIF
+ PARJ(153)=ALSPI*PARJ(152)*ZHURAT
+ ENDIF
+
+C...Shift in second order three-jet cross-section with optimized Q^2.
+ IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
+ & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
+
+C...Parametrization of second order four-jet cross-section.
+ IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
+ PARJ(154)=0D0
+ ELSE
+ CT=LOG(1D0/CUT-5D0)
+ IF(CUT.LE.0.018D0) THEN
+ XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
+ IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
+ & 0.4059D0*CT**2)
+ XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
+ IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
+ ELSE
+ XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
+ IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
+ & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
+ XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
+ & 0.002093D0*CT**3)
+ IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
+ ENDIF
+ PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
+ PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
+ ENDIF
+
+C...If negative three-jet rate, change y' optimization parameter.
+ IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
+ & PARJ(169).LT.0.99D0) THEN
+ PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
+ Q2=PARJ(169)*ECM**2
+ ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
+ GOTO 100
+ ENDIF
+
+C...If too high cross-section, use harder cuts, or fail.
+ IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
+ IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
+ & PARJ(169).LT.0.99D0) THEN
+ PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
+ Q2=PARJ(169)*ECM**2
+ ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
+ GOTO 100
+ ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
+ CALL PYERRM(26,
+ & '(PYXJET:) no allowed y cut value for Zhu parametrization')
+ ENDIF
+ CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
+ & PARJ(154))**(-1D0/3D0)
+ IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
+ GOTO 100
+ ENDIF
+
+C...Scalar gluon (first order only).
+ ELSE
+ ALSPI=PYALPS(ECM**2)/PARU(1)
+ CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
+ PARJ(152)=0D0
+ IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
+ & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
+ PARJ(153)=0D0
+ PARJ(154)=0D0
+ ENDIF
+
+C...Select number of jets.
+ PARJ(150)=CUT
+ IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
+ NJET=2
+ ELSEIF(MSTJ(101).LE.0) THEN
+ NJET=MIN(4,2-MSTJ(101))
+ ELSE
+ RNJ=PYR(0)
+ NJET=2
+ IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
+ IF(PARJ(154).GT.RNJ) NJET=4
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYX3JT
+C...Selects the kinematical variables of three-jet events.
+
+ SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+C...Local array.
+ DIMENSION ZHUP(5,12)
+
+C...Coefficients of Zhu second order parametrization.
+ DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
+ &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
+ &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
+ &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
+ &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
+ &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
+ &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
+ &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
+ &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
+ &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
+ &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
+
+C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
+ DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
+ &X**7/49D0
+
+C...Event type. Mass effect factors and other common constants.
+ MSTJ(120)=2
+ MSTJ(121)=0
+ PMQ=PYMASS(KFL)
+ QME=(2D0*PMQ/ECM)**2
+ IF(MSTJ(109).NE.1) THEN
+ CUTL=LOG(CUT)
+ CUTD=LOG(1D0/CUT-2D0)
+ IF(MSTJ(109).EQ.0) THEN
+ CF=4D0/3D0
+ CN=3D0
+ TR=2D0
+ WTMX=MIN(20D0,37D0-6D0*CUTD)
+ IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
+ ELSE
+ CF=1D0
+ CN=0D0
+ TR=12D0
+ WTMX=0D0
+ ENDIF
+
+C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
+ ALS2PI=PARU(118)/PARU(2)
+ WTOPT=0D0
+ IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
+ & LOG(PARJ(169))*ALS2PI
+ WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
+
+C...Choose three-jet events in allowed region.
+ 100 NJET=3
+ 110 Y13L=CUTL+CUTD*PYR(0)
+ Y23L=CUTL+CUTD*PYR(0)
+ Y13=EXP(Y13L)
+ Y23=EXP(Y23L)
+ Y12=1D0-Y13-Y23
+ IF(Y12.LE.CUT) GOTO 110
+ IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
+
+C...Second order corrections.
+ IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
+ Y12L=LOG(Y12)
+ Y13M=LOG(1D0-Y13)
+ Y23M=LOG(1D0-Y23)
+ Y12M=LOG(1D0-Y12)
+ IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
+ IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
+ IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
+ IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
+ IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
+ IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
+ WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
+ WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
+ & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
+ & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
+ & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
+ & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
+ & TR*(2D0*CUTL/3D0-10D0/9D0)+
+ & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
+ & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
+ & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
+ & Y13*Y23)/(Y12+Y13)**2)/WT1+
+ & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
+ & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
+ & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
+ & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
+ & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
+ & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
+ & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
+ IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
+ IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
+ PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
+
+ ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
+C...Second order corrections; Zhu parametrization of ERT.
+ ZX=(Y23-Y13)**2
+ ZY=1D0-Y12
+ IZA=0
+ DO 120 IY=1,5
+ IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
+ 120 CONTINUE
+ IF(IZA.NE.0) THEN
+ IZ=IZA
+ WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
+ ELSE
+ IZ=100D0*CUT
+ WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
+ IZ=IZ+1
+ WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
+ WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
+ ENDIF
+ IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
+ IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
+ PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
+ ENDIF
+
+C...Impose mass cuts (gives two jets). For fixed jet number new try.
+ X1=1D0-Y23
+ X2=1D0-Y13
+ X3=1D0-Y12
+ IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
+ IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
+ & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
+ & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
+ IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
+
+C...Scalar gluon model (first order only, no mass effects).
+ ELSE
+ 130 NJET=3
+ 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
+ IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
+ YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
+ X1=1D0-0.5D0*(X3+YD)
+ X2=1D0-0.5D0*(X3-YD)
+ IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
+ IF(MSTJ(102).GE.2) THEN
+ IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
+ & X3**2*PYR(0)) NJET=2
+ ENDIF
+ IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYX4JT
+C...Selects the kinematical variables of four-jet events.
+
+ SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYDAT1/
+C...Local arrays.
+ DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
+
+C...Common constants. Colour factors for QCD and Abelian gluon theory.
+ PMQ=PYMASS(KFL)
+ QME=(2D0*PMQ/ECM)**2
+ CT=LOG(1D0/CUT-5D0)
+ IF(MSTJ(109).EQ.0) THEN
+ CF=4D0/3D0
+ CN=3D0
+ TR=2.5D0
+ ELSE
+ CF=1D0
+ CN=0D0
+ TR=15D0
+ ENDIF
+
+C...Choice of process (qqbargg or qqbarqqbar).
+ 100 NJET=4
+ IT=1
+ IF(PARJ(155).GT.PYR(0)) IT=2
+ IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
+ IF(IT.EQ.1) WTMX=0.7D0/CUT**2
+ IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
+ IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
+ ID=1
+
+C...Sample the five kinematical variables (for qqgg preweighted in y34).
+ 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
+ Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
+ IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
+ IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
+ IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
+ VT=PYR(0)
+ CP=COS(PARU(1)*PYR(0))
+ Y14=(Y134-Y34)*VT
+ Y13=Y134-Y14-Y34
+ VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
+ Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
+ &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
+ Y23=Y234-Y34-Y24
+ Y12=1D0-Y134-Y23-Y24
+ IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
+ Y123=Y12+Y13+Y23
+ Y124=Y12+Y14+Y24
+
+C...Calculate matrix elements for qqgg or qqqq process.
+ IC=0
+ WTTOT=0D0
+ 120 IC=IC+1
+ IF(IT.EQ.1) THEN
+ WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
+ & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
+ & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
+ & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
+ & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
+ & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
+ & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
+ & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
+ WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
+ & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
+ & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
+ & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
+ WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
+ & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
+ & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
+ & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
+ & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
+ & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
+ & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
+ & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
+ & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
+ & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
+ & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
+ & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
+ WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
+ & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
+ & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
+ & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
+ & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
+ & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
+ & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
+ & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
+ & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
+ & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
+ & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
+ & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
+ & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
+ & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
+ & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
+ & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
+ WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
+ & CN*WTC(IC))/8D0
+ ELSE
+ WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
+ & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
+ & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
+ & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
+ & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
+ & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
+ & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
+ & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
+ & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
+ WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
+ & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
+ & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
+ & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
+ & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
+ & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
+ & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
+ & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
+ WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
+ ENDIF
+
+C...Permutations of momenta in matrix element. Weighting.
+ 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
+ YSAV=Y13
+ Y13=Y14
+ Y14=YSAV
+ YSAV=Y23
+ Y23=Y24
+ Y24=YSAV
+ YSAV=Y123
+ Y123=Y124
+ Y124=YSAV
+ ENDIF
+ IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
+ YSAV=Y13
+ Y13=Y23
+ Y23=YSAV
+ YSAV=Y14
+ Y14=Y24
+ Y24=YSAV
+ YSAV=Y134
+ Y134=Y234
+ Y234=YSAV
+ ENDIF
+ IF(IC.LE.3) GOTO 120
+ IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
+ IC=5
+
+C...qqgg events: string configuration and event type.
+ IF(IT.EQ.1) THEN
+ IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
+ PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
+ & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
+ IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
+ & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
+ IF(ID.EQ.2) GOTO 130
+ ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
+ PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
+ IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
+ IF(ID.EQ.2) GOTO 130
+ ENDIF
+ MSTJ(120)=3
+ IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
+ & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
+ KFLN=21
+
+C...Mass cuts. Kinematical variables out.
+ IF(Y12.LE.CUT+QME) NJET=2
+ IF(NJET.EQ.2) GOTO 150
+ Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
+ X1=1D0-(1D0-Q12)*Y234-Q12*Y134
+ X4=1D0-(1D0-Q12)*Y134-Q12*Y234
+ X2=1D0-Y124
+ X12=(1D0-Q12)*Y13+Q12*Y23
+ X14=Y12-0.5D0*QME
+ IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
+
+C...qqbarqqbar events: string configuration, choose new flavour.
+ ELSE
+ IF(ID.EQ.1) THEN
+ WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
+ IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
+ IF(WTR.LT.WTD(3)+WTD(4)) ID=3
+ IF(WTR.LT.WTD(4)) ID=4
+ IF(ID.GE.2) GOTO 130
+ ENDIF
+ MSTJ(120)=5
+ PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
+ 140 KFLN=1+INT(5D0*PYR(0))
+ IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
+ IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
+ IF(KFLN.GT.MSTJ(104)) NJET=2
+ PMQN=PYMASS(KFLN)
+ QMEN=(2D0*PMQN/ECM)**2
+
+C...Mass cuts. Kinematical variables out.
+ IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
+ IF(NJET.EQ.2) GOTO 150
+ Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
+ Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
+ X1=1D0-(1D0-Q24)*Y123-Q24*Y134
+ X4=1D0-(1D0-Q24)*Y134-Q24*Y123
+ X2=1D0-(1D0-Q13)*Y234-Q13*Y124
+ X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
+ & Q13*Y23)
+ X14=Y24-0.5D0*QME
+ X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
+ & Q13*Y14)
+ IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
+ & (PARJ(127)+PMQ+PMQN)**2) NJET=2
+ IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
+ ENDIF
+ 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYXDIF
+C...Gives the angular orientation of events.
+
+ SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Charge. Factors depending on polarization for QED case.
+ QF=KCHG(KFL,1)/3D0
+ POLL=1D0-PARJ(131)*PARJ(132)
+ POLD=PARJ(132)-PARJ(131)
+ IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
+ HF1=POLL
+ HF2=0D0
+ HF3=PARJ(133)**2
+ HF4=0D0
+
+C...Factors depending on flavour, energy and polarization for QFD case.
+ ELSE
+ SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
+ SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
+ SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
+ AE=-1D0
+ VE=4D0*PARU(102)-1D0
+ AF=SIGN(1D0,QF)
+ VF=AF-4D0*QF*PARU(102)
+ HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
+ & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
+ HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
+ & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
+ HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
+ & SFW*SFF**2*(VE**2-AE**2))
+ HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
+ & SFF*AE
+ ENDIF
+
+C...Mass factor. Differential cross-sections for two-jet events.
+ SQ2=SQRT(2D0)
+ QME=0D0
+ IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
+ &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
+ IF(NJET.EQ.2) THEN
+ SIGU=4D0*SQRT(1D0-QME)
+ SIGL=2D0*QME*SQRT(1D0-QME)
+ SIGT=0D0
+ SIGI=0D0
+ SIGA=0D0
+ SIGP=4D0
+
+C...Kinematical variables. Reduce four-jet event to three-jet one.
+ ELSE
+ IF(NJET.EQ.3) THEN
+ X1=2D0*P(NC+1,4)/ECM
+ X2=2D0*P(NC+3,4)/ECM
+ ELSE
+ ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
+ & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
+ X1=2D0*P(NC+1,4)/ECMR
+ X2=2D0*P(NC+4,4)/ECMR
+ ENDIF
+
+C...Differential cross-sections for three-jet (or reduced four-jet).
+ XQ=(1D0-X1)/(1D0-X2)
+ CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
+ ST12=SQRT(1D0-CT12**2)
+ IF(MSTJ(109).NE.1) THEN
+ SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
+ & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
+ SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
+ & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
+ & X2)*XQ
+ SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
+ SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
+ & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
+ SIGA=X2**2*ST12/SQ2
+ SIGP=2D0*(X1**2-X2**2*CT12)
+
+C...Differential cross-sect for scalar gluons (no mass effects).
+ ELSE
+ X3=2D0-X1-X2
+ XT=X2*ST12
+ CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
+ SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
+ & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
+ SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
+ & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
+ SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
+ & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
+ SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
+ & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
+ SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
+ SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
+ ENDIF
+ ENDIF
+
+C...Upper bounds for differential cross-section.
+ HF1A=ABS(HF1)
+ HF2A=ABS(HF2)
+ HF3A=ABS(HF3)
+ HF4A=ABS(HF4)
+ SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
+ &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
+ &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
+ &2D0*HF2A*ABS(SIGP)
+
+C...Generate angular orientation according to differential cross-sect.
+ 100 CHI=PARU(2)*PYR(0)
+ CTHE=2D0*PYR(0)-1D0
+ PHI=PARU(2)*PYR(0)
+ CCHI=COS(CHI)
+ SCHI=SIN(CHI)
+ C2CHI=COS(2D0*CHI)
+ S2CHI=SIN(2D0*CHI)
+ THE=ACOS(CTHE)
+ STHE=SIN(THE)
+ C2PHI=COS(2D0*(PHI-PARJ(134)))
+ S2PHI=SIN(2D0*(PHI-PARJ(134)))
+ SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
+ &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
+ &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
+ &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
+ &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
+ &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
+ &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
+ IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYONIA
+C...Generates Upsilon and toponium decays into three gluons
+C...or two gluons and a photon.
+
+ SUBROUTINE PYONIA(KFL,ECM)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
+
+C...Printout. Check input parameters.
+ IF(MSTU(12).GE.1) CALL PYLIST(0)
+ IF(KFL.LT.0.OR.KFL.GT.8) THEN
+ CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+ IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
+ CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
+ IF(MSTU(21).GE.1) RETURN
+ ENDIF
+
+C...Initial e+e- and onium state (optional).
+ NC=0
+ IF(MSTJ(115).GE.2) THEN
+ NC=NC+2
+ CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
+ K(NC-1,1)=21
+ CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
+ K(NC,1)=21
+ ENDIF
+ KFLC=IABS(KFL)
+ IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
+ NC=NC+1
+ KF=110*KFLC+3
+ MSTU10=MSTU(10)
+ MSTU(10)=1
+ P(NC,5)=ECM
+ CALL PY1ENT(NC,KF,ECM,0D0,0D0)
+ K(NC,1)=21
+ K(NC,3)=1
+ MSTU(10)=MSTU10
+ ENDIF
+
+C...Choose x1 and x2 according to matrix element.
+ NTRY=0
+ 100 X1=PYR(0)
+ X2=PYR(0)
+ X3=2D0-X1-X2
+ IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
+ &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
+ NTRY=NTRY+1
+ NJET=3
+ IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
+ IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
+
+C...Photon-gluon-gluon events. Small system modifications. Jet origin.
+ MSTU(111)=MSTJ(108)
+ IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
+ &MSTU(111)=1
+ PARU(112)=PARJ(121)
+ IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
+ QF=0D0
+ IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
+ RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
+ MK=0
+ ECMC=ECM
+ IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
+ IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
+ & NJET=2
+ IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
+ IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
+ ELSE
+ MK=1
+ ECMC=SQRT(1D0-X1)*ECM
+ IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
+ K(NC+1,1)=1
+ K(NC+1,2)=22
+ K(NC+1,4)=0
+ K(NC+1,5)=0
+ IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
+ IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
+ IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
+ IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
+ NJET=2
+ IF(ECMC.LT.4D0*PARJ(127)) THEN
+ MSTU10=MSTU(10)
+ MSTU(10)=1
+ P(NC+2,5)=ECMC
+ CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
+ MSTU(10)=MSTU10
+ NJET=0
+ ENDIF
+ ENDIF
+ DO 110 IP=NC+1,N
+ K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
+ 110 CONTINUE
+
+C...Differential cross-sections. Upper limit for cross-section.
+ IF(MSTJ(106).EQ.1) THEN
+ SQ2=SQRT(2D0)
+ HF1=1D0-PARJ(131)*PARJ(132)
+ HF3=PARJ(133)**2
+ CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
+ ST13=SQRT(1D0-CT13**2)
+ SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
+ SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
+ SIGT=0.5D0*SIGL
+ SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
+ SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
+ & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
+
+C...Angular orientation of event.
+ 120 CHI=PARU(2)*PYR(0)
+ CTHE=2D0*PYR(0)-1D0
+ PHI=PARU(2)*PYR(0)
+ CCHI=COS(CHI)
+ SCHI=SIN(CHI)
+ C2CHI=COS(2D0*CHI)
+ S2CHI=SIN(2D0*CHI)
+ THE=ACOS(CTHE)
+ STHE=SIN(THE)
+ C2PHI=COS(2D0*(PHI-PARJ(134)))
+ S2PHI=SIN(2D0*(PHI-PARJ(134)))
+ SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
+ & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
+ & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
+ & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
+ & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
+ IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
+ CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
+ CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
+ ENDIF
+
+C...Generate parton shower. Rearrange along strings and check.
+ IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
+ CALL PYSHOW(NC+MK+1,-NJET,ECMC)
+ MSTJ14=MSTJ(14)
+ IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
+ IF(MSTJ(105).GE.0) MSTU(28)=0
+ CALL PYPREP(0)
+ MSTJ(14)=MSTJ14
+ IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
+ ENDIF
+
+C...Generate fragmentation. Information for PYTABU:
+ IF(MSTJ(105).EQ.1) CALL PYEXEC
+ MSTU(161)=110*KFLC+3
+ MSTU(162)=0
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYBOOK
+C...Books a histogram.
+
+ SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+C...Local character variables.
+ CHARACTER TITLE*(*), TITFX*60
+
+C...Check that input is sensible. Find initial address in memory.
+ IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
+ &'(PYBOOK:) not allowed histogram number')
+ IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
+ &'(PYBOOK:) not allowed number of bins')
+ IF(XL.GE.XU) CALL PYERRM(28,
+ &'(PYBOOK:) x limits in wrong order')
+ INDX(ID)=IHIST(4)
+ IHIST(4)=IHIST(4)+28+NX
+ IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
+ &'(PYBOOK:) out of histogram space')
+ IS=INDX(ID)
+
+C...Store histogram size and reset contents.
+ BIN(IS+1)=NX
+ BIN(IS+2)=XL
+ BIN(IS+3)=XU
+ BIN(IS+4)=(XU-XL)/NX
+ CALL PYNULL(ID)
+
+C...Store title by conversion to integer to double precision.
+ TITFX=TITLE//' '
+ DO 100 IT=1,20
+ BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
+ & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFILL
+C...Fills entry in histogram.
+
+ SUBROUTINE PYFILL(ID,X,W)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+
+C...Find initial address in memory. Increase number of entries.
+ IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
+ &'(PYFILL:) not allowed histogram number')
+ IS=INDX(ID)
+ IF(IS.EQ.0) CALL PYERRM(28,
+ &'(PYFILL:) filling unbooked histogram')
+ BIN(IS+5)=BIN(IS+5)+1D0
+
+C...Find bin in x, including under/overflow, and fill.
+ IF(X.LT.BIN(IS+2)) THEN
+ BIN(IS+6)=BIN(IS+6)+W
+ ELSEIF(X.GE.BIN(IS+3)) THEN
+ BIN(IS+8)=BIN(IS+8)+W
+ ELSE
+ BIN(IS+7)=BIN(IS+7)+W
+ IX=(X-BIN(IS+2))/BIN(IS+4)
+ IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
+ BIN(IS+9+IX)=BIN(IS+9+IX)+W
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYFACT
+C...Multiplies histogram contents by factor.
+
+ SUBROUTINE PYFACT(ID,F)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+
+C...Find initial address in memory. Multiply all contents bins.
+ IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
+ &'(PYFACT:) not allowed histogram number')
+ IS=INDX(ID)
+ IF(IS.EQ.0) CALL PYERRM(28,
+ &'(PYFACT:) scaling unbooked histogram')
+ DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
+ BIN(IX)=F*BIN(IX)
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYOPER
+C...Performs operations between histograms.
+
+ SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+C...Character variable.
+ CHARACTER OPER*(*)
+
+C...Find initial addresses in memory, and histogram size.
+ IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
+ &'(PYFACT:) not allowed histogram number')
+ IS1=INDX(ID1)
+ IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
+ IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
+ NX=NINT(BIN(IS3+1))
+ IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
+
+C...Update info on number of histogram entries.
+ IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
+ BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
+ ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
+ BIN(IS3+5)=BIN(IS1+5)
+ ENDIF
+
+C...Operations on pair of histograms: addition, subtraction,
+C...multiplication, division.
+ IF(OPER.EQ.'+') THEN
+ DO 100 IX=6,8+NX
+ BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
+ 100 CONTINUE
+ ELSEIF(OPER.EQ.'-') THEN
+ DO 110 IX=6,8+NX
+ BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
+ 110 CONTINUE
+ ELSEIF(OPER.EQ.'*') THEN
+ DO 120 IX=6,8+NX
+ BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
+ 120 CONTINUE
+ ELSEIF(OPER.EQ.'/') THEN
+ DO 130 IX=6,8+NX
+ FA2=F2*BIN(IS2+IX)
+ IF(ABS(FA2).LE.1D-20) THEN
+ BIN(IS3+IX)=0D0
+ ELSE
+ BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
+ ENDIF
+ 130 CONTINUE
+
+C...Operations on single histogram: multiplication+addition,
+C...square root+addition, logarithm+addition.
+ ELSEIF(OPER.EQ.'A') THEN
+ DO 140 IX=6,8+NX
+ BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
+ 140 CONTINUE
+ ELSEIF(OPER.EQ.'S') THEN
+ DO 150 IX=6,8+NX
+ BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
+ 150 CONTINUE
+ ELSEIF(OPER.EQ.'L') THEN
+ ZMIN=1D20
+ DO 160 IX=9,8+NX
+ IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
+ & ZMIN=0.8D0*BIN(IS1+IX)
+ 160 CONTINUE
+ DO 170 IX=6,8+NX
+ BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
+ 170 CONTINUE
+
+C...Operation on two or three histograms: average and
+C...standard deviation.
+ ELSEIF(OPER.EQ.'M') THEN
+ DO 180 IX=6,8+NX
+ IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
+ BIN(IS2+IX)=0D0
+ ELSE
+ BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
+ ENDIF
+ IF(ID3.NE.0) THEN
+ IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
+ BIN(IS3+IX)=0D0
+ ELSE
+ BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
+ & BIN(IS2+IX)**2))
+ ENDIF
+ ENDIF
+ BIN(IS1+IX)=F1*BIN(IS1+IX)
+ 180 CONTINUE
+ ENDIF
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYHIST
+C...Prints and resets all histograms.
+
+ SUBROUTINE PYHIST
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+
+C...Loop over histograms, print and reset used ones.
+ DO 100 ID=1,IHIST(1)
+ IS=INDX(ID)
+ IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
+ CALL PYPLOT(ID)
+ CALL PYNULL(ID)
+ ENDIF
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYPLOT
+C...Prints a histogram (but does not reset it).
+
+ SUBROUTINE PYPLOT(ID)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYDAT1/,/PYBINS/
+C...Local arrays and character variables.
+ DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
+ CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
+
+C...Steps in histogram scale. Character sequence.
+ DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
+ DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
+
+C...Find initial address in memory; skip if empty histogram.
+ IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
+ IS=INDX(ID)
+ IF(IS.EQ.0) RETURN
+ IF(NINT(BIN(IS+5)).LE.0) THEN
+ WRITE(MSTU(11),5000) ID
+ RETURN
+ ENDIF
+
+C...Number of histogram lines and x bins.
+ LIN=IHIST(3)-18
+ NX=NINT(BIN(IS+1))
+
+C...Extract title by conversion from double precision via integer.
+ DO 100 IT=1,20
+ IEQ=NINT(BIN(IS+8+NX+IT))
+ TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
+ & //CHAR(MOD(IEQ,256))
+ 100 CONTINUE
+
+C...Find time; print title.
+ CALL PYTIME(IDATI)
+ IF(IDATI(1).GT.0) THEN
+ WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
+ ELSE
+ WRITE(MSTU(11),5200) ID, TITLE
+ ENDIF
+
+C...Find minimum and maximum bin content.
+ YMIN=BIN(IS+9)
+ YMAX=BIN(IS+9)
+ DO 110 IX=IS+10,IS+8+NX
+ IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
+ IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
+ 110 CONTINUE
+
+C...Determine scale and step size for y axis.
+ IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
+ IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
+ IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
+ IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
+ IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
+ IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
+ DELY=DYAC(1)
+ DO 120 IDEL=1,9
+ IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
+ 120 CONTINUE
+ DY=DELY*10D0**IPOT
+
+C...Convert bin contents to integer form; fractional fill in top row.
+ DO 130 IX=1,NX
+ CTA=ABS(BIN(IS+8+IX))/DY
+ IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
+ IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
+ 130 CONTINUE
+ IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
+ IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
+
+C...Print histogram row by row.
+ DO 150 IR=IRMA,IRMI,-1
+ IF(IR.EQ.0) GOTO 150
+ OUT=' '
+ DO 140 IX=1,NX
+ IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
+ IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
+ 140 CONTINUE
+ WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
+ 150 CONTINUE
+
+C...Print sign and value of bin contents.
+ IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
+ OUT=' '
+ DO 160 IX=1,NX
+ IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
+ IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
+ 160 CONTINUE
+ WRITE(MSTU(11),5400) OUT
+ DO 180 IR=4,1,-1
+ DO 170 IX=1,NX
+ OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
+ 170 CONTINUE
+ WRITE(MSTU(11),5500) IPOT+IR-4, OUT
+ 180 CONTINUE
+
+C...Print sign and value of lower bin edge.
+ IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
+ & 10.0001D0)-10
+ OUT=' '
+ DO 190 IX=1,NX
+ IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
+ & OUT(IX:IX)=CHA(11)
+ IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
+ 190 CONTINUE
+ WRITE(MSTU(11),5600) OUT
+ DO 210 IR=3,1,-1
+ DO 200 IX=1,NX
+ OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
+ 200 CONTINUE
+ WRITE(MSTU(11),5500) IPOT+IR-3, OUT
+ 210 CONTINUE
+ ENDIF
+
+C...Calculate and print statistics.
+ CSUM=0D0
+ CXSUM=0D0
+ CXXSUM=0D0
+ DO 220 IX=1,NX
+ CTA=ABS(BIN(IS+8+IX))
+ X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
+ CSUM=CSUM+CTA
+ CXSUM=CXSUM+CTA*X
+ CXXSUM=CXXSUM+CTA*X**2
+ 220 CONTINUE
+ XMEAN=CXSUM/MAX(CSUM,1D-20)
+ XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
+ WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
+ &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
+
+C...Formats for output.
+ 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
+ 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
+ &I2,':',I2/)
+ 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
+ 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
+ 5400 FORMAT(/8X,'Contents',3X,A100)
+ 5500 FORMAT(9X,'*10**',I2,3X,A100)
+ 5600 FORMAT(/8X,'Low edge',3X,A100)
+ 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
+ &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
+ &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYNULL
+C...Resets bin contents of a histogram.
+
+ SUBROUTINE PYNULL(ID)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+
+ IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
+ IS=INDX(ID)
+ IF(IS.EQ.0) RETURN
+ DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
+ BIN(IX)=0D0
+ 100 CONTINUE
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYDUMP
+C...Dumps histogram contents on file for reading by other program.
+C...Can also read back own dump.
+
+ SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
+
+C...Double precision declaration.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+C...Commonblock.
+ COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
+ SAVE /PYBINS/
+C...Local arrays and character variables.
+ DIMENSION IHI(*),ISS(100),VAL(5)
+ CHARACTER TITLE*60,FORMAT*13
+
+C...Dump all histograms that have been booked,
+C...including titles and ranges, one after the other.
+ IF(MDUMP.EQ.1) THEN
+
+C...Loop over histograms and find which are wanted and booked.
+ IF(NHI.LE.0) THEN
+ NW=IHIST(1)
+ ELSE
+ NW=NHI
+ ENDIF
+ DO 130 IW=1,NW
+ IF(NHI.EQ.0) THEN
+ ID=IW
+ ELSE
+ ID=IHI(IW)
+ ENDIF
+ IS=INDX(ID)
+ IF(IS.NE.0) THEN
+
+C...Write title, histogram size, filling statistics.
+ NX=NINT(BIN(IS+1))
+ DO 100 IT=1,20
+ IEQ=NINT(BIN(IS+8+NX+IT))
+ TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
+ & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
+ 100 CONTINUE
+ WRITE(LFN,5100) ID,TITLE
+ WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
+ WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
+ & BIN(IS+8)
+
+
+C...Write histogram contents, in groups of five.
+ DO 120 IXG=1,(NX+4)/5
+ DO 110 IXV=1,5
+ IX=5*IXG+IXV-5
+ IF(IX.LE.NX) THEN
+ VAL(IXV)=BIN(IS+8+IX)
+ ELSE
+ VAL(IXV)=0D0
+ ENDIF
+ 110 CONTINUE
+ WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
+ 120 CONTINUE
+
+C...Go to next histogram; finish.
+ ELSEIF(NHI.GT.0) THEN
+ CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
+ ENDIF
+ 130 CONTINUE
+
+C...Read back in histograms dumped MDUMP=1.
+ ELSEIF(MDUMP.EQ.2) THEN
+
+C...Read histogram number, title and range, and book.
+ 140 READ(LFN,5100,END=170) ID,TITLE
+ READ(LFN,5200) NX,XL,XU
+ CALL PYBOOK(ID,TITLE,NX,XL,XU)
+ IS=INDX(ID)
+
+C...Read filling statistics.
+ READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
+ BIN(IS+5)=DBLE(NENTRY)
+
+C...Read histogram contents, in groups of five.
+ DO 160 IXG=1,(NX+4)/5
+ READ(LFN,5400) (VAL(IXV),IXV=1,5)
+ DO 150 IXV=1,5
+ IX=5*IXG+IXV-5
+ IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
+ 150 CONTINUE
+ 160 CONTINUE
+
+C...Go to next histogram; finish.
+ GOTO 140
+ 170 CONTINUE
+
+C...Write histogram contents in column format,
+C...convenient e.g. for GNUPLOT input.
+ ELSEIF(MDUMP.EQ.3) THEN
+
+C...Find addresses to wanted histograms.
+ NSS=0
+ IF(NHI.LE.0) THEN
+ NW=IHIST(1)
+ ELSE
+ NW=NHI
+ ENDIF
+ DO 180 IW=1,NW
+ IF(NHI.EQ.0) THEN
+ ID=IW
+ ELSE
+ ID=IHI(IW)
+ ENDIF
+ IS=INDX(ID)
+ IF(IS.NE.0.AND.NSS.LT.100) THEN
+ NSS=NSS+1
+ ISS(NSS)=IS
+ ELSEIF(NSS.GE.100) THEN
+ CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
+ ELSEIF(NHI.GT.0) THEN
+ CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
+ ENDIF
+ 180 CONTINUE
+
+C...Check that they have common number of x bins. Fix format.
+ NX=NINT(BIN(ISS(1)+1))
+ DO 190 IW=2,NSS
+ IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
+ CALL PYERRM(8,'(PYDUMP:) different number of bins')
+ RETURN
+ ENDIF
+ 190 CONTINUE
+ FORMAT='(1P,000E12.4)'
+ WRITE(FORMAT(5:7),'(I3)') NSS+1
+
+C...Write histogram contents; first column x values.
+ DO 200 IX=1,NX
+ X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
+ WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
+ 200 CONTINUE
+
+ ENDIF
+
+C...Formats for output.
+ 5100 FORMAT(I5,5X,A60)
+ 5200 FORMAT(I5,1P,2D12.4)
+ 5300 FORMAT(I12,1P,3D12.4)
+ 5400 FORMAT(1P,5D12.4)
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYKCUT
+C...Dummy routine, which the user can replace in order to make cuts on
+C...the kinematics on the parton level before the matrix elements are
+C...evaluated and the event is generated. The cross-section estimates
+C...will automatically take these cuts into account, so the given
+C...values are for the allowed phase space region only. MCUT=0 means
+C...that the event has passed the cuts, MCUT=1 that it has failed.
+
+ SUBROUTINE PYKCUT(MCUT)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYDAT1/,/PYINT1/,/PYINT2/
+
+C...Set default value (accepting event) for MCUT.
+ MCUT=0
+
+C...Read out subprocess number.
+ ISUB=MINT(1)
+ ISTSB=ISET(ISUB)
+
+C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
+ TAU=VINT(21)
+ YST=VINT(22)
+ CTH=0D0
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
+ TAUP=0D0
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
+
+C...Calculate x_1, x_2, x_F.
+ IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
+ X1=SQRT(TAU)*EXP(YST)
+ X2=SQRT(TAU)*EXP(-YST)
+ ELSE
+ X1=SQRT(TAUP)*EXP(YST)
+ X2=SQRT(TAUP)*EXP(-YST)
+ ENDIF
+ XF=X1-X2
+
+C...Calculate shat, that, uhat, p_T^2.
+ SHAT=TAU*VINT(2)
+ SQM3=VINT(63)
+ SQM4=VINT(64)
+ RM3=SQM3/SHAT
+ RM4=SQM4/SHAT
+ BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
+ RPTS=4D0*VINT(71)**2/SHAT
+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
+ RM34=2D0*RM3*RM4
+ RSQM=1D0+RM34
+ RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
+ THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
+ UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
+ PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
+
+C...Decisions by user to be put here.
+
+C...Stop program if this routine is ever called.
+C...You should not copy these lines to your own routine.
+ WRITE(MSTU(11),5000)
+ IF(PYR(0).LT.10D0) STOP
+
+C...Format for error printout.
+ 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
+ &1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYEVWT
+C...Dummy routine, which the user can replace in order to multiply the
+C...standard PYTHIA differential cross-section by a process- and
+C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
+C...to generation of weighted events, with weight 1/WTXS, while for
+C...MSTP(142)=2 it corresponds to a modification of the underlying
+C...physics.
+
+ SUBROUTINE PYEVWT(WTXS)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINT1/MINT(400),VINT(400)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ SAVE /PYDAT1/,/PYINT1/,/PYINT2/
+
+C...Set default weight for WTXS.
+ WTXS=1D0
+
+C...Read out subprocess number.
+ ISUB=MINT(1)
+ ISTSB=ISET(ISUB)
+
+C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
+ TAU=VINT(21)
+ YST=VINT(22)
+ CTH=0D0
+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
+ TAUP=0D0
+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
+
+C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
+ X1=VINT(41)
+ X2=VINT(42)
+ XF=X1-X2
+ SHAT=VINT(44)
+ THAT=VINT(45)
+ UHAT=VINT(46)
+ PT2=VINT(48)
+
+C...Modifications by user to be put here.
+
+C...Stop program if this routine is ever called.
+C...You should not copy these lines to your own routine.
+ WRITE(MSTU(11),5000)
+ IF(PYR(0).LT.10D0) STOP
+
+C...Format for error printout.
+ 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
+ &1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYUPIN
+C...Dummy copy of routine to be called by user to set up a user-defined
+C...process.
+
+ SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
+ COMMON/PYINT6/PROC(0:500)
+ CHARACTER PROC*28
+ SAVE /PYDAT1/,/PYINT2/,/PYINT6/
+C...Local character variable.
+ CHARACTER*(*) TITLE
+
+C...Check that subprocess number free.
+ IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
+ WRITE(MSTU(11),5000) ISUB
+ STOP
+ ENDIF
+
+C...Fill information on new process.
+ ISET(ISUB)=11
+ COEF(ISUB,1)=SIGMAX
+ PROC(ISUB)=TITLE//' '
+
+C...Format for error output.
+ 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
+ &' not allowed.'//1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYUPEV
+C...Dummy routine, to be replaced by user. When called from PYTHIA
+C...the subprocess number ISUB will be given, and PYUPEV is supposed
+C...to generate an event of this type, to be stored in the PYUPPR
+C...commonblock. SIGEV gives the differential cross-section associated
+C...with the event, i.e. the acceptance probability of the event is
+C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
+C...call.
+
+ SUBROUTINE PYUPEV(ISUB,SIGEV)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
+ SAVE /PYDAT1/,/PYUPPR/
+
+C...Stop program if this routine is ever called.
+C...You should not copy these lines to your own routine.
+ WRITE(MSTU(11),5000)
+ IF(PYR(0).LT.10D0) STOP
+ SIGEV=ISUB
+
+C...Format for error printout.
+ 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
+ &1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTAUD
+C...Dummy routine, to be replaced by user, to handle the decay of a
+C...polarized tau lepton.
+C...Input:
+C...ITAU is the position where the decaying tau is stored in /PYJETS/.
+C...IORIG is the position where the mother of the tau is stored;
+C... is 0 when the mother is not stored.
+C...KFORIG is the flavour of the mother of the tau;
+C... is 0 when the mother is not known.
+C...Note that IORIG=0 does not necessarily imply KFORIG=0;
+C... e.g. in B hadron semileptonic decays the W propagator
+C... is not explicitly stored but the W code is still unambiguous.
+C...Output:
+C...NDECAY is the number of decay products in the current tau decay.
+C...These decay products should be added to the /PYJETS/ common block,
+C...in positions N+1 through N+NDECAY. For each product I you must
+C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
+C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
+
+ SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+C...Commonblocks.
+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+ SAVE /PYJETS/,/PYDAT1/
+
+C...Stop program if this routine is ever called.
+C...You should not copy these lines to your own routine.
+ NDECAY=ITAU+IORIG+KFORIG
+ WRITE(MSTU(11),5000)
+ IF(PYR(0).LT.10D0) STOP
+
+C...Format for error printout.
+ 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
+ &1X,'Execution stopped!')
+
+ RETURN
+ END
+
+C*********************************************************************
+
+C...PYTIME
+C...Finds current date and time.
+C...Since this task is not standardized in Fortran 77, the routine
+C...is dummy, to be replaced by the user. Examples are given for
+C...the Fortran 90 routine and DEC Fortran 77, and what to do if
+C...you do not have access to suitable routines.
+
+ SUBROUTINE PYTIME(IDATI)
+
+C...Double precision and integer declarations.
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ INTEGER PYK,PYCHGE,PYCOMP
+ CHARACTER*8 ATIME
+C...Local array.
+ INTEGER IDATI(6),IDTEMP(3)
+
+C...Example 0: if you do not have suitable routines.
+ DO 100 J=1,6
+ IDATI(J)=0
+ 100 CONTINUE
+
+C...Example 1: Fortran 90 routine.
+C INTEGER IVAL(8)
+C CALL DATE_AND_TIME(VALUES=IVAL)
+C IDATI(1)=IVAL(1)
+C IDATI(2)=IVAL(2)
+C IDATI(3)=IVAL(3)
+C IDATI(4)=IVAL(5)
+C IDATI(5)=IVAL(6)
+C IDATI(6)=IVAL(7)
+
+C...Example 2: DEC Fortran 77.
+C CALL IDATE(IMON,IDAY,IYEAR)
+C IDATI(1)=1900+IYEAR
+C IDATI(2)=IMON
+C IDATI(3)=IDAY
+C CALL ITIME(IHOUR,IMIN,ISEC)
+C IDATI(4)=IHOUR
+C IDATI(5)=IMIN
+C IDATI(6)=ISEC
+
+C...Example 3: DEC Fortran
+C CALL IDATE(IMON,IDAY,IYEAR)
+C IDATI(1)=1900+IYEAR
+C IDATI(2)=IMON
+C IDATI(3)=IDAY
+C CALL TIME(ATIME)
+C IHOUR=0
+C IMIN=0
+C ISEC=0
+C READ(ATIME(1:2),'(I2)') IHOUR
+C READ(ATIME(4:5),'(I2)') IMIN
+C READ(ATIME(7:8),'(I2)') ISEC
+C IDATI(4)=IHOUR
+C IDATI(5)=IMIN
+C IDATI(6)=ISEC
+
+C...Example 4: GNU LINUX libU77.
+C CALL IDATE(IDTEMP)
+C IDATI(1)=IDTEMP(3)
+C IDATI(2)=IDTEMP(2)
+C IDATI(3)=IDTEMP(1)
+C CALL ITIME(IDTEMP)
+C IDATI(4)=IDTEMP(1)
+C IDATI(5)=IDTEMP(2)
+C IDATI(6)=IDTEMP(3)
+
+ RETURN
+ END
--- /dev/null
+*
+*===program dpmjet=====================================================*
+*
+ PROGRAM DPMJET
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ EXTERNAL BDANDI, BDEMFL, BDEVAP, BDMULS, BDNOPT, BDPHFL, BDPWXS,
+ & BDRNDM, BDSQZI, BLKDT1, BLKDT2, BLKDT3, BLKDT4, BLKDT5,
+ & BLKDT6, BLKDT7, COUNTR, ELPROI, HADINI, BDPREE
+
+C EXTERNAL PYDATA
+
+* event flag
+ COMMON /DTEVNO/ NEVENT,ICASCA
+
+*-----------------------------------------------------------------------
+* initialization
+
+* the following statement provides a call to DT_USRHIS(MODE=1) for
+* histogram initialization etc.
+ CALL DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IEMU)
+
+*-----------------------------------------------------------------------
+* generation of events
+
+ DO 1 IEVT=1,NEVTS
+
+* some defaults, do not change!
+ NEVENT = IEVT
+ KKMAT = -1
+ ELAB = EPN
+* uncomment if dpmjet3 is linked to particle transport code
+C ICASCA = 1
+
+************************************************************************
+* The following lines show how to select the target nucleus for runs
+* with composite targets (and fixed projectile and energy!).
+*
+* Sampling of the target nucleus (mass number NTMASS, charge NTCHAR)
+* according to the fractions defined with EMULSION input-cards.
+* The different nuclei are numbered as KKMAT = 1,2,3,... according to
+* their appearance in the input-file.
+ IF (IEMU.GT.0) THEN
+* Replace this selection by your own one if needed.
+ CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
+* Kkmat has to be negative for composite targets!
+ KKMAT = -KKMAT
+ ENDIF
+************************************************************************
+
+************************************************************************
+* The following lines show how to define projectile, target and energy
+* for this event in runs with Glauber-data file pre-initialized for a
+* certain range of projectiles, targets and energies. The definitions
+* have to be within the pre-initialized parameter range.
+*
+* projectile-id (for hadron projectiles)
+C IDP = 1
+* projectile mass and charge numbers
+C NPMASS = 12
+C NPCHAR = 6
+* target mass and charge numbers
+C NTMASS = 16
+C NTCHAR = 8
+* lab energy
+C ELAB = 200.0D0
+************************************************************************
+
+************************************************************************
+* If an energy-range has been defined with the ENERGY input-card the
+* laboratory energy ELAB can be set to any value within that range. For
+* example:
+C ELO = 10.0D0
+C EHI = 1000.0D0
+C ELAB = DT_RNDM(ELAB)*(EHI-ELO)+ELO
+************************************************************************
+
+* sampling of one event
+ CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,ELAB,KKMAT,IREJ)
+ IF (IREJ.NE.0) GOTO 1
+
+* the following statement provides a call to DT_USRHIS(MODE=2) from
+* where the final state particles can be obtained
+
+ CALL PHO_PHIST(2000,DUM)
+
+ 1 CONTINUE
+
+*-----------------------------------------------------------------------
+* output, statistics etc.
+
+* the following statement provides a call to DT_USRHIS(MODE=3) in
+* order to calculate histograms etc.
+ CALL DT_DTUOUT
+
+ END
+*
+*===usrhis=============================================================*
+*
+CDECK ID>, DT_USRHIS
+ SUBROUTINE DT_USRHIS(MODE)
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+*
+* COMMON /DTEVT1/ :
+* NHKK number of entries in common block
+* NEVHKK number of the event
+* ISTHKK(i) status code for entry i
+* IDHKK(i) identifier for the entry
+* (for particles: identifier according
+* to the PDG numbering scheme)
+* JMOHKK(1,i) pointer to the entry of the first mother
+* of entry i
+* JMOHKK(2,i) pointer to the entry of the second mother
+* of entry i
+* JDAHKK(1,i) pointer to the entry of the first daughter
+* of entry i
+* JDAHKK(2,i) pointer to the entry of the second daughter
+* of entry i
+* PHKK(1..3,i) 3-momentum
+* PHKK(4,i) energy
+* PHKK(5,i) mass
+*
+* 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)
+
+ GOTO (1,2,3) MODE
+
+*------------------------------------------------------------------
+*
+ 1 CONTINUE
+*
+* initializations
+*
+* Called with MODE=1 once at the beginning of the run.
+*
+ RETURN
+*
+*------------------------------------------------------------------
+*
+ 2 CONTINUE
+*
+* scoring of the present event
+*
+* Called with MODE=2 every time one event has been finished.
+*
+* The final state particles from the actual event (number NEVHKK)
+* can be found in DTEVT1 and identified by their status:
+*
+* ISTHKK(i) = 1 final state particle produced in
+* photon-/hadron-/nucleon-nucleon collisions or
+* in intranuclear cascade processes
+* -1 nucleons, deuterons, H-3, He-3, He-4 evaporated
+* from excited nucleus and
+* photons produced in nuclear deexcitation processes
+* 1001 residual nucleus (ground state)
+*
+* The types of these particles/nuclei are given in IDHKK as follows
+*
+* all final state part. except nuclei :
+* IDHKK(i)=particle identifier according to PDG numbering scheme
+* nuclei (evaporation products, and residual nucleus) :
+* IDHKK(i)=80000, IDRES(i)=mass number, IDXRES(i)=charge number
+*
+* The 4-momenta and masses can be found in PHKK (target nucleus rest frame):
+* PHKK(1..3,i) 3-momentum (p_x,p_y,p_z)
+* PHKK(4,i) energy
+* PHKK(5,i) mass
+*
+*
+*
+* Pick out the final state particles from DTEVT1 in each event for
+* instance by the following loop (NHKK=number of entries in the present
+* event) and fill your histograms
+ NPART = 0
+ DO 19 I=1,NHKK
+C IF (ABS(ISTHKK(I)).NE. -1 .AND. ABS(ISTHKK(I)) .NE. 1001 ) THEN
+ IF (ABS(ISTHKK(I)).EQ. 1) THEN
+ NPART=NPART+1
+ ENDIF
+ 19 CONTINUE
+ write(16,*) npart
+ DO 20 I=1,NHKK
+C IF (ABS(ISTHKK(I)).NE. -1 .AND. ABS(ISTHKK(I)) .NE. 1001 ) THEN
+ IF (ABS(ISTHKK(I)).EQ. 1) THEN
+ WRITE(16,100)
+ & i, isthkk(i), idhkk(i),
+ & phkk(1,i), phkk(2,i), phkk(3,i), phkk(4,i), phkk(5,i),
+ & jmohkk(1,i), jmohkk(2,i), jdahkk(1,i), jdahkk(2,i)
+ ELSEIF (ABS(ISTHKK(I)).EQ.1001) THEN
+ ENDIF
+ 20 CONTINUE
+ 100 FORMAT(3i6, 5e13.5, 4i7)
+* At any time during the run a list of the actual entries in DTEVT1 and
+* DTEVT2 can be obtained (output unit 6) by the following statement:
+C CALL DT_EVTOUT(4)
+
+ RETURN
+*
+*------------------------------------------------------------------
+*
+ 3 CONTINUE
+*
+* output/statistics/histograms etc.
+*
+* Called with MODE=3 once after all events have been sampled.
+*
+ RETURN
+
+ END
git://git.uio.no / u / mrichter / AliRoot.git / commitdiff