diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index ee5cb0a361f537ecfd6425fa02fe71fcf566e163..ba3f81e434b808caac7e8e5df6cc7ad950baa71d 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -19,7 +19,10 @@ config-u-18_04:
stage: config
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
+ - git clone https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika-data.git
- mkdir build
- cd build
- cmake .. -DCMAKE_BUILD_TYPE=Debug -DWITH_PYTHIA=ON
@@ -27,6 +30,7 @@ config-u-18_04:
expire_in: 1 day
paths:
- build
+ - corsika-data
# job/stage to just prepare cmake
config-clang-8:
@@ -34,7 +38,10 @@ config-clang-8:
stage: config
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_BUILDS_DIR}/AirShowerPhysics/corsika/corsika-data/"
script:
+ - git clone https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika-data.git
- mkdir build
- cd build
- cmake .. -DCMAKE_BUILD_TYPE=Debug -DWITH_PYTHIA=ON
@@ -42,6 +49,7 @@ config-clang-8:
expire_in: 1 day
paths:
- build
+ - corsika-data
# normal pipeline for each commit
build-test-u-18_04:
@@ -51,6 +59,8 @@ build-test-u-18_04:
stage: build_test
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake --build . -- -j4
@@ -73,6 +83,8 @@ build-test-clang-8:
stage: build_test
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake --build . -- -j4
@@ -95,6 +107,8 @@ release-u-18_04:
stage: optional
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake .. -DCMAKE_BUILD_TYPE=Release
@@ -119,6 +133,8 @@ release-clang-8:
stage: optional
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake .. -DCMAKE_BUILD_TYPE=Release
@@ -143,6 +159,8 @@ release-clang-8:
stage: optional
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake .. -DCMAKE_BUILD_TYPE=Coverage
@@ -176,6 +194,8 @@ documentation:
stage: optional
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake --build . --target doxygen -- -j4
@@ -196,6 +216,8 @@ sanity:
stage: optional
tags:
- corsika
+ variables:
+ CORSIKA_DATA: "${CI_PROJECT_DIR}/corsika-data/"
script:
- cd build
- cmake .. -DWITH_CORSIKA_SANITIZERS_ENABLED=ON
diff --git a/Processes/CMakeLists.txt b/Processes/CMakeLists.txt
index 758b430e677109de684eaa52f081c6a74bd09c3d..9ca109dee4bbef7442de84944047730ffa0ba98c 100644
--- a/Processes/CMakeLists.txt
+++ b/Processes/CMakeLists.txt
@@ -4,6 +4,7 @@ add_subdirectory (NullModel)
add_subdirectory (TrackingLine)
# hadron interaction models
add_subdirectory (Sibyll)
+add_subdirectory (QGSJetII)
if (PYTHIA8_FOUND)
add_subdirectory (Pythia)
endif (PYTHIA8_FOUND)
diff --git a/Processes/QGSJetII/CMakeLists.txt b/Processes/QGSJetII/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..fbffc94be2a8f822e76232476ad9083006c32aaa
--- /dev/null
+++ b/Processes/QGSJetII/CMakeLists.txt
@@ -0,0 +1,132 @@
+set(Python_ADDITIONAL_VERSIONS 3)
+find_package(PythonInterp 3 REQUIRED)
+
+if (NOT DEFINED ENV{CORSIKA_DATA})
+ message (WARNING "WARNING: download corsika-data repository from gitlab for needed data tables, and set CORSIKA_DATA path!")
+endif ()
+
+add_custom_command (
+ OUTPUT ${PROJECT_BINARY_DIR}/Processes/QGSJetII/Generated.inc
+ COMMAND ${PROJECT_SOURCE_DIR}/Processes/QGSJetII/code_generator.py
+ ${PROJECT_BINARY_DIR}/Framework/Particles/particle_db.pkl
+ ${PROJECT_SOURCE_DIR}/Processes/QGSJetII/qgsjet-II-04-codes.dat
+ DEPENDS code_generator.py
+ qgsjet-II-04-codes.dat
+ ${PROJECT_BINARY_DIR}/Framework/Particles/particle_db.pkl
+ WORKING_DIRECTORY
+ ${PROJECT_BINARY_DIR}/Processes/QGSJetII/
+ COMMENT "Generate conversion tables for particle codes QGSJetII <-> CORSIKA"
+ VERBATIM
+ )
+
+set (
+ MODEL_SOURCES
+ ParticleConversion.cc
+ Interaction.cc
+ qgsjet-II-04.f
+ qgsjet-II-04.cc
+ )
+
+set (
+ MODEL_HEADERS
+ ParticleConversion.h
+ qgsjet-II-04.h
+ QGSJetIIStack.h
+ QGSJetIIFragmentsStack.h
+ Interaction.h
+ ${PROJECT_BINARY_DIR}/Processes/QGSJetII/Generated.inc
+ )
+
+set (
+ MODEL_NAMESPACE
+ corsika/process/qgsjetII
+ )
+
+add_library (ProcessQGSJetII STATIC ${MODEL_SOURCES})
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (ProcessQGSJetII ${MODEL_NAMESPACE} ${MODEL_HEADERS})
+
+# ....................................................
+# since Generated.inc is an automatically produced file in the build directory,
+# create a symbolic link into the source tree, so that it can be found and edited more easily
+# this is not needed for the build to succeed! .......
+add_custom_command (
+ OUTPUT ${CMAKE_CURRENT_SOURCE_DIR}/Generated.inc
+ COMMAND ${CMAKE_COMMAND} -E create_symlink ${PROJECT_BINARY_DIR}/include/corsika/process/qgsjetII/Generated.inc ${CMAKE_CURRENT_SOURCE_DIR}/Generated.inc
+ COMMENT "Generate link in source-dir: ${CMAKE_CURRENT_SOURCE_DIR}/Generated.inc"
+ )
+add_custom_target (SourceDirLinkQgsII DEPENDS ${PROJECT_BINARY_DIR}/Processes/QGSJetII/Generated.inc)
+add_dependencies (ProcessQGSJetII SourceDirLinkQgsII)
+# .....................................................
+
+
+
+set_target_properties (
+ ProcessQGSJetII
+ PROPERTIES
+ VERSION ${PROJECT_VERSION}
+ SOVERSION 1
+ )
+
+# target dependencies on other libraries (also the header onlys)
+target_link_libraries (
+ ProcessQGSJetII
+ CORSIKAprocesssequence
+ CORSIKAparticles
+ CORSIKAutilities
+ CORSIKAunits
+ CORSIKAthirdparty
+ CORSIKAgeometry
+ CORSIKAenvironment
+ )
+
+target_include_directories (
+ ProcessQGSJetII
+ INTERFACE
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/include>
+ )
+
+install (
+ TARGETS ProcessQGSJetII
+ LIBRARY DESTINATION lib
+ ARCHIVE DESTINATION lib
+ )
+
+# install(
+# FILES qgsdat-II-04 sectnu-II-04 DESTINATION etc/data
+# )
+
+
+# --------------------
+# code unit testing
+CORSIKA_ADD_TEST(testQGSJetII
+ SOURCES
+ testQGSJetII.cc
+ ${MODEL_HEADERS}
+)
+
+target_link_libraries (
+ testQGSJetII
+ ProcessQGSJetII
+ CORSIKAsetup
+ CORSIKArandom
+ CORSIKAgeometry
+ CORSIKAunits
+ CORSIKAtesting
+ )
+
+# also provide QGSJetII large data tables for testing in build tree (links)
+# -> changed that to use environment variable "${CORSIKA_DATA}/QGSJetII"
+# add_custom_command (
+# OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/qgsdat-II-04 ${CMAKE_CURRENT_BINARY_DIR}/sectnu-II-04
+# COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_SOURCE_DIR}/qgsdat-II-04 ${CMAKE_CURRENT_BINARY_DIR}/qgsdat-II-04
+# COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_SOURCE_DIR}/sectnu-II-04 ${CMAKE_CURRENT_BINARY_DIR}/sectnu-II-04
+# COMMENT "Generate link in source-dir: qgsjet-II-04"
+# )
+
+# add_custom_target (QGSJetDataLink DEPENDS
+# ${CMAKE_CURRENT_BINARY_DIR}/qgsdat-II-04
+# ${CMAKE_CURRENT_BINARY_DIR}/sectnu-II-04
+# )
+
+# add_dependencies (testQGSJetII QGSJetDataLink)
diff --git a/Processes/QGSJetII/Interaction.cc b/Processes/QGSJetII/Interaction.cc
new file mode 100644
index 0000000000000000000000000000000000000000..d9b4c3cea53a6479330992d0bc195d6c838ac418
--- /dev/null
+++ b/Processes/QGSJetII/Interaction.cc
@@ -0,0 +1,389 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#include <corsika/process/qgsjetII/Interaction.h>
+
+#include <corsika/environment/Environment.h>
+#include <corsika/environment/NuclearComposition.h>
+#include <corsika/geometry/QuantityVector.h>
+#include <corsika/geometry/FourVector.h>
+#include <corsika/process/qgsjetII/ParticleConversion.h>
+#include <corsika/process/qgsjetII/QGSJetIIFragmentsStack.h>
+#include <corsika/process/qgsjetII/QGSJetIIStack.h>
+#include <corsika/process/qgsjetII/qgsjet-II-04.h>
+#include <corsika/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+#include <corsika/utl/COMBoost.h>
+
+#include <sstream>
+#include <string>
+#include <tuple>
+
+using std::cout;
+using std::endl;
+using std::ostringstream;
+using std::string;
+using std::tuple;
+
+using namespace corsika;
+using namespace corsika::setup;
+using SetupParticle = setup::Stack::StackIterator;
+using SetupProjectile = setup::StackView::StackIterator;
+using Track = Trajectory;
+
+namespace corsika::process::qgsjetII {
+
+ Interaction::Interaction(const string& dataPath)
+ : data_path_(dataPath) {
+ if (dataPath == "") {
+ if (std::getenv("CORSIKA_DATA")) {
+ data_path_ = string(std::getenv("CORSIKA_DATA")) + "/QGSJetII/";
+ cout << "Searching for QGSJetII data tables in " << data_path_ << endl;
+ }
+ }
+ }
+
+ Interaction::~Interaction() { cout << "QgsjetII::Interaction n=" << count_ << endl; }
+
+ void Interaction::Init() {
+
+ using random::RNGManager;
+
+ // initialize QgsjetII
+ if (!initialized_) {
+ qgset_();
+ datadir DIR(data_path_);
+ qgaini_(DIR.data);
+ initialized_ = true;
+ }
+ }
+
+ units::si::CrossSectionType Interaction::GetCrossSection(
+ const particles::Code beamId, const particles::Code targetId,
+ const units::si::HEPEnergyType Elab, const unsigned int Abeam,
+ const unsigned int targetA) const {
+ using namespace units::si;
+ double sigProd = std::numeric_limits<double>::infinity();
+
+ if (process::qgsjetII::CanInteract(beamId)) {
+
+ const int iBeam = process::qgsjetII::GetQgsjetIIXSCode(beamId);
+ int iTarget = 1;
+ if (particles::IsNucleus(targetId)) {
+ iTarget = targetA;
+ if (iTarget > maxMassNumber_ || iTarget <= 0) {
+ std::ostringstream txt;
+ txt << "QgsjetII target outside range. iTarget=" << iTarget;
+ throw std::runtime_error(txt.str().c_str());
+ }
+ }
+ int iProjectile = 1;
+ if (particles::IsNucleus(beamId)) {
+ iProjectile = Abeam;
+ if (iProjectile > maxMassNumber_ || iProjectile <= 0)
+ throw std::runtime_error("QgsjetII target outside range. ");
+ }
+
+ cout << "QgsjetII::GetCrossSection Elab=" << Elab << " iBeam=" << iBeam
+ << " iProjectile=" << iProjectile << " iTarget=" << iTarget << endl;
+ sigProd = qgsect_(Elab / 1_GeV, iBeam, iProjectile, iTarget);
+ cout << "QgsjetII::GetCrossSection sigProd=" << sigProd << endl;
+ }
+
+ return sigProd * 1_mb;
+ }
+
+ template <>
+ units::si::GrammageType Interaction::GetInteractionLength(
+ SetupParticle const& vP) const {
+
+ using namespace units;
+ using namespace units::si;
+ using namespace geometry;
+
+ // coordinate system, get global frame of reference
+ CoordinateSystem& rootCS =
+ RootCoordinateSystem::GetInstance().GetRootCoordinateSystem();
+
+ const particles::Code corsikaBeamId = vP.GetPID();
+
+ // beam particles for qgsjetII : 1, 2, 3 for p, pi, k
+ // read from cross section code table
+ const bool kInteraction = process::qgsjetII::CanInteract(corsikaBeamId);
+
+ // FOR NOW: assume target is at rest
+ MomentumVector pTarget(rootCS, {0_GeV, 0_GeV, 0_GeV});
+
+ // total momentum and energy
+ HEPEnergyType Elab = vP.GetEnergy();
+
+ cout << "Interaction: LambdaInt: \n"
+ << " input energy: " << vP.GetEnergy() / 1_GeV << endl
+ << " beam can interact:" << kInteraction << endl
+ << " beam pid:" << vP.GetPID() << endl;
+
+ if (kInteraction) {
+
+ int Abeam = 0;
+ if (particles::IsNucleus(vP.GetPID())) Abeam = vP.GetNuclearA();
+
+ // get target from environment
+ /*
+ the target should be defined by the Environment,
+ ideally as full particle object so that the four momenta
+ and the boosts can be defined..
+ */
+
+ auto const* currentNode = vP.GetNode();
+ const auto& mediumComposition =
+ currentNode->GetModelProperties().GetNuclearComposition();
+
+ si::CrossSectionType weightedProdCrossSection = mediumComposition.WeightedSum(
+ [=](particles::Code targetID) -> si::CrossSectionType {
+ int targetA = 0;
+ if (corsika::particles::IsNucleus(targetID))
+ targetA = particles::GetNucleusA(targetID);
+ return GetCrossSection(corsikaBeamId, targetID, Elab, Abeam, targetA);
+ });
+
+ cout << "Interaction: "
+ << "IntLength: weighted CrossSection (mb): " << weightedProdCrossSection / 1_mb
+ << endl;
+
+ // calculate interaction length in medium
+ GrammageType const int_length = mediumComposition.GetAverageMassNumber() *
+ units::constants::u / weightedProdCrossSection;
+ cout << "Interaction: "
+ << "interaction length (g/cm2): " << int_length / (0.001_kg) * 1_cm * 1_cm
+ << endl;
+
+ return int_length;
+ }
+
+ return std::numeric_limits<double>::infinity() * 1_g / (1_cm * 1_cm);
+ }
+
+ /**
+ In this function QGSJETII is called to produce one event. The
+ event is copied (and boosted) into the shower lab frame.
+ */
+
+ template <>
+ process::EProcessReturn Interaction::DoInteraction(SetupProjectile& vP) {
+
+ using namespace units;
+ using namespace utl;
+ using namespace units::si;
+ using namespace geometry;
+
+ const auto corsikaBeamId = vP.GetPID();
+ cout << "ProcessQgsjetII: "
+ << "DoInteraction: " << corsikaBeamId << " interaction? "
+ << process::qgsjetII::CanInteract(corsikaBeamId) << endl;
+
+ if (process::qgsjetII::CanInteract(corsikaBeamId)) {
+
+ const CoordinateSystem& rootCS =
+ RootCoordinateSystem::GetInstance().GetRootCoordinateSystem();
+
+ // position and time of interaction, not used in QgsjetII
+ Point pOrig = vP.GetPosition();
+ TimeType tOrig = vP.GetTime();
+
+ // define target
+ // for QgsjetII is always a single nucleon
+ // FOR NOW: target is always at rest
+ const auto targetEnergyLab = 0_GeV + constants::nucleonMass;
+ const auto targetMomentumLab = MomentumVector(rootCS, 0_GeV, 0_GeV, 0_GeV);
+ const FourVector PtargLab(targetEnergyLab, targetMomentumLab);
+
+ // define projectile
+ HEPEnergyType const projectileEnergyLab = vP.GetEnergy();
+ auto const projectileMomentumLab = vP.GetMomentum();
+
+ int beamA = 0;
+ if (particles::IsNucleus(corsikaBeamId)) beamA = vP.GetNuclearA();
+
+ cout << "Interaction: ebeam lab: " << projectileEnergyLab / 1_GeV << endl
+ << "Interaction: pbeam lab: " << projectileMomentumLab.GetComponents() / 1_GeV
+ << endl;
+ cout << "Interaction: etarget lab: " << targetEnergyLab / 1_GeV << endl
+ << "Interaction: ptarget lab: " << targetMomentumLab.GetComponents() / 1_GeV << endl;
+
+ cout << "Interaction: position of interaction: " << pOrig.GetCoordinates() << endl;
+ cout << "Interaction: time: " << tOrig << endl;
+
+ // sample target mass number
+ auto const* currentNode = vP.GetNode();
+ auto const& mediumComposition =
+ currentNode->GetModelProperties().GetNuclearComposition();
+ // get cross sections for target materials
+ /*
+ Here we read the cross section from the interaction model again,
+ should be passed from GetInteractionLength if possible
+ */
+ auto const& compVec = mediumComposition.GetComponents();
+ std::vector<si::CrossSectionType> cross_section_of_components(compVec.size());
+
+ for (size_t i = 0; i < compVec.size(); ++i) {
+ auto const targetId = compVec[i];
+ int targetA = 0;
+ if (corsika::particles::IsNucleus(targetId))
+ targetA = particles::GetNucleusA(targetId);
+ const auto sigProd =
+ GetCrossSection(corsikaBeamId, targetId, projectileEnergyLab, beamA, targetA);
+ cross_section_of_components[i] = sigProd;
+ }
+
+ const auto targetCode =
+ mediumComposition.SampleTarget(cross_section_of_components, fRNG);
+ cout << "Interaction: target selected: " << targetCode << endl;
+
+ int targetQgsCode = -1;
+ if (particles::IsNucleus(targetCode))
+ targetQgsCode = particles::GetNucleusA(targetCode);
+ if (targetCode == particles::Proton::GetCode()) targetQgsCode = 1;
+ cout << "Interaction: target qgsjetII code/A: " << targetQgsCode << endl;
+ if (targetQgsCode > maxMassNumber_ || targetQgsCode < 1)
+ throw std::runtime_error("QgsjetII target outside range.");
+
+ int projQgsCode = 1;
+ if (particles::IsNucleus(corsikaBeamId)) projQgsCode = vP.GetNuclearA();
+ cout << "Interaction: projectile qgsjetII code/A: " << projQgsCode << " "
+ << corsikaBeamId << endl;
+ if (projQgsCode > maxMassNumber_ || projQgsCode < 1)
+ throw std::runtime_error("QgsjetII target outside range.");
+
+ // beam id for qgsjetII
+ int kBeam = 2; // default: proton Shouldn't we randomize neutron/proton for nuclei?
+ if (corsikaBeamId != particles::Code::Nucleus) {
+ kBeam = process::qgsjetII::ConvertToQgsjetIIRaw(corsikaBeamId);
+ // from conex
+ if (kBeam == 0) { // replace pi0 or rho0 with pi+/pi-
+ static int select = 1;
+ kBeam = select;
+ select *= -1;
+ }
+ // replace lambda by neutron
+ if (kBeam == 6)
+ kBeam = 3;
+ else if (kBeam == -6)
+ kBeam = -3;
+ // else if (abs(kBeam)>6) -> throw
+ }
+
+ cout << "Interaction: "
+ << " DoInteraction: E(GeV):" << projectileEnergyLab / 1_GeV << endl;
+ count_++;
+ qgini_(projectileEnergyLab / 1_GeV, kBeam, projQgsCode, targetQgsCode);
+ // this is from CRMC, is this REALLY needed ???
+ qgini_(projectileEnergyLab / 1_GeV, kBeam, projQgsCode, targetQgsCode);
+ qgconf_();
+
+ // bookkeeping
+ MomentumVector Plab_final(rootCS, {0.0_GeV, 0.0_GeV, 0.0_GeV});
+ HEPEnergyType Elab_final = 0_GeV;
+
+ // to read the secondaries
+ // define rotation to and from CoM frame
+ // CoM frame definition in QgsjetII projectile: +z
+ auto const& originalCS = projectileMomentumLab.GetCoordinateSystem();
+ geometry::CoordinateSystem const zAxisFrame =
+ originalCS.RotateToZ(projectileMomentumLab);
+
+ // fragments
+ QGSJetIIFragmentsStack qfs;
+ for (auto& fragm : qfs) {
+ particles::Code idFragm = particles::Code::Nucleus;
+ int A = fragm.GetFragmentSize();
+ int Z = 0;
+ switch (A) {
+ case 1: { // proton/neutron
+ idFragm = particles::Code::Proton;
+
+ auto momentum = geometry::Vector(
+ zAxisFrame,
+ corsika::geometry::QuantityVector<hepmomentum_d>{0.0_GeV, 0.0_GeV,
+ sqrt((projectileEnergyLab + particles::Proton::GetMass()) *
+ (projectileEnergyLab - particles::Proton::GetMass()))});
+
+ auto const energy = sqrt(momentum.squaredNorm() + square(particles::GetMass(idFragm)));
+ momentum.rebase(originalCS); // transform back into standard lab frame
+ std::cout << "secondary fragment> id=" << idFragm << " p=" << momentum.GetComponents() << std::endl;
+ auto pnew = vP.AddSecondary(
+ tuple<particles::Code, units::si::HEPEnergyType, stack::MomentumVector,
+ geometry::Point, units::si::TimeType>{
+ idFragm, energy, momentum, pOrig, tOrig});
+ Plab_final += pnew.GetMomentum();
+ Elab_final += pnew.GetEnergy();
+ } break;
+ case 2: // deuterium
+ Z = 1;
+ break;
+ case 3: // tritium
+ Z = 1;
+ break;
+ case 4: // helium
+ Z = 2;
+ break;
+ default: // nucleus
+ {
+ Z = int(A / 2.15 + 0.7);
+ }
+ }
+
+ if (idFragm == particles::Code::Nucleus) {
+ auto momentum = geometry::Vector(
+ zAxisFrame,
+ geometry::QuantityVector<hepmomentum_d>{0.0_GeV, 0.0_GeV,
+ sqrt((projectileEnergyLab + constants::nucleonMass * A) *
+ (projectileEnergyLab - constants::nucleonMass * A))});
+
+ auto const energy = sqrt(momentum.squaredNorm() + square(constants::nucleonMass*A));
+ momentum.rebase(originalCS); // transform back into standard lab frame
+ std::cout << "secondary fragment> id=" << idFragm << " p=" << momentum.GetComponents() << " A=" << A << " Z=" << Z << std::endl;
+ auto pnew = vP.AddSecondary(
+ tuple<particles::Code, units::si::HEPEnergyType, stack::MomentumVector,
+ geometry::Point, units::si::TimeType, unsigned short, unsigned short>{
+ idFragm, energy, momentum, pOrig, tOrig, A, Z});
+ Plab_final += pnew.GetMomentum();
+ Elab_final += pnew.GetEnergy();
+ }
+ }
+
+ // secondaries
+ QGSJetIIStack qs;
+ for (auto& psec : qs) {
+
+ auto momentum = psec.GetMomentum(zAxisFrame);
+ auto const energy = psec.GetEnergy();
+
+ momentum.rebase(originalCS); // transform back into standard lab frame
+ std::cout << "secondary fragment> id=" << process::qgsjetII::ConvertFromQgsjetII(psec.GetPID()) << " p=" << momentum.GetComponents() << std::endl;
+ auto pnew = vP.AddSecondary(
+ tuple<particles::Code, units::si::HEPEnergyType, stack::MomentumVector,
+ geometry::Point, units::si::TimeType>{
+ process::qgsjetII::ConvertFromQgsjetII(psec.GetPID()), energy, momentum, pOrig, tOrig});
+ Plab_final += pnew.GetMomentum();
+ Elab_final += pnew.GetEnergy();
+ }
+ cout << "conservation (all GeV): Ecm_final= n/a" /* << Ecm_final / 1_GeV*/ << endl
+ << "Elab_final=" << Elab_final / 1_GeV
+ << ", Plab_final=" << (Plab_final / 1_GeV).GetComponents()
+ << ", N_wounded,targ="
+ << QGSJetIIFragmentsStackData::GetWoundedNucleonsTarget()
+ << ", N_wounded,proj="
+ << QGSJetIIFragmentsStackData::GetWoundedNucleonsProjectile()
+ << ", N_fragm,proj=" << qfs.GetSize() << endl;
+ }
+ return process::EProcessReturn::eOk;
+ }
+
+} // namespace corsika::process::qgsjetII
diff --git a/Processes/QGSJetII/Interaction.h b/Processes/QGSJetII/Interaction.h
new file mode 100644
index 0000000000000000000000000000000000000000..3ae93106c50286fed7f9a06631e85b47e292d302
--- /dev/null
+++ b/Processes/QGSJetII/Interaction.h
@@ -0,0 +1,66 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#ifndef _corsika_process_qgsjetII_interaction_h_
+#define _corsika_process_qgsjetII_interaction_h_
+
+#include <corsika/particles/ParticleProperties.h>
+#include <corsika/process/InteractionProcess.h>
+#include <corsika/random/RNGManager.h>
+#include <corsika/units/PhysicalUnits.h>
+
+#include <string>
+
+namespace corsika::process::qgsjetII {
+
+ class Interaction : public corsika::process::InteractionProcess<Interaction> {
+
+ std::string data_path_;
+ int count_ = 0;
+ bool initialized_ = false;
+
+ public:
+ Interaction(const std::string& dataPath = "");
+ ~Interaction();
+
+ void Init();
+
+ bool WasInitialized() { return initialized_; }
+ int GetMaxTargetMassNumber() const { return maxMassNumber_; }
+ bool IsValidTarget(corsika::particles::Code TargetId) const {
+ return (corsika::particles::GetNucleusA(TargetId) < maxMassNumber_) &&
+ corsika::particles::IsNucleus(TargetId);
+ }
+
+ corsika::units::si::CrossSectionType GetCrossSection(
+ const corsika::particles::Code, const corsika::particles::Code,
+ const corsika::units::si::HEPEnergyType, const unsigned int Abeam = 0,
+ const unsigned int Atarget = 0) const;
+
+ template <typename TParticle>
+ corsika::units::si::GrammageType GetInteractionLength(TParticle const&) const;
+
+ /**
+ In this function QGSJETII is called to produce one event. The
+ event is copied (and boosted) into the shower lab frame.
+ */
+
+ template <typename TProjectile>
+ corsika::process::EProcessReturn DoInteraction(TProjectile&);
+
+ private:
+ corsika::random::RNG& fRNG =
+ corsika::random::RNGManager::GetInstance().GetRandomStream("qgran");
+ const int maxMassNumber_ = 208;
+ };
+
+} // namespace corsika::process::qgsjetII
+
+#endif
diff --git a/Processes/QGSJetII/ParticleConversion.cc b/Processes/QGSJetII/ParticleConversion.cc
new file mode 100644
index 0000000000000000000000000000000000000000..266ebc5567671acc0616a7a84f83f2201ddbb15f
--- /dev/null
+++ b/Processes/QGSJetII/ParticleConversion.cc
@@ -0,0 +1,14 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#include <corsika/particles/ParticleProperties.h>
+#include <corsika/process/qgsjetII/ParticleConversion.h>
+
+using namespace corsika::process::qgsjetII;
diff --git a/Processes/QGSJetII/ParticleConversion.h b/Processes/QGSJetII/ParticleConversion.h
new file mode 100644
index 0000000000000000000000000000000000000000..1a89658666deda150d5131c6bc0c01e06951174a
--- /dev/null
+++ b/Processes/QGSJetII/ParticleConversion.h
@@ -0,0 +1,56 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#ifndef _include_processes_qgsjetII_particles_h_
+#define _include_processes_qgsjetII_particles_h_
+
+#include <corsika/particles/ParticleProperties.h>
+
+#include <string>
+
+namespace corsika::process::qgsjetII {
+
+ enum class QgsjetIICode : int8_t;
+ using QgsjetIICodeIntType = std::underlying_type<QgsjetIICode>::type;
+
+#include <corsika/process/qgsjetII/Generated.inc>
+
+ QgsjetIICode constexpr ConvertToQgsjetII(corsika::particles::Code pCode) {
+ return static_cast<QgsjetIICode>(
+ corsika2qgsjetII[static_cast<corsika::particles::CodeIntType>(pCode)]);
+ }
+
+ corsika::particles::Code constexpr ConvertFromQgsjetII(QgsjetIICode pCode) {
+ auto const pCodeInt = static_cast<QgsjetIICodeIntType>(pCode);
+ auto const corsikaCode = qgsjetII2corsika[pCodeInt - minQgsjetII];
+ if (corsikaCode == corsika::particles::Code::Unknown) {
+ throw std::runtime_error(std::string("QGSJETII/CORSIKA conversion of pCodeInt=")
+ .append(std::to_string(pCodeInt))
+ .append(" impossible"));
+ }
+ return corsikaCode;
+ }
+
+ int constexpr ConvertToQgsjetIIRaw(corsika::particles::Code pCode) {
+ return static_cast<int>(ConvertToQgsjetII(pCode));
+ }
+
+ int constexpr GetQgsjetIIXSCode(corsika::particles::Code pCode) {
+ if (pCode == corsika::particles::Code::Nucleus) return 2;
+ return corsika2qgsjetIIXStype[static_cast<corsika::particles::CodeIntType>(pCode)];
+ }
+
+ bool constexpr CanInteract(corsika::particles::Code pCode) {
+ return (GetQgsjetIIXSCode(pCode) > 0) && (ConvertToQgsjetIIRaw(pCode) <= 5);
+ }
+
+} // namespace corsika::process::qgsjetII
+
+#endif
diff --git a/Processes/QGSJetII/QGSJetIIFragmentsStack.h b/Processes/QGSJetII/QGSJetIIFragmentsStack.h
new file mode 100644
index 0000000000000000000000000000000000000000..7704c19fc058ea82198b7a0462467624b5de1c3a
--- /dev/null
+++ b/Processes/QGSJetII/QGSJetIIFragmentsStack.h
@@ -0,0 +1,80 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#ifndef _include_qgsjetIIfragmentsstack_h_
+#define _include_qgsjetIIfragmentsstack_h_
+
+#include <corsika/geometry/RootCoordinateSystem.h>
+#include <corsika/geometry/Vector.h>
+#include <corsika/process/qgsjetII/ParticleConversion.h>
+#include <corsika/process/qgsjetII/qgsjet-II-04.h>
+#include <corsika/stack/Stack.h>
+#include <corsika/units/PhysicalUnits.h>
+
+namespace corsika::process::qgsjetII {
+
+ class QGSJetIIFragmentsStackData {
+
+ public:
+ void Init();
+ void Dump() const {}
+
+ void Clear() {
+ qgarr13_.nsf = 0;
+ qgarr55_.nwt = 0;
+ }
+ unsigned int GetSize() const { return qgarr13_.nsf; }
+ unsigned int GetCapacity() const { return iapmax; }
+
+ static unsigned int GetWoundedNucleonsTarget() { return qgarr55_.nwt; }
+ static unsigned int GetWoundedNucleonsProjectile() { return qgarr55_.nwp; }
+
+ int GetFragmentSize(const unsigned int i) const { return qgarr13_.iaf[i]; }
+ void SetFragmentSize(const unsigned int i, const int v) { qgarr13_.iaf[i] = v; }
+
+ void Copy(const unsigned int i1, const unsigned int i2) {
+ qgarr13_.iaf[i2] = qgarr13_.iaf[i1];
+ }
+
+ void Swap(const unsigned int i1, const unsigned int i2) {
+ std::swap(qgarr13_.iaf[i1], qgarr13_.iaf[i2]);
+ }
+
+ void IncrementSize() { qgarr13_.nsf++; }
+ void DecrementSize() {
+ if (qgarr13_.nsf > 0) { qgarr13_.nsf--; }
+ }
+ };
+
+ template <typename StackIteratorInterface>
+ class FragmentsInterface : public corsika::stack::ParticleBase<StackIteratorInterface> {
+
+ using corsika::stack::ParticleBase<StackIteratorInterface>::GetStackData;
+ using corsika::stack::ParticleBase<StackIteratorInterface>::GetIndex;
+
+ public:
+ void SetParticleData(const int vSize) { SetFragmentSize(vSize); }
+
+ void SetParticleData(FragmentsInterface<StackIteratorInterface>& /*parent*/,
+ const int vSize) {
+ SetFragmentSize(vSize);
+ }
+
+ void SetFragmentSize(const int v) { GetStackData().SetFragmentSize(GetIndex(), v); }
+
+ double GetFragmentSize() const { return GetStackData().GetFragmentSize(GetIndex()); }
+ };
+
+ typedef corsika::stack::Stack<QGSJetIIFragmentsStackData, FragmentsInterface>
+ QGSJetIIFragmentsStack;
+
+} // end namespace corsika::process::qgsjetII
+
+#endif
diff --git a/Processes/QGSJetII/QGSJetIIStack.h b/Processes/QGSJetII/QGSJetIIStack.h
new file mode 100644
index 0000000000000000000000000000000000000000..70288ef4e3c0ee1ffeea5978b0e11e77c70fdc57
--- /dev/null
+++ b/Processes/QGSJetII/QGSJetIIStack.h
@@ -0,0 +1,135 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#ifndef _include_qgsjetIIstack_h_
+#define _include_qgsjetIIstack_h_
+
+#include <corsika/geometry/CoordinateSystem.h>
+#include <corsika/geometry/Vector.h>
+#include <corsika/process/qgsjetII/ParticleConversion.h>
+#include <corsika/process/qgsjetII/qgsjet-II-04.h>
+#include <corsika/stack/Stack.h>
+#include <corsika/units/PhysicalUnits.h>
+
+namespace corsika::process::qgsjetII {
+
+ typedef corsika::geometry::Vector<corsika::units::si::hepmomentum_d> MomentumVector;
+
+ class QGSJetIIStackData {
+
+ public:
+ void Init();
+ void Dump() const {}
+
+ void Clear() {
+ qgarr12_.nsp = 0;
+ qgarr13_.nsf = 0;
+ qgarr55_.nwt = 0;
+ }
+ unsigned int GetSize() const { return qgarr12_.nsp; }
+ unsigned int GetCapacity() const { return nptmax; }
+
+ void SetId(const unsigned int i, const int v) { qgarr14_.ich[i] = v; }
+ void SetEnergy(const unsigned int i, const corsika::units::si::HEPEnergyType v) {
+ using namespace corsika::units::si;
+ qgarr14_.esp[i][0] = v / 1_GeV;
+ }
+
+ void SetMomentum(const unsigned int i, const MomentumVector& v) {
+ using namespace corsika::units::si;
+ auto tmp = v.GetComponents();
+ qgarr14_.esp[i][2] = tmp[0] / 1_GeV;
+ qgarr14_.esp[i][3] = tmp[1] / 1_GeV;
+ qgarr14_.esp[i][1] = tmp[2] / 1_GeV;
+ }
+
+ int GetId(const unsigned int i) const { return qgarr14_.ich[i]; }
+ corsika::units::si::HEPEnergyType GetEnergy(const int i) const {
+ using namespace corsika::units::si;
+ return qgarr14_.esp[i][0] * 1_GeV;
+ }
+ MomentumVector GetMomentum(const unsigned int i, const corsika::geometry::CoordinateSystem& CS) const {
+ using namespace corsika::units::si;
+ geometry::QuantityVector<hepmomentum_d> components = {qgarr14_.esp[i][2] * 1_GeV,
+ qgarr14_.esp[i][3] * 1_GeV,
+ qgarr14_.esp[i][1] * 1_GeV};
+ return MomentumVector(CS, components);
+ }
+
+ void Copy(const unsigned int i1, const unsigned int i2) {
+ qgarr14_.ich[i2] = qgarr14_.ich[i1];
+ for (unsigned int i = 0; i < 4; ++i) qgarr14_.esp[i2][i] = qgarr14_.esp[i1][i];
+ }
+
+ void Swap(const unsigned int i1, const unsigned int i2) {
+ std::swap(qgarr14_.ich[i1], qgarr14_.ich[i2]);
+ for (unsigned int i = 0; i < 4; ++i)
+ std::swap(qgarr14_.esp[i1][i], qgarr14_.esp[i2][i]);
+ }
+
+ void IncrementSize() { qgarr12_.nsp++; }
+ void DecrementSize() {
+ if (qgarr12_.nsp > 0) { qgarr12_.nsp--; }
+ }
+ };
+
+ template <typename StackIteratorInterface>
+ class ParticleInterface : public corsika::stack::ParticleBase<StackIteratorInterface> {
+
+ using corsika::stack::ParticleBase<StackIteratorInterface>::GetStackData;
+ using corsika::stack::ParticleBase<StackIteratorInterface>::GetIndex;
+
+ public:
+ void SetParticleData(const int vID,
+ const corsika::units::si::HEPEnergyType vE,
+ const MomentumVector& vP,
+ const corsika::units::si::HEPMassType vM) {
+ SetPID(vID);
+ SetEnergy(vE);
+ SetMomentum(vP);
+ }
+
+ void SetParticleData(ParticleInterface<StackIteratorInterface>& /*parent*/,
+ const int vID,
+ const corsika::units::si::HEPEnergyType vE,
+ const MomentumVector& vP,
+ const corsika::units::si::HEPMassType vM) {
+ SetPID(vID);
+ SetEnergy(vE);
+ SetMomentum(vP);
+ }
+
+ void SetEnergy(const corsika::units::si::HEPEnergyType v) {
+ GetStackData().SetEnergy(GetIndex(), v);
+ }
+
+ corsika::units::si::HEPEnergyType GetEnergy() const {
+ return GetStackData().GetEnergy(GetIndex());
+ }
+
+ void SetPID(const int v) { GetStackData().SetId(GetIndex(), v); }
+
+ corsika::process::qgsjetII::QgsjetIICode GetPID() const {
+ return static_cast<corsika::process::qgsjetII::QgsjetIICode>(
+ GetStackData().GetId(GetIndex()));
+ }
+
+ MomentumVector GetMomentum(const corsika::geometry::CoordinateSystem& CS) const { return GetStackData().GetMomentum(GetIndex(), CS); }
+
+ void SetMomentum(const MomentumVector& v) {
+ GetStackData().SetMomentum(GetIndex(), v);
+ }
+ };
+
+ typedef corsika::stack::Stack<QGSJetIIStackData, ParticleInterface> QGSJetIIStack;
+
+} // end namespace corsika::process::qgsjetII
+
+#endif
diff --git a/Processes/QGSJetII/code_generator.py b/Processes/QGSJetII/code_generator.py
new file mode 100755
index 0000000000000000000000000000000000000000..3b7113ec513e28fcb823fb1693cf83f6a6b6d545
--- /dev/null
+++ b/Processes/QGSJetII/code_generator.py
@@ -0,0 +1,116 @@
+#!/usr/bin/env python3
+
+# (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+#
+# See file AUTHORS for a list of contributors.
+#
+# This software is distributed under the terms of the GNU General Public
+# Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+# the license.
+
+
+import pickle, sys, itertools
+
+
+
+# loads the pickled particle_db (which is an OrderedDict)
+def load_particledb(filename):
+ with open(filename, "rb") as f:
+ particle_db = pickle.load(f)
+ return particle_db
+
+
+
+#
+def read_qgsjetII_codes(filename, particle_db):
+ with open(filename) as f:
+ for line in f:
+ line = line.strip()
+ if len(line)==0 or line[0] == '#':
+ continue
+ line = line.split('#')[0]
+ print (line)
+ identifier, model_code, xsType = line.split()
+ try:
+ particle_db[identifier]["qgsjetII_code"] = int(model_code)
+ particle_db[identifier]["qgsjetII_xsType"] = int(xsType)
+ except KeyError as e:
+ raise Exception("Identifier '{:s}' not found in particle_db".format(identifier))
+
+
+
+
+# generates the enum to access qgsjetII particles by readable names
+def generate_qgsjetII_enum(particle_db):
+ output = "enum class QgsjetIICode : int8_t {\n"
+ for identifier, pData in particle_db.items():
+ if pData.get('qgsjetII_code') != None:
+ output += " {:s} = {:d},\n".format(identifier, pData['qgsjetII_code'])
+ output += "};\n"
+ return output
+
+
+
+# generates the look-up table to convert corsika codes to qgsjetII codes
+def generate_corsika2qgsjetII(particle_db):
+ string = "std::array<QgsjetIICodeIntType, {:d}> constexpr corsika2qgsjetII = {{\n".format(len(particle_db))
+ for identifier, pData in particle_db.items():
+ modelCode = pData.get("qgsjetII_code", 0)
+ string += " {:d}, // {:s}\n".format(modelCode, identifier if modelCode else identifier + " (not implemented in QGSJETII)")
+ string += "};\n"
+ return string
+
+
+
+# generates the look-up table to convert corsika codes to qgsjetII codes
+def generate_corsika2qgsjetII_xsType(particle_db):
+ string = "std::array<int, {:d}> constexpr corsika2qgsjetIIXStype = {{\n".format(len(particle_db))
+ for identifier, pData in particle_db.items():
+ modelCodeXS = pData.get("qgsjetII_xsType", -1)
+ string += " {:d}, // {:s}\n".format(modelCodeXS, identifier if modelCodeXS else identifier + " (not implemented in QGSJETII)")
+ string += "};\n"
+ return string
+
+
+# generates the look-up table to convert qgsjetII codes to corsika codes
+def generate_qgsjetII2corsika(particle_db) :
+ minID = 0
+ for identifier, pData in particle_db.items() :
+ if 'qgsjetII_code' in pData:
+ minID = min(minID, pData['qgsjetII_code'])
+
+ string = "QgsjetIICodeIntType constexpr minQgsjetII = {:d};\n\n".format(minID)
+
+ pDict = {}
+ for identifier, pData in particle_db.items() :
+ if 'qgsjetII_code' in pData:
+ model_code = pData['qgsjetII_code'] - minID
+ pDict[model_code] = identifier
+
+ nPart = max(pDict.keys()) - min(pDict.keys()) + 1
+ string += "std::array<corsika::particles::Code, {:d}> constexpr qgsjetII2corsika = {{\n".format(nPart)
+
+ for iPart in range(nPart) :
+ identifier = pDict.get(iPart, "Unknown")
+ qgsID = iPart + minID
+ string += " corsika::particles::Code::{:s}, // {:d} \n".format(identifier, qgsID)
+
+ string += "};\n"
+ return string
+
+if __name__ == "__main__":
+ if len(sys.argv) != 3:
+ print("usage: {:s} <particle_db.pkl> <qgsjetII_codes.dat>".format(sys.argv[0]), file=sys.stderr)
+ sys.exit(1)
+
+ print("code_generator.py for QGSJETII")
+
+ particle_db = load_particledb(sys.argv[1])
+ read_qgsjetII_codes(sys.argv[2], particle_db)
+
+ with open("Generated.inc", "w") as f:
+ print("// this file is automatically generated\n// edit at your own risk!\n", file=f)
+ print(generate_qgsjetII_enum(particle_db), file=f)
+ print(generate_corsika2qgsjetII(particle_db), file=f)
+ print(generate_qgsjetII2corsika(particle_db), file=f)
+ print(generate_corsika2qgsjetII_xsType(particle_db), file=f)
diff --git a/Processes/QGSJetII/qgsjet-II-04-codes.dat b/Processes/QGSJetII/qgsjet-II-04-codes.dat
new file mode 100644
index 0000000000000000000000000000000000000000..df7e1f62306fc3585530b8f250edd2d13bba2523
--- /dev/null
+++ b/Processes/QGSJetII/qgsjet-II-04-codes.dat
@@ -0,0 +1,53 @@
+# input file for particle conversion to/from QGSJet
+# the format of this file is: "corsika-identifier" "qgsjet-id" "hadron-class for x-section"
+
+# class 0 (cannot interact)
+Electron 11 0
+Positron -11 0
+
+# class 1
+Pi0 0 1
+PiPlus 1 1
+PiMinus -1 1
+# in crmc: all particles from 100 to 999 ???
+Eta 10 1
+# Eta -10 1 there is no anti-eta
+Rho0 19 1
+
+# class 2
+#Nucleus 40 2
+Neutron 3 2
+AntiNeutron -3 2
+Proton 2 2
+AntiProton -2 2
+# in crmc: 1000 to 9999 ???
+Lambda0 6 2
+Lambda0Bar -6 2
+LambdaCPlus 9 2
+LambdaCMinusBar -9 2
+
+# class 3
+K0Long -5 3
+K0 5 3
+K0Bar -5 3
+K0Short 5 3
+# ambiguity between the K0/b and K0s/l
+KPlus 4 3
+KMinus -4 3
+
+# class 4
+D0 8 4
+D0Bar 8 4
+DPlus 7 4
+DMinus -7 4
+#DS+/- (340)
+#etac (440)
+#j/psi (441)
+#h_1c0
+#psi'
+#Xi_0c0
+#Xi_1c0
+#Xi_2c0
+
+
+
diff --git a/Processes/QGSJetII/qgsjet-II-04.cc b/Processes/QGSJetII/qgsjet-II-04.cc
new file mode 100644
index 0000000000000000000000000000000000000000..d7c307d39e0404cac894999665232de05e06bc24
--- /dev/null
+++ b/Processes/QGSJetII/qgsjet-II-04.cc
@@ -0,0 +1,39 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#include <corsika/process/qgsjetII/qgsjet-II-04.h>
+
+#include <corsika/random/RNGManager.h>
+
+#include <iostream>
+#include <random>
+
+datadir::datadir(const std::string& dir) {
+ if (dir.length() > 130) {
+ std::cerr << "QGSJetII error, will cut datadir \"" << dir
+ << "\" to 130 characters: " << std::endl;
+ }
+ int i = 0;
+ for (i = 0; i < std::min(130, int(dir.length())); ++i) data[i] = dir[i];
+ data[i + 0] = ' ';
+ data[i + 1] = '\0';
+}
+
+double qgran_(int&) {
+ static corsika::random::RNG& rng =
+ corsika::random::RNGManager::GetInstance().GetRandomStream("qgran");
+
+ std::uniform_real_distribution<double> dist;
+ return dist(rng);
+}
+
+void lzmaopenfile_(const char*, int) {}
+void lzmaclosefile_() {}
+void lzmafillarray_(const double&, const int&) {}
diff --git a/Processes/QGSJetII/qgsjet-II-04.f b/Processes/QGSJetII/qgsjet-II-04.f
new file mode 100644
index 0000000000000000000000000000000000000000..40b2a4ccbc8da8506f5a6bafec36f190bec9b7bb
--- /dev/null
+++ b/Processes/QGSJetII/qgsjet-II-04.f
@@ -0,0 +1,17733 @@
+C======================================================================C
+C C
+C QQQ GGG SSSS JJJJJJJ EEEEEEE TTTTTTT I I C
+C Q Q G G S S J E T I I C
+C Q Q G S J E T I I C
+C Q Q G GGG SSSS J EEEEE T == I I C
+C Q Q Q G G S J E T I I C
+C Q Q G G S S J J E T I I C
+C QQQQQ GGG SSSS JJJ EEEEEEE T I I C
+C C
+C C
+C----------------------------------------------------------------------C
+C C
+C QUARK - GLUON - STRING - JET - II MODEL C
+C C
+C HIGH ENERGY HADRON INTERACTION PROGRAM C
+C C
+C BY C
+C C
+C S. OSTAPCHENKO C
+C C
+C Institute for Physics, Norwegian University for Science & Tech C
+C D.V. Skobeltsyn Institute of Nuclear Physics, Moscow State UniversityC
+C e-mail: sergei@tf.phys.ntnu.no C
+C----------------------------------------------------------------------C
+C Publication to be cited when using this program: C
+C S. Ostapchenko, Phys. Rev. D 83 (2011) 014018 C
+C----------------------------------------------------------------------C
+C LIST OF MODIFICATIONS C
+C C
+C (Any modification of this program has to be approved by the author) C
+C C
+C 24.01.2005 - beta-version completed (qgsjet-II-01) C
+C 12.04.2005 - final version (qgsjet-II-02) C
+C 12.12.2005 - technical update - version II-03: C
+C improved treatment of Pomeron cuts (all "net" cuts included); C
+C improved treatment of nuclear config. (more consistent diffr.); C
+C "baryon junction" mechanism included (motivated by RHIC data); C
+C better parameter calibration, e.g. including RHIC data C
+C 21.02.2006 - some commons enlarged to avoid frequent rejects D.H. C
+C 26.04.2006 - reduce unnecessary looping in qgsha D.H. C
+C C
+C 01.10.2010 - new version (qgsjet-II-04, not released): C
+C treating all enhanced diagrams (incuding 'Pomeron loops'); C
+C calibration to LHC data on multiparticle production; C
+C a number of cosmetic improvements, C
+C e.g. more efficient simulation procedure (a factor of ~10 win) C
+C C
+C 26.06.2012 - final version (qgsjet-II-04): C
+C additional parameter retuning applied C
+C (mainly to TOTEM data on total/elastic pp cross sections); C
+C remnant treatment for pion-hadron/nucleus collisions improved C
+C C
+C 18.03.2013 - small corrections for A-p cross-section calculation C
+C 09.04.2013 - diffractive flag correction (no physics change) C
+C 30.09.2013 - small bug correction to avoid rare momentum inbalance C
+C (no physics change) C
+C C
+C last modification: 09.04.2013 C
+C Version qgsjet-II-04 (for CONEX) C
+C C
+C small corrections to adapt to CORSIKA : 25.07.2012 by T.Pierog C
+C=======================================================================
+
+
+
+c=============================================================================
+ subroutine qgset
+c-----------------------------------------------------------------------------
+c common model parameters setting
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ character*7 ty
+ character*2 tyq
+ parameter(iapmax=208)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr3/ rmin,emax,eev
+ common /qgarr6/ pi,bm,amws
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
+ common /qgarr11/ b10
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
+ common /qgarr28/ arr(5)
+ common /qgarr26/ factk,fqscal
+ common /qgarr41/ ty(6)
+ common /qgarr42/ tyq(16)
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /opt/ jopt
+ common /qgdebug/ debug
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+
+ moniou=6 !output channel for debugging
+ debug=0 !debugging level
+ !(0 - no debugging, 1 - very geheral,
+ !2 - more detailed, 3 - all function calls,
+ !4 - all returned values, 5 - technical)
+ if(debug.ge.1)write (moniou,210)
+
+ bqgs=0.d0 !used to link with nexus
+ bmaxqgs=0.d0 !used to link with nexus
+ bmaxnex=-1.d0 !used to link with nexus
+ bminnex=0.d0 !used to link with nexus
+
+ jopt=1 !parameter option
+
+ if(jopt.eq.1)then !tunable parameters
+c soft Pomeron parameters
+ dels=.165d0 !overcriticality
+ alfp=.135d0 !trajectory slope
+ sigs=1.01d0 !soft parton cross section
+c coupling to DGLAP
+ qt0=3.d0 !q**2 cutoff
+ betp=2.2d0 !gluon distribution hardness for soft Pomeron
+ dgqq=.16d0 !sea quark/gluon relative weight
+c multi-Pomeron vertex parameters
+ r3p=.0076d0 !triple-Pomeron coupling (/4/pi)
+ g3p=.35d0 !factor for multu-Pomeron couplings
+ sgap=exp(1.5d0) !minimal rap-gap between 3P-vertices
+c Pomeron-hadron coupling
+ rq(1,1)=1.d0 !pion: vertex slope for 1st diffr. eigenst.
+ rq(2,1)=.15d0 !pion: vertex slope for 2nd diffr. eigenst.
+ cd(1,1)=1.75d0 !pion: relat. strenth for 1st diffr. eigenst.
+ rq(1,2)=2.52d0 !proton: vertex slope for 1st diffr. eigenst.
+ rq(2,2)=.2d0 !proton: vertex slope for 2nd diffr. eigenst.
+ cd(1,2)=1.58d0 !proton: relat. strenth for 1st diffr. eigenst.
+ rq(1,3)=.75d0 !kaon: vertex slope for 1st diffr. eigenst.
+ rq(2,3)=.15d0 !kaon: vertex slope for 2nd diffr. eigenst.
+ cd(1,3)=1.75d0 !kaon: relat. strenth for 1st diffr. eigenst.
+
+c parameters for soft/hard fragmentation:
+
+ qtf=.15d0 !q**2 cutoff for timelike cascades
+ almpt=1.5d0 !string fragmentation parameter
+ wwm=1.d0 !switching to 2-particle string decay (threshold)
+c leading state exponents
+ ahl(1)=0.d0 !pion
+ ahl(2)=1.3d0 !proton
+ ahl(3)=-0.5 !kaon
+c remnant excitation probabilities
+ wex(1)=.5d0 !pion
+ wex(2)=.4d0 !proton
+ wex(3)=.5d0 !kaon
+c dc(i) - relative probabilities for qq~(qqq~q~)-pair creation from vacuum
+ dc(1)=.077d0 !udu~d~
+ dc(2)=.08d0 !ss~
+ dc(4)=.4d0 !ss~ (intrinsic)
+c be(i) - parameters for pt-distributions
+ be(1)=.225d0 !uu~(dd~)
+ be(2)=.43d0 !qqq~q~
+ be(3)=.48d0 !ss~
+ ptdif=.15d0 !diffractive momentum transfer
+ ptndi=.19d0 !non-diffractive momentum transfer
+
+c parameters for nuclear spectator part fragmentation:
+
+ rmin=3.35d0 !coupling radius squared (fm^2)
+ emax=.11d0 !relative critical energy ( / <E_ex>, <E_ex>~12.5 MeV )
+ eev=.25d0 !relative evaporation energy ( / <E_ex>, <E_ex>~12.5 MeV )
+
+ else
+ stop'wrong option!!!'
+ endif
+
+ do i=1,3 !relative strenth of 2nd diffr. eigenst. [2-CD(1,icz)]
+ cd(2,i)=2.d0-cd(1,i)
+ enddo
+
+!other parameters and constants:
+
+ spmax=1.d11 !max energy squared for tabulations
+ delh=0.25d0 !effective exponent for weighting (technical)
+ epsxmn=.01d0 !pt-resolution scale (technical)
+ alm=.04d0 !lambda_qcd squared
+ factk=1.5d0 !k-factor value
+ fqscal=4.d0 !factor for fact. scale (Mf^2=p_t^2/fqscal)
+ deta=.11111d0 !ratio of etas production to all pions (1/9)
+ dc(3)=.000d0 !to switch off charmed particles set to 0.000
+ dc(5)=.0d0 !to switch off charmed particles set to 0.000
+c weigts for diffractive eigenstates
+ cc(1,1)=.5d0 !pion
+ cc(2,1)=.5d0
+ cc(1,2)=.5d0 !proton
+ cc(2,2)=.5d0
+ cc(1,3)=.5d0 !kaon
+ cc(2,3)=.5d0
+c auxiliary constants
+ b10=.43876194d0 !initial value of the pseudorandom sequence
+ pi=3.1416d0 !pi-value
+ amws=.523d0 !diffusive radius for saxon-wood density
+c regge intercepts for the uu~, qqq~q~, us~, uc~ trajectories
+ arr(1)=0.5d0 !qq~-trajectory
+ arr(2)=-0.5d0 !qqq~q~-trajectory
+ arr(3)=0.d0 !us~-trajectory
+c lowest resonance masses for low-mass excitations
+ dmmin(1)=.76d0 !rho
+ dmmin(2)=1.23d0 !delta
+ dmmin(3)=.89d0 !K*
+c mass and width for resonance contribution to low mass diffraction
+ dmres(1)=1.23d0 !pion
+ dmres(2)=1.44d0 !proton
+ dmres(3)=1.27d0 !kaon
+ wdres(1)=.3d0 !pion
+ wdres(2)=.3d0 !proton
+ wdres(3)=.1d0 !kaon
+c proton, kaon, pion, d-meson, lambda, lambda_c, eta masses
+ amn=0.93827999
+ amk=.496d0
+ am0=.14d0
+ amc=1.868d0
+ amlam=1.116d0
+ amlamc=2.27d0
+ ameta=.548d0
+ ammu=.1057d0
+c initial particle classes
+ ty(1)='pion '
+ ty(2)='nucleon'
+ ty(3)='kaon '
+c parton types
+ tyq(1)='DD'
+ tyq(2)='UU'
+ tyq(3)='C '
+ tyq(4)='S '
+ tyq(5)='UD'
+ tyq(6)='D '
+ tyq(7)='U '
+ tyq(8)='g '
+ tyq(9)='u '
+ tyq(10)='d '
+ tyq(11)='ud'
+ tyq(12)='s '
+ tyq(13)='c '
+ tyq(14)='uu'
+ tyq(15)='dd'
+ if(debug.ge.2)write (moniou,202)
+
+210 format(2x,'qgset - common model parameters setting')
+202 format(2x,'qgset - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qgaini( DATDIR )
+c-----------------------------------------------------------------------------
+c common initialization procedure
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ CHARACTER DATDIR*(132)
+ real qggamfun
+ integer debug
+ character *7 ty
+ logical lcalc
+ parameter(iapmax=208)
+ dimension mij(40,40,4),nij(40,40,4),cs1(40,40,160)
+ *,evs(40,100,3,2),ixemax(40,3,2),gz0(5),gz1(3)
+ *,qfan0(11,14),qfan2(11,11,3),fann(14)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr10/ am(7),ammu
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr24/ qpomr(11,11,216,12,2)
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
+ *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
+ common /qgarr28/ arr(5)
+ common /qgarr29/ cstot(40,40,160)
+ common /qgarr30/ cs0(40,40,160)
+ common /qgarr31/ csborn(40,160)
+ common /qgarr33/ fsud(10,2)
+ common /qgarr34/ qrt(10,101,2)
+ common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
+ common /qgarr38/ qpomc(11,100,11,11,48)
+ common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
+ common /qgarr41/ ty(6)
+ common /qgarr43/ moniou
+ common /qgarr47/ gsect(10,5,6)
+ common /qgarr48/ qgsasect(10,6,6)
+ common /qgarr51/ epsxmn
+ common /qgarr52/ evk(40,40,100,3,2)
+c auxiliary common blocks to calculate hadron-nucleus cross-sections
+ common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
+ common /arr3/ x1(7),a1(7)
+ common /opt/ jopt
+ common /qgdebug/debug
+ character*500 fnIIdat,fnIIncs !used to link with nexus
+ common /version/ version !used to link with nexus
+ common/qgsIIfname/fnIIdat, fnIIncs, ifIIdat, ifIIncs !used to link with nexus
+ common/qgsIInfname/ nfnIIdat, nfnIIncs !used to link with nexus
+ common/producetab/ producetables !used to link with CRMC
+ logical producetables
+
+ if(debug.ge.1)write (moniou,210)
+ version = 204
+
+c-------------------------------------------------
+ write(*,100)
+ 100 format(' ',
+ * '====================================================',
+ * /,' ','| |',
+ * /,' ','| QUARK GLUON STRING JET -II MODEL |',
+ * /,' ','| |',
+ * /,' ','| HADRONIC INTERACTION MONTE CARLO |',
+ * /,' ','| BY |',
+ * /,' ','| S. OSTAPCHENKO |',
+ * /,' ','| |',
+ * /,' ','| e-mail: sergei@tf.phys.ntnu.no |',
+ * /,' ','| |',
+ * /,' ','| Version II-04 |',
+ * /,' ','| |',
+ * /,' ','| Publication to be cited when using this program: |',
+ * /,' ','| S.Ostapchenko, PRD 83 (2011) 014018 |',
+ * /,' ','| |',
+ * /,' ','| last modification: 09.04.2013 |',
+ * /,' ','| |',
+ * /,' ','| Any modification has to be approved by the author|',
+ * /,' ','====================================================',
+ * /)
+
+
+c-----------------------------------------------------------------------------
+c normalization of parton density in the soft pomeron
+ rr=qggamfun(real(2.d0+betp-dels))/qggamfun(real(1.d0-dels))
+ */qggamfun(real(1.d0+betp))/4.d0/pi
+
+ ahv(1)=.383d0+.624d0*dlog(dlog(qt0/.204d0**2)
+ */dlog(.26d0/.204d0**2))
+ ahv(3)=ahv(1)
+ sq=dlog(dlog(qt0/.232d0**2)/dlog(.23d0/.232d0**2))
+ ahv(2)=2.997d0+.753d0*sq-.076d0*sq*sq
+c valence quark momentum share
+ qnorm1=0.d0
+ do i=1,7
+ do m=1,2
+ tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
+ xp=1.d0-tp**(1.d0/(1.d0+ahv(1)))
+ qnorm1=qnorm1+a1(i)*(qggrv(xp,qt0,1,1)+qggrv(xp,qt0,1,2))
+ * /dsqrt(1.d0-tp)
+ enddo
+ enddo
+ qnorm1=qnorm1/(1.d0+ahv(1))/3.d0
+ qnorm2=0.d0
+ do i=1,7
+ do m=1,2
+ tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
+ xp=1.d0-tp**(1.d0/(1.d0+ahv(2)))
+ qnorm2=qnorm2+a1(i)*(qggrv(xp,qt0,2,1)+qggrv(xp,qt0,2,2))
+ * /dsqrt(1.d0-tp)
+ enddo
+ enddo
+ qnorm2=qnorm2/(1.d0+ahv(2))/3.d0
+c fp(i) - pomeron vertex constant (i=icz)
+ fp(2)=(1.d0-qnorm2)*(2.d0+ahl(2))*(1.d0+ahl(2))
+
+ gnorm=0.d0
+ seanrm=0.d0
+ do i=1,7
+ do m=1,2
+ xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
+ gnorm=gnorm+a1(i)*qgftld(xxg,2)
+ seanrm=seanrm+a1(i)*qgftle(xxg,2)
+ enddo
+ enddo
+ gnorm=gnorm/(1.d0-dels)*fp(2)*rr*2.d0*pi
+ seanrm=seanrm/(1.d0-dels)*fp(2)*rr*2.d0*pi
+ if(debug.ge.1)write (moniou,*)'rr,fp,norm,qnorm2,gnorm,seanrm'
+ *,rr,fp(2),qnorm2+gnorm+seanrm,qnorm2,gnorm,seanrm
+
+ do icz=1,3,2
+ fp(icz)=(1.d0-qnorm1)*(2.d0+ahl(icz))*(1.d0+ahl(icz))
+ gnorm=0.d0
+ seanrm=0.d0
+ do i=1,7
+ do m=1,2
+ xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
+ gnorm=gnorm+a1(i)*qgftld(xxg,icz)
+ seanrm=seanrm+a1(i)*qgftle(xxg,icz)
+ enddo
+ enddo
+ gnorm=gnorm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
+ seanrm=seanrm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
+
+ if(debug.ge.1)write (moniou,*)'fp,norm,qnorm1,gnorm,seanrm'
+ * ,fp(icz),qnorm1+gnorm+seanrm,qnorm1,gnorm,seanrm
+ enddo
+
+ do icz=1,3
+ gsoft(icz)=fp(icz)*fp(2)*sigs*4.d0*.0389d0
+ * *qggamfun(real(1.d0+dels))**2*qggamfun(real(1.d0+ahl(icz)))
+ * *qggamfun(real(1.d0+ahl(2)))/qggamfun(real(2.d0+dels+ahl(icz)))
+ * /qggamfun(real(2.d0+dels+ahl(2)))
+ enddo
+
+c-----------------------------------------------------------------------------
+c reading cross sections from the file
+ if(ifIIdat.ne.1)then
+ inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
+ * ,exist=lcalc)
+ else
+ inquire(file=fnIIdat(1:nfnIIdat),exist=lcalc) !used to link with nexus
+ endif
+ lzmaUse=0
+ if(lcalc)then
+ if(ifIIdat.ne.1)then
+ open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
+ * ,status='old')
+ else !used to link with nexus
+ if (LEN(fnIIdat).gt.6.and.
+ * fnIIdat(nfnIIdat-4:nfnIIdat) .eq. ".lzma") then
+ lzmaUse=1
+ call LzmaOpenFile(fnIIdat(1:nfnIIdat))
+ else
+ open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='old')
+ endif
+ endif
+
+ if (lzmaUse.ne.0) then
+
+ if(debug.ge.0)write (moniou,214) 'qgsdat-II-04.lzma'
+
+ call LzmaFillArray(csborn,size(csborn))
+ call LzmaFillArray(cs0,size(cs0))
+ call LzmaFillArray(cstot,size(cstot))
+ call LzmaFillArray(evk,size(evk))
+ call LzmaFillArray(qpomi,size(qpomi))
+ call LzmaFillArray(qpomis,size(qpomis))
+ call LzmaFillArray(qlegi,size(qlegi))
+ call LzmaFillArray(qfanu,size(qfanu))
+ call LzmaFillArray(qfanc,size(qfanc))
+ call LzmaFillArray(qdfan,size(qdfan))
+ call LzmaFillArray(qpomr,size(qpomr))
+ call LzmaFillArray(gsect,size(gsect))
+ call LzmaFillArray(qlegc0,size(qlegc0))
+ call LzmaFillArray(qlegc,size(qlegc))
+ call LzmaFillArray(qpomc,size(qpomc))
+ call LzmaFillArray(fsud,size(fsud))
+ call LzmaFillArray(qrt,size(qrt))
+ call LzmaFillArray(qrev,size(qrev))
+ call LzmaFillArray(fsud,size(fsud))
+ call LzmaFillArray(qrt,size(qrt))
+ call LzmaCloseFile()
+ else
+ if(debug.ge.0)write (moniou,214) 'qgsdat-II-04'
+ read (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
+ * ,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,
+ * qrt
+ close(1)
+ endif
+
+ if(debug.ge.0)write (moniou,*)'done'
+ goto 10
+ elseif(.not.producetables)then
+ write(moniou,*) "Missing QGSDAT-II-04 file !"
+ write(moniou,*) "Please correct the defined path ",
+ &"or force production ..."
+ stop
+ endif
+
+c--------------------------------------------------
+c qcd evolution and qcd ladder cross sections
+c--------------------------------------------------
+ if(debug.ge.0)write (moniou,201)
+ do i=1,40
+ do m=1,3
+ do k=1,2
+ ixemax(i,m,k)=99
+ do j=1,40
+ do l=1,100
+ evk(i,j,l,m,k)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ n=1
+1 n=n+1
+ do m=1,3
+ do k=1,2
+ if(m.ne.3.or.k.ne.1)then
+ do i=1,39
+ if(ixemax(i,m,k).gt.0)then
+ qi=spmax**((i-1)/39.d0)
+ qq=qi*(spmax/qi)**(1.d0/39.d0)
+ do l=1,99
+ if(l.le.37)then
+ xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
+ elseif(l.le.69)then
+ xx=.1d0+.8d0*(l-37.d0)/32.d0
+ else
+ xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
+ endif
+
+ ev=qgev(qi,qq,qq,xx,m,k)/qgfap(xx,m,k)
+ if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
+ evs(i,l,m,k)=dlog(1.d0+ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
+ * /dlog(dlog(qq/alm)/dlog(qi/alm)))
+ else
+ evs(i,l,m,k)=dlog(1.d0+ev/.3d0*(dlog(epsxmn)+.75d0)
+ * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+
+ jec=0
+ do m=1,3
+ do k=1,2
+ if(m.ne.3.or.k.ne.1)then
+ do i=1,39
+ if(ixemax(i,m,k).gt.0)then
+ qi=spmax**((i-1)/39.d0)
+ qq=qi*(spmax/qi)**(1.d0/39.d0)
+ imx=ixemax(i,m,k)
+ do l=imx,1,-1
+ if(l.le.37)then
+ xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
+ elseif(l.le.69)then
+ xx=.1d0+.8d0*(l-37.d0)/32.d0
+ else
+ xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
+ endif
+
+ if(abs(evs(i,l,m,k)-evk(i,2,l,m,k)).gt.1.d-3)then
+ evk(i,2,l,m,k)=evs(i,l,m,k)
+ jec=1
+ elseif(ixemax(i,m,k).eq.l)then
+ ixemax(i,m,k)=l-1
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+
+ do i=1,39
+ qi=spmax**((i-1)/39.d0)
+ qj=qi*(spmax/qi)**(1.d0/39.d0)
+ qq=qi*(spmax/qi)**(2.d0/39.d0)
+ do l=99,1,-1
+ if(l.le.37)then
+ xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
+ elseif(l.le.69)then
+ xx=.1d0+.8d0*(l-37.d0)/32.d0
+ else
+ xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
+ endif
+ do m=1,3
+ do k=1,2
+ if(m.ne.3.or.k.ne.1)then
+ ev=(qgev(qi,qj,qq,xx,m,k)
+ * +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
+ * +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
+ if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
+ evk(i,3,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
+ * /dlog(dlog(qq/alm)/dlog(qi/alm)))
+ else
+ evk(i,3,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
+ * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ if(jec.ne.0)goto 1
+
+ do i=1,39
+ qi=spmax**((i-1)/39.d0)
+ do j=4,40
+ qj=qi*(spmax/qi)**((j-2)/39.d0)
+ qq=qi*(spmax/qi)**((j-1)/39.d0)
+ do l=99,1,-1
+ if(l.le.37)then
+ xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
+ elseif(l.le.69)then
+ xx=.1d0+.8d0*(l-37.d0)/32.d0
+ else
+ xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
+ endif
+ do m=1,3
+ do k=1,2
+ if(m.ne.3.or.k.ne.1)then
+ ev=(qgev(qi,qj,qq,xx,m,k)
+ * +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
+ * +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
+ if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
+ evk(i,j,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
+ * /dlog(dlog(qq/alm)/dlog(qi/alm)))
+ else
+ evk(i,j,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
+ * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+c--------------------------------------------------
+c qcd ladder cross sections
+ do i=1,40
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0) !q^2 cutoff for born process
+ s2min=qi*4.d0*fqscal !energy threshold for 2->2 subprocess
+ do m=1,2 !parton types (1-g, 2-q)
+ do l=1,2 !parton types (1-g, 2-q)
+ l1=2*l-1
+ do k=1,40
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0) !c.m. energy squared
+ k1=k+40*(m-1)+80*(l-1)
+ csborn(i,k1)=dlog(qgborn(qi,qi,sk,m-1,l1-1)) !born cross-section (2->2)
+ if(.not.(csborn(i,k1).ge.0.d0.or.csborn(i,k1).lt.0.d0))stop
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do i=1,40
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
+ do j=1,40
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
+ s2min=qj*4.d0*fqscal
+ smin=s2min/(1.d0-epsxmn)
+ do m=1,2
+ do l=1,2
+ l1=2*l-1
+ ml=m+2*l-2
+ do k=1,40
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ k1=k+40*(m-1)+80*(l-1)
+
+ tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
+ sjtot=qgjett(qi,qj,sk,m-1,l-1)
+ sjord1=qgjeto(qi,qj,sk,m-1,l-1)
+ sjord2=qgjeto(qj,qi,sk,l-1,m-1)
+ born=qgborn(qi,qj,sk,m-1,l1-1)
+ if(k.eq.1.or.j.eq.40.or.i.eq.40.or.sk.le.smin)then
+ cstot(i,j,k1)=dlog(born)
+ cs0(i,j,k1)=cstot(i,j,k1)
+ else
+ cstot(i,j,k1)=dlog(born+(sjtot+sjord1+sjord2)
+ * /(1.d0/tmin-2.d0/sk))
+ cs0(i,j,k1)=dlog(born+sjord1/(1.d0/tmin-2.d0/sk))
+ endif
+ if(.not.(cstot(i,j,k1).ge.0.d0.or.cstot(i,j,k1).lt.0.d0))stop
+ if(.not.(cs0(i,j,k1).ge.0.d0.or.cs0(i,j,k1).lt.0.d0))stop
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ goto 3
+
+c--------------------------------------------------
+c alternative calculation (not used)
+ do i=1,40
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
+ do j=1,40
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
+ s2min=qj*4.d0*fqscal
+ do m=1,2
+ do l=1,2
+ l1=2*l-1
+ ml=m+2*l-2
+ do k=1,40
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ k1=k+40*(m-1)+80*(l-1)
+ cstot(i,j,k1)=dlog(qgborn(qi,qj,sk,m-1,l1-1))
+ cs0(i,j,k1)=cstot(i,j,k1)
+ mij(i,j,ml)=2
+ nij(i,j,ml)=2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ n=2 !number of ladder rungs considered
+2 if(debug.ge.1)write (moniou,202)n,mij(1,1,1),nij(1,1,1)
+ do i=1,39
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0) !q^2 for upper parton
+ do j=1,39
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0) !q^2 for downer parton
+ s2min=qj*4.d0*fqscal !energy threshold for 2->2 subprocess
+ smin=s2min/(1.d0-epsxmn) !energy threshold for 2->3 subprocess
+ do m=1,2 !parton types (1-g, 2-q)
+ do l=1,2 !parton types (1-g, 2-q)
+ l1=2*l-1
+ ml=m+2*l-2
+ kmin=nij(i,j,ml) !lowest energy bin for another rung
+ if(kmin.le.40)then
+ do k=kmin,40
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ if(sk.le.smin)then
+ nij(i,j,ml)=nij(i,j,ml)+1
+ else
+ k1=k+40*(m-1)+80*(l-1)
+ tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
+ cs1(i,j,k1)=dlog(qgjet1(qi,qj,sk,s2min,m,l)
+ * /(1.d0/tmin-2.d0/sk)+qgborn(qi,qj,sk,m-1,l1-1))
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do i=1,39
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
+ do j=1,39
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
+ s2min=qj*4.d0*fqscal
+ do m=1,2
+ do l=1,2
+ ml=m+2*l-2
+ kmin=nij(i,j,ml)
+ if(kmin.le.40)then
+ do k=40,kmin,-1
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
+ k1=k+40*(m-1)+80*(l-1)
+ if(abs(cs1(i,j,k1)-cs0(i,j,k1)).gt.1.d-2)then
+ cs0(i,j,k1)=cs1(i,j,k1)
+ elseif(k.eq.nij(i,j,ml))then
+ nij(i,j,ml)=nij(i,j,ml)+1
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do i=1,39
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
+ do j=1,39
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
+ s2min=qj*4.d0*fqscal !min energy squared for 2->2 subprocess
+ smin=s2min/(1.d0-epsxmn) !min energy squared for 2->3 subprocess
+ do m=1,2
+ do l=1,2
+ ml=m+2*l-2
+ kmin=mij(i,j,ml) !min energy bin for more ladder rungs
+ if(kmin.le.40)then
+ do k=kmin,40
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ if(sk.le.smin)then
+ mij(i,j,ml)=mij(i,j,ml)+1
+ else
+ k1=k+40*(m-1)+80*(l-1)
+ tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
+ cs1(i,j,k1)=dlog((qgjet(qi,qj,sk,s2min,m,l)
+ * +qgjit1(qj,qi,sk,l,m))/(1.d0/tmin-2.d0/sk))
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+c--------------------------------------------------
+c check convergence
+ do i=1,39
+ qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
+ do j=1,39
+ qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
+ s2min=qj*4.d0*fqscal
+ do m=1,2
+ do l=1,2
+ ml=m+2*l-2
+ kmin=mij(i,j,ml) !min energy bin for more ladder rungs
+ if(kmin.le.40)then
+ do k=40,kmin,-1
+ sk=s2min*(spmax/s2min)**((k-1)/39.d0)
+ tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
+ k1=k+40*(m-1)+80*(l-1)
+ if(abs(cs1(i,j,k1)-cstot(i,j,k1)).gt.1.d-2)then
+ cstot(i,j,k1)=cs1(i,j,k1)
+ elseif(k.eq.mij(i,j,ml))then
+ mij(i,j,ml)=mij(i,j,ml)+1
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ n=n+1 !one more rung
+ do i=1,39
+ do j=1,39
+ do l=1,4
+ if(mij(i,j,l).le.40.or.nij(i,j,l).le.40)goto 2
+ enddo
+ enddo
+ enddo
+
+3 if(debug.ge.2)write (moniou,205)
+c-------------------------------------------------
+c itermediate Pomeron
+ if(debug.ge.1)write (moniou,210)
+ s2min=4.d0*fqscal*qt0
+ do iy=1,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=alfp*log(sy)*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+
+ qpomi(iy,iz,1)=dlog(qgpint(sy,b*b)
+ * /sy**dels/sigs/z*rp/4.d0/.0389d0+1.d0)
+ enddo
+ enddo
+
+c-------------------------------------------------
+c loop contribution
+ do iy=1,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=alfp*log(sy)*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ do iqq=2,4
+ qpomi(iy,iz,iqq)=qpomi(iy,iz,1)
+ enddo
+ enddo
+ enddo
+
+ do iy=2,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=alfp*log(sy)*4.d0*.0389d0
+ do iz=1,11
+ do iqq=2,4
+ qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
+ enddo
+ enddo
+ n=0
+4 n=n+1
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ call qgloop(sy,b*b,fann,1)
+ do iqq=1,3
+ if(fann(iqq).gt.0.d0)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
+ * /4.d0/.0389d0)
+ elseif(iy.gt.2)then
+ qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
+ * -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
+ else
+ stop'loop<0: iy=2'
+ endif
+ if(qfan0(iz,iqq).lt.-20.d0)then
+ qfan0(iz,iqq)=-20.d0
+ endif
+ if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
+ enddo
+ enddo
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ do iqq=2,4
+ qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
+ if(.not.(qpomi(iy,iz,iqq).le.0.d0
+ * .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpom-nan'
+ enddo
+ enddo
+ if(nrep.eq.1.and.n.lt.100)goto 4
+ enddo
+
+c-------------------------------------------------
+c cut loops
+ do iy=1,51
+ do iz=1,11
+ do iqq=5,7
+ qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-3)
+ enddo
+ qpomi(iy,iz,8)=qpomi(iy,iz,2)
+ do iqq=9,10
+ qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-7)
+ qpomi(iy,iz,iqq+2)=qpomi(iy,iz,iqq-7)
+ enddo
+ do iqq=13,15
+ qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-11)
+ enddo
+ enddo
+ enddo
+
+ do iy=2,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=alfp*log(sy)*4.d0*.0389d0
+ do iz=1,11
+ do iqq=5,15
+ qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
+ enddo
+ enddo
+ n=0
+5 n=n+1
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ call qgloop(sy,b*b,fann,2)
+ do iqq=4,14
+ if(fann(iqq).gt.0.d0)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
+ * /4.d0/.0389d0)
+ elseif(iy.gt.2)then
+ qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
+ * -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
+ else
+ stop'loop<0: iy=2'
+ endif
+ if(qfan0(iz,iqq).lt.-20.d0)then
+ qfan0(iz,iqq)=-20.d0
+ endif
+ if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
+ enddo
+ enddo
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ do iqq=5,15
+ qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
+ if(.not.(qpomi(iy,iz,iqq).le.0.d0
+ * .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpomi-nan'
+ enddo
+ enddo
+ if(nrep.eq.1.and.n.lt.50)goto 5
+ enddo
+
+c-------------------------------------------------
+c cut loops with proj/targ screening corrections
+ do iv=1,11
+ vvx=dble(iv-1)/10.d0
+ do iv1=1,11
+ vvxt=dble(iv1-1)/10.d0
+
+ do iz=1,11
+ do iqq=1,8
+ qpomis(1,iz,iv,iv1,iqq)=0.d0
+ enddo
+ qpomis(1,iz,iv,iv1,1)=qpomi(1,iz,1)
+ qpomis(1,iz,iv,iv1,4)=qpomi(1,iz,1)
+ enddo
+
+ do iy=2,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=alfp*log(sy)*4.d0*.0389d0
+ do iz=1,11
+ do iqq=1,8
+ qpomis(iy,iz,iv,iv1,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
+ enddo
+ enddo
+
+ n=0
+6 n=n+1
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ call qgloos(sy,b*b,vvx,vvxt,fann)
+ vi=qgpini(sy,b*b,0.d0,0.d0,2)
+ vic=min(vi,qgpini(sy,b*b,0.d0,0.d0,8))
+ vicng=min(vic,qgpini(sy,b*b,0.d0,0.d0,11))
+ do iqq=1,8
+ if(fann(iqq).gt.0.d0)then
+ if(iqq.eq.1.or.iqq.eq.4)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
+ * /4.d0/.0389d0)
+ elseif(iqq.eq.3)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/(.5d0*max(0.d0,1.d0
+ * -exp(-2.d0*vic)*(1.d0+2.d0*vic))+vicng*exp(-2.d0*vic)))
+ elseif(iqq.gt.6)then
+ qfan0(iz,iqq)=dlog(fann(iqq)*2.d0/((1.d0-exp(-vi))**2
+ * +(exp(2.d0*(vi-vic))-1.d0)*exp(-2.d0*vi)))
+ else
+ qfan0(iz,iqq)=dlog(fann(iqq)/(1.d0-exp(-vi)))
+ endif
+ elseif(iy.gt.2)then
+ qfan0(iz,iqq)=min(2.d0*qpomis(iy-1,iz,iv,iv1,iqq)
+ * -qpomis(iy-2,iz,iv,iv1,iqq),qpomis(iy-1,iz,iv,iv1,iqq))
+ else
+ qfan0(iz,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
+ endif
+ if(iqq.gt.5)qfan0(iz,iqq)=min(qfan0(iz,iqq),qfan0(iz,iqq-1))
+ qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
+ if(abs(qfan0(iz,iqq)-qpomis(iy,iz,iv,iv1,iqq)).gt.1.d-3)
+ * nrep=1
+ enddo
+ enddo
+
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ do iqq=1,8
+ qpomis(iy,iz,iv,iv1,iqq)=qfan0(iz,iqq)
+ if(iqq.eq.1.or.iqq.eq.4)then
+ dpx=exp(qpomis(iy,iz,iv,iv1,iqq))*g3p**2*sigs
+ * *sy**dels*z/rp*4.d0*.0389d0
+ else
+ dpx=exp(qpomis(iy,iz,iv,iv1,iqq))
+ endif
+ enddo
+ enddo
+ if(nrep.eq.1.and.n.lt.50)goto 6
+ enddo
+ enddo
+ enddo
+
+c-------------------------------------------------
+c integrated Pomeron leg eikonals
+ if(debug.ge.1)write (moniou,212)
+ do icz=1,3
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+
+ qxl=qgleg(sy,b*b,icdp,icz)
+ qlegi(iy,iz,icdp,icz,1)=log(qxl/z)
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c-------------------------------------------------
+c loop-legs
+ do icz=1,3
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+ if(iy.eq.1)then
+ do iqq=2,7
+ qlegi(iy,iz,icdp,icz,iqq)=qlegi(iy,iz,icdp,icz,1)
+ enddo
+ else
+ call qglool(sy,b*b,icdp,icz,fann)
+ do iqq=2,7
+ if(fann(iqq-1).gt.0.d0)then
+ qlegi(iy,iz,icdp,icz,iqq)=log(fann(iqq-1)/z)
+ else
+ qlegi(iy,iz,icdp,icz,iqq)=2.d0*qlegi(iy-1,iz,icdp,icz,iqq)
+ * -qlegi(iy-2,iz,icdp,icz,iqq)
+ endif
+ qlegi(iy,iz,icdp,icz,iqq)=max(qlegi(iy,iz,icdp,icz,iqq)
+ * ,-20.d0)
+ if(.not.(qlegi(iy,iz,icdp,icz,iqq).le.0.d0
+ * .or.qlegi(iy,iz,icdp,icz,iqq).gt.0.d0))stop'leg-nan'
+ enddo
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c-------------------------------------------------
+c uncut fan-contributions
+ if(debug.ge.1)write (moniou,213)
+ do icz=1,3
+ do iv=1,11
+ vvx=dble(iv-1)/10.d0
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,51
+ do iz=1,11
+ do iqq=1,2
+ qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qlegi(iy,iz,icdp,icz,iqq+1)
+ enddo
+ enddo
+ enddo
+
+ do iy=2,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
+ do iz=1,11
+ do iqq=1,2
+ qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)
+ * =qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
+ enddo
+ enddo
+
+ n=1
+7 n=n+1
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ call qgfan(sy,b*b,vvx,icdp,icz,fann)
+ do iqq=1,2
+ if(fann(iqq).gt.0.d0)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/z)
+ else
+ qfan0(iz,iqq)=min(qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
+ * ,2.d0*qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
+ * -qfanu(iy-2,iz,iv,icdp+2*(icz-1),iqq))
+ endif
+ qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
+ if(abs(qfan0(iz,iqq)-qfanu(iy,iz,iv,icdp+2*(icz-1),iqq))
+ * .gt.1.d-3)nrep=1
+ enddo
+ enddo
+
+ do iz=1,11
+ do iqq=1,2
+ qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qfan0(iz,iqq)
+ enddo
+ enddo
+ if(nrep.eq.1)goto 7
+
+ do iz=1,11
+ do iqq=1,2
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ if(.not.(qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).le.0.d0
+ * .or.qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).gt.0.d0))stop'fan-nn'
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+
+c-------------------------------------------------
+c cut fan contributions
+ if(debug.ge.1)write (moniou,215)
+ do icz=1,3 !hadron class
+ do icdp=1,2 !diffractive eigenstate
+ if(cd(icdp,icz).ne.0.d0)then
+c vvx,vvxp,vvxpl - screening corrections from targ. and nuclear proj. fans
+ do iv=1,11
+ vvx=dble(iv-1)/10.d0
+ do iv1=1,1+5*(icz-1)*(3-icz)
+ vvxp=dble(iv1-1)/5.d0
+ do iv2=1,1+5*(icz-1)*(3-icz)
+ vvxpl=vvx*dble(iv2-1)/5.d0
+ do iy=1,51 !initialization
+ do iz=1,11
+ do iqq=1,9
+ qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
+ * +2*(iqq-1))=qfanu(iy,iz,iv,icdp+2*(icz-1),1)
+ enddo
+ enddo
+ enddo
+
+ do iy=2,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
+ do iz=1,11
+ do iqq=1,9
+ qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
+ * +2*(iqq-1))=qfanc(iy-1,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1
+ * +6*(iv2-1)),icdp+2*(iqq-1))
+ enddo
+ enddo
+
+ n=1
+8 n=n+1 !number of t-channel iterations
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ call qgfanc(sy,b*b,vvx,vvxp,vvxpl,icdp,icz,fann)
+ fann(7)=min(fann(7),fann(8))
+ do iqq=1,9
+ if(fann(iqq).gt.0.d0)then
+ qfan0(iz,iqq)=dlog(fann(iqq)/z)
+ else
+ qfan0(iz,iqq)=min(2.d0*qfanc(iy-1,iz,iv,icz
+ * +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))
+ * -qfanc(iy-2,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
+ * ,icdp+2*(iqq-1)),qfanc(iy-1,iz,iv,icz
+ * +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)))
+ endif
+ qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
+ enddo
+ enddo
+
+ do iz=1,11
+ do iqq=1,9
+ if(abs(qfan0(iz,iqq)-qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)
+ * *(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))).gt.1.d-3)nrep=1
+ qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
+ * ,icdp+2*(iqq-1))=qfan0(iz,iqq)
+ enddo
+ enddo
+ if(nrep.eq.1.and.n.lt.50)goto 8
+
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ do iqq=1,9
+ if(.not.(qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
+ * ,icdp+2*(iqq-1)).le.0.d0.or.qfanc(iy,iz,iv,icz+(icz-1)
+ * *(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)).gt.0.d0))
+ * stop'fanc-nan'
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c-------------------------------------------------
+c zigzag fans
+ do icz=1,3 !hadron class
+ do icdp=1,2 !diffractive eigenstate
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,11
+ sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
+ rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ bb=-dlog(z)*rp
+ else
+ bb=-rp*(dlog(0.2d0)+2.d0*dble(iz-7))
+ z=dexp(-bb/rp)
+ endif
+ do iv=1,11
+ vvxt0=dble(iv-1)/10.d0
+ do iv1=1,6
+ vvxt=vvxt0+(1.d0-vvxt0)*dble(iv1-1)/5.d0
+ do iv2=1,1+5*(icz-1)*(3-icz)
+ vvxpt=dble(iv2-1)/5.d0
+ do iv3=1,1+5*(icz-1)*(3-icz)
+ vvxp0=vvxpt*dble(iv3-1)/5.d0
+ do iv4=1,1+5*(icz-1)*(3-icz)
+ vvxpl=dble(iv4-1)/5.d0
+
+ dfan=qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0,vvxpl,icdp,icz)
+ if(dfan.gt.0.d0)then
+ qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
+ * *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)=dlog(dfan/z)
+ else
+ qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
+ * +6*(iv3-1)+36*(iv4-1)),icdp)=2.d0*qrev(iy-1,iz,iv+11*(iv1-1)
+ * ,icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)
+ * -qrev(iy-2,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
+ * +6*(iv3-1)+36*(iv4-1)),icdp)
+ endif
+ qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
+ * +36*(iv4-1)),icdp)=max(qrev(iy,iz,iv+11*(iv1-1),icz
+ * +(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp),-20.d0)
+
+ if(.not.(qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
+ * *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp).le.0.d0.or.qrev(iy,iz
+ * ,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
+ * +36*(iv4-1)),icdp).gt.0.d0))stop'fanc-nan'
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c-------------------------------------------------
+c diffractive fans
+ icz=2
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,21
+ xpomr=(1.d5/sgap**2)**(-dble(iy-1)/20.d0)/sgap**2
+ rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
+ if(iy.gt.1)then
+ do iy1=1,11
+ do iz=1,11
+ do iqq=1,3
+ qdfan(iy,iy1,iz,icdp,iqq)=qdfan(iy-1,iy1,iz,icdp,iqq)
+ enddo
+ enddo
+ enddo
+ endif
+
+ n=0
+9 n=n+1
+ nrep=0
+ do iy1=1,11
+ xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ call qgdfan(xpomr,xpomr1,b*b,icdp,fann,n)
+ do iqq=1,3
+ if(fann(iqq).gt.0.d0)then
+ qfan2(iy1,iz,iqq)=dlog(fann(iqq)/z)
+ else
+ qfan2(iy1,iz,iqq)=qfan2(iy1-1,iz,iqq)
+ endif
+ if(n.gt.1.and.abs(qfan2(iy1,iz,iqq)
+ * -qdfan(iy,iy1,iz,icdp,iqq)).gt.1.d-3)nrep=1
+ enddo
+ enddo
+ enddo
+
+ do iy1=1,11
+ do iz=1,11
+ do iqq=1,3
+ qdfan(iy,iy1,iz,icdp,iqq)=qfan2(iy1,iz,iqq)
+ enddo
+ enddo
+ enddo
+ if((n.eq.1.or.nrep.eq.1).and.iy.gt.1)goto 9
+
+ do iy1=1,11
+ xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*dble(iz-6)
+ b=dsqrt(-dlog(z)*rp)
+ else
+ b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
+ z=dexp(-b*b/rp)
+ endif
+ do iqq=1,3
+ if(iqq.ne.3)then
+ dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
+ else
+ dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
+ * *dlog(xpomr1/xpomr/sgap)
+ endif
+ if(.not.(qdfan(iy,iy1,iz,icdp,iqq).le.0.d0
+ * .or.qdfan(iy,iy1,iz,icdp,iqq).gt.0.d0))stop'qdfan-nan'
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+c-------------------------------------------------
+c integrated Pomeron eikonals
+ do icz=1,3
+ do icdp=1,2
+ do icdt=1,2
+ if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
+ do iy=1,11
+ e0n=10.d0**iy
+ sy=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
+ rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ b=sqrt(-log(z)*rp)
+ else
+ b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
+ z=exp(-b*b/rp)
+ endif
+
+ vsoft=gsoft(icz)*sy**dels/rp*cd(icdp,icz)*cd(icdt,2)
+ vgg=qgfsh(sy,b*b,icdp,icdt,icz,0)
+ vqg=qgfsh(sy,b*b,icdp,icdt,icz,1)
+ vgq=qgfsh(sy,b*b,icdp,icdt,icz,2)
+ vqq=qghard(sy,b*b,icdp,icdt,icz)
+
+ qxp=vsoft*z+vgg+vqg+vgq+vqq
+ do iv=1,6
+ vvx=(iv-1)/5.d0
+ do iv1=1,1+5*(icz-1)*(3-icz)
+ vvxp=(iv1-1)/5.d0
+ do iv2=1,6
+ vvxt=(iv2-1)/5.d0
+
+ v3p=qg3pom(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
+ v1p=qgpcut(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
+ qxp1=qxp+v3p
+ qxpc=qxp+v1p
+ if(qxp1.gt.0.d0)then
+ qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
+ * ,icdp+2*(icdt-1)+4*(icz-1),1)=log(qxp1/z)
+ else
+ qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
+ * +4*(icz-1),1)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
+ * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)-qpomr(iy-2,iz
+ * ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)
+ * ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
+ * ,icdp+2*(icdt-1)+4*(icz-1),1))
+ endif
+ if(qxpc.gt.0.d0)then
+ qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
+ * ,icdp+2*(icdt-1)+4*(icz-1),2)=log(qxpc/z)
+ else
+ qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
+ * +4*(icz-1),2)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
+ * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)-qpomr(iy-2,iz
+ * ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)
+ * ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
+ * ,icdp+2*(icdt-1)+4*(icz-1),2))
+ endif
+
+ do iqq=1,2
+ qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
+ * +4*(icz-1),iqq)=max(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
+ * ,icdp+2*(icdt-1)+4*(icz-1),iqq),-20.d0)
+
+ if(.not.(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
+ * +4*(icz-1),iqq).le.0.d0.or.qpomr(iy,iz,iv+6*(iv1-1)
+ * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),iqq).gt.0.d0))
+ * stop'qpomr-nan'
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+
+c-------------------------------------------------
+c interaction cross sections
+ ia(1)=1
+ do iy=1,10
+ e0n=10.d0**iy !interaction energy
+ scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
+
+ do iiz=1,3
+ icz=iiz !hadron class
+ rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0 !slope (in fm^2)
+ g0=pi*rp*10.d0 !factor for cross-sections (in mb)
+
+ do iia=1,6
+ if(iia.le.4)then
+ ia(2)=4**(iia-1) !target mass number
+ elseif(iia.eq.5)then
+ ia(2)=14
+ else
+ ia(2)=40
+ endif
+ if(debug.ge.1)write (moniou,206)e0n,ty(icz),ia(2)
+c-------------------------------------------------
+c nuclear densities
+ if(ia(2).lt.10)then !light nuclei - gaussian
+ rnuc(2)=.9d0*float(ia(2))**.3333 !nuclear radius
+ wsnuc(2)=amws !not used
+ wbnuc(2)=0.d0 !not used
+ elseif(ia(2).le.56)then !3-parameter Fermi
+ rnuc(2)=trnuc(ia(2)) !nuclear radius
+ wsnuc(2)=twsnuc(ia(2)) !diffuseness
+ wbnuc(2)=twbnuc(ia(2)) !'wine-bottle' parameter
+ else !2-parameter Fermi
+c rnuc - wood-saxon density radius (fit to the data of murthy et al.)
+ rnuc(2)=1.19d0*dble(ia(2))**(1.d0/3.d0)
+ * -1.38d0*dble(ia(2))**(-1.d0/3.d0) !nuclear radius
+ wsnuc(2)=amws !diffuseness
+ wbnuc(2)=0.d0 !not used
+ endif
+
+ if(ia(2).eq.1)then !hadron-proton interaction
+ call qgfz(0.d0,gz0,0,0)
+ gtot=gz0(1) !total cross-section
+ gin=(gz0(2)+gz0(3)+gz0(4))*.5d0 !inelastic cross section
+ bel=gz0(5) !elastic scattering slope
+ gel=gtot-gin !elastic cross section
+ gdp=gz0(3)*.5d0 !projectile low mass diffr. (+double LMD)
+ gdt=gz0(4)*.5d0 !target low mass diffraction
+ if(iy.le.10)gsect(iy,icz,iia)=log(gin)
+
+ if(debug.ge.1)write (moniou,225)gtot,gin,gel,gdp,gdt,bel
+ else !hadron-nucleus interaction
+ bm=rnuc(2)+dlog(29.d0)*wsnuc(2) !for numerical integration
+ anorm=qganrm(rnuc(2),wsnuc(2),wbnuc(2))*rp !density normalization
+ call qggau(gz1) !integration over b<bm
+ call qggau1(gz1) !integration over b>bm
+ gin=gz1(1)+gz1(2)+gz1(3) !inelastic cross section
+ if(iy.le.10)gsect(iy,icz,iia)=log(gin*10.d0)
+
+ if(debug.ge.1)write (moniou,224)
+ * gin*10.d0,gz1(3)*10.d0,gz1(2)*10.d0
+ endif
+ if(.not.(gsect(iy,icz,iia).le.0.d0
+ * .or.gsect(iy,icz,iia).gt.0.d0))stop'qpomr-nan'
+ enddo
+ enddo
+ enddo
+
+c-------------------------------------------------
+c cut Pomeron leg eikonals
+ if(debug.ge.1)write (moniou,223)
+ do icz=1,3 !hadron class
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,51
+ sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter^2
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do ix=1,10
+ if(ix.le.5)then
+ xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix-5)
+ endif
+ sys=xp*sy
+
+ vs=qgls(sys,xp,bb,icdp,icz)
+ vg=qglsh(sys,xp,bb,icdp,icz,0)
+ if(xp.lt..99d0)then
+ vq=qglsh(sys,xp,bb,icdp,icz,1)
+ * /dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
+ else
+ vq=0.d0
+ endif
+ qlegc0(iy,ix,iz,icdp+2*(icz-1),1)=dlog((vs+vg+vq)/vs)
+ qlegc0(iy,ix,iz,icdp+2*(icz-1),2)=dlog((vs+vg)/vs)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+ do icz=1,3 !hadron class
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ do iy=1,51
+ sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter^2
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do ix=1,10
+ if(ix.le.5)then
+ xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix-5)
+ endif
+ sys=xp*sy
+
+ do iqq=1,3
+ call qgloolc(sys,xp,bb,icdp,icz,iqq,fann(2*iqq-1)
+ * ,fann(2*iqq))
+ enddo
+ do iqq=1,6
+ if(fann(iqq).gt.0.d0)then
+ qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
+ * =dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
+ else
+ qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
+ * =min(2.d0*qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2)
+ * -qlegc0(iy-2,ix,iz,icdp+2*(icz-1),iqq+2)
+ * ,qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2))
+ endif
+ qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
+ * =max(qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2),-20.d0)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+ do icz=1,3 !hadron class
+ do icdp=1,2 !diffr. eigenstate
+ if(cd(icdp,icz).ne.0.d0)then
+ do iv=1,11
+ vvx=dble(iv-1)/10.d0
+ do iy=1,51 !initialization
+ do ix=1,10
+ do iz=1,11
+ do iqq=1,3
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =qlegc0(iy,ix,iz,icdp+2*(icz-1),2*iqq+1)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do iy=2,51
+ sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+
+ do ix=1,10
+ do iz=1,11
+ do iqq=1,3
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ enddo
+ enddo
+ enddo
+
+ n=1
+43 n=n+1 !number of t-channel iterations
+ nrep=0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter^2
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do ix=1,10
+ if(ix.le.5)then
+ xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix-5)
+ endif
+ sys=xp*sy
+
+ do iqq=1,3
+ fann(iqq)=qglscr(sys,xp,bb,vvx,icdp,icz,iqq)
+ if(fann(iqq).gt.0.d0)then
+ qfan2(ix,iz,iqq)=dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
+ elseif(iy.gt.2)then
+ qfan2(ix,iz,iqq)
+ * =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
+ else
+ qfan2(ix,iz,iqq)
+ * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ endif
+ qfan2(ix,iz,iqq)=max(qfan2(ix,iz,iqq),-20.d0)
+ if(abs(qfan2(ix,iz,iqq)-qlegc(iy,ix,iv,iz
+ * ,icdp+2*(icz-1)+6*(iqq-1))).gt.1.d-3)nrep=1
+ enddo
+ enddo
+ enddo
+
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do ix=1,10
+ if(ix.le.5)then
+ xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix-5)
+ endif
+ sys=xp*sy
+
+ do iqq=1,3
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))=qfan2(ix,iz,iqq)
+
+ if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
+ * .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
+ * stop'qlegc-nan'
+ enddo
+ enddo
+ enddo
+ if(nrep.eq.1.and.n.lt.50)goto 43
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c soft pre-evolution
+ do icz=1,3 !hadron class
+ do icdp=1,2 !diffr. eigenstate
+ if(cd(icdp,icz).ne.0.d0)then
+ do iv=1,11
+ vvx=dble(iv-1)/10.d0
+ do iy=1,51
+ sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do ix=1,10
+ if(ix.le.5)then
+ xp=.2d0*(sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix-5)
+ endif
+ sys=xp*sy
+
+ if(iy.eq.1)then
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+18)=0.d0
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+24)=0.d0
+ else
+ do iqq=4,5
+ fann(iqq)=qglh(sys,xp,bb,vvx,icdp,icz,iqq-4)
+ if(fann(iqq).gt.0.d0)then
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =dlog(fann(iqq))
+ elseif(iy.gt.2)then
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
+ else
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ endif
+ qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
+ * =max(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)),-20.d0)
+
+ if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
+ * .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
+ * stop'qlegc-nan'
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+
+c-------------------------------------------------
+c cut Pomeron eikonals
+ if(debug.ge.1)write (moniou,226)
+ do icz=1,3 !proj. class
+ do icdp=1,2
+ do icdt=1,2
+ if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
+ do iy=1,11
+ sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
+ rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
+ do iz=1,11
+ if(iz.gt.6)then
+ z=.2d0*(iz-6)
+ bb=-log(z)*rp !impact parameter^2
+ else
+ bb=-rp*(log(0.2d0)+2.d0*(iz-7))
+ z=exp(-bb/rp)
+ endif
+ do iv=1,11
+ vvx=(iv-1)/10.d0 !relative scr. strenth
+
+ do ix1=1,10
+ if(ix1.le.5)then
+ xp=.2d0*(5.d0*sgap/sy)**((6-ix1)/5.d0) !Pomeron LC+ momentum
+ else
+ xp=.2d0*(ix1-5)
+ endif
+ do ix2=1,10
+ if(ix2.le.5)then
+ xm=.2d0*(sgap/sy/xp)**((6-ix2)/5.d0) !Pomeron LC- momentum
+ else
+ xm=.2d0*(ix2-5)
+ endif
+ sys=xp*xm*sy
+
+ do iqq=1,4
+ vv=qgcutp(sys,xp,xm,bb,vvx,icdp,icdt,icz,iqq)
+ if(vv.gt.0.d0)then
+ qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
+ * +12*(iqq-1))=dlog(vv/z)
+ elseif(iy.gt.2)then
+ qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
+ * +12*(iqq-1))=min(2.d0*qpomc(iy-1,ix1+10*(ix2-1),iz,iv
+ * ,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))-qpomc(iy-2
+ * ,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))
+ * ,qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
+ * +12*(iqq-1)))
+ else
+ qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
+ * +12*(iqq-1))=qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)
+ * +4*(icz-1)+12*(iqq-1))
+ endif
+ qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
+ * +12*(iqq-1))=max(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
+ * +2*(icdt-1)+4*(icz-1)+12*(iqq-1)),-20.d0)
+
+ if(.not.(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz
+ * -1)+12*(iqq-1)).le.0.d0.or.qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
+ * +2*(icdt-1)+4*(icz-1)+12*(iqq-1)).gt.0.d0))stop'qpomc-nan'
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+
+c-----------------------------------------------------------------------------
+c timelike Sudakov formfactor
+ if(debug.ge.1)write (moniou,221)
+ do m=1,2 !parton type (1-g, 2-q)
+ fsud(1,m)=0.d0
+ do k=2,10
+ qmax=qtf*4.d0**(1.d0+k) !effective virtuality (qt**2/z**2/(1-z)**2)
+ fsud(k,m)=qgsudt(qmax,m)
+ enddo
+ enddo
+c-----------------------------------------------------------------------------
+c effective virtuality (used for inversion in timelike branching)
+ if(debug.ge.1)write (moniou,222)
+ do m=1,2 !parton type (1-g, 2-q)
+ do k=1,10
+ qlmax=1.38629d0*(k-1)
+ qrt(k,1,m)=0.d0
+ qrt(k,101,m)=qlmax
+ do i=1,99 !bins in Sudakov formfactor
+ if(k.eq.1)then
+ qrt(k,i+1,m)=0.d0
+ else
+ qrt(k,i+1,m)=qgroot(qlmax,.01d0*i,m)
+ endif
+ enddo
+ enddo
+ enddo
+
+c-----------------------------------------------------------------------------
+c writing cross sections to the file
+ if(debug.ge.1)write (moniou,220)
+ if(ifIIdat.ne.1)then
+ open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
+ * ,status='unknown')
+ else !used to link with nexus
+ open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='unknown')
+ endif
+ write (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
+ *,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,qrt
+ close(1)
+
+10 continue
+c-----------------------------------------------------------------------------
+c nuclear cross sections
+ if(ifIIncs.ne.2)then
+ inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
+ * ,exist=lcalc)
+ else !ctp
+ inquire(file=fnIIncs(1:nfnIIncs),exist=lcalc)
+ endif
+
+ if(lcalc)then
+ if(debug.ge.0)write (moniou,207)
+ if(ifIIncs.ne.2)then
+ open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
+ * ,status='old')
+ else !ctp
+ open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='old')
+ endif
+ read (2,*)qgsasect
+ close(2)
+
+ elseif(.not.producetables)then
+ write(moniou,*) "Missing sectnu-II-04 file !"
+ write(moniou,*) "Please correct the defined path ",
+ &"or force production ..."
+ stop
+
+ else
+ niter=5000 !number of iterations
+ do ie=1,10
+ e0n=10.d0**ie !interaction energy (per nucleon)
+ do iia1=1,6
+ iap=2**iia1 !proj. mass number
+ do iia2=1,6
+ if(iia2.le.4)then
+ iat=4**(iia2-1) !targ. mass number
+ elseif(iia2.eq.5)then
+ iat=14
+ else
+ iat=40
+ endif
+ if(debug.ge.1)write (moniou,208)e0n,iap,iat
+
+ call qgini(e0n,2,iap,iat)
+ call qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
+ if(debug.ge.1)write (moniou,209)gtot,gprod,gabs,gdd,gqel,gcoh
+ qgsasect(ie,iia1,iia2)=log(gprod)
+ enddo
+ enddo
+ enddo
+ if(ifIIncs.ne.2)then
+ open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
+ * ,status='unknown')
+ else !ctp
+ open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='unknown')
+ endif
+ write (2,*)qgsasect
+ close(2)
+ endif
+
+ if(debug.ge.3)write (moniou,218)
+201 format(2x,'qgaini: hard cross sections calculation')
+202 format(2x,'qgaini: number of rungs considered:',i2
+ */4x,'starting energy bin for ordered and general ladders:',3i4)
+205 format(2x,'qgaini: pretabulation of the interaction eikonals')
+206 format(2x,'qgaini: initial particle energy:',e10.3,2x
+ *,'its type:',a7,2x,'target mass number:',i2)
+207 format(2x,'qgaini: nuclear cross sections readout from the file'
+ *,' sectnu-II-04')
+208 format(2x,'qgaini: initial nucleus energy:',e10.3,2x
+ *,'projectile mass:',i2,2x,'target mass:',i2)
+209 format(2x,'gtot',d10.3,' gprod',d10.3,' gabs',d10.3
+ */2x,'gdd',d10.3,' gqel',d10.3,' gcoh',d10.3)
+210 format(2x,'qgaini - main initialization procedure')
+212 format(2x,'qgaini: integrated Pomeron leg eikonals')
+213 format(2x,'qgaini: integrated fan contributions')
+214 format(2x,'qgaini: cross sections readout from the file: ', A,2x)
+c *,' qgsdat-II-04')
+215 format(2x,'qgaini: integrated cut fan contributions')
+c216 format(2x,'qgaini: integrated cut Pomeron eikonals')
+218 format(2x,'qgaini - end')
+220 format(2x,'qgaini: cross sections are written to the file'
+ *,' qgsdat-II-04')
+221 format(2x,'qgaini: timelike Sudakov formfactor')
+222 format(2x,'qgaini: effective virtuality for inversion')
+223 format(2x,'qgaini: cut Pomeron leg eikonals')
+224 format(2x,'qgaini: hadron-nucleus cross sections:'
+ */4x,'gin=',e10.3,2x,'gdifr_targ=',e10.3,2x
+ *,'gdifr_proj=',e10.3)
+225 format(2x,'qgaini: hadron-proton cross sections:'
+ */4x,'gtot=',e10.3,2x,'gin=',e10.3,2x,'gel=',e10.3/4x
+ *,'gdifrp=',e10.3,2x,'gdifrt=',e10.3,2x,'b_el=',e10.3,2x)
+226 format(2x,'qgaini: cut Pomeron eikonals (semi-hard)')
+ return
+ end
+
+c=============================================================================
+ subroutine qgini(e0n,icp0,iap,iat)
+c-----------------------------------------------------------------------------
+c additional initialization procedure
+c e0n - interaction energy (per hadron/nucleon),
+c icp0 - hadron type (+-1 - pi+-, +-2 - p(p~), +-3 - n(n~),
+c +-4 - K+-, +-5 - K_l/s),
+c iap - projectile mass number (1 - for a hadron),
+c iat - target mass number
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr4/ ey0(3)
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr10/ am(7),ammu
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
+ common /qgdebug/ debug
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+
+ if(debug.ge.1)write (moniou,201)icp0,iap,iat,e0n
+ icp=icp0
+ ia(1)=iap
+ ia(2)=iat
+
+ icz=iabs(icp)/2+1 !!!!!particle class (1 - pion, 2 - nucleon, 3 - kaon)
+
+ scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2 !c.m. energy squared
+ ey0(1)=dsqrt(scm)/(e0n+am(2)+dsqrt(e0n-am(icz))
+ **dsqrt(e0n+am(icz))) !Lorentz boost to lab. frame
+ ey0(2)=1.d0
+ ey0(3)=1.d0
+ wp0=dsqrt(scm) !initial LC+ mometum
+ wm0=wp0 !initial LC- mometum
+
+c-------------------------------------------------
+c nuclear radii and weights for nuclear configurations - procedure qggea
+ do i=1,2
+ if(ia(i).lt.10.and.ia(i).ne.1)then !gaussian density
+ rnuc(i)=.9d0*float(ia(i))**.3333 !nuclear radius
+ if(ia(i).eq.2)rnuc(i)=3.16d0
+c rnuc -> rnuc * a / (a-1) - to use van-hove method (in qggea)
+ rnuc(i)=rnuc(i)*dsqrt(2.d0*ia(i)/(ia(i)-1.d0))
+ !rnuc -> rnuc*a/(a-1) - to use Van-Hove method
+ elseif(ia(i).ne.1)then
+ if(ia(i).le.56)then !3-parameter Fermi
+ rnuc(i)=trnuc(ia(i)) !nuclear radius
+ wsnuc(i)=twsnuc(ia(i)) !diffuseness
+ wbnuc(i)=twbnuc(ia(i)) !'wine-bottle' parameter
+ else
+ rnuc(i)=1.19*float(ia(i))**(1./3.)-1.38*float(ia(i))**(-1./3.)
+ wsnuc(i)=amws !diffuseness
+ wbnuc(i)=0.d0
+ endif
+ cr1(i)=1.d0+3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
+ * +6.d0/(rnuc(i)/wsnuc(i))**3
+ cr2(i)=3.d0/rnuc(i)*wsnuc(i)
+ cr3(i)=3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
+ endif
+ enddo
+
+ if(ia(1).ne.1.and.ia(2).ne.1)then !primary nucleus !so18032013-beg
+ bm=rnuc(1)+rnuc(2)+5.d0*max(wsnuc(1),wsnuc(2))
+ & +dsqrt(alfp*log(scm)) !b-cutoff
+ elseif(ia(2).ne.1)then !hadron-nucleus
+ bm=rnuc(2)+5.d0*wsnuc(2)+dsqrt(rq(1,2)+alfp*log(scm)) !b-cutoff
+ elseif(ia(1).ne.1)then !nucleus-proton
+ bm=rnuc(1)+5.d0*wsnuc(1)+dsqrt(rq(1,2)+alfp*log(scm)) !b-cutoff
+ else !hadron-proton
+ bm=3.d0*dsqrt((rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0398d0)
+ endif !so18032013-end
+
+ bmaxqgs=bm !used to link with nexus
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgini - miniinitialization: particle type icp0=',
+ *i2,2x,'projectile mass number iap=',i2/4x,
+ *'target mass number iat=',i2,' interaction energy e0n=',e10.3)
+202 format(2x,'qgini - end')
+ return
+ end
+
+c=============================================================================
+ double precision function qgpint(sy,bb)
+c-----------------------------------------------------------------------------
+c qgpint - interm. Pomeron eikonal
+c sy - pomeron mass squared,
+c bb - impact parameter squared
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)sy,bb
+
+ qgpint=0.d0
+ s2min=4.d0*fqscal*qt0
+ xmin=s2min/sy
+ if(xmin.ge.1.d0)return
+
+ xmin=xmin**(delh-dels)
+c numerical integration over z1
+ do i=1,7
+ do m=1,2
+ z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
+ * **(1.d0/(delh-dels))
+ ww=z1*sy
+ sjqq=qgjit(qt0,qt0,ww,2,2) !inclusive qq cross-section
+ sjqg=qgjit(qt0,qt0,ww,1,2) !inclusive qg cross-section
+ sjgg=qgjit(qt0,qt0,ww,1,1) !inclusive gg cross-section
+
+ st2=0.d0
+ do j=1,7
+ do k=1,2
+ xx=.5d0*(1.d0+x1(j)*(2*k-3))
+ xp=z1**xx
+ xm=z1/xp
+ glu1=qgppdi(xp,0)
+ sea1=qgppdi(xp,1)
+ glu2=qgppdi(xm,0)
+ sea2=qgppdi(xm,1)
+ st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
+ * +sea1*sea2*sjqq)
+ enddo
+ enddo
+ rh=-alfp*dlog(z1)
+ qgpint=qgpint-a1(i)*dlog(z1)/z1**delh*st2
+ * *exp(-bb/(4.d0*.0389d0*rh))/rh
+ enddo
+ enddo
+ qgpint=qgpint*(1.d0-xmin)/(delh-dels)*factk*rr**2/2.d0*pi
+
+ if(debug.ge.3)write (moniou,202)qgpint
+201 format(2x,'qgpint - interm. Pomeron eikonal:'
+ */4x,'sy=',e10.3,2x,'bb=',e10.3)
+202 format(2x,'qgpint=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpini(sy,bb,vvx,vvxt,iqq)
+c-----------------------------------------------------------------------
+c qgpini - intermediate gg-Pomeron eikonal
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c vvx - total / projectile screening factor,
+c vvxt - target screening factor
+c vvx - total/projectile screening factor:
+c vvx = 0 (iqq=1,...15)
+c vvx = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=16)
+c vvx = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
+c - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
+c - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=17 uncut)
+c vvx = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=17,...19)
+c vvx = 1 - exp[-sum_{i} chi_proj(i)] (iqq=20,...23)
+c vvxt - target screening factor:
+c vvxt = 0 (iqq=1,...19)
+c vvxt = 1 - exp[-sum_j chi_targ(j)] (iqq=20,...23)
+c uncut eikonals:
+c iqq=0 - single soft Pomeron
+c iqq=1 - single Pomeron
+c iqq=2 - general loop contribution
+c iqq=3 - single Pomeron end on one side
+c iqq=4 - single Pomeron ends on both sides
+c cut eikonals:
+c iqq=5 - single cut Pomeron
+c iqq=6 - single cut Pomeron with single end
+c iqq=7 - single cut Pomeron with 2 single ends
+c iqq=8 - any cuts except the complete rap-gap
+c iqq=9 - single cut Pomeron end at one side
+c iqq=10 - single cut Pomeron end at one side and single Pomeron on the other
+c iqq=11 - no rap-gap at one side
+c iqq=12 - no rap-gap at one side and single Pomeron on the other
+c iqq=13 - single cut soft Pomeron
+c iqq=14 - single cut soft Pomeron with single end
+c iqq=15 - single cut soft Pomeron with 2 single ends
+c with proj/targ screening corrections:
+c iqq=16 - single cut Pomeron
+c iqq=17 - uncut / cut end / loop sequence
+c iqq=18 - no rap-gap at the end
+c iqq=19 - single cut Pomeron end
+c iqq=20 - diffractive cut, Puu
+c iqq=21 - diffractive cut, Puu-Puc
+c iqq=22 - diffractive cut, Pcc
+c iqq=23 - diffractive cut, Pcc+Pcu
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3),wi(3),wj(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr26/ factk,fqscal
+ common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgpini=0.d0
+ pinm=0.d0
+ s2min=4.d0*fqscal*qt0
+ rp=alfp*dlog(sy)*4.d0*.0389d0
+ z=exp(-bb/rp)
+ if(iqq.le.1.and.(sy.le.s2min.or.iqq.eq.0))goto 1
+
+ yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
+ k=max(1,int(1.00001d0*yl-1.d0))
+ k=min(k,49)
+ wk(2)=yl-k
+ if(yl.le.2.d0)then
+ iymax=2
+ wk(1)=1.d0-wk(2)
+ else
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+ endif
+
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ if(iqq.le.15)then
+ iqr=iqq
+ if(sy.le.sgap**2.and.iqq.le.12)iqr=1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgpini=qgpini+qpomi(k2,l2,iqr)*wk(k1)*wz(l1)
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do k1=1,iymax
+ k2=k+k1-1
+ pinm=pinm+qpomi(k2,1,iqr)*wk(k1)
+ enddo
+ qgpini=min(qgpini,pinm)
+ endif
+
+ else
+ vi=vvx*10.d0+1.d0
+ i=max(1,int(vi))
+ i=min(i,9)
+ wi(2)=vi-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+
+ if(iqq.le.19)then
+ do i1=1,3
+ i2=i+i1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgpini=qgpini+qpomis(k2,l2,i2,1,iqq-15)*wk(k1)*wz(l1)*wi(i1)
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do i1=1,3
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ pinm=pinm+qpomis(k2,1,i2,1,iqq-15)*wk(k1)*wi(i1)
+ enddo
+ enddo
+ qgpini=min(qgpini,pinm)
+ endif
+
+ else
+ vj=vvxt*10.d0+1.d0
+ j=max(1,int(vj))
+ j=min(j,9)
+ wj(2)=vj-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ jmax=3
+
+ do j1=1,jmax
+ j2=j+j1-1
+ do i1=1,3
+ i2=i+i1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgpini=qgpini+qpomis(k2,l2,i2,j2,iqq-15)
+ * *wk(k1)*wz(l1)*wi(i1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,jmax
+ j2=j+j1-1
+ do i1=1,3
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ pinm=pinm+qpomis(k2,1,i2,j2,iqq-15)*wk(k1)*wi(i1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ qgpini=min(qgpini,pinm)
+ endif
+ endif
+ endif
+1 qgpini=exp(qgpini)
+ if(iqq.le.16.or.iqq.eq.19)qgpini=qgpini
+ **sy**dels*sigs*g3p**2*z/rp*4.d0*.0389d0
+ return
+ end
+
+c=============================================================================
+ double precision function qgleg(sy,bb,icdp,icz)
+c-----------------------------------------------------------------------------
+c qgleg - integrated Pomeron leg eikonal
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr25/ ahv(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)sy,bb,icz
+
+ qgleg=0.d0
+ if(sy.lt.1.001d0)then
+ tmin=1.d0
+ else
+ tmin=(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels)
+ endif
+ if(debug.ge.3)write (moniou,203)tmin
+ do i1=1,7
+ do m1=1,2
+ tp=1.d0-(.5d0*(1.d0+tmin)+x1(i1)*(m1-1.5d0)*(1.d0-tmin))
+ * **(1./(1.+dels))
+ if(tp.gt.1.d-9)then
+ xp=1.d0-tp**(1.d0/(1.d0+ahl(icz)))
+ else
+ xp=1.d0
+ endif
+
+ ws=qgls(xp*sy,xp,bb,icdp,icz)
+ wg=qglsh(xp*sy,xp,bb,icdp,icz,0)
+ wq=qglsh(xp*sy,xp,bb,icdp,icz,1)/dsqrt(xp)
+ * *(1.d0-xp)**(ahv(icz)-ahl(icz))
+
+ qgleg=qgleg+a1(i1)*(ws+wg+wq)/(1.d0-tp)**dels
+ enddo
+ enddo
+ qgleg=qgleg/2.d0/(1.+ahl(icz))/(1.d0+dels)
+
+ if(debug.ge.3)write (moniou,202)qgleg
+201 format(2x,'qgleg - Pomeron leg eikonal:'
+ */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
+202 format(2x,'qgleg=',e10.3)
+203 format(2x,'qgleg:',2x,'tmin=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qglegi(sy,bb,icdp,icz,iqq)
+c-----------------------------------------------------------------------
+c qglegi - integrated Pomeron leg eikonal
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the hadron,
+c icz - hadron class
+c iqq=1 - single leg Pomeron
+c iqq=2 - all loops
+c iqq=3 - single Pomeron end
+c iqq=4 - single cut Pomeron
+c iqq=5 - single cut Pomeron with single Pomeron end
+c iqq=6 - single cut Pomeron end
+c iqq=7 - no rap-gap at the end
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
+ *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qglegi=0.d0
+ xlegm=0.d0
+ rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
+ z=exp(-bb/rp)
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
+ k=max(1,int(yl))
+ k=min(k,49)
+ wk(2)=yl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+
+ iqr=iqq
+ if(sy.le.sgap**2)iqr=1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qglegi=qglegi+qlegi(k2,l2,icdp,icz,iqr)*wk(k1)*wz(l1)
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do k1=1,iymax
+ k2=k+k1-1
+ xlegm=xlegm+qlegi(k2,1,icdp,icz,iqr)*wk(k1)
+ enddo
+ qglegi=min(qglegi,xlegm)
+ endif
+ qglegi=exp(qglegi)*z
+ **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
+ return
+ end
+
+c=============================================================================
+ double precision function qgls(sy,xp,bb,icdp,icz)
+c-----------------------------------------------------------------------------
+c qgls - soft pomeron leg eikonal
+c sy - pomeron mass squared,
+c xp - pomeron light cone momentum,
+c bb - impact parameter squared,
+c icdp - diffractive state for the connected hadron,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)sy,bb,icz
+
+ rp=rq(icdp,icz)+alfp*log(sy/xp)
+ qgls=sy**dels*fp(icz)*g3p*sigs/rp*exp(-bb/(4.d0*.0389d0*rp))
+ **cd(icdp,icz)
+
+ if(debug.ge.3)write (moniou,202)qgls
+201 format(2x,'qgls - soft pomeron leg eikonal:'
+ */4x,'sy=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
+202 format(2x,'qgls=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qglsh(sy,xp,bb,icdp,icz,iqq)
+c-----------------------------------------------------------------------------
+c qglsh - unintegrated Pomeron leg eikonal
+c sy - pomeron mass squared,
+c xp - light cone momentum share,
+c bb - impact parameter squared,
+c icz - hadron class
+c iqq=0 - gluon/sea quark contribution,
+c iqq=1 - valence quark contribution
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)sy,bb,icz
+
+ qglsh=0.d0
+ s2min=4.d0*fqscal*qt0
+ if(sy.lt.1.001d0*s2min)return
+
+ xmin=(s2min/sy)**(delh-dels)
+c numerical integration over zh
+ do i1=1,7
+ do m1=1,2
+ zh=(.5d0*(1.d0+xmin-(2*m1-3)*x1(i1)*(1.d0-xmin)))
+ * **(1.d0/(delh-dels))
+ ww=zh*sy !c.m. energy squared for hard interaction
+ sjqq=qgjit(qt0,qt0,ww,2,2)
+ sjqg=qgjit(qt0,qt0,ww,1,2)
+ sjgg=qgjit(qt0,qt0,ww,1,1)
+ if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
+
+ if(iqq.eq.0)then
+ stg=0.d0
+ do i2=1,7
+ do m2=1,2
+ xx=.5d0*(1.d0+x1(i2)*(2*m2-3))
+ xph=zh**xx
+ xmh=zh/xph
+ glu1=qgppdi(xph,0)
+ sea1=qgppdi(xph,1)
+ glu2=qgppdi(xmh,0)
+ sea2=qgppdi(xmh,1)
+ rh=rq(icdp,icz)-alfp*dlog(zh*xp)
+
+ stsum=(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
+ * +sea1*sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
+ stg=stg+a1(i2)*stsum
+ enddo
+ enddo
+ qglsh=qglsh-a1(i1)*dlog(zh)/zh**delh*stg
+
+ elseif(iqq.eq.1)then
+ xmh=zh
+ glu2=qgppdi(xmh,0)
+ sea2=qgppdi(xmh,1)
+ rh=rq(icdp,icz)-alfp*dlog(zh)
+
+ stq=(glu2*sjqg+sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
+ qglsh=qglsh+a1(i1)/zh**delh*stq
+ * *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))/dsqrt(xp)
+ endif
+ enddo
+ enddo
+ if(iqq.eq.0)then
+ qglsh=qglsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*g3p*factk
+ * /2.d0*pi*cd(icdp,icz)
+ elseif(iqq.eq.1)then
+ qglsh=qglsh*rr*(1.d0-xmin)/(delh-dels)*g3p*factk/4.d0
+ * *cd(icdp,icz)
+ endif
+
+ if(debug.ge.3)write (moniou,202)qglsh
+201 format(2x,'qglsh - unintegrated Pomeron leg eikonal:'
+ */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
+202 format(2x,'qglsh=',e10.3)
+203 format(2x,'qglsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgloop(sy,bb,fann,jj)
+c-----------------------------------------------------------------------
+c qgloop - intermediate Pomeron eikonal with loops
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c jj=1 - uncut loops (iqq=1,...3)
+c jj=2 - cut loops (iqq=4,...11)
+c iqq=1 - general loop contribution
+c iqq=2 - single Pomeron end on one side
+c iqq=3 - single Pomeron ends on both sides
+c iqq=4 - single cut Pomeron
+c iqq=5 - single cut Pomeron with single end
+c iqq=6 - single cut Pomeron with 2 single ends
+c iqq=7 - any cuts except the complete rap-gap
+c iqq=8 - single cut Pomeron at one side
+c iqq=9 - single cut Pomeron at one side and single Pomeron on the other
+c iqq=10 - no rap-gap at one side
+c iqq=11 - no rap-gap at one side and single Pomeron on the other
+c iqq=12 - single cut soft Pomeron
+c iqq=13 - single cut soft Pomeron with single end
+c iqq=14 - single cut soft Pomeron with 2 single ends
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ do iqq=1,14
+ fann(iqq)=0.d0
+ enddo
+ if(sy.le.sgap**2)goto 1
+ do ix1=1,7
+ do mx1=1,2
+ xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=-alfp*log(xpomr)*4.d0*.0389d0
+ rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vi=qgpini(xpomr*sy,bb1,0.d0,0.d0,1)
+ vit=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
+ v1i0=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,4)
+ v1i1=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,3))
+ v1i=min(v1i1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2))
+ if(jj.eq.1)then
+ do iqq=1,3
+ if(iqq.eq.1)then
+ dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ * +min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-v1i))
+ elseif(iqq.eq.2)then
+ dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ elseif(iqq.eq.3)then
+ dpx=vi*(v1i1-v1i0)
+ else
+ dpx=0.d0
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+
+ else
+ v1ic0=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,7))
+ v1ic1=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,6))
+ v1ic=min(v1ic1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,5))
+ v1icn=min(v1i,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
+ vict=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
+ victn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
+ victg=min(victn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
+ vict1=min(victg,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
+
+ vis=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,0))
+ v1ic0s=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,15))
+ v1ic1s=min(v1ic0s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,14))
+ v1ics=min(v1ic1s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,13))
+ victs=min(vict,qgpini(xpomr*sy,bb1,0.d0,0.d0,13))
+ do iqq=4,14
+ if(iqq.eq.4)then
+ dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
+ * +vict*(exp(-2.d0*victn)-1.d0)*v1ic*exp(-2.d0*v1icn)
+ elseif(iqq.eq.5)then
+ dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
+ elseif(iqq.eq.6)then
+ dpx=vi*(v1ic1-v1ic0)
+ elseif(iqq.eq.7)then
+ dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ * +.5d0*min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-2.d0*v1icn))
+ * +.5d0*min(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn)
+ * *max(0.d0,1.d0-exp(-v1i)-.5d0*(1.d0-exp(-2.d0*v1icn)))
+ elseif(iqq.eq.8)then
+ dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ * +vict1*(exp(-2.d0*victn)-1.d0)*(1.d0-exp(-v1i))
+ elseif(iqq.eq.9)then
+ dpx=vi*(v1i1-v1i0)
+ * +vict1*(exp(-2.d0*victn)-1.d0)*v1i1
+ elseif(iqq.eq.10)then
+ dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ * +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
+ * *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))
+ * *(1.d0-exp(-v1i))
+ elseif(iqq.eq.11)then
+ dpx=vi*(v1i1-v1i0)
+ * +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
+ * *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))*v1i1
+ elseif(iqq.eq.12)then
+ dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
+ * +victs*(exp(-2.d0*victn)-1.d0)*v1ics*exp(-2.d0*v1icn)
+ elseif(iqq.eq.13)then
+ dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
+ elseif(iqq.eq.14)then
+ dpx=vis*(v1ic1s-v1ic0s)
+ else
+ dpx=0.d0
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+1 dpin=qgpini(sy,bb,0.d0,0.d0,1)
+ do iqq=1,11
+ fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ * +dpin
+ enddo
+ dpins=min(dpin,qgpini(sy,bb,0.d0,0.d0,0))
+ do iqq=12,14
+ fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ * +dpins
+ enddo
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgloos(sy,bb,vvx,vvxt,fann)
+c-----------------------------------------------------------------------
+c qgloos - intermediate Pomeron eikonal with screening corrections
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c vvx - total/projectile screening factor:
+c vvx = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=1)
+c vvx = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
+c - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
+c - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=2 uncut)
+c vvx = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)] (iqq=2,...4)
+c vvx = 1 - exp[-sum_{i} chi_proj(i)] (iqq=5,...8)
+c vvxt - target screening factor:
+c vvxt = 0 (iqq=1,...4)
+c vvxt = 1 - exp[-sum_j chi_targ(j)] (iqq=5,...8)
+c iqq=1 - single cut Pomeron
+c iqq=2 - uncut / cut end / loop sequence
+c iqq=3 - no rap-gap at the end
+c iqq=4 - single cut Pomeron end
+c iqq=5 - diffractive cut, Puu
+c iqq=6 - diffractive cut, Puu-Puc
+c iqq=7 - diffractive cut, Pcc
+c iqq=8 - diffractive cut, Pcc+Pcu
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ do iqq=1,8
+ fann(iqq)=0.d0
+ enddo
+ if(sy.le.sgap**2)goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=-alfp*log(xpomr)*4.d0*.0389d0
+ rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vit=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
+ vicn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
+ vicng=min(vicn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
+ vicpe=min(vicng,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
+ vic1=min(vicpe,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
+
+ viu=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2)
+ v1icn=min(viu,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
+ v1i=qgpini(1.d0/xpomr,bb2,vvx,0.d0,16)*exp(-2.d0*v1icn)
+ vi=qgpini(1.d0/xpomr,bb2,vvx,0.d0,17)*(1.d0-exp(-viu))
+ vduu=qgpini(1.d0/xpomr,bb2,vvx,vvxt,20)*(1.d0-exp(-viu))
+ vduc=max(0.d0,vduu-qgpini(1.d0/xpomr,bb2,vvx,vvxt,21)
+ * *(1.d0-exp(-viu)))
+ vdcc=qgpini(1.d0/xpomr,bb2,vvx,vvxt,22)*((1.d0-exp(-viu))**2
+ * +(exp(2.d0*(viu-v1icn))-1.d0)*exp(-2.d0*viu))/2.d0
+ vdcu=max(0.d0,qgpini(1.d0/xpomr,bb2,vvx,vvxt,23)
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*(viu-v1icn))-1.d0)
+ * *exp(-2.d0*viu))/2.d0-vdcc)
+
+ do iqq=1,8
+ if(iqq.eq.1)then !single cut Pomeron
+ dpx=-vvx*v1i*vic1*exp(-2.d0*vicn)
+ elseif(iqq.eq.2)then !uncut / cut end / loop sequence
+ dpx=-(1.d0-exp(-vit))*vi*vvx
+ elseif(iqq.eq.3)then !no rap-gap at the end
+ dpx=-(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
+ * +vicng*exp(-2.d0*vicn))*vi*vvx
+ elseif(iqq.eq.4)then !single cut Pomeron end
+ dpx=-vicpe*exp(-2.d0*vicn)*vi*vvx
+ elseif(iqq.eq.5)then !Puu
+ dpx=(1.d0-exp(-vit))
+ * *(vduu*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
+ * -vdcu*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
+ elseif(iqq.eq.6)then !Puu-Puc
+ dpx=(1.d0-exp(-vit))
+ * *((vduu-vduc)*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
+ * -(vdcc+vdcu)*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
+ elseif(iqq.eq.7)then !Pcc
+ dpx=.5d0*((1.d0-exp(-vit))**2
+ * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
+ * *(vdcc*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
+ * -vduc*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
+ elseif(iqq.eq.8)then !Pcc+Pcu
+ dpx=.5d0*((1.d0-exp(-vit))**2
+ * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
+ * *((vdcc+vdcu)*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
+ * +(vduu-vduc)*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
+ else
+ dpx=0.d0
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+1 vit=qgpini(sy,bb,0.d0,0.d0,2)
+ vicn=min(vit,qgpini(sy,bb,0.d0,0.d0,8))
+ vicng=min(vicn,qgpini(sy,bb,0.d0,0.d0,11))
+ vicpe=min(vicng,qgpini(sy,bb,0.d0,0.d0,9))
+ vic1=min(vicpe,qgpini(sy,bb,0.d0,0.d0,5))
+ do iqq=1,8
+ fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ if(iqq.eq.1)then
+ fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vic1
+ elseif(iqq.eq.3)then
+ fann(iqq)=fann(iqq)+vicng*exp(-2.d0*vicn)
+ * +.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
+ elseif(iqq.eq.4)then
+ fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vicpe
+ elseif(iqq.lt.7)then
+ fann(iqq)=fann(iqq)+(1.d0-exp(-vit))
+ else
+ fann(iqq)=fann(iqq)+.5d0*((1.d0-exp(-vit))**2
+ * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
+ endif
+ enddo
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qglool(sy,bb,icdp,icz,fann)
+c-----------------------------------------------------------------------
+c qglool - integrated Pomeron leg eikonal with loops
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c icz - hadron class
+c iqq=1 - all
+c iqq=2 - single Pomeron end
+c iqq=3 - single cut Pomeron
+c iqq=4 - single cut Pomeron with single Pomeron end
+c iqq=5 - single cut Pomeron end
+c iqq=6 - no rap-gap at the end
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ do iqq=1,6
+ fann(iqq)=0.d0
+ enddo
+ if(sy.le.sgap**2)goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
+ rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpl=qglegi(1.d0/xpomr,bb2,icdp,icz,1)
+ v1i0=qgpini(xpomr*sy,bb1,0.d0,0.d0,4)
+ v1i1=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,3))
+ v1i=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
+ v1ic0=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,7))
+ v1ic1=min(v1ic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,6))
+ v1ic=min(v1ic1,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
+ v1icn=min(v1i,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
+ vicn0=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,12))
+ vicn=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
+ vic0=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,10))
+ vic1=min(vic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
+ vicn=min(vicn,v1icn)
+ vic1=min(vicn,vic1)
+ do iqq=1,6
+ if(iqq.eq.1)then
+ dpx=vpl*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
+ elseif(iqq.eq.2)then
+ dpx=vpl*(v1i1-v1i0)
+ elseif(iqq.eq.3)then
+ dpx=vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
+ elseif(iqq.eq.4)then
+ dpx=vpl*(v1ic1-v1ic0)
+ elseif(iqq.eq.5)then
+ dpx=vpl*(vic1*exp(-2.d0*v1icn)-vic0)
+ elseif(iqq.eq.6)then
+ dpx=vpl*(.5d0*max(0.d0,1.d0-exp(-2.d0*v1icn)-2.d0*v1icn
+ * *exp(-2.d0*v1icn))+vicn*exp(-2.d0*v1icn)-vicn0)
+ else
+ dpx=0.d0
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+1 dlool=qglegi(sy,bb,icdp,icz,1)
+ do iqq=1,6
+ fann(iqq)=(fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ * +dlool)/(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
+ enddo
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
+ *,vvxpl,icdp,icz)
+c-----------------------------------------------------------------------
+c qgrev - zigzag contribution
+c sy - c.m. energy squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class,
+c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
+c vvxt = 1 - exp[-sum_j chi_targ(j)]
+c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
+c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
+c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgrev=0.d0
+ if(sy.lt..999d0*sgap**2)return
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
+ rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vvx=1.d0-(1.d0-vvxt)*(1.d0-vvxpl)
+ vpf=qgfani(1.d0/xpomr,bb2,vvx,0.d0,0.d0,icdp,icz,1)
+
+ viu=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
+ viloop=(1.d0-exp(-viu))
+ vim=2.d0*min(viu,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
+
+ if(vvxt.eq.0.d0)then
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf)
+ vvxtin=0.d0
+ vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
+ * -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
+ * *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
+
+ dpx=vi*(1.d0-exp(-vpf))
+ else
+ vpf0=min(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxp0,vvxpl,icdp,icz,3))
+ vpft=max(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxpt,vvxpl,icdp,icz,6))
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf0)
+ vvxtin=vvxt0
+ vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
+ * -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
+ * *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
+ if(vvxpt.eq.1.d0)then
+ dpx=vi*(1.d0-exp(-vpft))
+ else
+ dpx=vi*(1.d0-exp(-vpft)+((1.d0-vvxt)**2*(max(0.d0
+ * ,1.d0-exp(-vpft)*(1.d0+vpft))-max(0.d0,1.d0-exp(-vpf0)
+ * *(1.d0+vpf0))*(1.d0-vvxp0)/(1.d0-vvxpt))
+ * +vpft*((1.d0-vvxt)**2*exp(-vpft)-exp(-vpf0)*(1.d0-vvxpl)
+ * *(1.d0-vvxp0)/(1.d0-vvxpt)*(1.d0-vvxt0)**2)
+ * -vpf0*exp(-vpf0)*(1.d0-vvxp0)/(1.d0-vvxpt)*((1.d0-vvxt)**2
+ * -(1.d0-vvxpl)*(1.d0-vvxt0)**2))/(1.d0-(1.d0-vvxt)**2))
+ if(dpx.le.0.d0)dpx=vi*(1.d0-exp(-vpft))
+ endif
+ endif
+
+ qgrev=qgrev+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qgrev=qgrev/8.d0*pi*r3p/.0389d0/g3p**3
+ if(.not.(qgrev.gt.0.d0.and.qgrev.lt.1.d10))stop'qgrev=NAN'
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgrevi(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
+ *,vvxpl,icdp,icz)
+c-----------------------------------------------------------------------
+c qgrevi - zigzag contribution (interpolation)
+c sy - c.m. energy squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class,
+c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
+c vvxt = 1 - exp[-sum_j chi_targ(j)
+c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
+c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
+c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3),wj(3),wi(3),wm2(3),wm3(3),wm4(3)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
+ *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgrevi=0.d0
+ revm=0.d0
+ if(sy.le.sgap**2)return
+
+ rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
+ z=dexp(-bb/rp)
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=dlog(sy/sgap**2)/dlog(spmax/sgap**2)*10.d0+1.d0
+ k=max(1,int(1.00001d0*yl-1.d0))
+ k=min(k,9)
+ wk(2)=yl-k
+ if(yl.le.2.d0)then
+ iymax=2
+ wk(1)=1.d0-wk(2)
+ else
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+ endif
+
+ if(vvxt0.gt..99d0)then
+ j=11
+ wj(1)=1.d0
+ ivmax=1
+ i=1
+ wi(1)=1.d0
+ iv1max=1
+ else
+ vl=max(1.d0,vvxt0*10.d0+1.d0)
+ j=min(int(vl),9)
+ wj(2)=vl-dble(j)
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ ivmax=3
+
+ vl1=max(1.d0,(vvxt-vvxt0)/(1.d0-vvxt0)*5.d0+1.d0)
+ i=min(int(vl1),4)
+ wi(2)=vl1-dble(i)
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ iv1max=3
+ endif
+
+ if(icz.ne.2.or.vvxpt+vvxp0+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
+ ll=icz+(icz-1)*(3-icz)*2
+ do i1=1,iv1max
+ i2=i+i1-2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,ll,icdp)
+ * *wk(k1)*wz(l1)*wj(j1)*wi(i1)
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do i1=1,iv1max
+ i2=i+i1-2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ revm=revm+qrev(k2,1,j2+11*i2,ll,icdp)*wk(k1)*wj(j1)*wi(i1)
+ enddo
+ enddo
+ enddo
+ qgrevi=min(qgrevi,revm)
+ endif
+
+ else
+ vm2=max(1.d0,vvxpt*5.d0+1.d0)
+ m2=min(int(vm2),5)
+ wm2(2)=vm2-dble(m2)
+ wm2(1)=1.d0-wm2(2)
+ im2max=2
+
+ if(vvxpt.lt.1.d-2)then
+ m3=1
+ wm3(1)=1.d0
+ im3max=1
+ else
+ vm3=max(1.d0,vvxp0/vvxpt*5.d0+1.d0)
+ m3=min(int(vm3),5)
+ wm3(2)=vm3-dble(m3)
+ wm3(1)=1.d0-wm3(2)
+ im3max=2
+ endif
+
+ vm4=max(1.d0,vvxpl*5.d0+1.d0)
+ m4=min(int(vm4),5)
+ wm4(2)=vm4-dble(m4)
+ wm4(1)=1.d0-wm4(2)
+ im4max=2
+
+ do mn4=1,im4max
+ do mn3=1,im3max
+ do mn2=1,im2max
+ mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
+ do i1=1,iv1max
+ i2=i+i1-2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,mn,icdp)
+ * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do mn4=1,im4max
+ do mn3=1,im3max
+ do mn2=1,im2max
+ mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
+ do i1=1,iv1max
+ i2=i+i1-2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ revm=revm+qrev(k2,1,j2+11*i2,mn,icdp)
+ * *wk(k1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qgrevi=min(qgrevi,revm)
+ endif
+ endif
+ qgrevi=dexp(qgrevi)*z*dlog(sy/sgap**2)
+ **(1.d0-(1.d0-vvxt)**2)*(1.d0-vvxpt)
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgfan(sy,bb,vvx,icdp,icz,fann)
+c-----------------------------------------------------------------------
+c qgfan - integrated fan-contributions
+c sy - c.m. energy squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class
+c vvx = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
+c iqq=1 - general fan with loops
+c iqq=2 - general fan with single pomeron end
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ do iqq=1,2
+ fann(iqq)=0.d0
+ enddo
+ if(sy.le.sgap**2)goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpf1=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,2)
+ vpf=min(vpf1,qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1))
+ v1i1=qgpini(xpomr1*sy,bb1,0.d0,0.d0,3)
+ v1i=min(v1i1,qgpini(xpomr1*sy,bb1,0.d0,0.d0,2))
+ do iqq=1,2
+ if(iqq.eq.1)then
+ dpx=(1.d0-exp(-v1i))*(min(0.d0,1.d0-exp(-vpf)-vpf)
+ * *(1.d0-vvx)-vpf*vvx)
+ else
+ dpx=v1i1*(min(0.d0,1.d0-exp(-vpf)-vpf)*(1.d0-vvx)-vpf*vvx)
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+1 continue
+ do iqq=1,2
+ fann(iqq)=(fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ * +qglegi(sy,bb,icdp,icz,iqq+1))
+ * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
+ enddo
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgfanc(sy,bb,vvx,vvxp,vvxpl,icdp,icz,fann)
+c-----------------------------------------------------------------------
+c qgfan - cut fan-contributions
+c sy - c.m. energy squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class,
+c vvx = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
+c vvxp = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=1,2,3)
+c vvxp = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=4)
+c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)] (iqq=5-9)
+c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
+c iqq=1 - cut handle fan
+c iqq=2 - no rap-gap at the end
+c iqq=3 - single cut Pomeron end
+c iqq=4 - total fan-like contribution
+c iqq=5 - leg-like cut
+c iqq=6 - leg-like cut with cut handle
+c iqq=7 - single Pomeron cut
+c iqq=8 - leg-like cut with single cut Pomeron end
+c iqq=9 - leg-like cut without a rap-gap at the end
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ do iqq=1,9
+ fann(iqq)=0.d0
+ enddo
+ if(sy.le.sgap**2)goto 1
+
+ if(vvx.gt..999d0)then
+ vvxs=0.d0
+ else
+ vvxs=(1.d0-vvx)**2/(1.d0-vvxpl)
+ endif
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vi=qgpini(xpomr1*sy,bb1,0.d0,0.d0,2)
+ vicn=min(vi,qgpini(xpomr1*sy,bb1,0.d0,0.d0,8))
+ vicgap=min(vicn,qgpini(xpomr1*sy,bb1,0.d0,0.d0,11))
+ vic1p=min(vicgap,qgpini(xpomr1*sy,bb1,0.d0,0.d0,9))
+ vic1=min(vic1p,qgpini(xpomr1*sy,bb1,0.d0,0.d0,5))
+
+ vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
+ vpfc0=min(vpf
+ * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,3))
+ vpfct=max(vpf
+ * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,6))
+ vpf1p=min(vpf
+ * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,7))
+ vpf1p0=min(vpf1p
+ * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,8))
+ vpfc1=min(vpf1p0
+ * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,9))
+ do iqq=1,9
+ if(iqq.eq.1)then !cut handle
+ dpx=(1.d0-exp(-vi))
+ * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
+ * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
+ elseif(iqq.eq.2)then !no rap-gap at the end
+ dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
+ * +vicgap*exp(-2.d0*vicn))
+ * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
+ * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
+ elseif(iqq.eq.3)then !single cut Pomeron end
+ dpx=vic1p*exp(-2.d0*vicn)
+ * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
+ * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
+ elseif(iqq.eq.4)then !total fan-like contribution
+ dpx=(1.d0-exp(-vi))
+ * *((1.d0-vvxpl)*(min(0.d0,1.d0-exp(-vpfct)-vpfct)
+ * +vvxp*(exp(-vpfct)-exp(-vpf)))-vpfct*vvxpl)
+ elseif(iqq.eq.5)then !leg-like cut
+ dpx=(1.d0-exp(-vi))*vpf1p
+ * *((1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
+ elseif(iqq.eq.6)then !leg-like cut with cut handle
+ dpx=(1.d0-exp(-vi))
+ * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
+ * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
+ * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
+ elseif(iqq.eq.7)then !single Pomeron cut
+ dpx=vic1*exp(-2.d0*vicn)
+ * *vpfc1*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
+ elseif(iqq.eq.8)then !leg-like cut with single cut Pomeron end
+ dpx=vic1p*exp(-2.d0*vicn)
+ * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
+ * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
+ * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
+ elseif(iqq.eq.9)then !leg-like cut without a rap-gap at the end
+ dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
+ * +vicgap*exp(-2.d0*vicn))
+ * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
+ * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
+ * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
+ else
+ dpx=0.d0
+ endif
+ fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+1 continue
+ dfan=qglegi(sy,bb,icdp,icz,2)
+ dfangap=min(dfan,qglegi(sy,bb,icdp,icz,7))
+ dfan1p=min(dfangap,qglegi(sy,bb,icdp,icz,6))
+ dfanc1=min(dfan1p,qglegi(sy,bb,icdp,icz,4))
+ do iqq=1,9
+ fann(iqq)=fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
+ if(iqq.eq.2.or.iqq.eq.9)then
+ fann(iqq)=fann(iqq)+dfangap
+ elseif(iqq.eq.3.or.iqq.eq.8)then
+ fann(iqq)=fann(iqq)+dfan1p
+ elseif(iqq.eq.7)then
+ fann(iqq)=fann(iqq)+dfanc1
+ else
+ fann(iqq)=fann(iqq)+dfan
+ endif
+ fann(iqq)=fann(iqq)
+ * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
+ enddo
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgfani(sy,bb,vvx,vvxp,vvxpl
+ *,icdp,icz,iqq)
+c-----------------------------------------------------------------------
+c qgfani - integrated fan-contributions
+c sy - c.m. energy squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class,
+c vvx = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
+c vvxp=vvxpl=0 (iqq=1,2)
+c vvxp = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=3,4,5)
+c vvxp = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=6)
+c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)] (iqq=7-11)
+c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
+c uncut fans:
+c iqq=1 - general fan with loops
+c iqq=2 - general fan with single pomeron end
+c cut fans:
+c iqq=3 - cut handle fan
+c iqq=4 - no rap-gap at the end
+c iqq=5 - single cut Pomeron end
+c iqq=6 - total fan-like contribution
+c iqq=7 - leg-like cut
+c iqq=8 - leg-like cut with cut handle
+c iqq=9 - single Pomeron cut
+c iqq=10 - leg-like cut with single cut Pomeron end
+c iqq=11 - leg-like cut without a rap-gap at the end
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3),wj(3),wi(3),wn(3)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
+ *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgfani=0.d0
+ fanm=0.d0
+
+ if(sy.le.sgap**2)then
+ qgfani=qglegi(sy,bb,icdp,icz,1)
+ return
+ endif
+
+ rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
+ z=dexp(-bb/rp)
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=dlog(sy/sgap)/dlog(spmax/sgap)*50.d0+1.d0
+ k=max(1,int(1.00001d0*yl-1.d0))
+ k=min(k,49)
+ wk(2)=yl-k
+ if(yl.le.2.d0)then
+ iymax=2
+ wk(1)=1.d0-wk(2)
+ else
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+ endif
+
+ vl=max(1.d0,vvx*10.d0+1.d0)
+ if(vvx.eq.0.d0)then
+ ivmax=1
+ j=1
+ wj(1)=1.d0
+ else
+ j=min(int(vl),9)
+ wj(2)=vl-dble(j)
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ ivmax=3
+ endif
+
+ if(iqq.le.2)then
+ ii=icdp+2*(icz-1)
+ do j1=1,ivmax
+ j2=j+j1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgfani=qgfani+qfanu(k2,l2,j2,ii,iqq)
+ * *wk(k1)*wz(l1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,ivmax
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ fanm=fanm+qfanu(k2,1,j2,ii,iqq)*wk(k1)*wj(j1)
+ enddo
+ enddo
+ qgfani=min(qgfani,fanm)
+ endif
+
+ elseif(icz.ne.2.or.vvxp+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
+ ii=icdp+2*(iqq-3)
+ ll=icz+(icz-1)*(3-icz)*2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgfani=qgfani+qfanc(k2,l2,j2,ll,ii)*wk(k1)*wz(l1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,ivmax
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ fanm=fanm+qfanc(k2,1,j2,ll,ii)*wk(k1)*wj(j1)
+ enddo
+ enddo
+ qgfani=min(qgfani,fanm)
+ endif
+
+ else
+ iv1max=2
+ vl1=max(1.d0,vvxp*5.d0+1.d0)
+ i=min(int(vl1),5)
+ wi(2)=vl1-i
+ wi(1)=1.d0-wi(2)
+
+ if(vvx.lt..01d0)then !weak (no) screening
+ iv2max=1
+ n=1
+ wn(1)=1.d0
+ else !nuclear effects
+ iv2max=2
+ vl2=max(1.d0,vvxpl/vvx*5.d0+1.d0)
+ n=min(int(vl2),5)
+ wn(2)=vl2-n
+ wn(1)=1.d0-wn(2)
+ endif
+
+ ii=icdp+2*(iqq-3)
+ do n1=1,iv2max
+ n2=n+n1-2
+ do i1=1,iv1max
+ i2=i+i1+2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgfani=qgfani+qfanc(k2,l2,j2,i2+6*n2,ii)
+ * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wn(n1)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do n1=1,iv2max
+ n2=n+n1-2
+ do i1=1,iv1max
+ i2=i+i1+2
+ do j1=1,ivmax
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ fanm=fanm+qfanc(k2,1,j2,i2+6*n2,ii)
+ * *wk(k1)*wj(j1)*wi(i1)*wn(n1)
+ enddo
+ enddo
+ enddo
+ enddo
+ qgfani=min(qgfani,fanm)
+ endif
+ endif
+ qgfani=dexp(qgfani)*z
+ **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgdfan(xpomr,xpomr1,bb,icdp,fann,nn)
+c-----------------------------------------------------------------------
+c qgdfan - diffractive fans
+c xpomr - pomeron lc momentum,
+c xpomr1 - rapgap,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension fann(14),dps(3)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ icz=2
+ do iqq=1,3
+ fann(iqq)=0.d0
+ enddo
+
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
+ rp1=alfp*log(xpomr1/xpomr)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpf=qgfani(1.d0/xpomr1,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
+ v1i1=qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,3)
+ v1i=min(v1i1,qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,2))
+
+ do iqq=1,2
+ if(iqq.eq.1)then
+ dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2
+ else
+ dpx=v1i1*(1.d0-exp(-vpf))**2
+ endif
+ fann(iqq)=fann(iqq)+a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr2=xpomr1*(xpomr/xpomr1*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))
+ rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
+ rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
+ v1i=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2)
+ dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2/2.d0
+ fann(3)=fann(3)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ do iqq=1,3
+ fann(iqq)=fann(iqq)*(r3p*pi/.0389d0)/g3p**3/8.d0
+ enddo
+
+ if(nn.gt.1.and.xpomr1/xpomr.gt.sgap**2)then
+ do iqq=1,3
+ dps(iqq)=0.d0
+ enddo
+ do ix1=1,7
+ do mx1=1,2
+ xpomr2=xpomr1/sgap*(xpomr/xpomr1*sgap**2)
+ * **(.5d0+x1(ix1)*(mx1-1.5d0))
+ rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
+ rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
+ v1i1=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,3)
+ v1i=min(v1i1,qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2))
+ vpdf=qgdfani(xpomr2,xpomr1,bb2,icdp,1)
+ vpdfi=qgdfani(xpomr2,xpomr1,bb2,icdp,3)
+ do iqq=1,3
+ if(iqq.eq.1)then
+ dpx=(1.d0-exp(-v1i))*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
+ elseif(iqq.eq.2)then
+ dpx=v1i1*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
+ elseif(iqq.eq.3)then
+ dpx=(1.d0-exp(-v1i))*((exp(2.d0*vpdfi)-1.d0)*exp(-2.d0*vpf)
+ * -2.d0*vpdfi)/2.d0/dlog(xpomr1/xpomr/sgap)
+ endif
+ dps(iqq)=dps(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ do iqq=1,3
+ fann(iqq)=fann(iqq)+dps(iqq)*dlog(xpomr1/xpomr/sgap**2)
+ * *(r3p*pi/.0389d0)/g3p**3/8.d0
+ enddo
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgdfani(xpomr,xpomr1,bb,icdp,iqq)
+c-----------------------------------------------------------------------
+c qgfani - integrated fan-contributions
+c xpomr - pomeron lc momentum,
+c xpomr1 - rapgap,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icz - hadron class
+c iqq=1 - total unintegrated,
+c iqq=2 - single end unintegrated,
+c iqq=3 - total integrated
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3),wj(3)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
+ *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgdfani=0.d0
+ dfanm=0.d0
+ if(xpomr*sgap**2.gt.1.d0)return
+
+ icz=2
+ rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
+ z=dexp(-bb/rp)
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ if(xpomr*sgap**2.gt..9999d0)then
+ k=1
+ j=1
+ wk(1)=1.d0
+ wj(1)=1.d0
+ iymax=1
+ iy1max=1
+ else
+ yl=-dlog(xpomr*sgap**2)/dlog(1.d5/sgap**2)*20.d0+1.d0
+ k=max(1,int(1.00001d0*yl-1.d0))
+ k=min(k,19)
+ wk(2)=yl-k
+ if(yl.le.2.d0)then
+ iymax=2
+ wk(1)=1.d0-wk(2)
+ else
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+ endif
+
+ yl1=11.d0-dlog(xpomr1*sgap)/dlog(xpomr*sgap**2)*10.d0
+ j=max(1,int(yl1))
+ j=min(j,9)
+ wj(2)=yl1-dble(j)
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ iy1max=3
+ endif
+
+ do l1=1,izmax
+ l2=jz+l1-1
+ do j1=1,iy1max
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgdfani=qgdfani+qdfan(k2,j2,l2,icdp,iqq)
+ * *wk(k1)*wz(l1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,iy1max
+ j2=j+j1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ dfanm=dfanm+qdfan(k2,j2,1,icdp,iqq)*wk(k1)*wj(j1)
+ enddo
+ enddo
+ qgdfani=min(qgdfani,dfanm)
+ endif
+ qgdfani=dexp(qgdfani)*z
+ if(iqq.eq.3)qgdfani=qgdfani*max(0.d0,dlog(xpomr1/xpomr/sgap))
+ return
+ end
+
+c=============================================================================
+ double precision function qg3pom(sy,b,vvx,vvxp,vvxt
+ *,icdp,icdt,icz)
+c-----------------------------------------------------------------------
+c qg3pom - integrated 3p-contributions to the interaction eikonal
+c sy - pomeron mass squared,
+c b - impact parameter,
+c icdp - diffractive state for the projectile,
+c icdt - diffractive state for the target,
+c icz - hadron class
+c vvx = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
+c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
+c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgdebug/ debug
+ common /qgarr43/ moniou
+ common /arr3/ x1(7),a1(7)
+
+ qg3pom=0.d0
+ if(sy.le.sgap**2)return
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
+ rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ do ib1=1,7
+ do mb1=1,2
+ z=.5d0+x1(ib1)*(mb1-1.5d0)
+ bb0=-rp*dlog(z)
+ do ib2=1,7
+ do mb2=1,2
+ phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
+ bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
+ bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
+
+ v1p0=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
+ v1t0=qglegi(xpomr1*sy,bb2,icdt,2,1)
+ v1p1=min(v1p0,qglegi(1.d0/xpomr1,bb1,icdp,icz,3))
+ v1t1=min(v1t0,qglegi(xpomr1*sy,bb2,icdt,2,3))
+ v1p=min(v1p1,qglegi(1.d0/xpomr1,bb1,icdp,icz,2))
+ v1t=min(v1t1,qglegi(xpomr1*sy,bb2,icdt,2,2))
+
+ vpf0=min(v1p,qgfani(1.d0/xpomr1,bb1
+ * ,1.d0-(1.d0-vvx)*(1.d0-vvxt),0.d0,0.d0,icdp,icz,1))
+ vtf0=min(v1t,qgfani(xpomr1*sy,bb2
+ * ,1.d0-(1.d0-vvx)*(1.d0-vvxp),0.d0,0.d0,icdt,2,1))
+
+ n=1
+1 n=n+1
+ vpf=qgfani(1.d0/xpomr1,bb1
+ * ,1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf0),0.d0,0.d0,icdp,icz,1)
+ vtf=qgfani(xpomr1*sy,bb2
+ * ,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0),0.d0,0.d0,icdt,2,1)
+ if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
+ * then
+ vpf0=vpf
+ vtf0=vtf
+ goto 1
+ endif
+
+ dpx=(1.d0-vvx)*(min(0.d0,1.d0-exp(-vpf)-vpf)
+ * *min(0.d0,1.d0-exp(-vtf)-vtf)
+ * +vpf*min(0.d0,1.d0-exp(-vtf)-vtf)
+ * +vtf*min(0.d0,1.d0-exp(-vpf)-vpf))-vvx*vpf*vtf
+ * -.5d0*(vtf-v1t)*(min(0.d0,1.d0-exp(-vpf)-vpf)
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)
+ * -vpf*(1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)))
+ * -.5d0*(vpf-v1p)*(min(0.d0,1.d0-exp(-vtf)-vtf)
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
+ * -vtf*(1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)))
+ * +.5d0*(v1t-v1t1)*v1p0+.5d0*(v1p-v1p1)*v1t0
+ dpx=min(1.d0,dpx)
+
+ qg3pom=qg3pom+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qg3pom=qg3pom/8.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpcut(sy,b,vvx,vvxp,vvxt
+ *,icdp,icdt,icz)
+c-----------------------------------------------------------------------
+c qglool - integrated Pomeron leg eikonal with loops
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c vvx = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
+c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
+c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
+c icz - hadron class
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgpcut=0.d0
+ if(sy.le.sgap**2)return
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
+ rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ do ib1=1,7
+ do mb1=1,2
+ z=.5d0+x1(ib1)*(mb1-1.5d0)
+ bb0=-rp*dlog(z)
+ do ib2=1,7
+ do mb2=1,2
+ phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
+ bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
+ bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
+
+ vpl=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
+ vtl=qglegi(xpomr1*sy,bb2,icdt,2,1)
+ vpf0=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
+ * ,0.d0,0.d0,icdp,icz,1)
+ vtf0=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)
+ * ,0.d0,0.d0,icdt,2,1)
+
+ n=1
+1 n=n+1
+ vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
+ * *exp(-vtf0),0.d0,0.d0,icdp,icz,1)
+ vtf=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0)
+ * ,0.d0,0.d0,icdt,2,1)
+ if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
+ * then
+ vpf0=vpf
+ vtf0=vtf
+ goto 1
+ endif
+
+ vpls=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
+ * *exp(-vtf),vvxp,0.d0,icdp,icz,9)
+ vtls=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
+ * ,vvxt,0.d0,icdt,2,9)
+ vploop0=qglegi(1.d0/xpomr1,bb1,icdp,icz,5)
+ vploop=min(vploop0,qglegi(1.d0/xpomr1,bb1,icdp,icz,4))
+ vtloop0=qglegi(xpomr1*sy,bb2,icdt,2,5)
+ vtloop=min(vtloop0,qglegi(xpomr1*sy,bb2,icdt,2,4))
+
+ dpx=(vpls*vtloop+vtls*vploop)*(((1.d0-vvx)*(1.d0-vvxp)
+ * *(1.d0-vvxt))**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
+ * +vpl*(vtloop-vtloop0)+vtl*(vploop-vploop0)
+
+ qgpcut=qgpcut+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qgpcut=qgpcut/16.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpomi(sy,bb,vvx,vvxp,vvxt
+ *,icdp,icdt,icz,iqq)
+c-----------------------------------------------------------------------
+c qgpomi - integrated eikonal contributions
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c icdp - diffractive state for the projectile,
+c icdt - diffractive state for the target,
+c icz - projectile class
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3),wi(3),wj(3),wm(3)
+ common /qgarr10/ am(7),ammu
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr24/ qpomr(11,11,216,12,2)
+ common /qgdebug/ debug
+ common /qgarr43/ moniou
+
+ qgpomi=0.d0
+ pomm=0.d0
+ if(cd(icdp,icz).eq.0.d0.or.cd(icdt,2).eq.0.d0)return
+
+ rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
+ z=exp(-bb/rp)
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=dlog10((sy-am(2)**2-am(icz)**2)/2.d0/am(2))
+ k=max(1,int(yl))
+ k=min(k,9)
+ wk(2)=yl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ ml=icdp+2*(icdt-1)+4*(icz-1)
+ if(vvx+vvxp+vvxt.eq.0.d0)then !hadron-proton (no nucl. screening)
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,3
+ k2=k+k1-1
+ qgpomi=qgpomi+qpomr(k2,l2,1,ml,iqq)*wk(k1)*wz(l1)
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do k1=1,3
+ k2=k+k1-1
+ pomm=pomm+qpomr(k2,1,1,ml,iqq)*wk(k1)
+ enddo
+ qgpomi=min(qgpomi,pomm)
+ endif
+ else
+ vl=max(1.d0,vvx*5.d0+1.d0)
+ j=min(int(vl),4)
+ wj(2)=vl-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+
+ if(icz.ne.2.or.vvxp.eq.0.d0)then !hadron-nucleus (no proj. nucl. scr.)
+ i1max=1
+ i=1
+ wi(1)=1.d0
+ else
+ i1max=3
+ vl1=max(1.d0,vvxp*5.d0+1.d0)
+ i=min(int(vl1),4)
+ wi(2)=vl1-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ endif
+
+ vl2=max(1.d0,vvxt*5.d0+1.d0)
+ m=min(int(vl2),4)
+ wm(2)=vl2-m
+ wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
+ wm(1)=1.d0-wm(2)+wm(3)
+ wm(2)=wm(2)-2.d0*wm(3)
+
+ do m1=1,3
+ m2=m+m1-2
+ do i1=1,i1max
+ i2=i+i1-2
+ do j1=1,3
+ j2=j+j1-1
+ mij=j2+6*i2+36*m2
+ do l1=1,izmax
+ l2=jz+l1-1
+ do k1=1,3
+ k2=k+k1-1
+ qgpomi=qgpomi+qpomr(k2,l2,mij,ml,iqq)
+ * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm(m1)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do m1=1,3
+ m2=m+m1-2
+ do i1=1,i1max
+ i2=i+i1-2
+ do j1=1,3
+ j2=j+j1-1
+ mij=j2+6*i2+36*m2
+ do k1=1,3
+ k2=k+k1-1
+ pomm=pomm+qpomr(k2,1,mij,ml,iqq)*wk(k1)*wj(j1)*wi(i1)*wm(m1)
+ enddo
+ enddo
+ enddo
+ enddo
+ qgpomi=min(qgpomi,pomm)
+ endif
+ endif
+ qgpomi=exp(qgpomi)*z
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgppdi(xp,iqq)
+c-----------------------------------------------------------------------
+c qgppdi - parton distributions in the Pomeron
+c xp - parton LC momentum share,
+c iqq=0 - gluon
+c iqq=1 - sea quark
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)xp,iqq
+ if(xp.ge..9999999d0)then
+ qgppdi=0.d0
+ else
+ if(iqq.eq.0)then !gluon
+ qgppdi=(1.d0-xp)**betp*(1.d0-dgqq)
+ elseif(iqq.eq.1)then !quark
+ qgppdi=qgftlf(xp)*dgqq
+ endif
+ endif
+ if(debug.ge.4)write (moniou,202)qgppdi
+
+201 format(2x,'qgppdi - parton distr. in the Pomeron (interpol.):'
+ */4x,'xp=',e10.3,2x,'iqq=',i1)
+202 format(2x,'qgppdi=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgvpdf(x,icz)
+c-----------------------------------------------------------------------------
+c qgvpdf - valence quark structure function
+c x - Feinman x,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgvpdf=(qggrv(x,qt0,icz,1)+qggrv(x,qt0,icz,2))*(1.d0-x)**ahv(icz)
+ return
+ end
+
+c=============================================================================
+ double precision function qgspdf(x,icz)
+c-----------------------------------------------------------------------------
+c qgspdf - sea quark structure function
+c x - Feinman x,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgspdf=0.d0
+ if(x*sgap.ge.1.d0)goto 1
+
+ do icdp=1,2
+ rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
+ if(cd(icdp,icz).ne.0.d0)then
+ dps=0.d0
+ do ix=1,7
+ do mx=1,2
+ xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
+ v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
+ dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
+ * *qgftlf(x/xpomr)*(xpomr/x)**dels/z
+ enddo
+ enddo
+ enddo
+ enddo
+ qgspdf=qgspdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
+ * *dgqq*cc(icdp,icz)
+ endif
+ enddo
+
+1 qgspdf=qgspdf+4.*pi*rr*fp(icz)*qgftle(x,icz)/x**dels
+ return
+ end
+
+c=============================================================================
+ double precision function qggpdf(x,icz)
+c-----------------------------------------------------------------------------
+c qggpdf - gluon structure function (xg(x,qt0))
+c x - Feinman x,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qggpdf=0.d0
+ if(x*sgap.ge.1.d0)goto 1
+
+ do icdp=1,2
+ rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
+ if(cd(icdp,icz).ne.0.d0)then
+ dps=0.d0
+ do ix=1,7
+ do mx=1,2
+ xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
+ v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
+ dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
+ * *(1.d0-x/xpomr)**betp*(xpomr/x)**dels/z
+ enddo
+ enddo
+ enddo
+ enddo
+ qggpdf=qggpdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
+ * *(1.d0-dgqq)*cc(icdp,icz)
+ endif
+ enddo
+
+1 qggpdf=qggpdf+4.*pi*rr*fp(icz)*qgftld(x,icz)/x**dels
+ return
+ end
+
+c=============================================================================
+ double precision function qgpdfb(x,bb,icz,jj)
+c-----------------------------------------------------------------------------
+c qgpdfb - b-dependent parton momentum distributions (xf(x,b,qt0))
+c x - Feinman x,
+c icz - hadron class
+c jj=0 - g,
+c jj=1 - q
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgpdfb=0.d0
+ if(x*sgap.lt.1.d0)then
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ dps=0.d0
+ do ix=1,7
+ do mx=1,2
+ xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
+ rp1=alfp*dlog(xpomr/x)*4.d0*.0389d0
+ rp2=rp1*rp/(rp1+rp)
+ do ix2=1,7
+ do mx2=1,2
+ bb0=-rp2*log(.5d0+x1(ix2)*(mx2-1.5d0))
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ if(jj.eq.0)then
+ v1i=(1.d0-x/xpomr)**betp*(1.d0-dgqq)
+ else
+ v1i=qgftlf(x/xpomr)*dgqq
+ endif
+ v1p1=qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,2)
+ v1p=min(v1p1,qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,1))
+
+ dps=dps+a1(ix)*a1(ix2)*a1(ix3)*v1i
+ * *(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
+ * *(xpomr/x)**dels*rp/(rp1+rp)*exp(bb2/rp-bb/(rp1+rp))
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qgpdfb=qgpdfb-dps*dlog(x*sgap)*pi*rr*r3p/g3p**2/.0389d0/2.d0
+ * *cc(icdp,icz)
+ endif
+ enddo
+
+ do icdp=1,2
+ rp=(rq(icdp,icz)-alfp*dlog(x))*4.d0*.0389d0
+ if(jj.eq.0)then
+ qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftld(x,icz)/x**dels
+ * /rp*exp(-bb/rp)*cc(icdp,icz)
+ else
+ qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftle(x,icz)/x**dels
+ * /rp*exp(-bb/rp)*cc(icdp,icz)
+ endif
+ enddo
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpdfi(x,bb,icz,jj)
+c-----------------------------------------------------------------------
+c qgpdfi - b-dependent parton momentum distributions
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wz(3)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr20/ spmax
+ common /qgarr53/ qpdfb(51,11,3,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgpdfi=0.d0
+ rp=(rq(1,icz)-alfp*dlog(x))*4.d0*.0389d0
+ if(rp.le.1.d-10)then
+ z=1.d0
+ else
+ z=exp(-bb/rp)
+ endif
+ if(z.lt..2d0*exp(-10.d0))then
+ izmax=2
+ jz=1
+ wz(2)=5.d0*z*exp(10.d0)
+ wz(1)=1.d0-wz(2)
+ else
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(2,jz)
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=-dlog(x)/log(spmax)*50.d0+1.d0
+ k=max(1,int(yl))
+ k=min(k,49)
+ wk(2)=yl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ do j1=1,izmax
+ j2=jz+j1-1
+ do k1=1,3
+ k2=k+k1-1
+ qgpdfi=qgpdfi+qpdfb(k2,j2,icz,jj+1)*wk(k1)*wz(j1)
+ enddo
+ enddo
+ qgpdfi=exp(qgpdfi)*z*4.d0*rr*fp(icz)/x**dels/rp
+ if(jj.eq.0)then
+ qgpdfi=qgpdfi*qgftld(x,icz)
+ else
+ qgpdfi=qgpdfi*qgftle(x,icz)
+ endif
+ return
+ end
+
+c=============================================================================
+ double precision function qgdgdf(x,xpomr,icz,jj)
+c-----------------------------------------------------------------------------
+c qgdgdf - diffractive gluon pdf xpomr*g_d^3(x,xpomr,qt0)
+c x - Feinman x,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgdgdf=0.d0
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ dps=0.d0
+ if(jj.eq.1)then
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
+ dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
+ enddo
+ enddo
+ dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
+ * *(1.d0-x/xpomr)**betp*(1.d0-dgqq)*(xpomr/x)**dels
+
+ elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
+ vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
+ vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
+ vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
+ dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
+
+ dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
+ * *(1.d0-x/xpomr1)**betp*(xpomr1/x)**dels
+ enddo
+ enddo
+ enddo
+ enddo
+ dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
+ * *(1.d0-dgqq)*cc(icdp,icz)
+ endif
+ qgdgdf=qgdgdf+dps
+ endif
+ enddo
+ return
+ end
+
+c=============================================================================
+ double precision function qgdpdf(x,xpomr,icz,jj)
+c-----------------------------------------------------------------------------
+c qgdpdf - diffractive structure function
+c x - Feinman x,
+c icz - hadron class
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgdpdf=0.d0
+ do icdp=1,2
+ if(cd(icdp,icz).ne.0.d0)then
+ dps=0.d0
+ if(jj.eq.1)then
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
+ dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
+ enddo
+ enddo
+ dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
+ * *qgftlf(x/xpomr)*dgqq*(xpomr/x)**dels
+
+ elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
+ do ib=1,7
+ do mb=1,2
+ z=.5d0+x1(ib)*(mb-1.5d0)
+ bb=-rp*log(z)
+
+ vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
+ vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
+ vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
+ vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
+ dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
+
+ dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
+ * *qgftlf(x/xpomr1)*(xpomr1/x)**dels
+ enddo
+ enddo
+ enddo
+ enddo
+ dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
+ * *dgqq*cc(icdp,icz)
+ endif
+ qgdpdf=qgdpdf+dps
+ endif
+ enddo
+ qgdpdf=qgdpdf/4.5d0
+ return
+ end
+
+c=============================================================================
+ double precision function qgfsh(sy,bb,icdp,icdt,icz,iqq)
+c-----------------------------------------------------------------------------
+c qgfsh - semihard interaction eikonal
+c sy - pomeron mass squared,
+c bb - impact parameter squared,
+c icz - hadron class
+c iqq - type of the hard interaction (0-gg, 1-q_vg, 2-gq_v)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /arr3/ x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)sy,bb,iqq,icz
+
+ qgfsh=0.d0
+ s2min=4.d0*fqscal*qt0
+ xmin=s2min/sy
+ if(xmin.ge.1.d0)return
+ xmin=xmin**(delh-dels)
+ if(iqq.eq.1)then
+ icv=icz
+ icq=2
+ elseif(iqq.eq.2)then
+ icv=2
+ icq=icz
+ endif
+ if(debug.ge.3)write (moniou,205)xmin,iqq
+
+c numerical integration over z1
+ do i=1,7
+ do m=1,2
+ z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
+ * **(1.d0/(delh-dels))
+ ww=z1*sy
+ sjqq=qgjit(qt0,qt0,ww,2,2)
+ sjqg=qgjit(qt0,qt0,ww,1,2)
+ sjgg=qgjit(qt0,qt0,ww,1,1)
+ if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
+
+ if(iqq.eq.0)then
+ st2=0.d0
+ do j=1,7
+ do k=1,2
+ xx=.5d0*(1.d0+x1(j)*(2*k-3))
+ xp=z1**xx
+ xm=z1/xp
+ glu1=qgftld(xp,icz)
+ sea1=qgftle(xp,icz)
+ glu2=qgftld(xm,2)
+ sea2=qgftle(xm,2)
+ st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
+ * +sea1*sea2*sjqq)
+ enddo
+ enddo
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(z1)
+ qgfsh=qgfsh-a1(i)*dlog(z1)/z1**delh*st2
+ * *exp(-bb/(4.d0*.0389d0*rh))/rh
+
+ else
+ st2=0.d0
+ alh=.5d0+dels
+ xam=z1**alh
+
+ do j=1,7
+ do k=1,2
+ xp=(.5d0*(1.d0+xam+x1(j)*(2*k-3)*(1.d0-xam)))**(1.d0/alh)
+ xm=z1/xp
+ glu=qgftld(xm,icq)
+ sea=qgftle(xm,icq)
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm)
+
+ fst=(glu*sjqg+sea*sjqq)*(1.d0-xp)**ahv(icv)
+ * *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
+ * *exp(-bb/(4.d0*.0389d0*rh))/rh
+ st2=st2+a1(j)*fst
+ enddo
+ enddo
+ st2=st2*(1.d0-xam)/alh
+ qgfsh=qgfsh+a1(i)/z1**delh*st2
+ endif
+ enddo
+ enddo
+
+ if(iqq.eq.0)then
+ qgfsh=qgfsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*fp(2)*factk
+ * /2.d0*pi*cd(icdp,icz)*cd(icdt,2)
+ else
+ qgfsh=qgfsh*rr*fp(icq)*(1.d0-xmin)/(delh-dels)*factk/8.d0
+ * *cd(icdp,icz)*cd(icdt,2)
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgfsh
+201 format(2x,'qgfsh - semihard interaction eikonal:'
+ */4x,'sy=',e10.3,2x,'bb=',e10.3,2x,'iqq=',i1,2x,'icz=',i1)
+202 format(2x,'qgfsh=',e10.3)
+203 format(2x,'qgfsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
+205 format(2x,'qgfsh:',2x,'xmin=',e10.3,2x,'iqq=',i3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgftld(z,icz)
+c-----------------------------------------------------------------------------
+c qgftld - auxilliary function for semihard eikonals calculation -
+c (proportional to gluon sf: g(z)*z^(1+dels)) -
+c integration over semihard block light cone momentum share x
+c z - x-cutoff from below,
+c icz - type of the hadron to which the semihard block is connected
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)z,icz
+
+ qgftld=0.d0
+ xpmin=z**(1.d0+dels)
+ do i1=1,7
+ do m1=1,2
+ tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
+ * **(1.d0/(1.d0+ahl(icz)))
+ xp=tp**(1.d0/(1.d0+dels))
+ qgftld=qgftld+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
+ * *(1.d0-z/xp)**betp
+ enddo
+ enddo
+ qgftld=qgftld*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
+ */(ahl(icz)+1.d0)/(1.d0+dels)*(1.d0-dgqq)
+
+ if(debug.ge.3)write (moniou,202)qgftld
+201 format(2x,'qgftld:',2x,'z=',e10.3,2x,'icz=',i1)
+202 format(2x,'qgftld=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgftle(z,icz)
+c-----------------------------------------------------------------------
+c qgftle - auxilliary function for semihard eikonals calculation
+c (proportional to sea quark sf: q_s(z)*z^(1+dels)) -
+c integration over semihard pomeron light cone momentum share x
+c z - light cone x of the quark,
+c icz - type of the hadron to which the semihard block is connected
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)z,icz
+
+ qgftle=0.d0
+ xpmin=z**(1.d0+dels)
+ do i1=1,7
+ do m1=1,2
+ tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
+ * **(1.d0/(1.d0+ahl(icz)))
+ xp=tp**(1.d0/(1.d0+dels))
+ qgftle=qgftle+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
+ * *qgftlf(z/xp)
+ enddo
+ enddo
+ qgftle=qgftle*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
+ */(ahl(icz)+1.d0)/(1.d0+dels)*dgqq
+
+ if(debug.ge.3)write (moniou,202)qgftle
+201 format(2x,'qgftle:',2x,'z=',e10.3,2x,'icz=',i1)
+202 format(2x,'qgftle=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgftlf(zz)
+c-----------------------------------------------------------------------
+c qgftlf - auxilliary function for semihard eikonals calculation
+c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
+c integration over quark to gluon light cone momentum ratio (z=x/x_G):
+c qgftlf=int(dz) z^dels * (1-zz/z)^betp * P_qG(z)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)zz
+201 format(2x,'qgftlf:',2x,'zz=',e10.3)
+
+ qgftlf=0.d0
+ zmin=zz**(1.d0+dels)
+ do i=1,7
+ do m=1,2
+ z=(.5d0*(1.d0+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))**(1.d0/
+ * (1.d0+dels))
+ qgftlf=qgftlf+a1(i)*max(1.d-9,(1.d0-zz/z))**betp
+ * *(z**2+(1.d0-z)**2)
+ enddo
+ enddo
+ qgftlf=qgftlf*1.5d0*(1.d0-zmin)/(1.d0+dels) !1.5=naflav/2 at Q0
+
+ if(debug.ge.3)write (moniou,202)qgftlf
+202 format(2x,'qgftlf=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgfz(b,gz,iddp1,iddp2)
+c----------------------------------------------------------------------------
+c hadron-hadron and hadron-nucleus cross sections calculation
+c----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension gz(5),wt1(3),wt2(3)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /arr3/ x1(7),a1(7)
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)b,iddp1,iddp2
+ do l=1,5
+ gz(l)=0.d0
+ enddo
+ rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0
+ g0=0.d0
+ if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then
+ g0=pi*rp*10.d0 !normalization factor (in mb)
+ bm=2.d0*dsqrt(rp) !impact parameter for exp. fall-down
+ endif
+
+ do i1=1,7
+ do m=1,2
+ z=.5d0+x1(i1)*(m-1.5d0)
+ bb1=rp*z
+ bb2=rp*(1.d0-dlog(z))
+
+ do l=1,3
+ wt1(l)=0.d0
+ wt2(l)=0.d0
+ enddo
+
+ if(ia(2).eq.1)then
+ do idd1=1,2
+ do idd2=1,2
+ vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
+ vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
+
+ do l=1,2
+ wt1(l)=wt1(l)+cc(idd1,icz)*cc(idd2,2)*vv1**l
+ wt2(l)=wt2(l)+cc(idd1,icz)*cc(idd2,2)*vv2**l
+ enddo
+ do idd3=1,2
+ wt1(3)=wt1(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv1
+ * *exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
+ wt2(3)=wt2(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv2
+ * *exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
+ enddo
+ enddo
+ enddo
+ do l=1,2
+ gz(l)=gz(l)+a1(i1)*((1.d0-wt1(l))+(1.d0-wt2(l))/z)
+ enddo
+ gz(3)=gz(3)+a1(i1)*((wt1(2)-wt1(3))+(wt2(2)-wt2(3))/z)
+ gz(4)=gz(4)+a1(i1)*((wt1(3)-wt1(1)**2)+(wt2(3)-wt2(1)**2)/z)
+ gz(5)=gz(5)+a1(i1)*((1.d0-wt1(1))*z+(1.d0-wt2(1))/z*(1.-log(z)))
+
+ else
+ do idd1=1,2
+ do idd2=1,2
+ vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
+ * -qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
+ vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
+ * -qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
+
+ if(idd1.eq.idd2)then
+ wt1(1)=wt1(1)+cc(idd1,2)*vv1
+ wt2(1)=wt2(1)+cc(idd1,2)*vv2
+ endif
+ wt1(2)=wt1(2)+cc(idd1,2)*cc(idd2,2)*vv1
+ wt2(2)=wt2(2)+cc(idd1,2)*cc(idd2,2)*vv2
+ enddo
+ enddo
+ cg1=qgrot(b,dsqrt(bb1))
+ cg2=qgrot(b,dsqrt(bb2))
+ do l=1,2
+ gz(l)=gz(l)+a1(i1)*(cg1*(1.d0-wt1(l))+cg2*(1.d0-wt2(l))/z)
+ enddo
+ endif
+ enddo
+ enddo
+ if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then !hadron-proton
+ do l=1,5
+ gz(l)=gz(l)*g0
+ enddo
+ gz(5)=gz(5)/gz(1)*(rq(1,icz)+rq(1,2)+alfp*log(scm))*2.d0
+ endif
+
+ if(debug.ge.2)write (moniou,203)gz
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgfz - hadronic cross-sections calculation'
+ */4x,'b=',e10.3,2x,'iddp=',2i3)
+202 format(2x,'qgfz - end')
+203 format(2x,'qgfz: gz=',5e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qghard(sy,bb,icdp,icdt,icz)
+c-----------------------------------------------------------------------------
+c qghard - hard quark-quark interaction cross-section
+c s - energy squared for the interaction (hadron-hadron),
+c icz - type of the primaty hadron (nucleon)
+c----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /arr3/ x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)sy,icz
+
+ qghard=0.d0
+ s2min=4.d0*fqscal*qt0
+ xmin=s2min/sy
+ if(xmin.ge.1.d0)return
+ xmin=xmin**(delh+.5d0)
+
+c numerical integration over z1
+ do i=1,7
+ do m=1,2
+ z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
+ * **(1.d0/(delh+.5d0))
+
+ st2=0.d0
+ do j=1,7
+ do k=1,2
+ xx=.5d0*(1.d0+x1(j)*(2*k-3))
+ xp=z1**xx
+ xm=z1/xp
+ st2=st2+a1(j)*(1.d0-xp)**ahv(icz)*(1.d0-xm)**ahv(2)
+ * *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
+ * *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/dsqrt(z1)
+ enddo
+ enddo
+ sj=qgjit(qt0,qt0,z1*sy,2,2)
+ st2=-st2*dlog(z1)*sj
+ if(debug.ge.3)write (moniou,203)z1*sy,sj
+
+ qghard=qghard+a1(i)/z1**delh*st2
+ enddo
+ enddo
+ qghard=qghard*(1.d0-xmin)/(.5d0+delh)*.25d0*factk
+ rh=rq(icdp,icz)+rq(icdt,2)
+ qghard=qghard/(8.d0*pi*rh)*exp(-bb/(4.d0*.0389d0*rh))
+ **cd(icdp,icz)*cd(icdt,2)
+
+ if(debug.ge.2)write (moniou,202)qghard
+201 format(2x,'qghard - hard quark-quark interaction eikonal:'
+ */2x,'s=',e10.3,2x,'icz=',i1)
+202 format(2x,'qghard=',e10.3)
+203 format(2x,'qghard:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgbdef(bba,bbb,xxa,yya,xxb,yyb,xxp,yyp,jb)
+c-----------------------------------------------------------------------
+c qgbdef - defines coordinates (xxp,yyp) of a multi-pomeron vertex
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ xx=xxa-xxb
+ yy=yya-yyb
+ bb=xx**2+yy**2
+ if(bb.lt.1.d-5)then
+ xxp=xxb+dsqrt(bba)
+ yyp=yyb
+ elseif(abs(yy).lt.1.d-8)then
+ xxp=(bba-bbb+xxb**2-xxa**2)/2.d0/(xxb-xxa)
+ yyp=yyb+(2*jb-3)*dsqrt(max(0.d0,bbb-(xxb-xxp)**2))
+ else
+ bbd=bb+bbb-bba
+ discr=max(0.d0,4.d0*bb*bbb-bbd**2)
+ xxp=(xx*bbd+(2*jb-3)*abs(yy)*dsqrt(discr))/2.d0/bb
+ yyp=(bbd-2.d0*xx*xxp)/2.d0/yy
+ xxp=xxp+xxb
+ yyp=yyp+yyb
+ endif
+ return
+ end
+
+c=============================================================================
+ subroutine qgv(x,y,xb,vin,vdd,vabs)
+c xxv - eikonal dependent factor for hadron-nucleus interaction
+c (used for total and diffractive hadron-nucleus cross-sections calculation)
+c----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension xb(iapmax,3),vabs(2)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)x,y
+
+ vin=0.d0
+ vdd=0.d0
+ do iddp1=1,2
+ dv=0.d0
+ do m=1,ia(2)
+ bb=(x-xb(m,1))**2+(y-xb(m,2))**2
+ dv=dv+qgpomi(scm,bb,0.d0,0.d0,0.d0,iddp1,iddt(m),icz,1)
+ enddo
+ dv=exp(-dv)
+ vabs(iddp1)=1.d0-dv**2 !1-exp(-2 * chi_i)
+ vdd=vdd+cc(iddp1,icz)*dv**2 !sum_i cc(i) exp(-2 * chi_i)
+ vin=vin+cc(iddp1,icz)*dv !sum_i cc(i) exp(-chi_i)
+ enddo
+ vin=1.d0-vin**2 !1-sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
+ vdd=vdd+vin-1.d0
+ !sum_i cc(i) exp(-2*chi_i) - sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
+
+ if(debug.ge.3)write (moniou,202)vin,vdd,vabs
+201 format(2x,'qgv - eikonal factor: nucleon coordinates x='
+ * ,e10.3,2x,'y=',e10.3)
+202 format(2x,'vin=',e10.3,2x,'vdd=',e10.3,2x,'vabs=',2e10.3)
+ return
+ end
+
+
+c=============================================================================
+ subroutine qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt
+ * ,vvxpl,vvxtl,ip,it)
+c-----------------------------------------------------------------------
+c qgfdf - configuration of fan contributions (cut and uncut fans)
+c xxp, yyp - coordinates of the multi-Pomeron vertex,
+c xpomr - LC momentum share of the multi-Pomeron vertex,
+c ip - proj. index,
+c it - targ. index
+c vvx = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
+c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
+c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
+c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
+c vvxtl = 1 - exp[-sum_{j<J} chi_targ(j)]
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension vpac(iapmax),vtac(iapmax)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
+ *,iconb(iapmax)
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)xxp,yyp,xpomr,ip,it
+
+ vvx=0.d0
+ vvxp=0.d0
+ vvxt=0.d0
+ vvxpl=0.d0
+ vvxtl=0.d0
+ if(scm.le.sgap**2)return
+
+ sumup0=0.d0 !proj. fans without targ. screening
+ do ipp=1,ia(1)
+ if(iconab(ipp,it).eq.0)then !no connection
+ !(nucleon too far from the vertex)
+ vpac(ipp)=0.d0
+ else
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup0),0.d0,0.d0
+ * ,iddp(ipp),icz,1)
+ sumup0=sumup0+vpac(ipp)
+ endif
+ enddo
+
+ sumut0=0.d0 !targ. fans without proj. screening
+ do itt=1,ia(2)
+ if(iconab(ip,itt).eq.0)then !no connection
+ vtac(itt)=0.d0
+ else
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut0),0.d0,0.d0
+ * ,iddt(itt),2,1)
+ sumut0=sumut0+vtac(itt)
+ endif
+ enddo
+
+ nn=0
+1 nn=nn+1
+ sumup=0.d0 !proj. fans with targ. screening
+ do ipp=1,ia(1)
+ if(iconab(ipp,it).eq.0)then !no connection
+ vpac(ipp)=0.d0
+ else
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup-sumut0)
+ * ,0.d0,0.d0,iddp(ipp),icz,1)
+ sumup=sumup+vpac(ipp)
+ endif
+ enddo
+
+ sumut=0.d0 !targ. uncut fans with proj. screening
+ do itt=1,ia(2)
+ if(iconab(ip,itt).eq.0)then
+ vtac(itt)=0.d0
+ else
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut-sumup0)
+ * ,0.d0,0.d0,iddt(itt),2,1)
+ sumut=sumut+vtac(itt)
+ endif
+ enddo
+
+ if((abs(sumup-sumup0).gt..01d0.or.abs(sumut-sumut0).gt..01d0)
+ *.and.nn.lt.100)then
+ sumup0=sumup
+ sumut0=sumut
+ goto 1
+ endif
+
+ if(ia(1).gt.1)then
+ do ipp=1,ia(1)
+ if(ipp.lt.ip)then
+ vvxpl=vvxpl+vpac(ipp)
+ elseif(ipp.gt.ip)then
+ vvxp=vvxp+vpac(ipp)
+ endif
+ enddo
+ endif
+
+ if(ia(2).gt.1)then
+ do itt=1,ia(2)
+ if(itt.lt.it)then
+ vvxtl=vvxtl+vtac(itt)
+ elseif(itt.gt.it)then
+ vvxt=vvxt+vtac(itt)
+ endif
+ enddo
+ endif
+ vvx=1.d0-exp(-vvxpl-vvxtl)
+ vvxp=1.d0-exp(-vvxp)
+ vvxpl=1.d0-exp(-vvxpl)
+ vvxt=1.d0-exp(-vvxt)
+ vvxtl=1.d0-exp(-vvxtl)
+ if(debug.ge.4)write (moniou,202)
+
+201 format(2x,'qgfdf - configuration of fan contributions:'
+ */2x,'xxp=',e10.3,2x,'yyp=',e10.3,2x,'xpomr=',e10.3
+ *,2x,'ip=',i3,2x,'it=',i3)
+202 format(2x,'qgfdf - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qgconf
+c-----------------------------------------------------------------------------
+c interaction (cut Pomeron) configuration:
+c b - impact parameter,
+c xa(1-iap,3), xb(1-iat,3) - proj. and targ. nucleon coordinates,
+c iddp(1-iap), iddt(1-iat) - proj. and targ. nucleon diffractive eigenstates,
+c icona(1-iap) - connection for proj. nucleons (0 if too far from the target),
+c iconab(1-iap,1-iat) - connection for proj.-targ. nucleons (0 if too far from
+c each other),
+c nwp, nwt - numbers of wounded proj. and targ. nucleons (inelastic or diff.),
+c iwp(1-iap), iwt(1-iat) - indexes for wounded proj. and targ. nucleons
+c (0 - intact, 1 - inel., 2,3 - diffr., -1 - recoiled from diffraction),
+c ncola(1-iap), ncolb(1-iat) - index for inel.-wounded proj. and targ. nucleons,
+c nbpom - total number of Pomeron blocks,
+c ias(k) (ibs(k)) - index of the proj. (targ.) nucleon for k-th Pomeron block,
+c bbpom(k) - squared impact parameter (between proj. and targ.) for k-th block,
+c vvxpom(k) - relative strenth of A-screening corrections for k-th block,
+c nqs(k) - number of single Pomerons in k-th block (without cut 3P-vertexes),
+c npompr(k) - number of proj. leg Pomerons in k-th block,
+c npomtg(k) - number of targ. leg Pomerons in k-th block,
+c npomin(k) - number of interm. Pomerons (between 2 3P-vertexes) in k-th block,
+c xpopin(n,k) - LC momentum of the upper 3P-vertex for n-th interm. Pomeron
+c in k-th block,
+c xpomin(n,k) - LC momentum of the lower 3P-vertex for n-th interm. Pomeron
+c in k-th block,
+c nnpr(i,k) - proj. participant index for i-th single Pomeron in k-th block,
+c nntg(i,k) - targ. participant index for i-th single Pomeron in k-th block,
+c ilpr(i,k) - proj. index for i-th proj. leg Pomeron in k-th block,
+c iltg(i,k) - proj. index for i-th targ. leg Pomeron in k-th block,
+c lnpr(i,k) - proj. participant index for i-th proj. leg Pomeron in k-th block,
+c lntg(i,k) - targ. participant index for i-th targ. leg Pomeron in k-th block,
+c lqa(ip) - number of cut Pomerons connected to ip-th proj. nucleon (hadron),
+c lqb(it) - number of cut Pomerons connected to it-th targ. nucleon (hadron),
+c nbpi(n,ip) - block index for n-th Pomeron connected to ip-th proj. nucleon,
+c nbti(n,it) - block index for n-th Pomeron connected to it-th targ. nucleon,
+c idnpi(n,ip) - type of n-th Pomeron (0 - single, 1 - leg) connected to ip-th
+c proj. nucleon,
+c idnti(n,it) - type of n-th Pomeron (0 - single, 1 - leg) connected to it-th
+c targ. nucleon,
+c nppi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
+c nucleon (for single Pomerons),
+c npti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
+c nucleon (for single Pomerons),
+c nlpi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
+c nucleon (for leg Pomerons),
+c nlti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
+c nucleon (for leg Pomerons),
+c iprcn(ip) - index of the recoiled targ. nucleon for ip-th proj. nucleon
+c (undergoing diffraction),
+c itgcn(it) - index of the recoiled proj. nucleon for it-th targ. nucleon
+c (undergoing diffraction),
+c bpompr(n,ip) - squared impact parameter for n-th leg Pomeron connected
+c to ip-th proj. nucleon,
+c bpomtg(n,it) - squared impact parameter for n-th leg Pomeron connected
+c to it-th targ. nucleon,
+c vvxpr(n,ip) - relative strenth of A-screening corrections for n-th leg
+c Pomeron connected to ip-th proj. nucleon,
+c vvxtg(n,it) - relative strenth of A-screening corrections for n-th leg
+c Pomeron connected to it-th targ. nucleon,
+c xpompr(n,ip) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
+c to ip-th proj. nucleon,
+c xpomtg(n,it) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
+c to it-th targ. nucleon
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
+ dimension xas(iapmax,3),vabs(2),vabsi(2,iapmax),wdifi(iapmax)
+ *,vpac(iapmax),vtac(iapmax),xpomip(npmax),xpomim(npmax)
+ *,vvxim(npmax),bpomim(npmax),xpompi(legmax),xpomti(legmax)
+ *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
+ *,ipompi(legmax),ipomti(legmax),ncola(iapmax),ncolb(iapmax)
+ *,wdp(2,iapmax),wdt(2,iapmax),wabs(2,2),xrapmin(100),xrapmax(100)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr4/ ey0(3)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
+ *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
+ *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
+ *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
+ *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
+ *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
+ *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
+ *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
+ common /qgarr10/ am(7),ammu
+ common /qgarr11/ b10
+ common /qgarr12/ nsp
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
+ *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
+ *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
+ *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
+ *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
+ *,bpomin(npmax,npbmax)
+ common /qgarr43/ moniou
+ common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
+ *,iconb(iapmax)
+ common /qgarr55/ nwt,nwp !N of wounded targ.(proj.) nucleons
+ common /qgarr56/ nspec,nspect !N of spectators targ.(proj.) nucleons
+ common /qgdebug/ debug
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+ common/jdiff/bdiff,jdiff !for external use: impact parameter
+ !for diffraction, diffraction type
+ctp from epos
+ integer ng1evt,ng2evt,ikoevt
+ real rglevt,sglevt,eglevt,fglevt,typevt
+ common/c2evt/ng1evt,ng2evt,rglevt,sglevt,eglevt,fglevt,ikoevt
+ *,typevt !in epos.inc
+
+ external qgran
+
+ if(debug.ge.1)write (moniou,201)
+ nsp=0
+ nsf=0
+ nsp0=nsp
+
+c initialization
+1 continue
+ do i=1,ia(1)
+ iddp(i)=1+int(qgran(b10)+cc(2,icz)) !diffractive eigenstates for proj.
+ enddo
+ do i=1,ia(2)
+ iddt(i)=1+int(qgran(b10)+cc(2,2)) !diffractive eigenstates for targ.
+ enddo
+
+c-------------------------------------------------
+c squared impact parameter is sampled uniformly (b**2<bm**2)
+ b=bm*dsqrt(qgran(b10))
+ if(debug.ge.1)write (moniou,202)b
+
+ if(bmaxnex.ge.0.d0)then !used to link with nexus
+ b1=bminnex
+ b2=min(bm,bmaxnex)
+ if(b1.gt.b2)stop'bmin > bmax in qgsjet'
+ b=dsqrt(b1*b1+(b2*b2-b1*b1)*qgran(b10))
+ bqgs=b
+ endif
+
+c-------------------------------------------------
+c nuclear configurations
+ if(debug.ge.1)write (moniou,203)
+ if(ia(1).gt.1)then !projectile nucleon coordinates
+ call qggea(ia(1),xa,1) !xa(n,i), i=1,2,3 - x,y,z for n-th nucleon
+ else
+ do i=1,3
+ xa(1,i)=0.d0 !projectile hadron
+ enddo
+ endif
+ if(ia(2).gt.1)then !target nucleon coordinates
+ call qggea(ia(2),xb,2) !xb(n,i), i=1,2,3 - x,y,z for n-th nucleon
+ else
+ do i=1,3
+ xb(1,i)=0.d0 !target proton
+ enddo
+ endif
+
+c-------------------------------------------------
+c check connections
+ if(debug.ge.1)write (moniou,204)
+ do it=1,ia(2)
+ iconb(it)=0
+ enddo
+
+ do ip=1,ia(1)
+ icdp=iddp(ip)
+ icona(ip)=0
+ do it=1,ia(2)
+ icdt=iddt(it)
+ bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
+ vv1p=qgpomi(scm,bbp,0.d0,0.d0,0.d0,icdp,icdt,icz,1)
+ if(vv1p.gt.1.d-3)then
+ if(debug.ge.2)write (moniou,205)ip,it
+ iconab(ip,it)=1
+ icona(ip)=1
+ iconb(it)=1
+ if(debug.ge.2)write (moniou,206)ip
+ if(debug.ge.2)write (moniou,207)it
+ else
+ iconab(ip,it)=0
+ endif
+ enddo
+ enddo
+
+ nrej=0
+2 nrej=nrej+1
+ if(debug.ge.2)write (moniou,208)nrej
+ if(nrej.gt.10)then
+ if(debug.ge.1)write (moniou,209)
+ goto 1
+ endif
+ nsp=nsp0
+ nbpom=0
+ nwp=0
+ nwt=0
+ do i=1,ia(1)
+ lqa(i)=0
+ iwp(i)=0
+ ncola(i)=0
+ wdp(1,i)=0.d0
+ wdp(2,i)=0.d0
+ enddo
+ do i=1,ia(2)
+ lqb(i)=0
+ iwt(i)=0
+ ncolb(i)=0
+ wdt(1,i)=0.d0
+ wdt(2,i)=0.d0
+ enddo
+ nqs(1)=0
+ npomin(1)=0
+ npompr(1)=0
+ npomtg(1)=0
+
+c-------------------------------------------------
+c Pomeron configuration
+ if(debug.ge.1)write (moniou,210)
+ do 4 ip=1,ia(1) !loop over all projectile nucleons
+ if(debug.ge.2)write (moniou,211)ip
+ if(icona(ip).eq.0)goto 4
+ x=xa(ip,1)+b !proj. x is shifted by the impact parameter b
+ y=xa(ip,2)
+ icdp=iddp(ip) !diffr. eigenstate for ip
+
+ do 3 it=1,ia(2) !loop over all target nucleons
+ if(debug.ge.2)write (moniou,212)it
+ if(iconab(ip,it).eq.0)goto 3
+ icdt=iddt(it) !diffr. eigenstate for it
+ bbp=(x-xb(it,1))**2+(y-xb(it,2))**2 !distance squared between ip, it
+
+c calculate nuclear screening factors for "middle point" -> eikonals
+ xpomr=1.d0/dsqrt(scm)
+ xxp=.5d0*(x+xb(it,1))
+ yyp=.5d0*(y+xb(it,2))
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ * ,ip,it)
+ vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
+ vv1p=min(vv,qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,2)) !1P-eikonal
+ if(debug.ge.2)write (moniou,213)vv,vv1p
+
+ if(qgran(b10).gt.1.d0-exp(-2.d0*vv))goto 3 !1.-exp(-2*vv) - probability
+ !for inelastic interaction
+ iwt(it)=1
+ iwp(ip)=1
+ ncola(ip)=ncola(ip)+1 !N of binary collisions for ip
+ ncolb(it)=ncolb(it)+1 !N of binary collisions for it
+
+ n=npgen(2.d0*vv,1,50) !number of elem. inter. for (ip-it) collision
+ nbpom=nbpom+1 !new Pomeron block
+ if(nbpom.gt.npbmax)then
+ goto 2
+ endif
+ ias(nbpom)=ip !proj. index for current elementary interaction
+ ibs(nbpom)=it !targ. index for current elementary interaction
+ bbpom(nbpom)=bbp !distance squared between ip, it
+ vvxpom(nbpom)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
+ if(debug.ge.2)write (moniou,214)nbpom,ip,it,n
+
+ nqs(nbpom)=0
+ npomin(nbpom)=0
+ npompr(nbpom)=0
+ npomtg(nbpom)=0
+ do i=1,n
+ if(qgran(b10).lt.vv1p/vv.or.scm.le.sgap**2)then !single Pomeron
+ if(debug.ge.2)write (moniou,215)i
+ np=nqs(nbpom)+1
+ if(np.gt.legmax)then
+ goto 2
+ endif
+ nqs(nbpom)=np !update Pomeron number in the block
+ l0=lqa(ip)+1
+ if(l0.gt.npnmax)then
+ goto 2
+ endif
+ lqa(ip)=l0 !update number of connections for proj.
+ nnpr(np,nbpom)=l0 !index for connected proj. participant
+ nbpi(l0,ip)=nbpom
+ idnpi(l0,ip)=0
+ nppi(l0,ip)=np
+ l0=lqb(it)+1
+ if(l0.gt.npnmax)then
+ goto 2
+ endif
+ lqb(it)=l0
+ nntg(np,nbpom)=l0 !index for connected targ. participant
+ nbti(l0,it)=nbpom
+ idnti(l0,it)=0
+ npti(l0,it)=np
+
+ else !multi-Pomeron vertex
+ if(debug.ge.2)write (moniou,219)
+ call qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti,xpomip
+ * ,xpomim,vvxim,bpomim,npompi,npomti,npin,ipompi,ipomti
+ * ,wdp,wdt,ip,it,iret)
+ if(iret.ne.0)goto 2
+
+ if(npin.ne.0)then
+ if(debug.ge.2)write (moniou,220)i,npin
+ npomin(nbpom)=npomin(nbpom)+npin
+ if(npomin(nbpom).gt.npmax)then
+ goto 2
+ endif
+ do l=1,npin
+ l1=npomin(nbpom)+l-npin
+ xpopin(l1,nbpom)=xpomip(l)
+ xpomin(l1,nbpom)=xpomim(l)
+ vvxin(l1,nbpom)=vvxim(l)
+ bpomin(l1,nbpom)=bpomim(l)
+ enddo
+ endif
+ if(npompi.ne.0)then
+ if(debug.ge.2)write (moniou,221)i,npompi
+ do m=1,npompi
+ np=npompr(nbpom)+1
+ if(np.gt.legmax)then
+ goto 2
+ endif
+ npompr(nbpom)=np
+ ipp=ipompi(m)
+ iwp(ipp)=1
+ ilpr(np,nbpom)=ipp
+ l0=lqa(ipp)+1
+ if(l0.gt.npnmax)then
+ goto 2
+ endif
+ lqa(ipp)=l0
+ lnpr(np,nbpom)=l0
+ nbpi(l0,ipp)=nbpom
+ idnpi(l0,ipp)=1
+ nlpi(l0,ipp)=np
+ vvxpr(l0,ipp)=vvxpi(m)
+ xpompr(l0,ipp)=1.d0/xpompi(m)/scm
+ bpompr(l0,ipp)=bpompi(m)
+ enddo
+ endif
+ if(npomti.ne.0)then
+ if(debug.ge.2)write (moniou,222)i,npomti
+ do m=1,npomti
+ np=npomtg(nbpom)+1
+ if(np.gt.legmax)then
+ goto 2
+ endif
+ npomtg(nbpom)=np
+ itt=ipomti(m)
+ iwt(itt)=1
+ iltg(np,nbpom)=itt
+ l0=lqb(itt)+1
+ if(l0.gt.npnmax)then
+ goto 2
+ endif
+ lqb(itt)=l0
+ lntg(np,nbpom)=l0
+ nbti(l0,itt)=nbpom
+ idnti(l0,itt)=1
+ nlti(l0,itt)=np
+ vvxtg(l0,itt)=vvxti(m)
+ xpomtg(l0,itt)=xpomti(m)
+ bpomtg(l0,itt)=bpomti(m)
+ enddo
+ endif
+ endif
+ enddo !end of Pomeron loop
+3 continue !end of it-loop
+4 continue !end of ip-loop
+
+c-------------------------------------------------
+c diffraction (hadron-hadron case)
+ if(ia(1).eq.1.and.ia(2).eq.1.and.iwp(1).eq.0.and.iwt(1).eq.0)then
+ wel=0.d0
+ winel=0.d0
+ do icdp=1,2
+ do icdt=1,2
+ vv=qgpomi(scm,b*b,0.d0,0.d0,0.d0,icdp,icdt,icz,1) !total eikonal
+ wabs(icdp,icdt)=exp(-vv)
+ wel=wel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)
+ winel=winel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)**2
+ enddo
+ enddo
+ if(qgran(b10).le.wel**2/winel)then
+ if(debug.ge.1)write (moniou,231)
+ goto 1
+ endif
+
+ wdifp=cc(1,icz)*cc(2,icz)*(cc(1,2)**2*(wabs(1,1)-wabs(2,1))**2
+ * +cc(2,2)**2*(wabs(1,2)-wabs(2,2))**2+2.d0*cc(1,2)*cc(2,2)
+ * *(wabs(1,1)-wabs(2,1))*(wabs(1,2)-wabs(2,2)))
+ wdift=cc(1,2)*cc(2,2)*(cc(1,icz)**2*(wabs(1,1)-wabs(1,2))**2
+ * +cc(2,icz)**2*(wabs(2,1)-wabs(2,2))**2+2.d0*cc(1,icz)*cc(2,icz)
+ * *(wabs(1,1)-wabs(1,2))*(wabs(2,1)-wabs(2,2)))
+ wdifd=cc(1,icz)*cc(2,icz)*cc(1,2)*cc(2,2)
+ * *(wabs(1,1)+wabs(2,2)-wabs(1,2)-wabs(2,1))**2
+ aks=(wdifp+wdift+wdifd)*qgran(b10)
+ if(aks.lt.wdifp)then
+ nwp=nwp+1
+ iwp(1)=2
+ iprcn(1)=1
+ iwt(1)=-1
+ elseif(aks.lt.wdifp+wdift)then
+ nwt=nwt+1
+ iwt(1)=2
+ itgcn(1)=1
+ iwp(1)=-1
+ else
+ nwp=nwp+1
+ nwt=nwt+1
+ iwp(1)=2
+ iwt(1)=2
+ iprcn(1)=1
+ itgcn(1)=1
+ endif
+ goto 9
+ endif
+
+c-------------------------------------------------
+c diffraction (hadron-nucleus & nucleus-nucleus)
+ do ip=1,ia(1) !loop over all projectile nucleons
+ x=xa(ip,1)+b !proj. x is shifted by b
+ y=xa(ip,2)
+ if(iwp(ip).ne.0)then
+ nwp=nwp+1 !one more wounded proj. nucleon
+ if(lqa(ip).eq.0.and.(wdp(1,ip).ne.0.d0.or.wdp(2,ip).ne.0.d0))
+ * then
+ icdps=iddp(ip)
+ xpomr=1.d0/dsqrt(scm)
+ do it=1,ia(2)
+ if(iconab(ip,it).ne.0)then
+ bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
+ xxp=.5d0*(x+xb(it,1))
+ yyp=.5d0*(y+xb(it,2))
+ icdt=iddt(it)
+ do icdp=1,2
+ iddp(ip)=icdp
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+ vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
+ wdp(icdp,ip)=wdp(icdp,ip)*exp(-vv)
+ enddo
+ endif
+ enddo
+ iddp(ip)=icdps
+ wdifr=cc(1,icz)*cc(2,icz)*(wdp(1,ip)-wdp(2,ip))**2
+ * /(cc(1,icz)*wdp(1,ip)**2+cc(2,icz)*wdp(2,ip)**2)
+ if(qgran(b10).lt.wdifr)iwp(ip)=3 !LMD excitation
+ endif
+
+ elseif(icona(ip).ne.0)then
+ if(debug.ge.2)write (moniou,223)ip
+ vabs(1)=0.d0
+ vabs(2)=0.d0
+ icdps=iddp(ip)
+ do it=1,ia(2)
+ bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
+ icdt=iddt(it)
+ do icdp=1,2
+ if(iconab(ip,it).eq.0)then
+ vabsi(icdp,it)=0.d0
+ else
+ iddp(ip)=icdp
+ xpomr=1.d0/dsqrt(scm)
+ xxp=.5d0*(x+xb(it,1))
+ yyp=.5d0*(y+xb(it,2))
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ * ,ip,it)
+ vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
+ vabsi(icdp,it)=vv
+ vabs(icdp)=vabs(icdp)+vv
+ endif
+ enddo
+ enddo
+ iddp(ip)=icdps
+ wdifr=cc(1,icz)*cc(2,icz)*(exp(-vabs(1))-exp(-vabs(2)))**2
+ * /(cc(1,icz)*exp(-2.d0*vabs(1))+cc(2,icz)*exp(-2.d0*vabs(2)))
+
+ if(qgran(b10).lt.wdifr)then !projectile diffraction
+ wdift=0.d0
+ do it=1,ia(2)
+ if(iwt(it).ne.-1)then
+ wdifi(it)=cc(1,icz)*cc(2,icz)*(exp(-vabsi(1,it))
+ * -exp(-vabsi(2,it)))**2/(cc(1,icz)*exp(-2.d0*vabsi(1,it))
+ * +cc(2,icz)*exp(-2.d0*vabsi(2,it)))
+ wdift=wdift+wdifi(it)
+ else
+ wdifi(it)=0.d0
+ endif
+ enddo
+ if(wdift.ne.0.d0)then
+ nwp=nwp+1
+ iwp(ip)=2
+ aks=qgran(b10)*wdift
+ do it=1,ia(2)
+ aks=aks-wdifi(it)
+ if(aks.lt.0.d0)goto 5
+ enddo
+5 continue
+ iprcn(ip)=it
+ if(iwt(it).eq.0)iwt(it)=-1
+ if(debug.ge.2)write (moniou,224)ip,it
+ endif
+ endif
+ endif
+ enddo !end of ip-loop
+
+ do 8 it=1,ia(2) !check target diffraction
+ if(iwt(it).gt.0)then
+ nwt=nwt+1 !one more wounded targ. nucleon
+ if(lqb(it).eq.0.and.(wdt(1,it).ne.0.d0.or.wdt(2,it).ne.0.d0))
+ * then
+ icdts=iddt(it)
+ xpomr=1.d0/dsqrt(scm)
+ do ip=1,ia(1)
+ if(iconab(ip,it).ne.0)then
+ bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
+ xxp=.5d0*(xa(ip,1)+b+xb(it,1))
+ yyp=.5d0*(xa(ip,2)+xb(it,2))
+ icdp=iddp(ip)
+ do icdt=1,2
+ iddt(it)=icdt
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+ vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
+ wdt(icdt,it)=wdt(icdt,it)*exp(-vv)
+ enddo
+ endif
+ enddo
+ iddt(it)=icdts
+ wdifr=cc(1,2)*cc(2,2)*(wdt(1,it)-wdt(2,it))**2
+ * /(cc(1,2)*wdt(1,it)**2+cc(2,2)*wdt(2,it)**2)
+ if(qgran(b10).lt.wdifr)iwt(it)=3
+ endif
+
+ elseif(iconb(it).ne.0)then
+ if(debug.ge.2)write (moniou,225)it
+ vabs(1)=0.d0
+ vabs(2)=0.d0
+ icdts=iddt(it)
+ do ip=1,ia(1)
+ bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
+ icdp=iddp(ip)
+ do icdt=1,2
+ if(iconab(ip,it).eq.0)then
+ vabsi(icdt,ip)=0.d0
+ else
+ iddt(it)=icdt
+ xpomr=1.d0/dsqrt(scm)
+ xxp=.5d0*(xa(ip,1)+b+xb(it,1))
+ yyp=.5d0*(xa(ip,2)+xb(it,2))
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ * ,ip,it)
+ vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
+ vabsi(icdt,ip)=vv
+ vabs(icdt)=vabs(icdt)+vv
+ endif
+ enddo
+ enddo
+ iddt(it)=icdts
+ wdifr=cc(1,2)*cc(2,2)*(exp(-vabs(1))-exp(-vabs(2)))**2
+ * /(cc(1,2)*exp(-2.d0*vabs(1))+cc(2,2)*exp(-2.d0*vabs(2)))
+
+ if(qgran(b10).lt.wdifr)then !target diffraction
+ wdift=0.d0
+ do ip=1,ia(1)
+ if(iwp(ip).eq.-1)then
+ wdifi(ip)=0.d0
+ else
+ if(iwp(ip).eq.2)then
+ itt=iprcn(ip)
+ if(itt.eq.it)goto 7
+ if(iwt(itt).eq.2)then
+ wdifi(ip)=0.d0
+ goto 6
+ endif
+ endif
+ wdifi(ip)=cc(1,2)*cc(2,2)*(exp(-vabsi(1,ip))
+ * -exp(-vabsi(2,ip)))**2/(cc(1,2)*exp(-2.d0*vabsi(1,ip))
+ * +cc(2,2)*exp(-2.d0*vabsi(2,ip)))
+ endif
+6 wdift=wdift+wdifi(ip)
+ enddo
+ if(wdift.eq.0.d0)goto 8
+ nwt=nwt+1
+ iwt(it)=2
+ aks=qgran(b10)*wdift
+ do ip=1,ia(1)
+ aks=aks-wdifi(ip)
+ if(aks.lt.0.d0)goto 7
+ enddo
+7 continue
+ itgcn(it)=ip
+ if(debug.ge.2)write (moniou,226)it,ip
+ if(iwp(ip).eq.0)then
+ iwp(ip)=-1
+ elseif(iwp(ip).eq.2)then
+ itt=iprcn(ip)
+ iprcn(ip)=it
+ if(itt.ne.it.and.iwt(itt).eq.-1)iwt(itt)=0
+ endif
+ endif
+ endif
+8 continue
+c check diffractive cross sections !so060413-beg
+9 jdiff=0 !non-diffractive
+ nqst=0
+ nint=0
+ if(nbpom.ne.0)then
+ do i=1,nbpom
+ nqst=nqst+nqs(i)
+ nint=nint+npomin(i)
+ enddo
+ endif
+ if((nwp.ne.0.or.nwt.ne.0).and.nqst.eq.0)then !not elastic nor ND
+ lqat=0
+ do ip=1,ia(1)
+ lqat=lqat+lqa(ip)
+ enddo
+ lqbt=0
+ do it=1,ia(2)
+ lqbt=lqbt+lqb(it)
+ enddo
+ iwpt=0
+ do ip=1,ia(1)
+ if(iwp(ip).eq.1)then
+ iwpt=1
+ goto 10
+ elseif(iwp(ip).ge.2)then
+ iwpt=2
+ endif
+ enddo
+10 continue
+ iwtt=0
+ do it=1,ia(2)
+ if(iwt(it).eq.1)then
+ iwtt=1
+ goto 11
+ elseif(iwt(it).ge.2)then
+ iwtt=2
+ endif
+ enddo
+11 continue
+ if(lqat.eq.0.and.lqbt.eq.0)then
+ if(nbpom.eq.0.or.nint.eq.0)then
+ if(iwpt.eq.2.and.iwtt.ne.2)then
+ jdiff=6 !SD(LM)-proj
+ elseif(iwpt.ne.2.and.iwtt.eq.2)then
+ jdiff=7 !SD(LM)-targ
+ elseif(iwpt.eq.2.and.iwtt.eq.2)then
+ jdiff=8 !DD(LM)
+ else
+ goto 14
+ endif
+ else
+ if(iwpt.ne.2.and.iwtt.ne.2)then
+ jdiff=9 !CD(DPE)
+ else
+ jdiff=10 !CD+LMD
+ endif
+ endif
+ elseif(lqat.gt.0.and.lqbt.eq.0.and.iwtt.ne.2)then
+ jdiff=1 !SD(HM)-proj
+ elseif(lqat.eq.0.and.lqbt.gt.0.and.iwpt.ne.2)then
+ jdiff=2 !SD(HM)-targ
+ elseif(lqat.gt.0.and.lqbt.eq.0.and.iwtt.eq.2)then
+ jdiff=3 !DD(LHM)-proj
+ elseif(lqat.eq.0.and.lqbt.gt.0.and.iwpt.eq.2)then
+ jdiff=4 !DD(LHM)-targ
+
+ elseif(lqat.gt.0.and.lqbt.gt.0)then
+ if(nbpom.eq.0)stop'problem with nbpom!!!'
+ xrapmax(1)=1.d0
+ xrapmin(1)=1.d0/scm
+ do ibpom=1,nbpom
+ if(npompr(ibpom).gt.0)then
+ do i=1,npompr(ibpom)
+ ip=ilpr(i,ibpom)
+ lpom=lnpr(i,ibpom)
+ xrapmax(1)=min(xrapmax(1),1.d0/xpompr(lpom,ip)/scm)
+ enddo
+ endif
+ if(npomtg(ibpom).gt.0)then
+ do i=1,npomtg(ibpom)
+ it=iltg(i,ibpom)
+ lpom=lntg(i,ibpom)
+ xrapmin(1)=max(xrapmin(1),xpomtg(lpom,it))
+ enddo
+ endif
+ enddo
+ if(xrapmin(1).gt..999d0*xrapmax(1))goto 14
+ nraps=1
+12 if(nraps.gt.90)stop'nraps>90'
+ do ibpom=1,nbpom
+ if(npomin(ibpom).gt.0)then
+ do i=1,npomin(ibpom)
+ if(nraps.eq.1)then
+ if(1.d0/scm/xpomin(i,ibpom).lt..999d0*xrapmax(1)
+ * .and.xpopin(i,ibpom).gt.1.001d0*xrapmin(1))then !rap-gaps changed
+ if(1.d0/scm/xpomin(i,ibpom).lt.1.001d0*xrapmin(1)
+ * .and.xpopin(i,ibpom).gt..999d0*xrapmax(1))then !no rap-gap (filled)
+ goto 14
+ elseif(xpopin(i,ibpom).gt..999d0*xrapmax(1))then
+ xrapmax(1)=1.d0/scm/xpomin(i,ibpom)
+ elseif(1.d0/scm/xpomin(i,ibpom).lt.1.001d0*xrapmin(1))then
+ xrapmin(1)=xpopin(i,ibpom)
+ else
+ xrapmin(2)=xrapmin(1)
+ xrapmin(1)=xpopin(i,ibpom)
+ xrapmax(2)=1.d0/scm/xpomin(i,ibpom)
+ nraps=2
+ goto 12
+ endif
+ endif
+ else
+ if(1.d0/scm/xpomin(i,ibpom).lt..999d0*xrapmax(1)
+ * .and.xpopin(i,ibpom).gt.1.001d0*xrapmin(nraps))then !rap-gaps changed
+ if(1.d0/scm/xpomin(i,ibpom).lt.1.001d0*xrapmin(nraps)
+ * .and.xpopin(i,ibpom).gt..999d0*xrapmax(1))then !no rap-gaps (filled)
+ goto 14
+ else
+ do irap=1,nraps
+ if(xpopin(i,ibpom).gt..999d0*xrapmax(irap).and.1.d0/scm
+ * /xpomin(i,ibpom).lt.1.001d0*xrapmin(irap))then !gap filled
+ if(irap.lt.nraps)then
+ do j=irap,nraps-1
+ xrapmax(j)=xrapmax(j+1)
+ xrapmin(j)=xrapmin(j+1)
+ enddo
+ endif
+ nraps=nraps-1
+ goto 12
+ elseif(xpopin(i,ibpom).gt..999d0*xrapmax(irap))then
+ xrapmax(irap)=min(1.d0/scm/xpomin(i,ibpom)
+ * ,xrapmax(irap))
+ elseif(1.d0/scm/xpomin(i,ibpom)
+ * .lt.1.001d0*xrapmin(irap))then
+ xrapmin(irap)=max(xpopin(i,ibpom),xrapmin(irap))
+ elseif(1.d0/scm/xpomin(i,ibpom).gt.xrapmin(irap)
+ * .and.xpopin(i,ibpom).lt.xrapmax(irap))then
+ xrapmin(irap)=max(xpopin(i,ibpom),xrapmin(irap))
+ if(irap.lt.nraps)then
+ do j=1,nraps-irap
+ xrapmax(nraps-j+2)=xrapmax(nraps-j+1)
+ xrapmin(nraps-j+2)=xrapmin(nraps-j+1)
+ enddo
+ endif
+ xrapmin(irap+1)=xrapmin(irap)
+ xrapmin(irap)=xpopin(i,ibpom)
+ xrapmax(irap+1)=1.d0/scm/xpomin(i,ibpom)
+ nraps=nraps+1
+ goto 12
+ endif
+ enddo !end of irap-loop
+ endif
+ endif
+ endif
+ enddo !end of npin-loop
+ endif
+ enddo !end of ibpom-loop
+ jdiff=5 !DD(HM)
+ endif
+ endif !end of diffr. check
+14 bdiff=b
+
+ctp define collision type
+ typevt=0 !no interaction
+ if(nwp.gt.0.or.nwt.gt.0)then !so060413-end
+ if(jdiff.eq.0)then !ND (no rap-gaps)
+ typevt=1
+ elseif(jdiff.eq.8.or.jdiff.eq.10.or.
+ * (jdiff.gt.2.and.jdiff.lt.6))then !DD + (CD+LMD)
+ typevt=2
+ elseif(jdiff.eq.1.or.jdiff.eq.6)then !SD pro
+ typevt=4
+ elseif(jdiff.eq.2.or.jdiff.eq.7)then !SD tar
+ typevt=-4
+ elseif(jdiff.eq.9)then !CD
+ typevt=3
+ else
+ stop'problem with typevt!'
+ endif
+ endif
+
+
+c form projectile spectator part
+ if(debug.ge.1)write (moniou,227)
+ nspec=0
+ do ip=1,ia(1)
+ if(iwp(ip).eq.0)then
+ if(debug.ge.2)write (moniou,228)ip
+ nspec=nspec+1
+ do l=1,3
+ xas(nspec,l)=xa(ip,l)
+ enddo
+ endif
+ enddo
+
+ nspect=0
+ do it=1,ia(2)
+ if(iwt(it).eq.0)nspect=nspect+1
+ enddo
+
+c inelastic interaction: energy sharing and particle production
+ if(nwp.ne.0.or.nwt.ne.0)then
+ if(ia(1).eq.nspec.or.ia(2).eq.nspect)stop'ia(1)=nspec!!!'
+ if(debug.ge.1)write (moniou,229)
+
+ call qgsha(nbpom,ncola,ncolb,iret)
+ if(iret.ne.0)goto 1
+ if(nsp.le.nsp0+2)then
+ if(debug.ge.1)write (moniou,230)
+ goto 1
+ endif
+ else !no interaction
+ if(debug.ge.1)write (moniou,231)
+ goto 1
+ endif
+ if(debug.ge.1)write (moniou,232)nsp
+
+c fragmentation of the projectile spectator part
+ if(debug.ge.1)write (moniou,233)
+ call qgfrgm(nspec,xas)
+ if(debug.ge.1)write (moniou,234)nsf
+ if(debug.ge.1)write (moniou,235)
+
+201 format(2x,'qgconf - configuration of the interaction')
+202 format(2x,'qgconf: impact parameter b=',e10.3,' fm')
+203 format(2x,'qgconf: nuclear configurations')
+204 format(2x,'qgconf: check connections')
+205 format(2x,'qgconf: ',i3,'-th proj. nucleon may interact with '
+ *,i3,'-th target nucleon')
+206 format(2x,'qgconf: ',i3,'-th projectile nucleon may interact')
+207 format(2x,'qgconf: ',i3,'-th target nucleon may interact')
+208 format(2x,'qgconf: ',i3,'-th rejection,'
+ *,' redo Pomeron configuration')
+209 format(2x,'qgconf: too many rejections,'
+ *,' redo nuclear configuartions')
+210 format(2x,'qgconf: Pomeron configuration')
+211 format(2x,'qgconf: check ',i3,'-th projectile nucleon')
+212 format(2x,'qgconf: interaction with ',i3,'-th target nucleon?')
+213 format(2x,'qgconf: eikonals - total: ',e10.3,2x,'single: ',e10.3)
+214 format(2x,'qgconf: ',i4,'-th Pomeron block connected to ',i3
+ *,'-th proj. nucleon and'/4x,i3,'-th targ. nucleon;'
+ *,' number of element. processes in the block: ',i3)
+215 format(2x,'qgconf: ',i3
+ *,'-th process in the block is single cut Pomeron')
+219 format(2x,'qgconf: configuration of multi-Pomeron vertexes')
+220 format(2x,'qgconf: ',i3,'-th process in the block contains '
+ *,i3,' interm. Pomerons')
+221 format(2x,'qgconf: ',i3,'-th process in the block contains '
+ *,i3,' proj. legs')
+222 format(2x,'qgconf: ',i3,'-th process in the block contains '
+ *,i3,' targ. legs')
+223 format(2x,'qgconf: check diffraction for ',i3,'-th proj. nucleon')
+224 format(2x,'qgconf: diffr. of ',i3,'-th proj. nucleon,'
+ *,' recoil of ',i3,'-th targ. nucleon')
+225 format(2x,'qgconf: check diffraction for ',i3,'-th targ. nucleon')
+226 format(2x,'qgconf: diffr. of ',i3,'-th targ. nucleon,'
+ *,' recoil of ',i3,'-th proj. nucleon')
+227 format(2x,'qgconf: projectile spectator part')
+228 format(2x,'qgconf: ',i3,'-th proj. nucleon stays idle')
+229 format(2x,'qgconf: inelastic interaction: energy sharing'
+ *,' and particle production')
+230 format(2x,'qgconf: no particle produced - rejection')
+231 format(2x,'qgconf: no interaction - rejection')
+232 format(2x,'qgconf: ',i5,' particles have been produced')
+233 format(2x,'qgconf: fragmentation of the proj. spectator part')
+234 format(2x,'qgconf: ',i3,' proj. fragments have been produced')
+235 format(2x,'qgconf - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti
+ *,xpomip,xpomim,vvxim,bpomim,nppr,nptg,npin,ipompi,ipomti
+ *,wdp,wdt,ip,it,iret)
+c-----------------------------------------------------------------------
+c qg3pdf - configuration for multi-Pomeron/diffractive contributions
+c ip,it - indexes of proj. and targ. nucleons for current collision
+c to determine:
+c nppr - number of proj. leg Pomerons in the process,
+c nptg - number of targ. leg Pomerons in the process,
+c npin - number of interm. Pomerons (between 2 3P-vertexes) in the process,
+c xpomip(i) - LC momentum of the upper 3P-vertex for i-th interm. Pomeron
+c in the process,
+c xpomim(i) - LC momentum of the lower 3P-vertex for i-th interm. Pomeron
+c in the process,
+c ipompi(i) - proj. index for i-th proj. leg Pomeron in the process,
+c ipomti(i) - proj. index for i-th targ. leg Pomeron in the process,
+c bpompi(i) - squared impact param. for i-th proj. leg Pomeron in the process,
+c bpomti(i) - squared impact param. for i-th targ. leg Pomeron in the process,
+c vvxpi(i) - relative strenth of scr. corrections for i-th proj. leg Pomeron,
+c vvxti(i) - relative strenth of scr. corrections for i-th targ. leg Pomeron,
+c xpompi(i) - LC momentum of the 3P-vertex for i-th proj. leg Pomeron,
+c xpomti(i) - LC momentum of the 3P-vertex for i-th targ. leg Pomeron
+c iret=1 - reject configuration
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
+ *,levmax=20,legmax=900)
+ dimension vpac(iapmax),vtac(iapmax)
+ *,vpac0(iapmax),vtac0(iapmax),vpact(iapmax),vtact(iapmax)
+ *,xpomip(npmax),xpomim(npmax),vvxim(npmax),bpomim(npmax)
+ *,xpompi(legmax),xpomti(legmax)
+ *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
+ *,ipompi(legmax),ipomti(legmax),ippr0(legmax),iptg0(legmax)
+ *,nppm(levmax),ippm(legmax,levmax),ii(levmax),xpomm(levmax)
+ *,wgpm(levmax),xxm(levmax),yym(levmax)
+ *,itypr0(legmax),itytg0(legmax),itypm(legmax,levmax),vv(12)
+ *,wdp(2,iapmax),wdt(2,iapmax)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
+ *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
+ *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
+ *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
+ *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
+ *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
+ *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
+ *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
+ common /qgarr11/ b10
+ common /qgarr12/ nsp
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
+ *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
+ *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
+ *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
+ *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
+ *,bpomin(npmax,npbmax)
+ common /qgarr43/ moniou
+ common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
+ *,iconb(iapmax)
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.2)write (moniou,201)ip,it
+
+ if(scm.le.sgap**2)stop'qg3pdf: scm<sgap**2!'
+ iret=0
+ vpacng=0.d0
+ vtacng=0.d0
+ vpacpe=0.d0
+ vtacpe=0.d0
+ vimp=0.d0
+ viuc=0.d0
+ viuu=0.d0
+ vip=0.d0
+ vicc=0.d0
+ vicu=0.d0
+c normalization of rejection function
+ xpomr=1.d0/dsqrt(scm)
+ bpt=dsqrt((xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2)
+ rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
+ rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
+ rp0=rp1*rp2/(rp1+rp2)
+ bbpr=(bpt*rp1/(rp1+rp2))**2
+ bbtg=(bpt*rp2/(rp1+rp2))**2
+ call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
+ *,xxp,yyp,1)
+
+ rpmax=max(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
+ rpmin=min(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
+ if(rpmax.eq.rpmin)then
+ rpmax=rpmax+alfp*dlog(scm)*2.d0*.0389d0
+ rpmin=rpmin+alfp*dlog(scm)*2.d0*.0389d0
+ else
+ rpmin=rpmin+alfp*dlog(scm/sgap)*4.d0*.0389d0
+ endif
+ rp0=rpmax*rpmin/(rpmax+rpmin)
+
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ *,ip,it)
+ vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
+ vplc=min(vpl
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
+ vplc0=min(vplc
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
+ vplcpe=min(vplc0
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
+ vplcp=min(vplcpe
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
+
+ vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
+ vtlc=min(vtl
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
+ vtlc0=min(vtlc
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
+ vtlcpe=min(vtlc0
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
+ vtlcp=min(vtlcpe
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
+
+ sumcp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)-ip+1
+ ipp=ia(1)-i+1
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ sumct0=0.d0
+ sumut=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)-it+1
+ itt=ia(2)-i+1
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.gt.it)sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxp0=1.d0-exp(-sumcp0)
+ vvxt0=1.d0-exp(-sumct0)
+
+c weights for vertex contributions:
+c vv(1): >1 proj. legs and >1 targ. legs
+ vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)**2
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)*(1.d0-vvxtl)
+ *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxpl)
+c vv(2): 0 proj. legs and 0 targ. legs
+ vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
+c vv(3): 0 proj. legs and >1 targ. legs
+ vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
+ **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvxtl)
+ *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
+ *-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
+c vv(4): >1 proj. legs and 0 targ. legs
+ vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(1.d0-vvxpl)
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
+c vv(5): 0 proj. legs and >1 targ. (handle) legs
+ vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
+ if(xpomr*scm.lt.1.1d0*sgap**2)vv(5)=0.d0
+c vv(6): >1 proj. (handle) legs and 0 targ. legs
+ vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
+ *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
+ **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
+ if(xpomr*sgap**2.gt..9d0)vv(6)=0.d0
+c vv(7): >1 proj. legs and 1 targ. leg
+ vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
+ **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+c vv(8): 1 proj. leg and >1 targ. legs
+ vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
+ *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
+ **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+c vv(9): 0 proj. legs and 1 targ. leg
+ vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
+ **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
+c vv(10): 1 proj. leg and 0 targ. legs
+ vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
+c vv(11): 1 cut proj. leg and 1 targ. leg
+ vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
+ **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ **exp(-2.d0*vpac(ip)-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
+ if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
+c vv(12): 1 proj. leg and 1 cut targ. leg
+ vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
+ **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ **exp(-2.d0*vtac(it)-vpac(ip))
+ **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
+
+ gb0=0.d0
+ do i=1,12
+ gb0=gb0+max(0.d0,vv(i))/4.d0
+ enddo
+
+ if(gb0.le.0.d0)then !so170712
+ if(debug.ge.3)write (moniou,202)
+ iret=1
+ goto 31
+ endif
+ if(debug.ge.3)write (moniou,203)gb0
+
+1 continue
+ xpomr=(scm/sgap**2)**(-qgran(b10))/sgap !proposed LC momentum for 3P-vertex
+ rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
+ rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbpr=(bpt*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bbtg=(bpt*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+ call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
+ *,xxp,yyp,int(1.5d0+qgran(b10))) !determine coordinates for the vertex
+
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ *,ip,it)
+ vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
+ vplc=min(vpl
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
+ vplc0=min(vplc
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
+ vplcpe=min(vplc0
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
+ vplcp=min(vplcpe
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
+
+ vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
+ vtlc=min(vtl
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
+ vtlc0=min(vtlc
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
+ vtlcpe=min(vtlc0
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
+ vtlcp=min(vtlcpe
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
+
+ sumcp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)-ip+1
+ ipp=ia(1)-i+1
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ sumct0=0.d0
+ sumut=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)-it+1
+ itt=ia(2)-i+1
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.gt.it)sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxp0=1.d0-exp(-sumcp0)
+ vvxt0=1.d0-exp(-sumct0)
+
+c weights for vertex contributions:
+c vv(1): >1 proj. legs and >1 targ. legs
+ vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)**2
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)*(1.d0-vvxtl)
+ *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxpl)
+c vv(2): 0 proj. legs and 0 targ. legs
+ vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
+c vv(3): 0 proj. legs and >1 targ. legs
+ vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
+ **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvxtl)
+ *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
+ *-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
+c vv(4): >1 proj. legs and 0 targ. legs
+ vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **(1.d0-vvxpl)
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
+c vv(5): 0 proj. legs and >1 targ. (handle) legs
+ vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
+ if(xpomr*scm.le.sgap**2)vv(5)=0.d0
+c vv(6): >1 proj. (handle) legs and 0 targ. legs
+ vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
+ *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
+ **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
+ if(xpomr*sgap**2.ge.1.d0)vv(6)=0.d0
+c vv(7): >1 proj. legs and 1 targ. leg
+ vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
+ *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
+ **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
+ *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
+ *-(vpac(ip)-vpac0(ip)))
+ **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
+ **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+c vv(8): 1 proj. leg and >1 targ. legs
+ vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
+ **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
+ *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
+ **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
+ *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
+ **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
+ **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
+ **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+c vv(9): 0 proj. legs and 1 targ. leg
+ vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
+ *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
+ **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
+c vv(10): 1 proj. leg and 0 targ. legs
+ vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
+ **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
+ *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
+c vv(11): 1 cut proj. leg and 1 targ. leg
+ vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
+ **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ **exp(-2.d0*vpac(ip)-vtac(it))
+ **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
+ if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
+c vv(12): 1 proj. leg and 1 cut targ. leg
+ vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
+ **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ **exp(-2.d0*vtac(it)-vpac(ip))
+ **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
+
+ gb=0.d0
+ do i=1,12
+ vv(i)=max(0.d0,vv(i))
+ gb=gb+vv(i)/4.d0
+ enddo
+ gb=gb/gb0/z*rp/rp0 /max(2.d0,dlog10(scm)-1.d0) /2.
+ if(debug.ge.5)write (moniou,204)xpomr,bbpr,bbtg,gb
+
+ if(qgran(b10).gt.gb)goto 1
+ if(debug.ge.3)write (moniou,205)xpomr,bbpr,bbtg,xxp,yyp
+
+ vplcng=min(vplc0
+ *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,11))
+ vtlcng=min(vtlc0
+ *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,11))
+
+ sumcpt=0.d0
+ sumcp0=0.d0
+ sumup=0.d0
+ vvxp0l=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ sumup=sumup-vpac(ipp)
+ if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.gt.ip)then
+ sumcpt=sumcpt+vpact(ipp)
+ elseif(ipp.lt.ip)then
+ vvxp0l=vvxp0l+vpac0(ipp)
+ endif
+ sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ sumctt=0.d0
+ sumct0=0.d0
+ sumut=0.d0
+ vvxt0l=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ sumut=sumut-vtac(itt)
+ if(itt.ge.it)vtact(itt)=max(vtac(itt)
+ * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.gt.it)then
+ sumctt=sumctt+vtact(itt)
+ elseif(itt.lt.it)then
+ vvxt0l=vvxt0l+vtac0(itt)
+ endif
+ sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxpt=1.d0-exp(-sumcpt)
+ vvxtt=1.d0-exp(-sumctt)
+ vvxp0l=1.d0-exp(-vvxp0l)
+ vvxt0l=1.d0-exp(-vvxt0l)
+
+ vvt=0.d0
+ do i=1,12
+ vvt=vvt+vv(i)
+ enddo
+ if(.not.(vvt.gt.0.d0))stop'vvt<0'
+
+ aks=qgran(b10)*vvt
+ do jt=1,12
+ aks=aks-vv(jt)
+ if(aks.lt.0.d0)goto 2
+ enddo
+ stop'jt>12!'
+
+2 continue
+ if(xpomr*scm.gt.sgap**2)then
+ wzgp=-2.d0*(1.d0-exp(-2.d0*vpac(ip)))*(1.d0-vvxpl)**2
+ * *(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))*(1.d0-vvxtt)
+ * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0)
+ * +vtact(it)*exp(-vtact(it))*(1.d0-vvxtt
+ * -exp(vtact(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt))
+ * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0
+ * -exp(vtac0(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt)))
+ else
+ wzgp=0.d0
+ endif
+ if(xpomr*sgap**2.lt.1.d0)then
+ wzgt=-2.d0*(1.d0-exp(-2.d0*vtac(it)))*(1.d0-vvxtl)**2
+ * *(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))*(1.d0-vvxpt)
+ * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0)
+ * +vpact(ip)*exp(-vpact(ip))*(1.d0-vvxpt
+ * -exp(vpact(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp))
+ * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0
+ * -exp(vpac0(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp)))
+ else
+ wzgt=0.d0
+ endif
+
+ nppr0=0
+ nptg0=0
+ npprh0=0
+ nptgh0=0
+ wgpr0=0.d0
+ wgtg0=0.d0
+ if(jt.eq.1.or.jt.eq.4.or.jt.eq.7)then
+ ntry=0
+3 ntry=ntry+1
+ npprh0=0
+ if(ip.eq.ia(1).or.ntry.gt.100)then
+ nppr0=npgen(2.d0*vpac(ip),2,20)
+ do i=1,nppr0
+ if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
+ * then
+ itypr0(i)=0
+ else
+ npprh0=npprh0+1
+ itypr0(i)=1
+ endif
+ ippr0(i)=ip
+ enddo
+ wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
+ else
+ nppr0=npgen(2.d0*vpac(ip),1,20)
+ do i=1,nppr0
+ if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
+ * then
+ itypr0(i)=0
+ else
+ npprh0=npprh0+1
+ itypr0(i)=1
+ endif
+ ippr0(i)=ip
+ enddo
+ wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
+ do ipp=ip+1,ia(1)
+ ninc=npgen(2.d0*vpac(ipp),0,20)
+ if(ninc.ne.0)then
+ nppr0=nppr0+ninc
+ nh0=npprh0
+ if(nppr0.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppr0-ninc+1,nppr0
+ if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
+ * .or.xpomr*sgap**2.ge.1.d0)then
+ itypr0(i)=0
+ else
+ npprh0=npprh0+1
+ itypr0(i)=1
+ endif
+ ippr0(i)=ipp
+ enddo
+ if(ninc.gt.npprh0-nh0)wh=(vpac(ipp)/vpac0(ipp)-1.d0)/ninc
+ endif
+ enddo
+ if(nppr0.eq.1)goto 3
+ endif
+ if(nppr0.le.npprh0+1)then
+ if(jt.ne.7)then
+ wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ else
+ wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ * *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * -(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ * *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ endif
+ if(nppr0.eq.npprh0.and.wh0.lt.0.d0
+ * .or.nppr0.eq.npprh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 3
+ endif
+ endif
+
+ if(jt.eq.1.or.jt.eq.3.or.jt.eq.8)then
+ ntry=0
+4 ntry=ntry+1
+ nptgh0=0
+ if(it.eq.ia(2).or.ntry.gt.100)then
+ nptg0=npgen(2.d0*vtac(it),2,20)
+ do i=1,nptg0
+ if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
+ * then
+ itytg0(i)=0
+ else
+ nptgh0=nptgh0+1
+ itytg0(i)=1
+ endif
+ iptg0(i)=it
+ enddo
+ wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
+ else
+ nptg0=npgen(2.d0*vtac(it),1,20)
+ do i=1,nptg0
+ if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
+ * then
+ itytg0(i)=0
+ else
+ nptgh0=nptgh0+1
+ itytg0(i)=1
+ endif
+ iptg0(i)=it
+ enddo
+ wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
+ do itt=it+1,ia(2)
+ ninc=npgen(2.d0*vtac(itt),0,20)
+ if(ninc.ne.0)then
+ nptg0=nptg0+ninc
+ nh0=nptgh0
+ if(nptg0.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nptg0-ninc+1,nptg0
+ if(qgran(b10).le.vtac0(itt)/vtac(itt)
+ * .or.xpomr*scm.le.sgap**2) then
+ itytg0(i)=0
+ else
+ nptgh0=nptgh0+1
+ itytg0(i)=1
+ endif
+ iptg0(i)=itt
+ enddo
+ if(ninc.gt.nptgh0-nh0)wh=(vtac(itt)/vtac0(itt)-1.d0)/ninc
+ endif
+ enddo
+ if(nptg0.eq.1)goto 4
+ endif
+ if(nptg0.le.nptgh0+1)then
+ if(jt.ne.8)then
+ wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ else
+ wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ * *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * -(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ * *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ endif
+ if(nptg0.eq.nptgh0.and.wh0.lt.0.d0
+ * .or.nptg0.eq.nptgh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 4
+ endif
+ endif
+
+ if(jt.eq.6)then
+ ntry=0
+5 ntry=ntry+1
+ if(ip.eq.ia(1).or.ntry.gt.100)then
+ nppr0=npgen(vpac(ip)-vpac0(ip),2,20)
+ do i=1,nppr0
+ itypr0(i)=1
+ ippr0(i)=ip
+ enddo
+ else
+ nppr0=npgen(vpac(ip)-vpac0(ip),1,20)
+ do i=1,nppr0
+ itypr0(i)=1
+ ippr0(i)=ip
+ enddo
+ do ipp=ip+1,ia(1)
+ ninc=npgen(vpac(ipp)-vpac0(ipp),0,20)
+ if(ninc.ne.0)then
+ nppr0=nppr0+ninc
+ if(nppr0.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppr0-ninc+1,nppr0
+ itypr0(i)=1
+ ippr0(i)=ipp
+ enddo
+ endif
+ enddo
+ if(nppr0.eq.1)goto 5
+ endif
+ endif
+
+ if(jt.eq.5)then
+ ntry=0
+6 ntry=ntry+1
+ if(it.eq.ia(2).or.ntry.gt.100)then
+ nptg0=npgen(vtac(it)-vtac0(it),2,20)
+ do i=1,nptg0
+ itytg0(i)=1
+ iptg0(i)=it
+ enddo
+ else
+ nptg0=npgen(vtac(it)-vtac0(it),1,20)
+ do i=1,nptg0
+ itytg0(i)=1
+ iptg0(i)=it
+ enddo
+ do itt=it+1,ia(2)
+ ninc=npgen(vtac(itt)-vtac0(itt),0,20)
+ if(ninc.ne.0)then
+ nptg0=nptg0+ninc
+ if(nptg0.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nptg0-ninc+1,nptg0
+ itytg0(i)=1
+ iptg0(i)=itt
+ enddo
+ endif
+ enddo
+ if(nptg0.eq.1)goto 6
+ endif
+ endif
+
+ gbt=1.d0
+ if((jt.eq.1.and.nptgh0.lt.nptg0.or.jt.eq.4)
+ *.and.npprh0.eq.nppr0)then
+ gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ elseif((jt.eq.1.and.npprh0.lt.nppr0.or.jt.eq.3)
+ *.and.nptgh0.eq.nptg0)then
+ gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ elseif(jt.eq.1.and.nptgh0.eq.nptg0.and.npprh0.eq.nppr0)then
+ gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
+ elseif(jt.eq.7.and.npprh0.eq.nppr0)then
+ gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ * *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * -(vtac(it)+vtlc-vtac0(it)-vtlc0)
+ * *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ elseif(jt.eq.8.and.nptgh0.eq.nptg0)then
+ gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ * *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * -(vpac(ip)+vplc-vpac0(ip)-vplc0)
+ * *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ endif
+ if(qgran(b10).gt.gbt)goto 2
+
+c less important part of 'zigzag' cuts - commented out (sub-per cent effect)
+c if((jt.eq.1.or.jt.eq.8)
+c * .and.qgran(b10).lt.max(0.d0,wzgp/(vv(1)+vv(8))))nppr0=0
+c if((jt.eq.1.or.jt.eq.7)
+c * .and.qgran(b10).lt.max(0.d0,wzgt/(vv(1)+vv(7))))nptg0=0
+
+ if(jt.eq.7.or.jt.eq.9.or.jt.eq.11.or.jt.eq.12)then
+ nptg0=1
+ iptg0(1)=it
+ endif
+ if(jt.eq.8.or.jt.eq.10.or.jt.eq.11.or.jt.eq.12)then
+ nppr0=1
+ ippr0(1)=ip
+ endif
+
+ if(jt.eq.8.and.nptgh0.lt.nptg0.or.jt.eq.10)then !'fan' from cut vertex
+ vpacng=min(vpac0(ip)
+ * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
+
+ factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=(vpacng+vplcng)*factor
+ wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
+ * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)-wng)
+ if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
+ if(qgran(b10).lt.vpacng/(vpacng+vplcng)
+ * .and.xpomr*sgap**2.lt..9d0)then
+ itypr0(1)=2 !cut 'fan' (no gap at the end)
+ else
+ itypr0(1)=4 !cut 'leg' (no gap at the end)
+ endif
+ else
+ wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
+ * -(vpac(ip)-vpac0(ip))*(1.d0-factor))
+ wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor))
+ if(qgran(b10).lt.wfg/(wfg+wlg))then
+ itypr0(1)=3 !cut 'fan' (gap at the end)
+ else
+ itypr0(1)=5 !cut 'leg' (gap at the end)
+ endif
+ wgpr0=(1.d0-factor)/factor
+ endif
+
+ elseif(jt.eq.8.and.nptgh0.eq.nptg0)then !'fan' from cut/uncut vertex
+ vpacng=min(vpac0(ip)
+ * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
+
+ factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=(vpacng+vplcng)*factor*(1.d0-exp(vtac(it)
+ * +(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl))
+ wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
+ * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)
+ * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
+ * *(vpac(ip)+vplc)*factor-wng)
+ if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
+ if(qgran(b10).lt.vpacng/(vpacng+vplcng)
+ * .and.xpomr*sgap**2.lt..9d0)then
+ itypr0(1)=2 !cut 'fan' (no gap at the end)
+ else
+ itypr0(1)=4 !cut 'leg' (no gap at the end)
+ endif
+ else
+ wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
+ * -(vpac(ip)-vpac0(ip))*(1.d0-factor)
+ * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)*(vpac(ip)-vpacng)*factor)
+ wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor)
+ * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)*(vplc-vplcng)*factor)
+ if(qgran(b10).lt.wfg/(wfg+wlg))then
+ itypr0(1)=3 !cut 'fan' (gap at the end)
+ else
+ itypr0(1)=5 !cut 'leg' (gap at the end)
+ endif
+ wgpr0=1.d0/factor/(1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl))-1.d0
+ endif
+
+ elseif(jt.eq.11)then
+ itypr0(1)=6
+ elseif(jt.eq.12)then
+ factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=max(0.d0,vplcng-vplcpe)*factor
+ * /((vplc0-vplcpe)*factor-(vplc-vplc0)*(1.d0-factor))
+ if(qgran(b10).le.wng)then
+ itypr0(1)=7 !cut 'leg' (>1 cut Poms at the end)
+ else
+ itypr0(1)=5 !cut 'leg' (gap at the end)
+ wgpr0=(1.d0-factor)/factor
+ endif
+ endif
+
+ if(jt.eq.7.and.npprh0.lt.nppr0.or.jt.eq.9)then !'fan' from cut vertex
+ vtacng=min(vtac0(it)
+ * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
+
+ factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=(vtacng+vtlcng)*factor
+ wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
+ * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)-wng)
+ if(qgran(b10).ge.wgap/(wgap+wng)
+ * .or.xpomr*scm.lt.1.1d0*sgap**2)then
+ if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
+ * .and.xpomr*scm.gt.1.1d0*sgap**2)then
+ itytg0(1)=2 !cut 'fan' (no gap at the end)
+ else
+ itytg0(1)=4 !cut 'leg' (no gap at the end)
+ endif
+ else
+ wfg=max(0.d0,(vtac0(it)-vtacng)*factor
+ * -(vtac(it)-vtac0(it))*(1.d0-factor))
+ wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor))
+ if(qgran(b10).lt.wfg/(wfg+wlg))then
+ itytg0(1)=3 !cut 'fan' (gap at the end)
+ else
+ itytg0(1)=5 !cut 'leg' (gap at the end)
+ endif
+ wgtg0=(1.d0-factor)/factor
+ endif
+
+ elseif(jt.eq.7.and.npprh0.eq.nppr0)then !'fan' from cut/uncut vertex
+ vtacng=min(vtac0(it)
+ * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
+
+ factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=(vtacng+vtlcng)*factor*(1.d0-exp(vpac(ip)
+ * +(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl))
+ wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
+ * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)
+ * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl)
+ * *(vtac(it)+vtlc)*factor-wng)
+ if(qgran(b10).ge.wgap/(wgap+wng)
+ * .or.xpomr*scm.lt.1.1d0*sgap**2)then
+ if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
+ * .and.xpomr*scm.gt.1.1d0*sgap**2)then
+ itytg0(1)=2 !cut 'fan' (no gap at the end)
+ else
+ itytg0(1)=4 !cut 'leg' (no gap at the end)
+ endif
+ else
+ wfg=max(0.d0,(vtac0(it)-vtacng)*factor
+ * -(vtac(it)-vtac0(it))*(1.d0-factor)
+ * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)*(vtac(it)-vtacng)*factor)
+ wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor)
+ * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)*(vtlc-vtlcng)*factor)
+ if(qgran(b10).lt.wfg/(wfg+wlg))then
+ itytg0(1)=3 !cut 'fan' (gap at the end)
+ else
+ itytg0(1)=5 !cut 'leg' (gap at the end)
+ endif
+ wgtg0=1.d0/factor/(1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl))-1.d0
+ endif
+
+ elseif(jt.eq.12)then
+ itytg0(1)=6
+ elseif(jt.eq.11)then
+ factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=max(0.d0,vtlcng-vtlcpe)*factor
+ * /((vtlc0-vtlcpe)*factor-(vtlc-vtlc0)*(1.d0-factor))
+ if(qgran(b10).le.wng)then
+ itytg0(1)=7 !cut 'leg' (>1 cut Poms at the end)
+ else
+ itytg0(1)=5 !cut 'leg' (gap at the end)
+ wgtg0=(1.d0-factor)/factor
+ endif
+ endif
+ if(debug.ge.3)write (moniou,206)nppr0,nptg0
+
+ nppr=0
+ nptg=0
+ npin=0
+
+ if(nppr0.eq.1.and.itypr0(1).eq.6)then !single cut Pomeron
+ nppr=1
+ xpompi(nppr)=xpomr
+ vvxpi(nppr)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
+ * *exp(-vtac(it))
+ ipompi(nppr)=ip
+ bpompi(nppr)=bbpr
+ if(debug.ge.4)write (moniou,209)nppr,ip,bbpr,xpompi(nppr)
+ * ,vvxpi(nppr)
+ nppr0=0
+ endif
+ if(nptg0.eq.1.and.itytg0(1).eq.6)then !single cut Pomeron
+ nptg=1
+ xpomti(nptg)=xpomr
+ vvxti(nptg)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
+ * *exp(-vpac(ip))
+ ipomti(nptg)=it
+ bpomti(nptg)=bbtg
+ if(debug.ge.4)write (moniou,217)nptg,it,bbtg,xpomti(nptg)
+ * ,vvxti(nptg)
+ nptg0=0
+ endif
+
+ vvxps=vvxp
+ vvxpls=vvxpl
+ vvxp0s=vvxp0
+ if(nppr0.ne.0)then
+ i=0
+7 i=i+1
+ ityp=itypr0(i)
+ if(ityp.eq.0.or.ityp.eq.2.or.ityp.eq.4)then
+ ipp=ippr0(i)
+ bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
+ vvxp=0.d0
+ vvxpl=0.d0
+ vvxp0=0.d0
+ if(ia(1).gt.1)then
+ do l=1,ia(1)
+ if(l.lt.ipp)then
+ vvxpl=vvxpl+vpac(l)
+ elseif(l.gt.ipp)then
+ vvxp=vvxp+vpac(l)
+ vvxp0=vvxp0+vpac0(l)
+ endif
+ enddo
+ endif
+ vvxp=1.d0-exp(-vvxp)
+ vvxpl=1.d0-exp(-vvxpl)
+ vvxp0=1.d0-exp(-vvxp0)
+ vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*(1.d0-vvxpl)*exp(-vtac(it))
+ if(ityp.ne.4)then
+ vpacng=min(vpac0(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
+ vpacpe=min(vpacng
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
+ vplcp=min(vpacpe
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
+ else
+ vplcng=min(vpac0(ipp)
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
+ vplcpe=min(vplcng
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
+ vplcp=min(vplcpe
+ * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
+ endif
+
+ if(ityp.eq.0)then
+ aks=qgran(b10)*vpac0(ipp)
+ if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
+ itypr0(i)=6 !single cut Pomeron
+ elseif(aks.lt.vpacpe)then
+ itypr0(i)=-1 !'fan' (cut Pomeron end)
+ elseif(aks.lt.vpacng)then
+ itypr0(i)=2 !'fan' (>1 cut Poms at the end)
+ endif
+ elseif(ityp.eq.2)then
+ aks=qgran(b10)*vpacng
+ if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
+ itypr0(i)=6 !single cut Pomeron
+ elseif(aks.lt.vpacpe)then
+ itypr0(i)=-1 !'fan' (cut Pomeron end)
+ endif
+ elseif(ityp.eq.4)then
+ aks=qgran(b10)*vplcng
+ if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
+ itypr0(i)=6 !single cut Pomeron
+ elseif(aks.gt.vplcpe.or.xpomr*sgap**3.gt..9d0)then
+ itypr0(i)=7 !'leg' (>1 cut Poms at the end)
+ endif
+ endif
+
+ if(itypr0(i).eq.6)then !single cut Pomeron
+ nppr=nppr+1
+ xpompi(nppr)=xpomr
+ vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vtac(it))
+ ipompi(nppr)=ipp
+ bpompi(nppr)=bbp
+ if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
+ * ,vvxpi(nppr)
+ nppr0=nppr0-1
+ if(nppr0.ge.i)then
+ do l=i,nppr0
+ ippr0(l)=ippr0(l+1)
+ itypr0(l)=itypr0(l+1)
+ enddo
+ endif
+ i=i-1
+ endif
+ endif
+ if(i.lt.nppr0)goto 7
+ endif
+
+ vvxp=vvxps
+ vvxpl=vvxpls
+ vvxp0=vvxp0s
+ vvxts=vvxt
+ vvxtls=vvxtl
+ vvxt0s=vvxt0
+ if(nptg0.ne.0)then
+ i=0
+8 i=i+1
+ ityt=itytg0(i)
+ if(ityt.eq.0.or.ityt.eq.2.or.ityt.eq.4)then
+ itt=iptg0(i)
+ bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
+ vvxt=0.d0
+ vvxtl=0.d0
+ vvxt0=0.d0
+ if(ia(2).gt.1)then
+ do l=1,ia(2)
+ if(l.lt.itt)then
+ vvxtl=vvxtl+vtac(l)
+ elseif(l.gt.itt)then
+ vvxt=vvxt+vtac(l)
+ vvxt0=vvxt0+vtac0(l)
+ endif
+ enddo
+ endif
+ vvxt=1.d0-exp(-vvxt)
+ vvxtl=1.d0-exp(-vvxtl)
+ vvxt0=1.d0-exp(-vvxt0)
+ vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxtl)*exp(-vpac(ip))
+ if(ityt.ne.4)then
+ vtacng=min(vtac0(itt)
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
+ vtacpe=min(vtacng
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
+ vtlcp=min(vtacpe
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
+ else
+ vtlcng=min(vtac0(itt)
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
+ vtlcpe=min(vtlcng
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
+ vtlcp=min(vtlcpe
+ * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
+ endif
+
+ if(ityt.eq.0)then
+ aks=qgran(b10)*vtac0(itt)
+ if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
+ itytg0(i)=6 !single cut Pomeron
+ elseif(aks.lt.vtacpe)then
+ itytg0(i)=-1 !'fan' (cut Pomeron end)
+ elseif(aks.lt.vtacng)then
+ itytg0(i)=2 !'fan' (>1 cut Poms at the end)
+ endif
+ elseif(ityt.eq.2)then
+ aks=qgran(b10)*vtacng
+ if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
+ itytg0(i)=6 !single cut Pomeron
+ elseif(aks.lt.vtacpe)then
+ itytg0(i)=-1 !'fan' (cut Pomeron end)
+ endif
+ elseif(ityt.eq.4)then
+ aks=qgran(b10)*vtlcng
+ if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
+ itytg0(i)=6
+ elseif(aks.gt.vtlcpe.or.xpomr*scm.lt.1.1d0*sgap**3)then
+ itytg0(i)=7 !'leg' (>1 cut Poms at the end)
+ endif
+ endif
+
+ if(itytg0(i).eq.6)then !single cut Pomeron
+ nptg=nptg+1
+ xpomti(nptg)=xpomr
+ vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vpac(ip))
+ ipomti(nptg)=itt
+ bpomti(nptg)=bbt
+ if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
+ * ,vvxti(nptg)
+ nptg0=nptg0-1
+ if(nptg0.ge.i)then
+ do l=i,nptg0
+ iptg0(l)=iptg0(l+1)
+ itytg0(l)=itytg0(l+1)
+ enddo
+ endif
+ i=i-1
+ endif
+ endif
+ if(i.lt.nptg0)goto 8
+ endif
+ vvxt=vvxts
+ vvxtl=vvxtls
+ vvxt0=vvxt0s
+
+ if((jt-1)*(jt-4)*(jt-7).eq.0.and.xpomr*sgap**2.lt..9d0)then
+ vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ vvxt0s=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
+ vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
+ vvx0s=((1.d0-vvxp0)*(1.d0-vvxp0l))**2*exp(-2.d0*vpac0(ip))
+
+ wzzp=2.d0*qgrevi(1.d0/xpomr,bbpr,vvxt0s,vvxts
+ * ,vvxpt,vvxp0,vvxpl,iddp(ip),icz)
+ * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
+ * *(1.d0-vvxtt)
+ * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
+ * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
+ * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
+ * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
+ * *(vvxs-vvx0s+vvxt0l*vvx0s))
+ wzzp=max(0.d0,wzzp)
+ nzzp=npgen(wzzp/(vv(1)+vv(4)+vv(7)),0,50)
+ else
+ nzzp=0
+ endif
+
+ if((jt-1)*(jt-3)*(jt-8).eq.0.and.xpomr*scm.gt.1.1d0*sgap**2)then
+ vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ vvxp0s=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
+ vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
+ vvx0s=((1.d0-vvxt0)*(1.d0-vvxt0l))**2*exp(-2.d0*vtac0(it))
+ wzzt=2.d0*qgrevi(xpomr*scm,bbtg,vvxp0s,vvxps
+ * ,vvxtt,vvxt0,vvxtl,iddt(it),2)
+ * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
+ * *(1.d0-vvxpt)
+ * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
+ * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
+ * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
+ * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
+ * *(vvxs-vvx0s+vvxp0l*vvx0s))
+ wzzt=max(0.d0,wzzt)
+ nzzt=npgen(wzzt/(vv(1)+vv(3)+vv(8)),0,50)
+ else
+ nzzt=0
+ endif
+
+ if(nzzp.ne.0)then
+ bpm=(xa(ip,1)+b-xxp)**2+(xa(ip,2)-yyp)**2
+ xpomr0=min(dsqrt(xpomr),1.d0/sgap)
+ xpomr0=max(xpomr0,xpomr*sgap)
+ rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomr0/xpomr)*4.d0*.0389d0
+ rp0=rp1*rp2/(rp1+rp2)
+ bbp=bpm*(rp1/(rp1+rp2))**2
+ bbi=bpm*(rp2/(rp1+rp2))**2
+ call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp,xxp0,yyp0,1)
+ call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
+ * ,vvxpl,vvxtl,ip,it)
+
+ sumcp0=0.d0
+ sumcpt=0.d0
+ sumup=0.d0
+ vvxp0=0.d0
+ vvxp0l=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
+ * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
+ if(ipp.gt.ip)then
+ vvxp0=vvxp0+vpac0(ipp)
+ sumcpt=sumcpt+vpact(ipp)
+ elseif(ipp.lt.ip)then
+ vvxp0l=vvxp0l+vpac0(ipp)
+ endif
+ sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ vvxpt=1.d0-exp(-sumcpt)
+ vvxp0=1.d0-exp(-vvxp0)
+ vvxp0l=1.d0-exp(-vvxp0l)
+
+ sumut=0.d0
+ sumct0=0.d0
+ vvxt0=0.d0
+ vvxt0l=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.gt.it)then
+ vvxt0=vvxt0+vtac0(itt)
+ elseif(itt.lt.it)then
+ vvxt0l=vvxt0l+vtac0(itt)
+ endif
+ sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+ vvxt0l=1.d0-exp(-vvxt0l)
+
+ viu=qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,8))
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
+ vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
+ vi=qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
+ * -qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
+ * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
+
+ vvx0s=(1.d0-vvxtin)**2
+ vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
+
+ gb0=vi *15.
+ * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
+ * *(1.d0-vvxpt)
+ * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
+ * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
+ * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
+ * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
+ * *(vvxs-vvx0s+vvxp0l*vvx0s))
+
+ do in=1,nzzp
+ nrej=0
+32 xpomri=(xpomr*sgap**2)**qgran(b10)/sgap
+ rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomri))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomri/xpomr)*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+ call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp
+ * ,xxi,yyi,int(1.5d0+qgran(b10))) !coordinates for the vertex
+ call qgfdf(xxi,yyi,xpomri,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+
+ sumcp0=0.d0
+ sumcpt=0.d0
+ sumup=0.d0
+ vvxp0=0.d0
+ vvxp0l=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
+ * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
+ if(ipp.gt.ip)then
+ vvxp0=vvxp0+vpac0(ipp)
+ sumcpt=sumcpt+vpact(ipp)
+ elseif(ipp.lt.ip)then
+ vvxp0l=vvxp0l+vpac0(ipp)
+ endif
+ sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ vvxpt=1.d0-exp(-sumcpt)
+ vvxp0=1.d0-exp(-vvxp0)
+ vvxp0l=1.d0-exp(-vvxp0l)
+
+ sumut=0.d0
+ sumct0=0.d0
+ vvxt0=0.d0
+ vvxt0l=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.gt.it)then
+ vvxt0=vvxt0+vtac0(itt)
+ elseif(itt.lt.it)then
+ vvxt0l=vvxt0l+vtac0(itt)
+ endif
+ sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+ vvxt0l=1.d0-exp(-vvxt0l)
+
+ viu=qgpini(xpomri/xpomr,bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomri/xpomr,bbi,0.d0,0.d0,8))
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
+ vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
+ vi=qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
+ * -qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
+ * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
+
+ vvx0s=(1.d0-vvxtin)**2
+ vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
+
+ gb=vi
+ * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
+ * *(1.d0-vvxpt)
+ * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
+ * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
+ * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
+ * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
+ * *(vvxs-vvx0s+vvxp0l*vvx0s))
+
+ gb=gb/gb0/z*rp/rp0
+ nrej=nrej+1
+ if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 32
+
+ vi1p=qgpini(xpomri/xpomr,bbi,1.d0-(1.d0-vvxpin)**2*vvx0s
+ * ,0.d0,16)*exp(-vim)
+ vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
+
+ if(qgran(b10).le.(vi1p+vimp)/vi
+ * .or.xpomri/xpomr.lt.1.1d0*sgap**2)then
+ if(qgran(b10).le.vi1p/(vi1p+vimp))then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomr/scm
+ xpomip(npin)=xpomri
+ vvxim(npin)=1.d0-(1.d0-vvxpin)**2*vvx0s
+ bpomim(npin)=bbi
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ else !more than 1 cut Pomeron
+ ninc=npgen(vim,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomr/scm
+ xpomip(i)=xpomri
+ vvxim(i)=0.d0
+ bpomim(i)=bbi
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ else !additional vertices
+ xpomz0=dsqrt(xpomr*xpomri)
+ rp0=alfp*dlog(xpomri/xpomr)*.0389d0
+ xxz0=.5d0*(xxp+xxi)
+ yyz0=.5d0*(yyp+yyi)
+ bbzp=.25d0*bbi
+ bbzt=bbzp
+ call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
+ * ,vvxpl,vvxtl,ip,it)
+
+ vvxp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ vvxp0=vvxp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
+ vvxt0=vvxt0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+
+ viu=qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,2)
+ vilu=1.d0-exp(-viu)
+ vimu=2.d0*min(viu,qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,8))
+ vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
+ vid=qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,2)
+ vild=1.d0-exp(-vid)
+ vimd=2.d0*min(vid,qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,8))
+ vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
+
+ vi1pu=qgpini(xpomri/xpomz0,bbzp
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
+ vguu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
+ vgcu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,23)
+ * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
+ vi1pd=qgpini(xpomz0/xpomr,bbzt
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
+ vgud=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
+ vgcd=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,23)
+ * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
+
+ gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
+ * +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
+ * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
+
+ nrej=0
+34 xpomz=xpomr*sgap*(xpomri/xpomr/sgap**2)**qgran(b10)
+ rpp=alfp*dlog(xpomri/xpomz)*4.d0*.0389d0
+ rpt=alfp*dlog(xpomz/xpomr)*4.d0*.0389d0
+ rp=rpp*rpt/(rpp+rpt)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
+ * +(b0*sin(phi))**2
+ bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
+ * +(b0*sin(phi))**2
+ call qgbdef(bbzp,bbzt,xxi,yyi,xxp,yyp,xxz,yyz
+ * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
+ call qgfdf(xxz,yyz,xpomz,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+
+ vvxp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ vvxp0=vvxp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
+ vvxt0=vvxt0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+
+ viu=qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,2)
+ vilu=1.d0-exp(-viu)
+ vimu=2.d0*min(viu,qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,8))
+ vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
+ vid=qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,2)
+ vild=1.d0-exp(-vid)
+ vimd=2.d0*min(vid,qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,8))
+ vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
+
+ vi1pu=qgpini(xpomri/xpomz,bbzp
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
+ vguu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
+ vgcu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,23)
+ * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
+ vi1pd=qgpini(xpomz/xpomr,bbzt
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
+ vgud=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
+ vgcd=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,23)
+ * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
+
+ vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
+ * +vi1pu*vgcd+vgcu*vi1pd
+ vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
+ * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
+
+ gbz=vvt/gbz0/z*rp/rp0 /1.4d0
+ nrej=nrej+1
+ if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 34
+
+ aks=vvt*qgran(b10)
+ if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
+ jtu=0
+ if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
+ jtd=2
+ else
+ jtd=1
+ endif
+ elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
+ jtd=0
+ if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
+ jtu=2
+ else
+ jtu=1
+ endif
+ else
+ aks=vvcc*qgran(b10)
+ if(aks.lt.vimpu*vimpd)then
+ jtu=2
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
+ jtu=2
+ jtd=1
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
+ jtu=1
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd)then
+ jtu=2
+ jtd=0
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd+vgcu*vimpd)then
+ jtu=0
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
+ jtu=1
+ jtd=0
+ else
+ jtu=0
+ jtd=1
+ endif
+ endif
+
+ if(jtu.eq.1)then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomz/scm
+ xpomip(npin)=xpomri
+ vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
+ bpomim(npin)=bbzp
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ elseif(jtu.eq.2)then !more than 1 cut Pomeron
+ ninc=npgen(vimu,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomz/scm
+ xpomip(i)=xpomri
+ vvxim(i)=0.d0
+ bpomim(i)=bbzp
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ if(jtd.eq.1)then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomr/scm
+ xpomip(npin)=xpomz
+ vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
+ bpomim(npin)=bbzt
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ elseif(jtu.eq.2)then !more than 1 cut Pomeron
+ ninc=npgen(vimd,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomr/scm
+ xpomip(i)=xpomz
+ vvxim(i)=0.d0
+ bpomim(i)=bbzt
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+ endif
+ enddo !end of the zigzag-loop
+ endif !nzzp.ne.0
+
+ if(nzzt.ne.0)then
+ btm=(xb(it,1)-xxp)**2+(xb(it,2)-yyp)**2
+ xpomr0=max(dsqrt(xpomr/scm),sgap/scm)
+ xpomr0=min(xpomr0,xpomr/sgap)
+ rp1=(rq(iddt(it),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomr/xpomr0)*4.d0*.0389d0
+ rp0=rp1*rp2/(rp1+rp2)
+ bbt=btm*(rp1/(rp1+rp2))**2
+ bbi=btm*(rp2/(rp1+rp2))**2
+ call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxp0,yyp0,1)
+ call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+
+ sumct0=0.d0
+ sumctt=0.d0
+ sumut=0.d0
+ vvxt0=0.d0
+ vvxt0l=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.ge.it)vtact(itt)=max(vtac(itt)
+ * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
+ if(itt.gt.it)then
+ vvxt0=vvxt0+vtac0(itt)
+ sumctt=sumctt+vtact(itt)
+ elseif(itt.lt.it)then
+ vvxt0l=vvxt0l+vtac0(itt)
+ endif
+ sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxtt=1.d0-exp(-sumctt)
+ vvxt0=1.d0-exp(-vvxt0)
+ vvxt0l=1.d0-exp(-vvxt0l)
+
+ sumcp0=0.d0
+ sumup=0.d0
+ vvxp0=0.d0
+ vvxp0l=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.gt.ip)then
+ vvxp0=vvxp0+vpac0(ipp)
+ elseif(ipp.lt.ip)then
+ vvxp0l=vvxp0l+vpac0(ipp)
+ endif
+ sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+ vvxp0l=1.d0-exp(-vvxp0l)
+
+ viu=qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,8))
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
+ vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
+ vi=qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
+ * -qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
+ * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
+
+ vvx0s=(1.d0-vvxpin)**2
+ vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
+
+ gb0=vi *15.
+ * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
+ * *(1.d0-vvxtt)
+ * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
+ * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
+ * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
+ * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
+ * *(vvxs-vvx0s+vvxt0l*vvx0s))
+
+ do in=1,nzzt
+ nrej=0
+33 xpomri=xpomr/sgap/(xpomr*scm/sgap**2)**qgran(b10)
+ rp1=(rq(iddt(it),2)+alfp*dlog(xpomri*scm))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomr/xpomri)*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+ call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxi,yyi
+ * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
+ call qgfdf(xxi,yyi,xpomri,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+
+ sumct0=0.d0
+ sumctt=0.d0
+ sumut=0.d0
+ vvxt0=0.d0
+ vvxt0l=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
+ if(itt.ge.it)vtact(itt)=max(vtac(itt)
+ * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
+ if(itt.gt.it)then
+ vvxt0=vvxt0+vtac0(itt)
+ sumctt=sumctt+vtact(itt)
+ elseif(itt.lt.it)then
+ vvxt0l=vvxt0l+vtac0(itt)
+ endif
+ sumct0=sumct0+vtac0(itt)
+ enddo
+ vvxtt=1.d0-exp(-sumctt)
+ vvxt0=1.d0-exp(-vvxt0)
+ vvxt0l=1.d0-exp(-vvxt0l)
+
+ sumcp0=0.d0
+ sumup=0.d0
+ vvxp0=0.d0
+ vvxp0l=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ if(ipp.gt.ip)then
+ vvxp0=vvxp0+vpac0(ipp)
+ elseif(ipp.lt.ip)then
+ vvxp0l=vvxp0l+vpac0(ipp)
+ endif
+ sumcp0=sumcp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+ vvxp0l=1.d0-exp(-vvxp0l)
+
+ viu=qgpini(xpomr/xpomri,bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomr/xpomri,bbi,0.d0,0.d0,8))
+ vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
+ vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
+ vi=qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
+ * -qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
+ * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
+
+ vvx0s=(1.d0-vvxpin)**2
+ vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
+
+ gb=vi
+ * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
+ * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
+ * *(1.d0-vvxtt)
+ * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
+ * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
+ * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
+ * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
+ * *(vvxs-vvx0s+vvxt0l*vvx0s))
+
+ gb=gb/gb0/z*rp/rp0
+ nrej=nrej+1
+ if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 33
+
+ vi1p=qgpini(xpomr/xpomri,bbi,1.d0-(1.d0-vvxtin)**2*vvx0s
+ * ,0.d0,16)*exp(-vim)
+ vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
+
+ if(qgran(b10).le.(vi1p+vimp)/vi
+ * .or.xpomr/xpomri.lt.1.1d0*sgap**2)then
+ if(qgran(b10).le.vi1p/(vi1p+vimp))then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomri/scm
+ xpomip(npin)=xpomr
+ vvxim(npin)=1.d0-(1.d0-vvxtin)**2*vvx0s
+ bpomim(npin)=bbi
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ else !more than 1 cut pomeron
+ ninc=npgen(vim,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomri/scm
+ xpomip(i)=xpomr
+ vvxim(i)=0.d0
+ bpomim(i)=bbi
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ else !additional vertices
+ xpomz0=dsqrt(xpomr*xpomri)
+ rp0=alfp*dlog(xpomr/xpomri)*.0389d0
+ xxz0=.5d0*(xxp+xxi)
+ yyz0=.5d0*(yyp+yyi)
+ bbzp=.25d0*bbi
+ bbzt=bbzp
+ call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
+ * ,vvxpl,vvxtl,ip,it)
+
+ vvxp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ vvxp0=vvxp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
+ vvxt0=vvxt0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+
+ viu=qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,2)
+ vilu=1.d0-exp(-viu)
+ vimu=2.d0*min(viu,qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,8))
+ vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
+ vid=qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,2)
+ vild=1.d0-exp(-vid)
+ vimd=2.d0*min(vid,qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,8))
+ vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
+
+ vi1pu=qgpini(xpomr/xpomz0,bbzp
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
+ vguu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
+ vgcu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,23)
+ * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
+ vi1pd=qgpini(xpomz0/xpomri,bbzt
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
+ vgud=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
+ vgcd=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,23)
+ * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
+
+ gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
+ * +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
+ * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
+
+ nrej=0
+35 xpomz=xpomri*sgap*(xpomr/xpomri/sgap**2)**qgran(b10)
+ rpt=alfp*dlog(xpomz/xpomri)*4.d0*.0389d0
+ rpp=alfp*dlog(xpomr/xpomz)*4.d0*.0389d0
+ rp=rpp*rpt/(rpp+rpt)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
+ * +(b0*sin(phi))**2
+ bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
+ * +(b0*sin(phi))**2
+ call qgbdef(bbzt,bbzp,xxi,yyi,xxp,yyp,xxz,yyz
+ * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
+ call qgfdf(xxz,yyz,xpomz,vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
+
+ vvxp0=0.d0
+ sumup=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)
+ ipp=ia(1)-i+1
+ bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
+ sumup=sumup-vpac(ipp)
+ vpac0(ipp)=min(vpac(ipp)
+ * ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
+ vvxp0=vvxp0+vpac0(ipp)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)
+ itt=ia(2)-i+1
+ bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
+ sumut=sumut-vtac(itt)
+ vtac0(itt)=min(vtac(itt)
+ * ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
+ vvxt0=vvxt0+vtac0(itt)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+
+ viu=qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,2)
+ vilu=1.d0-exp(-viu)
+ vimu=2.d0*min(viu,qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,8))
+ vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
+ vid=qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,2)
+ vild=1.d0-exp(-vid)
+ vimd=2.d0*min(vid,qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,8))
+ vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
+
+ vi1pu=qgpini(xpomr/xpomz,bbzp
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
+ vguu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
+ vgcu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,23)
+ * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
+ vi1pd=qgpini(xpomz/xpomri,bbzt
+ * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
+ vgud=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
+ vgcd=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,23)
+ * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
+
+ vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
+ * +vi1pu*vgcd+vgcu*vi1pd
+ vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
+ * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
+
+ gbz=vvt/gbz0/z*rp/rp0 /1.4d0
+ nrej=nrej+1
+ if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 35
+
+ aks=vvt*qgran(b10)
+ if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
+ * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
+ jtu=0
+ if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
+ jtd=2
+ else
+ jtd=1
+ endif
+ elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
+ jtd=0
+ if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
+ jtu=2
+ else
+ jtu=1
+ endif
+ else
+ aks=vvcc*qgran(b10)
+ if(aks.lt.vimpu*vimpd)then
+ jtu=2
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
+ jtu=2
+ jtd=1
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
+ jtu=1
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd)then
+ jtu=2
+ jtd=0
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd+vgcu*vimpd)then
+ jtu=0
+ jtd=2
+ elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
+ * +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
+ jtu=1
+ jtd=0
+ else
+ jtu=0
+ jtd=1
+ endif
+ endif
+
+ if(jtu.eq.1)then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomz/scm
+ xpomip(npin)=xpomr
+ vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
+ bpomim(npin)=bbzp
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ elseif(jtu.eq.2)then !more than 1 cut Pomeron
+ ninc=npgen(vimu,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomz/scm
+ xpomip(i)=xpomr
+ vvxim(i)=0.d0
+ bpomim(i)=bbzp
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ if(jtd.eq.1)then !single cut Pomeron
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomri/scm
+ xpomip(npin)=xpomz
+ vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
+ bpomim(npin)=bbzt
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
+ * ,xpomim(npin),vvxim(npin),bpomim(npin)
+ elseif(jtu.eq.2)then !more than 1 cut Pomeron
+ ninc=npgen(vimd,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomri/scm
+ xpomip(i)=xpomz
+ vvxim(i)=0.d0
+ bpomim(i)=bbzt
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+ endif
+ enddo !end of the zigzag-loop
+ endif !nzzt.ne.0
+
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ *,ip,it)
+ if((jt.eq.2.or.jt.eq.3.or.jt.eq.9)
+ *.and.qgran(b10).lt.(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
+ */((1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)+2.d0*vvxpl))then
+ icdps=iddp(ip)
+ do icdp=1,2
+ iddp(ip)=icdp
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ * ,ip,it)
+ wdp(icdp,ip)=(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
+ enddo
+ iddp(ip)=icdps
+ endif
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ *,ip,it)
+ if((jt.eq.2.or.jt.eq.4.or.jt.eq.10)
+ *.and.qgran(b10).lt.(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
+ */((1.d0-exp(-vtac(it)))*(1.d0-vvxtl)+2.d0*vvxtl))then
+ icdts=iddt(it)
+ do icdt=1,2
+ iddt(it)=icdt
+ call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
+ * ,ip,it)
+ wdt(icdt,it)=(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
+ enddo
+ iddt(it)=icdts
+ endif
+
+ if(nppr0.eq.0)goto 20
+
+c projectile 'fans'
+ m=0
+ nppm(1)=nppr0
+ xpomm(1)=xpomr
+ wgpm(1)=wgpr0
+ xxm(1)=xxp
+ yym(1)=yyp
+ do i=1,nppr0
+ ippm(i,1)=ippr0(i)
+ itypm(i,1)=itypr0(i)
+ enddo
+
+9 m=m+1 !next level multi-Pomeron vertex
+ if(m.gt.levmax)then
+ iret=1
+ goto 31
+ endif
+ ii(m)=0
+10 ii(m)=ii(m)+1 !next cut fan in the vertex
+ if(ii(m).gt.nppm(m))then !all fans at the level considered
+ m=m-1 !one level down
+ if(m.eq.0)goto 20 !all proj. fans considered
+ goto 10
+ endif
+ l=ii(m)
+ ipp=ippm(l,m) !proj. index for the leg
+ itypom=itypm(l,m) !type of the cut
+ bpm=(xa(ipp,1)+b-xxm(m))**2+(xa(ipp,2)-yym(m))**2 !b^2 for the leg
+ if(debug.ge.4)write (moniou,208)ii(m),m,ipp,bpm
+ if(xpomm(m)*sgap**2.gt.1.d0)stop'xpomm(m)*sgap**2>1!'
+ if(itypom.eq.4.and.xpomm(m)*sgap**3.gt.1.d0)
+ *stop'4:xpomm(m)*sgap**3>1!'
+
+ if(debug.ge.4)write (moniou,210)m
+ xpomr0=min(dsqrt(xpomm(m)),1.d0/sgap)
+ xpomr0=max(xpomr0,xpomm(m)*sgap)
+ if(itypom.eq.4)xpomr0=min(xpomr0,dsqrt(xpomm(m)/sgap))
+ rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomr0/xpomm(m))*4.d0*.0389d0
+ rp0=rp1*rp2/(rp1+rp2)
+ bbp=bpm*(rp1/(rp1+rp2))**2
+ bbi=bpm*(rp2/(rp1+rp2))**2
+ call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
+ *,xxp0,yyp0,1)
+
+ call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
+ *,vvxpl,vvxtl,ipp,it)
+ vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ viu=qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,8))
+ if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
+ vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
+ * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
+ vip=qgpini(xpomr0/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Poms at the end
+ vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
+ else !rap-gap
+ vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
+ vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ viuu=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,20)
+ * *(1.d0-exp(-viu))
+ viuc=max(0.d0,viuu
+ * -qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
+ vicc=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ vicu=max(0.d0,qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,23)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ * -vicc)
+ endif
+
+ if(itypom.le.3)then
+ sumup=0.d0
+ vvxp0=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)-ipp+1
+ ipi=ia(1)-i+1
+ bbl=(xa(ipi,1)+b-xxp0)**2+(xa(ipi,2)-yyp0)**2
+ sumup=sumup-vpac(ipi)
+ vpac0(ipi)=min(vpac(ipi)
+ * ,qgfani(1.d0/xpomr0,bbl,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
+ if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+ vpacng=min(vpac0(ipp)
+ * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
+ vpacpe=min(vpacng
+ * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
+ else
+ vplc=qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,7)
+ vplc0=min(vplc
+ * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
+ vplcng=min(vplc0
+ * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
+ vplcpe=min(vplcng
+ * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
+ endif
+
+ if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
+ gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
+ gb0=gb0*40.d0
+ elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)
+ elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)
+ elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
+ gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
+ elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
+ gb0=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ if(gb0.le.0.d0)then
+ gb0=vip*vplc0*.01d0*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ endif
+ elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
+ gb0=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
+ * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
+ * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
+ gb0=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ endif
+ if(gb0.le.0.d0)then !so170712
+ iret=1
+ goto 31
+ endif
+ nrej=0
+
+11 xpomm(m+1)=(xpomm(m)*sgap**2)**qgran(b10)/sgap
+ if(itypom.eq.4)xpomm(m+1)=(xpomm(m)*sgap**3)**qgran(b10)/sgap**2
+ rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomm(m+1)))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomm(m+1)/xpomm(m))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+ call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
+ *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10))) !coordinates for the vertex
+
+ call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
+ *,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
+ vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ viu=qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,8))
+ if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
+ vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
+ * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
+ vip=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Poms at the end
+ vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
+ else !rap-gap
+ vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
+ vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ viuu=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,20)
+ * *(1.d0-exp(-viu))
+ viuc=max(0.d0,viuu-qgpini(xpomm(m+1)/xpomm(m),bbi
+ * ,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
+ vicc=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ vicu=max(0.d0,qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,23)
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ * /2.d0-vicc)
+ endif
+
+ if(itypom.le.3)then
+ sumup=0.d0
+ vvxp0=0.d0
+ do i=1,ia(1)
+ sumup=sumup+vpac(i)
+ enddo
+ vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ do i=1,ia(1)-ipp+1
+ ipi=ia(1)-i+1
+ bbl=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
+ sumup=sumup-vpac(ipi)
+ vpac0(ipi)=min(vpac(ipi)
+ * ,qgfani(1.d0/xpomm(m+1),bbl,1.d0-vvxs*exp(-sumup)
+ * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
+ if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
+ enddo
+ vvxp0=1.d0-exp(-vvxp0)
+
+ vpacng=min(vpac0(ipp)
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
+ vpacpe=min(vpacng
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
+ else
+ vplc=qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp)
+ * ,icz,7)
+ vplc0=min(vplc
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
+ vplcng=min(vplc0
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
+ vplcpe=min(vplcng
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
+ endif
+
+ if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
+ gb=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
+ elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)
+ elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)
+ elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
+ gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
+ elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
+ * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
+ * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
+ * *exp(-vtac(it))))*(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
+ * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))
+ * -1.d0-(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvx)*(1.d0-vvxt)
+ elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
+ gb=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
+ gb=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
+ * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
+ * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
+ * *exp(-vtac(it))))
+ elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
+ gb=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
+ * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
+ * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ endif
+ gb=gb/gb0/z*rp/rp0 /10.d0
+ nrej=nrej+1
+ if(qgran(b10).gt.gb.and.nrej.le.1000)goto 11
+
+ if(itypom.eq.-1.or.itypom.eq.4)then !'single cut Pomeron in the handle
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomm(m)/scm
+ xpomip(npin)=xpomm(m+1)
+ vvxim(npin)=vvxi
+ bpomim(npin)=bbi
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
+ * ,vvxim(npin),bpomim(npin)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons in the handle
+ ninc=npgen(vim,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomm(m)/scm
+ xpomip(i)=xpomm(m+1)
+ vvxim(i)=0.d0
+ bpomim(i)=bbi
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
+ vv3=2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
+ if(xpomm(m+1)*sgap**2.gt..9d0.or.vv3.lt.0.d0)vv3=0.d0
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ elseif(itypom.eq.0)then !cut 'loop' in the 'handle' (rap-gap)
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)*(vicc+vicu)
+ * /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
+ vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ elseif(itypom.eq.1)then !uncut 'handle' (rap-gap)
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
+ vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ vv4=2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0-(vpac(ipp)
+ * -vpac0(ipp)))*(1.d0-vvxp0)+(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
+ * *exp(-vpac(ipp))*viuu/(viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
+ * *exp(-vtac(it)))+viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it)))
+ if(xpomm(m+1)*sgap**2.gt..9d0.or.vv4.lt.0.d0)vv4=0.d0
+ aks=(vv1+vv2+vv3+vv4)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ elseif(aks.lt.vv1+vv2+vv3)then
+ jt=3 !1 cut fan
+ else
+ jt=4 !>1 cut 'handle' fans
+ endif
+ elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
+ vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
+ vv3=2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
+ * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+
+ elseif(itypom.eq.3)then !rap-gap in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
+ * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
+ * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
+ * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
+ * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
+ * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
+ * *exp(-vpac(ipp)-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * *(vicc+vicu+wgpm(m)*(viuu-viuc))
+ * /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
+ * *exp(-vtac(it))))
+ vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
+ * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
+ vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2
+ * *(1.d0-vvxpl)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ else
+ jt=5 !cut leg
+ endif
+
+ nppm(m+1)=0
+ wgpm(m+1)=0.d0
+ if(jt.eq.1)then !>1 cut fans
+ ntry=0
+12 ntry=ntry+1
+ nphm=0
+ if(ipp.eq.ia(1).or.ntry.gt.100)then
+ nppm(m+1)=npgen(2.d0*vpac(ipp),2,20)
+ do i=1,nppm(m+1)
+ if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(i,m+1)=0
+ else
+ itypm(i,m+1)=1
+ nphm=nphm+1
+ endif
+ ippm(i,m+1)=ipp
+ enddo
+ wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
+ else
+ nppm(m+1)=npgen(2.d0*vpac(ipp),1,20)
+ do i=1,nppm(m+1)
+ if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(i,m+1)=0
+ else
+ itypm(i,m+1)=1
+ nphm=nphm+1
+ endif
+ ippm(i,m+1)=ipp
+ enddo
+ wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
+ do ipi=ipp+1,ia(1)
+ ninc=npgen(2.d0*vpac(ipi),0,20)
+ if(ninc.ne.0)then
+ nppm(m+1)=nppm(m+1)+ninc
+ nh0=nphm
+ if(nppm(m+1).gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppm(m+1)-ninc+1,nppm(m+1)
+ if(qgran(b10).le.vpac0(ipi)/vpac(ipi)
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(i,m+1)=0
+ else
+ itypm(i,m+1)=1
+ nphm=nphm+1
+ endif
+ ippm(i,m+1)=ipi
+ enddo
+ if(ninc.gt.nphm-nh0)wh=(vpac(ipi)/vpac0(ipi)-1.d0)/ninc
+ endif
+ enddo
+ if(nppm(m+1).eq.1)goto 12
+ endif
+
+ if(nphm+1.ge.nppm(m+1))then
+ if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
+ gbt=1.d0-exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ elseif(itypom.eq.0)then
+ gbt=1.d0-(vicc+vicu)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ elseif(itypom.eq.3)then
+ gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
+ * /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)
+ * *exp(-vtac(it))-(vicu+wgpm(m)*viuu)
+ * *(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
+ * *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxp)/(1.d0-vvxpl)
+ else
+ stop'unknown itypom'
+ endif
+ if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
+ * .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
+ ntry=0
+ goto 12
+ endif
+ endif
+
+ elseif(jt.eq.4)then !>1 cut 'handle' fans
+ ntry=0
+14 ntry=ntry+1
+ if(ipp.eq.ia(1).or.ntry.gt.100)then
+ nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),2,20)
+ do i=1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=ipp
+ enddo
+ else
+ nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),1,20)
+ do i=1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=ipp
+ enddo
+ do ipi=ipp+1,ia(1)
+ ninc=npgen(vpac(ipi)-vpac0(ipi),0,20)
+ if(ninc.ne.0)then
+ nppm(m+1)=nppm(m+1)+ninc
+ if(nppm(m+1).gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppm(m+1)-ninc+1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=ipi
+ enddo
+ endif
+ enddo
+ if(nppm(m+1).eq.1)goto 14
+ endif
+
+ elseif(jt.eq.3)then !1 cut fan
+ nppm(m+1)=1
+ ippm(1,m+1)=ipp
+ if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
+ factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=(vpacng-vpacpe)*factor/((vpac0(ipp)-vpacpe)*factor
+ * -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ else
+ itypm(1,m+1)=3 !rap-gap in the 'handle'
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
+ factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=vpacng*factor/(vpac0(ipp)*factor
+ * -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ if(qgran(b10).le.vpacpe/vpacng
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
+ else
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+ else
+ itypm(1,m+1)=3 !rap-gap in the 'handle'
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ else !rap-gap in the 'handle'
+ if(qgran(b10).le.vpacpe/vpacng
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
+ else
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+ endif
+
+ if(itypm(1,m+1).eq.-1)then !single cut Pomeron in the 'handle'
+ vplcp=min(vpacpe
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
+ if(qgran(b10).le.vplcp/vpacpe
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
+ endif
+
+ elseif(jt.eq.5)then !cut 'leg'
+ nppm(m+1)=1
+ ippm(1,m+1)=ipp
+ if(itypom.eq.4)then !single cut Pomeron at the end
+ if(xpomm(m+1)*sgap**2.ge.1.d0)stop'=4:xpomm(m+1)*sgap**2>1'
+ factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=(vplcng-vplcpe)*factor/((vplc0-vplcpe)*factor
+ * -(vplc-vplc0)*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0)then
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ else
+ itypm(1,m+1)=5 !rap-gap at the end
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ elseif(itypom.eq.5)then !rap-gap at the end (cut or uncut loop)
+ if(qgran(b10).le.vplcpe/vplcng
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(1,m+1)=4 !single cut Pomeron at the end
+ else
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ endif
+ elseif(itypom.eq.7)then !>1 cut Pomerons at the end
+ factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
+ wng=vplcng*factor/(vplc0*factor-(vplc-vplc0)*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ if(qgran(b10).le.vplcpe/vplcng
+ * .or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(1,m+1)=4 !single cut Pomeron at the end
+ else
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ endif
+ else
+ itypm(1,m+1)=5 !rap-gap at the end
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ endif
+
+ if(itypm(1,m+1).eq.4)then !single cut Pomeron at the end
+ vplcp=min(vplcpe
+ * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
+ if(qgran(b10).le.vplcp/vplcpe
+ * .or.xpomm(m+1)*sgap**3.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
+ endif
+ endif
+
+ if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then !record single cut Pomeron
+ nppr=nppr+1
+ if(nppr.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ xpompi(nppr)=xpomm(m+1)
+ vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vtac(it))
+ ipompi(nppr)=ipp
+ bpompi(nppr)=bbp
+ nppm(m+1)=0
+ if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
+ * ,vvxpi(nppr)
+
+ elseif(nppm(m+1).gt.1)then
+ i=0
+15 i=i+1
+ ityp=itypm(i,m+1)
+ if(ityp.eq.0)then
+ ipi=ippm(i,m+1)
+ bbi=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
+ vvxp=0.d0
+ vvxpl=0.d0
+ vvxp0=0.d0
+ if(ia(1).gt.1)then
+ do l=1,ia(1)
+ if(l.lt.ipi)then
+ vvxpl=vvxpl+vpac(l)
+ elseif(l.gt.ipi)then
+ vvxp=vvxp+vpac(l)
+ vvxp0=vvxp0+vpac0(l)
+ endif
+ enddo
+ endif
+ vvxp=1.d0-exp(-vvxp)
+ vvxpl=1.d0-exp(-vvxpl)
+ vvxp0=1.d0-exp(-vvxp0)
+
+ vpacng=min(vpac0(ipi)
+ * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,4))
+ vpacpe=min(vpacng
+ * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,5))
+ vplcp=min(vpacpe
+ * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp,vvxpl,iddp(ipi),icz,9))
+
+ aks=qgran(b10)*vpac0(ipi)
+ if(aks.le.vplcp.or.xpomm(m+1)*sgap**2.gt..9d0)then
+ itypm(i,m+1)=6 !single cut Pomeron
+ elseif(aks.lt.vpacpe)then
+ itypm(i,m+1)=-1 !single cut Pomeron in the 'handle'
+ elseif(aks.lt.vpacng)then
+ itypm(i,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+
+ if(itypm(i,m+1).eq.6)then !record single cut Pomeron
+ nppr=nppr+1
+ if(nppr.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ xpompi(nppr)=xpomm(m+1)
+ vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vtac(it))
+ ipompi(nppr)=ipi
+ bpompi(nppr)=bbi
+ if(debug.ge.4)write (moniou,209)nppr,ipi,bbi,xpompi(nppr)
+ * ,vvxpi(nppr)
+ nppm(m+1)=nppm(m+1)-1
+ if(nppm(m+1).ge.i)then
+ do l=i,nppm(m+1)
+ ippm(l,m+1)=ippm(l+1,m+1)
+ itypm(l,m+1)=itypm(l+1,m+1)
+ enddo
+ endif
+ i=i-1
+ endif
+ endif
+ if(i.lt.nppm(m+1))goto 15
+ endif
+
+ if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
+ */((1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)+2.d0*vvxpl))then
+ if(debug.ge.4)write (moniou,212)
+ icdps=iddp(ipp)
+ do icdp=1,2
+ iddp(ipp)=icdp
+ call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
+ wdp(icdp,ipp)=(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
+ enddo
+ iddp(ipp)=icdps
+ endif
+
+ if(nppm(m+1).ne.0)then
+ goto 9
+ else
+ goto 10
+ endif
+
+20 continue
+ if(debug.ge.3)write (moniou,214)nppr
+ if(nptg0.eq.0)goto 31
+
+c target 'fans'
+ m=0
+ nppm(1)=nptg0
+ xpomm(1)=xpomr
+ wgpm(1)=wgtg0
+ xxm(1)=xxp
+ yym(1)=yyp
+ do i=1,nptg0
+ ippm(i,1)=iptg0(i)
+ itypm(i,1)=itytg0(i)
+ enddo
+
+21 m=m+1 !next level multi-Pomeron vertex
+ if(m.gt.levmax)then
+ iret=1
+ goto 31
+ endif
+ ii(m)=0
+22 ii(m)=ii(m)+1 !next cut fan in the vertex
+ if(ii(m).gt.nppm(m))then !all fans at the level considered
+ m=m-1 !one level down
+ if(m.eq.0)goto 31 !all targ. fans considered
+ goto 22
+ endif
+ l=ii(m)
+ itt=ippm(l,m) !targ. index for the leg
+ itypom=itypm(l,m) !type of the cut
+ btm=(xb(itt,1)-xxm(m))**2+(xb(itt,2)-yym(m))**2 !b^2 for the leg
+ if(debug.ge.4)write (moniou,216)ii(m),m,itt,btm
+ if(xpomm(m)*scm.lt.sgap**2)stop'xpomm(m)*scm<sgap**2!'
+
+ if(debug.ge.4)write (moniou,210)m
+ xpomr0=min(dsqrt(xpomm(m)/scm),xpomm(m)/sgap)
+ xpomr0=max(xpomr0,sgap/scm)
+ if(itypom.eq.4)xpomr0=max(xpomr0,dsqrt(xpomm(m)*sgap/scm))
+ rp1=(rq(iddt(itt),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomm(m)/xpomr0)*4.d0*.0389d0
+ rp0=rp1*rp2/(rp1+rp2)
+ bbt=btm*(rp1/(rp1+rp2))**2
+ bbi=btm*(rp2/(rp1+rp2))**2
+ call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
+ *,xxp0,yyp0,1)
+
+ call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
+ *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
+ vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ viu=qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,8))
+ if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
+ vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
+ * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
+ vip=qgpini(xpomm(m)/xpomr0,bbi,vvxi,0.d0,16)*exp(-vim)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons at the end
+ vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
+ else !rap-gap at the end
+ vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
+ viuu=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,20)
+ * *(1.d0-exp(-viu))
+ viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomr0,bbi
+ * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
+ vicc=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,22)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ vicu=max(0.d0,qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,23)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ * -vicc)
+ endif
+
+ if(itypom.le.3)then !cut 'fan'
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)-itt+1
+ iti=ia(2)-i+1
+ bbl=(xb(iti,1)-xxp0)**2+(xb(iti,2)-yyp0)**2
+ sumut=sumut-vtac(iti)
+ vtac0(iti)=min(vtac(iti)
+ * ,qgfani(xpomr0*scm,bbl,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
+ if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+ vtacng=min(vtac0(itt)
+ * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
+ vtacpe=min(vtacng
+ * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
+ else !cut 'leg'
+ vtlc=qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
+ vtlc0=min(vtlc
+ * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
+ vtlcng=min(vtlc0
+ * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
+ vtlcpe=min(vtlcng
+ * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
+ endif
+
+ if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
+ gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
+ gb0=gb0*40.d0
+ elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)
+ elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)
+ elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
+ gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
+ elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
+ gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
+ gb0=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ if(gb0.eq.0.d0)then
+ gb0=vip*vtlc0*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl) *.01d0
+ endif
+ elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
+ gb0=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
+ * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
+ * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
+ gb0=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ endif
+ if(gb0.le.0.d0)then !so170712
+ iret=1
+ goto 31
+ endif
+ nrej=0
+
+23 xpomm(m+1)=xpomm(m)/sgap/(xpomm(m)*scm/sgap**2)**qgran(b10)
+ if(itypom.eq.4)xpomm(m+1)=xpomm(m)/sgap
+ */(xpomm(m)*scm/sgap**3)**qgran(b10)
+ rp1=(rq(iddt(itt),2)+alfp*dlog(xpomm(m+1)*scm))*4.d0*.0389d0
+ rp2=alfp*dlog(xpomm(m)/xpomm(m+1))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+ call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
+ *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10))) !coordinates for the vertex
+
+ call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
+ *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
+ vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ viu=qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,2)
+ vim=2.d0*min(viu,qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,8))
+ if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
+ vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
+ * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
+ vip=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxi,0.d0,16)*exp(-vim)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons at the end
+ vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
+ else !rap-gap at the end
+ vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
+ viuu=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,20)
+ * *(1.d0-exp(-viu))
+ viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomm(m+1),bbi
+ * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
+ vicc=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,22)*.5d0
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ vicu=max(0.d0,qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,23)
+ * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
+ * /2.d0-vicc)
+ endif
+
+ if(itypom.le.3)then !cut 'fan'
+ sumut=0.d0
+ vvxt0=0.d0
+ do i=1,ia(2)
+ sumut=sumut+vtac(i)
+ enddo
+ vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ do i=1,ia(2)-itt+1
+ iti=ia(2)-i+1
+ bbl=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
+ sumut=sumut-vtac(iti)
+ vtac0(iti)=min(vtac(iti)
+ * ,qgfani(xpomm(m+1)*scm,bbl,1.d0-vvxs*exp(-sumut)
+ * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
+ if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
+ enddo
+ vvxt0=1.d0-exp(-vvxt0)
+
+ vtacng=min(vtac0(itt)
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
+ vtacpe=min(vtacng
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
+ else !cut 'leg'
+ vtlc=qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
+ vtlc0=min(vtlc
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
+ vtlcng=min(vtlc0
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
+ vtlcpe=min(vtlcng
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
+ endif
+
+ if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
+ gb=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
+ elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)
+ elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)
+ elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
+ gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
+ elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
+ gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
+ * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
+ * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
+ * *exp(-vpac(ip))))*(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
+ * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vtac(itt)-vtac0(itt))
+ * -1.d0-(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvx)*(1.d0-vvxp)
+ elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
+ gb=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
+ gb=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
+ * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
+ * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
+ * *exp(-vpac(ip))))
+ elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
+ gb=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
+ * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
+ * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
+ endif
+ nrej=nrej+1
+ gb=gb/gb0/z*rp/rp0 /10.d0
+ if(qgran(b10).gt.gb.and.nrej.le.1000)goto 23
+
+ if(itypom.eq.-1.or.itypom.eq.4)then !'single cut Pomeron in the handle
+ npin=npin+1
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ xpomim(npin)=1.d0/xpomm(m+1)/scm
+ xpomip(npin)=xpomm(m)
+ vvxim(npin)=vvxi
+ bpomim(npin)=bbi
+ if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
+ * ,vvxim(npin),bpomim(npin)
+ elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons in the handle
+ ninc=npgen(vim,2,20)
+ npin=npin+ninc
+ if(npin.gt.npmax)then
+ iret=1
+ goto 31
+ endif
+ do i=npin-ninc+1,npin
+ xpomim(i)=1.d0/xpomm(m+1)/scm
+ xpomip(i)=xpomm(m)
+ vvxim(i)=0.d0
+ bpomim(i)=bbi
+ if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
+ * ,vvxim(i),bpomim(i)
+ enddo
+ endif
+
+ if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
+ vv3=2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
+ if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv3.lt.0.d0)vv3=0.d0
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ elseif(itypom.eq.0)then !cut 'loop' in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)*(vicc+vicu)
+ * /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
+ vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ elseif(itypom.eq.1)then !uncut 'handle' (rap-gap)
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
+ vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
+ vv4=2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0-(vtac(itt)
+ * -vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))
+ * *exp(-vtac(itt))*viuu/(viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
+ * *exp(-vpac(ip)))+viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip)))
+ if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv4.lt.0.d0)vv4=0.d0
+ aks=(vv1+vv2+vv3+vv4)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ elseif(aks.lt.vv1+vv2+vv3)then
+ jt=3 !1 cut fan
+ else
+ jt=4 !>1 cut 'handle' fans
+ endif
+ elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
+ * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
+ * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
+ * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
+ * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
+ vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
+ vv3=2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
+ * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
+ * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ elseif(itypom.eq.3)then !rap-gap in the 'handle'
+ vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))*(1.d0+2.d0*vtac(itt)))
+ * +2.d0*vtac(itt)*exp(-2.d0*vtac(itt))*(1.d0-(1.d0-vvxt)**2))
+ * *(1.d0-vvxtl)-2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
+ * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))
+ * *(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
+ * *(vicc+vicu+wgpm(m)*(viuu-viuc))
+ * /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
+ * *exp(-vpac(ip))))
+ vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
+ * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
+ vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2
+ * *(1.d0-vvxtl)
+ aks=(vv1+vv2+vv3)*qgran(b10)
+ if(aks.lt.vv1)then
+ jt=1 !>1 cut fans
+ elseif(aks.lt.vv1+vv2)then
+ jt=2 !diffr. cut
+ else
+ jt=3 !1 cut fan
+ endif
+ else
+ jt=5 !cut leg
+ endif
+
+ nppm(m+1)=0
+ wgpm(m+1)=0.d0
+ if(jt.eq.1)then !>1 cut fans
+ ntry=0
+24 ntry=ntry+1
+ nphm=0
+ if(itt.eq.ia(2).or.ntry.gt.100)then
+ nppm(m+1)=npgen(2.d0*vtac(itt),2,20)
+ do i=1,nppm(m+1)
+ if(qgran(b10).le.vtac0(itt)/vtac(itt)
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(i,m+1)=0
+ else
+ nphm=nphm+1
+ itypm(i,m+1)=1
+ endif
+ ippm(i,m+1)=itt
+ enddo
+ wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
+ else
+ nppm(m+1)=npgen(2.d0*vtac(itt),1,20)
+ do i=1,nppm(m+1)
+ if(qgran(b10).le.vtac0(itt)/vtac(itt)
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(i,m+1)=0
+ else
+ nphm=nphm+1
+ itypm(i,m+1)=1
+ endif
+ ippm(i,m+1)=itt
+ enddo
+ wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
+ do iti=itt+1,ia(2)
+ ninc=npgen(2.d0*vtac(iti),0,20)
+ if(ninc.ne.0)then
+ nppm(m+1)=nppm(m+1)+ninc
+ nh0=nphm
+ if(nppm(m+1).gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppm(m+1)-ninc+1,nppm(m+1)
+ if(qgran(b10).le.vtac0(iti)/vtac(iti)
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(i,m+1)=0
+ else
+ nphm=nphm+1
+ itypm(i,m+1)=1
+ endif
+ ippm(i,m+1)=iti
+ enddo
+ if(ninc.gt.nphm-nh0)wh=(vtac(iti)/vtac0(iti)-1.d0)/ninc
+ endif
+ enddo
+ if(nppm(m+1).eq.1)goto 24
+ endif
+
+ if(nphm+1.ge.nppm(m+1))then
+ if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
+ gbt=1.d0-exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ elseif(itypom.eq.0)then
+ gbt=1.d0-(vicc+vicu)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ elseif(itypom.eq.3)then
+ gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
+ * *(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
+ * /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)
+ * *exp(-vpac(ip))-(vicu+wgpm(m)*viuu)
+ * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
+ * *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
+ * /(1.d0-vvxt)/(1.d0-vvxtl)
+ else
+ stop'unknown itypom'
+ endif
+ if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
+ * .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
+ ntry=0
+ goto 24
+ endif
+ endif
+
+ elseif(jt.eq.4)then !>1 cut 'handle' fans
+ ntry=0
+25 ntry=ntry+1
+ if(itt.eq.ia(2).or.ntry.gt.100)then
+ nppm(m+1)=npgen(vtac(itt)-vtac0(itt),2,20)
+ do i=1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=itt
+ enddo
+ else
+ nppm(m+1)=npgen(vtac(itt)-vtac0(itt),1,20)
+ do i=1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=itt
+ enddo
+ do iti=itt+1,ia(2)
+ ninc=npgen(vtac(iti)-vtac0(iti),0,20)
+ if(ninc.ne.0)then
+ nppm(m+1)=nppm(m+1)+ninc
+ if(nppm(m+1).gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ do i=nppm(m+1)-ninc+1,nppm(m+1)
+ itypm(i,m+1)=1
+ ippm(i,m+1)=iti
+ enddo
+ endif
+ enddo
+ if(nppm(m+1).eq.1)goto 25
+ endif
+
+ elseif(jt.eq.3)then !1 cut fan
+ nppm(m+1)=1
+ ippm(1,m+1)=itt
+ if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
+ factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=(vtacng-vtacpe)*factor/((vtac0(itt)-vtacpe)*factor
+ * -(vtac(itt)-vtac0(itt))*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ else
+ itypm(1,m+1)=3 !rap-gap in the 'handle'
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
+ factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=vtacng*factor/(vtac0(itt)*factor
+ * -(vtac(itt)-vtac0(itt))*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ if(qgran(b10).le.vtacpe/vtacng
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
+ else
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+ else
+ itypm(1,m+1)=3 !rap-gap in the 'handle'
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ else !rap-gap in the 'handle'
+ if(qgran(b10).le.vtacpe/vtacng
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
+ else
+ itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+ endif
+
+ if(itypm(1,m+1).eq.-1)then !single cut Pomeron in the 'handle'
+ vtlcp=min(vtacpe
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
+ if(qgran(b10).le.vtlcp/vtacpe
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)itypm(1,m+1)=6 !single cut Pomeron
+ endif
+
+ elseif(jt.eq.5)then !cut 'leg'
+ nppm(m+1)=1
+ ippm(1,m+1)=itt
+ if(itypom.eq.4)then !single cut Pomeron at the end
+ if(xpomm(m+1)*scm.le.sgap**2)stop'=4:xpomm(m+1)*scm<sgap**2'
+ factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=(vtlcng-vtlcpe)*factor/((vtlc0-vtlcpe)*factor
+ * -(vtlc-vtlc0)*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0)then
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ else
+ itypm(1,m+1)=5 !rap-gap at the end
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ elseif(itypom.eq.5)then !rap-gap at the end (cut or uncut loop)
+ if(qgran(b10).le.vtlcpe/vtlcng
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(1,m+1)=4 !single cut Pomeron at the end
+ else
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ endif
+ elseif(itypom.eq.7)then !>1 cut Pomerons at the end
+ factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
+ wng=vtlcng*factor/(vtlc0*factor-(vtlc-vtlc0)*(1.d0-factor))
+ if(qgran(b10).le.wng.or.wng.lt.0.d0
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ if(qgran(b10).le.vtlcpe/vtlcng
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(1,m+1)=4 !single cut Pomeron at the end
+ else
+ itypm(1,m+1)=7 !>1 cut Pomerons at the end
+ endif
+ else
+ itypm(1,m+1)=5 !rap-gap at the end
+ wgpm(m+1)=(1.d0-factor)/factor
+ endif
+ endif
+
+ if(itypm(1,m+1).eq.4)then !single cut Pomeron at the end
+ vtlcp=min(vtlcpe
+ * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
+ if(qgran(b10).le.vtlcp/vtlcpe
+ * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**3)itypm(1,m+1)=6 !single cut Pomeron
+ endif
+ endif
+
+ if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then !record single cut Pomeron
+ nptg=nptg+1
+ if(nptg.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ xpomti(nptg)=xpomm(m+1)
+ vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vpac(ip))
+ ipomti(nptg)=itt
+ bpomti(nptg)=bbt
+ nppm(m+1)=0
+ if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
+ * ,vvxti(nptg)
+
+ elseif(nppm(m+1).gt.1)then
+ i=0
+26 i=i+1
+ ityp=itypm(i,m+1)
+ if(ityp.eq.0)then
+ iti=ippm(i,m+1)
+ bbi=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
+ vvxt=0.d0
+ vvxtl=0.d0
+ vvxt0=0.d0
+ if(ia(2).gt.1)then
+ do l=1,ia(2)
+ if(l.lt.iti)then
+ vvxtl=vvxtl+vtac(l)
+ elseif(l.gt.iti)then
+ vvxt=vvxt+vtac(l)
+ vvxt0=vvxt0+vtac0(l)
+ endif
+ enddo
+ endif
+ vvxt=1.d0-exp(-vvxt)
+ vvxtl=1.d0-exp(-vvxtl)
+ vvxt0=1.d0-exp(-vvxt0)
+
+ vtacng=min(vtac0(iti)
+ * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,4))
+ vtacpe=min(vtacng
+ * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,5))
+ vtlcp=min(vtacpe
+ * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt,vvxtl,iddt(iti),2,9))
+
+ aks=qgran(b10)*vtac0(iti)
+ if(aks.le.vtlcp.or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
+ itypm(i,m+1)=6 !single cut Pomeron
+ elseif(aks.lt.vtacpe)then
+ itypm(i,m+1)=-1 !single cut Pomeron in the 'handle'
+ elseif(aks.lt.vtacng)then
+ itypm(i,m+1)=2 !>1 cut Pomerons in the 'handle'
+ endif
+
+ if(itypm(i,m+1).eq.6)then !record single cut Pomeron
+ nptg=nptg+1
+ if(nptg.gt.legmax)then
+ iret=1
+ goto 31
+ endif
+ xpomti(nptg)=xpomm(m+1)
+ vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
+ * *(1.d0-vvxtl)*exp(-vpac(ip))
+ ipomti(nptg)=iti
+ bpomti(nptg)=bbi
+ if(debug.ge.4)write (moniou,217)nptg,iti,bbi,xpomti(nptg)
+ * ,vvxti(nptg)
+ nppm(m+1)=nppm(m+1)-1
+ if(nppm(m+1).ge.i)then
+ do l=i,nppm(m+1)
+ ippm(l,m+1)=ippm(l+1,m+1)
+ itypm(l,m+1)=itypm(l+1,m+1)
+ enddo
+ endif
+ i=i-1
+ endif
+ endif
+ if(i.lt.nppm(m+1))goto 26
+ endif
+
+ if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
+ */((1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)+2.d0*vvxtl))then
+ if(debug.ge.4)write (moniou,212)
+ icdts=iddt(itt)
+ do icdt=1,2
+ iddt(itt)=icdt
+ call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
+ * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
+ wdt(icdt,itt)=(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
+ enddo
+ iddt(itt)=icdts
+ endif
+
+ if(nppm(m+1).ne.0)then
+ goto 21
+ else
+ goto 22
+ endif
+31 continue
+ if(debug.ge.2)write (moniou,219)nppr,nptg,npin,iret
+
+201 format(2x,'qg3pdf - configuration for multi-Pomeron'
+ *,'/diffractive contributions'
+ */4x,i2,'-th proj. nucleon',2x,i2,'-th targ. nucleon')
+202 format(2x,'qg3pdf: problem with initial normalization'
+ *,' -> rejection')
+203 format(2x,'qg3pdf: normalization of rejection function - ',e10.3)
+204 format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
+ *,2x,'gb=',e10.3)
+205 format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
+ *,2x,'xxp=',e10.3,2x,'yyp=',e10.3)
+206 format(2x,'qg3pdf: main vertex, nppr0=',i3,2x,'nptg0=',i3)
+208 format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
+ *,' proj. index - ',i3,2x,'b^2=',e10.3)
+209 format(2x,'qg3pdf: ',i3,'-th proj. leg, proj. index - ',i3
+ *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
+210 format(2x,'qg3pdf: new vertex at ',i3,'-th level')
+211 format(2x,'qg3pdf: ',i3,'-th interm. Pomeron'
+ */4x,'xpomip=',e10.3,2x,'xpomim=',e10.3
+ *,2x,'vvxim=',e10.3,2x,'bpomim=',e10.3)
+212 format(2x,'qg3pdf: diffractive cut')
+214 format(2x,'qg3pdf: total number of proj. legs - ',i3)
+216 format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
+ *,' targ. index - ',i3,2x,'b^2=',e10.3)
+217 format(2x,'qg3pdf: ',i3,'-th targ. leg, targ. index - ',i3
+ *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
+219 format(2x,'qg3pdf - end',2x,'number of proj. legs:',i3
+ *,2x,'number of targ. legs:',i3
+ */4x,'number of interm. Pomerons:',i3,'return flag:',i2)
+ return
+ end
+
+c------------------------------------------------------------------------
+ subroutine qgloolc(sy,xp,bb,icdp,icz,iqq,fan1,fan0)
+c-----------------------------------------------------------------------
+c qgloolc - unintegrated Pomeron leg eikonal with loops
+c sy - Pomeron mass squared,
+c xp - Pomeron LC momentum,
+c bb - impact parameter squared,
+c icz - hadron class
+c iqq=1 - tot
+c iqq=2 - soft Pomeron
+c iqq=3 - (soft+g)-Pomeron
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ fan0=0.d0
+ fan1=0.d0
+ if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
+ * **(.5d0+x1(ix1)*(mx1-1.5d0))
+ rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
+ rp1=alfp*log(xpomr*sy/xp)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ v1icn=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,8)
+ if(iqq.eq.1)then
+ vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,1)
+ v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
+ v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
+ v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
+ elseif(iqq.eq.2)then
+ vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,0)
+ v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,15)
+ v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,14))
+ v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,13))
+ elseif(iqq.eq.3)then
+ vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,2)
+ v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
+ v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
+ v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
+ else
+ vpl=0.d0
+ v1ic0=0.d0
+ v1ic1=0.d0
+ v1ic=0.d0
+ stop 'Should no happen in qgloolc !'
+ endif
+ fan1=fan1+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2
+ * *vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
+ fan0=fan0+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2*vpl*(v1ic1-v1ic0)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ fan0=fan0/8.d0*pi*r3p/.0389d0/g3p**3
+ **dlog(sy/sgap/max(1.d0,xp*sgap))
+ fan1=fan1/8.d0*pi*r3p/.0389d0/g3p**3
+ **dlog(sy/sgap/max(1.d0,xp*sgap))
+1 continue
+ if(iqq.eq.1)then
+ dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,1)
+ elseif(iqq.eq.2)then
+ dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,0)
+ elseif(iqq.eq.3)then
+ dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,2)
+ else
+ dleg=0.d0
+ stop 'Should no happen in qgloolc !'
+ endif
+ fan0=fan0+dleg
+ fan1=fan1+dleg
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qglscr(sy,xp,bb,vvx,icdp,icz,iqq)
+c-----------------------------------------------------------------------
+c vvx = 1 - exp[-sum_j chi_targ(j) - sum_{i.ne.I} chi_proj(i)]
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qglscr=0.d0
+ if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
+ * **(.5d0+x1(ix1)*(mx1-1.5d0))
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vicn=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,8)
+ vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
+ if(iqq.eq.1)then
+ vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,9)
+ vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
+ elseif(iqq.eq.2)then
+ vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
+ vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,13)
+ elseif(iqq.eq.3)then
+ vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,11)
+ vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
+ else
+ vpl=0.d0
+ vi=0.d0
+ stop 'Should no happen in qglscr !'
+ endif
+
+ dpx=vpl*vi*exp(-2.d0*vicn)
+ * *((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
+ qglscr=qglscr+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qglscr=qglscr/8.d0*pi*r3p/.0389d0/g3p**3
+ **dlog(sy/sgap/max(1.d0,xp*sgap))
+1 continue
+ if(iqq.eq.1)then
+ qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,3)
+ elseif(iqq.eq.2)then
+ qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,5)
+ elseif(iqq.eq.3)then
+ qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,7)
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qglh(sy,xp,bb,vvx,icdp,icz,iqq)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qglh=0.d0
+ if(sy.le.max(1.d0,xp*sgap))goto 1
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=min(xp,1.d0/sgap)/(sy/max(1.d0,xp*sgap))
+ * **(.5d0+x1(ix1)*(mx1-1.5d0))
+ rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
+ rp2=rp*rp1/(rp+rp1)
+ do ix2=1,7
+ do mx2=1,2
+ z=.5d0+x1(ix2)*(mx2-1.5d0)
+ bb0=-rp2*log(z)
+ do ix3=1,7
+ do mx3=1,2
+ phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vi=qgppdi(xp/xpomr1/sy,iqq)
+ vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
+ vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
+
+ dpx=vpl*vi*((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
+ * *(xpomr1/xp)**dels*exp(bb2/rp)*rp
+ qglh=qglh+a1(ix1)*a1(ix2)*a1(ix3)*dpx
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qglh=qglh/8.d0*pi*r3p/.0389d0/g3p**2*dlog(sy/max(1.d0,xp*sgap))
+ */fp(icz)/cd(icdp,icz)/qgppdi(1.d0/sy,iqq)
+
+1 qglh=qglh+1.d0
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgcutp(sy,xp,xm,bb,vvx
+ *,icdp,icdt,icz,iqq)
+c-----------------------------------------------------------------------
+c qgcutp - unintegrated cut Pomeron eikonal
+c sy - Pomeron mass squared,
+c xp,xm - Pomeron light cone momenta,
+c b - squared impact parameter,
+c vvx - relative strenth of nuclear screening corrections,
+c icdp, icdt - proj. and targ. diffractive eigenstates,
+c icz - hadron class
+c iqq=1 - total,
+c iqq=2 - soft contribution,
+c iqq=3 - (soft+gg+gq+qq) contribution
+c iqq=4 - (soft+gg+qq) contribution
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgcutp=0.d0
+ if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap))goto 2
+
+ do ix1=1,7
+ do mx1=1,2
+ xpomr1=xp/max(1.d0,xp*sgap)/(sy/max(1.d0,xp*sgap)
+ * /max(1.d0,xm*sgap))**(.5+x1(ix1)*(mx1-1.5))
+ rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
+ rp2=(rq(icdt,2)+alfp*log(xpomr1*sy/xp/xm))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ do ib1=1,7
+ do mb1=1,2
+ z=.5d0+x1(ib1)*(mb1-1.5d0)
+ bb0=-rp*dlog(z)
+ do ib2=1,7
+ do mb2=1,2
+ phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
+ bb1=(dsqrt(bb)*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+ bb2=(dsqrt(bb)*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2
+ * +bb0*sin(phi)**2
+
+ vpf0=qgfani(1.d0/xpomr1,bb1,vvx,0.d0,0.d0,icdp,icz,1)
+ vtf0=qgfani(xpomr1*sy/xp/xm,bb2,vvx,0.d0,0.d0,icdt,2,1)
+ n=1
+1 n=n+1
+ vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*exp(-vtf0)
+ * ,0.d0,0.d0,icdp,icz,1)
+ vtf=qgfani(xpomr1*sy/xp/xm,bb2,1.d0-(1.d0-vvx)*exp(-vpf0)
+ * ,0.d0,0.d0,icdt,2,1)
+ if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.le.50)
+ * then
+ vpf0=vpf
+ vtf0=vtf
+ goto 1
+ endif
+
+ if(iqq.eq.1)then
+ vplt=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,1)
+ vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
+ vpltloop0=min(vplt,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,4))
+ vpltloop=min(vpltloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,3))
+ vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
+ vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
+ * ,icdt,2,3))
+ vpltscr=min(vpltloop,qglegc(xp/xpomr1,xp,bb1
+ * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,9))
+ vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
+ * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
+
+ dpx=(vpltscr*vtltloop+vtltscr*vpltloop)
+ * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
+ * +vplt*(vtltloop-vtltloop0)+vtlt*(vpltloop-vpltloop0)
+ elseif(iqq.eq.2)then
+ vpls=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,0)
+ vtls=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,0)
+ vplsloop0=min(vpls,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,6))
+ vplsloop=min(vplsloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,5))
+ vtlsloop0=min(vtls,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,6))
+ vtlsloop=min(vtlsloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
+ * ,icdt,2,5))
+ vplsscr=min(vplsloop,qglegc(xp/xpomr1,xp,bb1
+ * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,10))
+ vtlsscr=min(vtlsloop,qglegc(xpomr1*sy/xp,xm,bb2
+ * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,10))
+
+ dpx=(vplsscr*vtlsloop+vtlsscr*vplsloop)
+ * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
+ * +vpls*(vtlsloop-vtlsloop0)+vtls*(vplsloop-vplsloop0)
+ elseif(iqq.eq.3)then
+ vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
+ vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
+ vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
+ vplqloop=min(vplqloop0
+ * ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
+ vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
+ vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
+ * ,icdt,2,3))
+ vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
+ * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
+ vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
+ * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
+
+ dpx=(vplqscr*vtltloop+vtltscr*vplqloop)
+ * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
+ * +vplq*(vtltloop-vtltloop0)+vtlt*(vplqloop-vplqloop0)
+ elseif(iqq.eq.4)then
+ vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
+ vtlq=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,2)
+ vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
+ vplqloop=min(vplqloop0
+ * ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
+ vtlqloop0=min(vtlq,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,8))
+ vtlqloop=min(vtlqloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
+ * ,icdt,2,7))
+ vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
+ * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
+ vtlqscr=min(vtlqloop,qglegc(xpomr1*sy/xp,xm,bb2
+ * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,11))
+
+ dpx=(vplqscr*vtlqloop+vtlqscr*vplqloop)
+ * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
+ * +vplq*(vtlqloop-vtlqloop0)+vtlq*(vplqloop-vplqloop0)
+ else
+ dpx=0.d0
+ endif
+ qgcutp=qgcutp+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ qgcutp=qgcutp/16.d0*(r3p*pi/.0389d0)/g3p**3
+ **dlog(sy/max(1.d0,xp*sgap)/max(1.d0,xm*sgap))
+
+2 continue
+ rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))
+ vs=sy**dels*fp(icz)*fp(2)*sigs/rp
+ **exp(-bb/rp/4.d0/.0389d0)*cd(icdp,icz)*cd(icdt,2)
+ vgg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,0)
+ vqq=qgpomc(sy,xp,xm,bb,0.d0,icdp,icdt,icz,5)
+ vqg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,1)
+ */dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
+ vgq=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,2)
+ */dsqrt(xm)*(1.d0-xm)**(ahv(2)-ahl(2))
+ if(iqq.eq.1)then
+ qgcutp=qgcutp+vs+vgg+vqg+vgq+vqq
+ elseif(iqq.eq.2)then
+ qgcutp=qgcutp+vs
+ elseif(iqq.eq.3)then
+ qgcutp=qgcutp+vs+vgg+vgq+vqq
+ elseif(iqq.eq.4)then
+ qgcutp=qgcutp+vs+vgg+vqq
+ endif
+ return
+ end
+
+c=============================================================================
+ double precision function qgpsh(sy,xpp,xpm,bb,icdp,icdt,icz,iqq)
+c-----------------------------------------------------------------------------
+c qgpsh - unintegrated semihard Pomeron eikonal
+c sy - Pomeron mass squared,
+c xpp, xpm - Pomeron LC momenta,
+c b - impact parameter,
+c icdp, icdt - proj. and targ. diffractive eigenstates,
+c icz - hadron class,
+c iqq - type of the hard interaction (0-gg, 1-q_vg, 2-gq_v)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /arr3/ x1(7),a1(7)
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)sy,xpp,xpm,b,vvx0,icdp,icdt
+ *,icz,iqq
+ qgpsh=0.d0
+ s2min=4.d0*fqscal*qt0 !energy threshold for hard interaction
+ if(s2min/sy.ge.1.d0)then
+ if(debug.ge.4)write (moniou,202)qgpsh
+ return
+ endif
+
+ if(iqq.ne.2)then
+ icv=icz
+ icq=2
+ xp=xpp
+ xm=xpm
+ icdv=icdp
+ icdq=icdt
+ else
+ icv=2
+ icq=icz
+ xp=xpm
+ xm=xpp
+ icdq=icdp
+ icdv=icdt
+ endif
+
+ xmin=(s2min/sy)**(delh-dels)
+ do i=1,7
+ do m=1,2
+ z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
+ * **(1.d0/(delh-dels))
+ ww=z1*sy
+ sjqq=qgjit(qt0,qt0,ww,2,2)
+ sjqg=qgjit(qt0,qt0,ww,1,2)
+ sjgg=qgjit(qt0,qt0,ww,1,1)
+
+ if(iqq.eq.0)then !gg-Pomeron
+ st2=0.d0
+ do j=1,7
+ do k=1,2
+ xx=.5d0*(1.d0+x1(j)*(2*k-3))
+ xph=z1**xx
+ xmh=z1/xph
+
+ glu1=qgppdi(xph,0)
+ sea1=qgppdi(xph,1)
+ glu2=qgppdi(xmh,0)
+ sea2=qgppdi(xmh,1)
+ st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
+ * +sea1*sea2*sjqq)
+ enddo
+ enddo
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xpp*xpm*z1)
+ qgpsh=qgpsh-a1(i)*dlog(z1)/z1**delh*st2
+ * *exp(-bb/rh/4.d0/.0389d0)/rh
+
+ else !qg-Pomeron
+ xmh=z1
+ glu=qgppdi(xmh,0)
+ sea=qgppdi(xmh,1)
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm*xmh)
+
+ fst=(glu*sjqg+sea*sjqq)
+ * *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
+ * *exp(-bb/rh/4.d0/.0389d0)/rh
+ qgpsh=qgpsh+a1(i)/z1**delh*fst
+ endif
+ enddo
+ enddo
+ qgpsh=qgpsh*(1.d0-xmin)/(delh-dels)
+ if(iqq.eq.0)then
+ qgpsh=qgpsh*rr**2*fp(icz)*fp(2)*factk/2.d0*pi
+ * *cd(icdp,icz)*cd(icdt,2)
+ else
+ qgpsh=qgpsh*rr*fp(icq)*factk/4.d0
+ * *cd(icdp,icz)*cd(icdt,2)
+ endif
+ if(debug.ge.4)write (moniou,202)qgpsh
+
+201 format(2x,'qgpsh - unintegrated semihard Pomeron eikonal:'
+ */4x,'sy=',e10.3,2x,'xpp=',e10.3,2x,'xpm=',e10.3,2x,'b=',e10.3
+ */4x,'vvx0=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
+ *,2x,'iqq=',i1)
+202 format(2x,'qgpsh=',e10.3)
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qglegc(sy,xp,bb,vvx,icdp,icz,iqq)
+c-----------------------------------------------------------------------
+c qglegc - interpolation of cut Pomeron leg eikonal
+c sy - Pomeron mass squared,
+c xp - Pomeron LC momentum,
+c bb - squared impact parameter,
+c vvx - relative strenth of screening corrections (0<vvx<1),
+c icdp - diffractive eigenstate for the hadron,
+c icz - hadron class
+c iqq=0 - soft Pomeron,
+c iqq=1 - total Pomeron,
+c iqq=2 - (soft+g)-Pomeron,
+c iqq=3 - total loop,
+c iqq=4 - total loop with single Pomeron end,
+c iqq=5 - soft loop,
+c iqq=6 - soft loop with single Pomeron end,
+c iqq=7 - (soft+g)-loop,
+c iqq=8 - (soft+g)-loop with single Pomeron end,
+c iqq=9 - total screened,
+c iqq=10 - soft screened,
+c iqq=11 - (soft+g)-screened
+c iqq=12 - g-distribution,
+c iqq=13 - q-distribution
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wj(3),wi(3),wz(3)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)sy,xp,bb,vvx,icdp,icz,iqq
+
+ qglegc=0.d0
+ clegm=0.d0
+ rp=(rq(icdp,icz)+alfp*log(max(1.d0,sy/xp)))*4.d0*.0389d0
+ z=exp(-bb/rp)
+ if(iqq.eq.0.or.iqq.le.11.and.sy.le.sgap*max(1.d0,xp*sgap)
+ * .or.iqq.gt.11.and.sy.le.max(1.d0,xp*sgap))then
+ if(iqq.le.11)then
+ qglegc=sy**dels*fp(icz)*sigs*g3p/rp*4.d0*.0389d0*z*cd(icdp,icz)
+ else
+ qglegc=qgppdi(1.d0/sy,iqq-12)
+ endif
+ if(debug.ge.4)write (moniou,202)qglegc
+ return
+ endif
+
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ if(iqq.le.11)then
+ yl=max(0.d0,dlog(sy/xp/sgap**2)/dlog(spmax/sgap**2))*50.d0+1.d0
+ else
+ yl=max(0.d0,dlog(sy/xp/sgap)/dlog(spmax/sgap))*50.d0+1.d0
+ endif
+ k=max(1,int(yl))
+ k=min(k,49)
+ wk(2)=yl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+
+ if(xp.lt..2d0)then
+ if(iqq.le.11)then
+ xl=6.d0-5.d0*log(5.d0*xp)/log(5.d0*xp*sgap/sy)
+ elseif(sy.gt.1.01d0*xp*sgap)then
+ xl=6.d0-5.d0*log(5.d0*xp)/log(xp*sgap/sy)
+ else
+ xl=1.d0
+ endif
+ else
+ xl=5.d0*xp+5.d0
+ endif
+ i=min(8,int(xl))
+ i=max(1,i)
+ if(i.eq.5)i=4
+ wi(2)=xl-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ ixmax=3
+
+ if(iqq.lt.9)then
+ do k1=1,iymax
+ k2=k+k1-1
+ do i1=1,ixmax
+ i2=i+i1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ qglegc=qglegc+qlegc0(k2,i2,l2,icdp+2*(icz-1),iqq)
+ * *wk(k1)*wi(i1)*wz(l1)
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do k1=1,iymax
+ k2=k+k1-1
+ do i1=1,ixmax
+ i2=i+i1-1
+ clegm=clegm+qlegc0(k2,i2,1,icdp+2*(icz-1),iqq)*wk(k1)*wi(i1)
+ enddo
+ enddo
+ qglegc=min(qglegc,clegm)
+ endif
+ else
+ vl=max(1.d0,vvx*10.d0+1.d0)
+ if(vl.lt.2.d0)then
+ j=1
+ wj(2)=vl-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ ivmax=3
+ else
+ j=min(int(vl),10)
+ wj(2)=vl-j
+ wj(1)=1.d0-wj(2)
+ ivmax=2
+ endif
+
+ do l1=1,izmax
+ l2=jz+l1-1
+ do j1=1,ivmax
+ j2=j+j1-1
+ do i1=1,ixmax
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qglegc=qglegc+qlegc(k2,i2,j2,l2,icdp+2*(icz-1)+6*(iqq-9))
+ * *wk(k1)*wi(i1)*wz(l1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,ivmax
+ j2=j+j1-1
+ do i1=1,ixmax
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ clegm=clegm+qlegc(k2,i2,j2,1,icdp+2*(icz-1)+6*(iqq-9))
+ * *wk(k1)*wi(i1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ qglegc=min(qglegc,clegm)
+ endif
+ endif
+ if(iqq.le.11)then
+ qglegc=exp(qglegc)*qgls(sy,xp,bb,icdp,icz)
+ else
+ qglegc=exp(qglegc)*qgppdi(1.d0/sy,iqq-12)
+ endif
+ if(debug.ge.4)write (moniou,202)qglegc
+
+201 format(2x,'qglegc - interpolation of Pomeron leg eikonal:'
+ */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'b^2=',e10.3,2x,'vvx=',e10.3
+ *,2x,'icdp=',i1,2x,'icz=',i1,2x,'iqq=',i1)
+202 format(2x,'qglegc=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgpomc(sy,xp,xm,bb,vvx
+ *,icdp,icdt,icz,iqq)
+c-----------------------------------------------------------------------
+c qgpomc - unintegrated cut Pomeron eikonal
+c sy - Pomeron mass squared,
+c xp,xm - Pomeron light cone momenta,
+c bb - squared impact parameter,
+c vvx - relative strenth of nuclear screening corrections,
+c icdp, icdt - proj. and targ. diffractive eigenstates,
+c icz - hadron class
+c iqq=1 - total,
+c iqq=2 - soft contribution,
+c iqq=3 - qg contribution
+c iqq=4 - gq contribution
+c iqq=5 - qq contribution
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wi(3),wj(3),wz(3),wm(3)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr19/ ahl(3)
+ common /qgarr20/ spmax
+ common /qgarr25/ ahv(3)
+ common /qgarr26/ factk,fqscal
+ common /qgarr38/ qpomc(11,100,11,11,48)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)sy,xp,xm,bb,vvx
+ *,icdp,icdt,icz,iqq
+
+ qgpomc=0.d0
+ pomm=0.d0
+ if(iqq.eq.5)then !qq contribution
+ s2min=4.d0*fqscal*qt0
+ if(sy.gt.1.001d0*s2min.and.xp.lt..99d0.and.xm.lt..99d0)then
+ sj=qgjit(qt0,qt0,sy,2,2)
+ qgpomc=sj*factk*(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
+ * *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/xp/xm
+ * *(1.d0-xp)**(ahv(icz)-ahl(icz))*(1.d0-xm)**(ahv(2)-ahl(2))
+ * *exp(-bb/(4.d0*.0389d0*(rq(icdp,icz)+rq(icdt,2))))
+ * /(8.d0*pi*(rq(icdp,icz)+rq(icdt,2)))*cd(icdp,icz)*cd(icdt,2)
+ endif
+ if(debug.ge.4)write (moniou,202)qgpomc
+ return
+ endif
+
+ rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))*4.d0*.0389d0
+ z=exp(-bb/rp)
+ if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap)*1.01d0)then
+ qgpomc=sy**dels*fp(icz)*fp(2)*sigs*z/rp
+ * *4.d0*.0389d0*cd(icdp,icz)*cd(icdt,2)
+ return
+ endif
+
+ if(z.gt..2d0)then
+ zz=5.d0*z+6.d0
+ else
+ zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
+ endif
+ jz=min(9,int(zz))
+ jz=max(1,jz)
+ if(zz.lt.1.d0)then
+ wz(2)=zz-jz
+ wz(1)=1.d0-wz(2)
+ izmax=2
+ else
+ if(jz.eq.6)jz=5
+ wz(2)=zz-jz
+ wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
+ wz(1)=1.d0-wz(2)+wz(3)
+ wz(2)=wz(2)-2.d0*wz(3)
+ izmax=3
+ endif
+
+ yl=max(0.d0,dlog(sy/xp/xm/sgap**2)
+ */dlog(spmax/sgap**2))*10.d0+1.d0
+ k=max(1,int(yl))
+ k=min(k,9)
+ wk(2)=yl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ iymax=3
+
+ if(xp.lt..2d0)then
+ xl1=6.d0-5.d0*log(5.d0*xp)/log(5.d0*sgap*xp*xm/sy)
+ else
+ xl1=5.d0*xp+5.d0
+ endif
+ i=min(8,int(xl1))
+ i=max(1,i)
+ if(i.eq.5)i=4
+ wi(2)=xl1-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ ix1max=3
+
+ if(sgap/sy*xm.gt..99d0)then
+ j=1
+ wj(1)=1.d0
+ ix2max=1
+ else
+ if(xm.lt..2d0)then
+ xl2=6.d0-5.d0*log(5.d0*xm)/log(sgap/sy*xm)
+ else
+ xl2=5.d0*xm+5.d0
+ endif
+ j=min(8,int(xl2))
+ j=max(1,j)
+ if(j.eq.5)j=4
+ wj(2)=xl2-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ ix2max=3
+ endif
+
+ ml=icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1)
+ if(vvx.eq.0.d0)then !hadron-proton collision
+ do l1=1,izmax
+ l2=jz+l1-1
+ do j1=1,ix2max
+ j2=j+j1-2
+ do i1=1,ix1max
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,1,ml)
+ * *wk(k1)*wi(i1)*wj(j1)*wz(l1)
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do j1=1,ix2max
+ j2=j+j1-2
+ do i1=1,ix1max
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ pomm=pomm+qpomc(k2,i2+10*j2,1,1,ml)*wk(k1)*wi(i1)*wj(j1)
+ enddo
+ enddo
+ enddo
+ qgpomc=min(qgpomc,pomm)
+ endif
+
+ else !hA (AA) collision
+ vl=max(1.d0,vvx*10.d0+1.d0)
+ if(vl.lt.2.d0)then
+ m=1
+ wm(2)=vl-m
+ wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
+ wm(1)=1.d0-wm(2)+wm(3)
+ wm(2)=wm(2)-2.d0*wm(3)
+ ivmax=3
+ else
+ m=min(int(vl),10)
+ wm(2)=vl-m
+ wm(1)=1.d0-wm(2)
+ ivmax=2
+ endif
+
+ do m1=1,ivmax
+ m2=m+m1-1
+ do l1=1,izmax
+ l2=jz+l1-1
+ do j1=1,ix2max
+ j2=j+j1-2
+ do i1=1,ix1max
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,m2,ml)
+ * *wk(k1)*wi(i1)*wj(j1)*wz(l1)*wm(m1)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ if(zz.lt.1.d0)then
+ do m1=1,ivmax
+ m2=m+m1-1
+ do j1=1,ix2max
+ j2=j+j1-2
+ do i1=1,ix1max
+ i2=i+i1-1
+ do k1=1,iymax
+ k2=k+k1-1
+ pomm=pomm+qpomc(k2,i2+10*j2,1,m2,ml)
+ * *wk(k1)*wi(i1)*wj(j1)*wm(m1)
+ enddo
+ enddo
+ enddo
+ enddo
+ qgpomc=min(qgpomc,pomm)
+ endif
+ endif
+ qgpomc=exp(qgpomc)*z
+ if(debug.ge.4)write (moniou,202)qgpomc
+
+201 format(2x,'qgpomc - unintegrated cut Pomeron eikonal:'
+ */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'xm=',e10.3,2x,'b^2=',e10.3
+ */4x,'vvx=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
+ *,2x,'iqq=',i1)
+202 format(2x,'qgpomc=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgsha(nbpom,ncola,ncolb,iret)
+c-----------------------------------------------------------------------------
+c qgsha - inelastic interaction (energy sharing and particle production)
+c nbpom - number of Pomeron blocks (nucleon(hadron)-nucleon collisions),
+c ncola - number of inel.-wounded proj. nucleons,
+c ncolb - number of inel.-wounded targ. nucleons
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
+ *,legmax=900,njmax=50000)
+ dimension wppr0(iapmax),wmtg0(iapmax),wppr1(iapmax),wmtg1(iapmax)
+ *,wppr2(iapmax),wmtg2(iapmax),izp(iapmax),izt(iapmax)
+ *,ila(iapmax),ilb(iapmax),lva(iapmax),lvb(iapmax)
+ *,lqa0(iapmax),lqb0(iapmax),ncola(iapmax),ncolb(iapmax)
+ *,ncola0(iapmax),ncolb0(iapmax)
+ *,xpomp0(npnmax,iapmax),xpomt0(npnmax,iapmax)
+ *,xpopin0(npmax,npbmax),xpomin0(npmax,npbmax)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
+ common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
+ *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
+ *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
+ *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
+ *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
+ *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
+ *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
+ *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
+ common /qgarr11/ b10
+ common /qgarr12/ nsp
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
+ *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
+ *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
+ *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
+ *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
+ *,bpomin(npmax,npbmax)
+ common /qgarr26/ factk,fqscal
+ common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
+ common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.1)write (moniou,201)nbpom !so161205
+ nsp0=nsp
+
+ do j=1,ia(1)
+ if(lqa(j).ne.0)then
+ do i=1,lqa(j)
+ if(idnpi(i,j).ne.0)xpomp0(i,j)=xpompr(i,j)
+ enddo
+ endif
+ enddo
+ do j=1,ia(2)
+ if(lqb(j).ne.0)then
+ do i=1,lqb(j)
+ if(idnti(i,j).ne.0)xpomt0(i,j)=xpomtg(i,j)
+ enddo
+ endif
+ enddo
+ if(nbpom.ne.0)then
+ do nb=1,nbpom !loop over collisions
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb) !loop over interm. Pomerons in the collision
+ xpopin0(np,nb)=xpopin(np,nb)
+ xpomin0(np,nb)=xpomin(np,nb)
+ enddo
+ endif
+ enddo
+ endif
+ iret=0
+ nret=0
+
+1 nsp=nsp0
+ nj=0
+
+ if(iret.ne.0)then !rejection during energy-sharing
+ nret=nret+1
+ if(nret.gt.100)return !too many rejections -> redo configuration
+ endif
+
+ do j=1,ia(1)
+ if(lqa(j).ne.0)then
+ do i=1,lqa(j)
+ if(idnpi(i,j).ne.0)xpompr(i,j)=xpomp0(i,j)
+ enddo
+ endif
+ enddo
+ do j=1,ia(2)
+ if(lqb(j).ne.0)then
+ do i=1,lqb(j)
+ if(idnti(i,j).ne.0)xpomtg(i,j)=xpomt0(i,j)
+ enddo
+ endif
+ enddo
+ if(nbpom.ne.0)then
+ do nb=1,nbpom !loop over collisions
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb) !loop over interm. Pomerons in the collision
+ xpopin(np,nb)=xpopin0(np,nb)
+ xpomin(np,nb)=xpomin0(np,nb)
+ enddo
+ endif
+ enddo
+ endif
+
+c-------------------------------------------------
+c initial nucleon (hadron) types
+ if(ia(1).ne.1)then
+ do i=1,ia(1)
+ izp(i)=int(2.5d0+qgran(b10)) !i-th projectile nucleon type
+ enddo
+ else
+ izp(1)=icp !projectile hadron type
+ endif
+ if(ia(2).ne.1)then
+ do i=1,ia(2)
+ izt(i)=int(2.5d0+qgran(b10)) !i-th target nucleon type
+ enddo
+ else
+ izt(1)=2 !target proton
+ endif
+
+ do i=1,ia(1)
+ lqa0(i)=lqa(i)
+ lva(i)=0
+ ncola0(i)=ncola(i)
+ enddo
+ do i=1,ia(2)
+ lqb0(i)=lqb(i)
+ lvb(i)=0
+ ncolb0(i)=ncolb(i)
+ enddo
+
+c-------------------------------------------------
+c energy-momentum sharing between Pomerons
+ if(nbpom.ne.0)then
+ if(debug.ge.1)write (moniou,202)
+ call qgprox(0) !initial x-configuration
+ gbl0=qgweix(nbpom) !log-weight for the initial x-configuration
+ nrej=0
+ nchange=0
+ gbnorm=.1d0
+ gbhmax=-1000.d0
+
+2 continue
+ call qgprox(1) !proposed x-configuration
+ gbl=qgweix(nbpom) !log-weight for the proposed x-configuration
+ gbh=gbl-gbl0-gbnorm !log of acceptance probability
+ gbhmax=max(gbhmax,gbh)
+
+ if(debug.ge.5)write (moniou,203)gbh,nrej,nchange
+ if(gbh.lt.-50.d0.or.qgran(b10).gt.exp(gbh))then
+ nrej=nrej+1
+ if(nrej.gt.100)then !too many rejections
+ nrej=0
+ nchange=nchange+1
+ gbnorm=gbnorm+gbhmax+.5d0 !new normalization of acceptance
+ gbhmax=-1000.d0
+ if(debug.ge.4)write (moniou,204)nchange
+ endif
+ goto 2 !rejection
+ endif
+ endif
+
+c-------------------------------------------------
+c leading remnant LC momenta
+ if(debug.ge.1)write (moniou,205)
+ do i=1,ia(1) !loop over proj. nucleons
+ wppr0(i)=wp0
+ wppr1(i)=0.d0
+ wppr2(i)=0.d0
+ if(lqa(i).ne.0)then
+ do l=1,lqa(i) !loop over constituent partons
+ wppr0(i)=wppr0(i)-wp0*xppr(l,i) !subtract Pomeron LC momentum
+ if(wppr0(i).lt.0.d0)then
+ wppr0(i)=0.d0
+ endif
+ enddo
+ endif
+ enddo
+ do i=1,ia(2) !loop over targ. nucleons
+ wmtg0(i)=wm0
+ wmtg1(i)=0.d0
+ wmtg2(i)=0.d0
+ if(lqb(i).ne.0)then
+ do l=1,lqb(i) !loop over constituent partons
+ wmtg0(i)=wmtg0(i)-wm0*xmtg(l,i) !subtract Pomeron LC momentum
+ if(wmtg0(i).lt.-1.d-15)stop'w^-<0!!!'
+ wmtg0(i)=max(0.d0,wmtg0(i))
+ enddo
+ endif
+ enddo
+
+c-------------------------------------------------
+c momentum conservation (correction for 3p-vertexes)
+ if(debug.ge.1)write (moniou,206)
+ if(nbpom.ne.0)then
+ do nb=1,nbpom !loop over collisions
+ ip=ias(nb) !proj. index
+ it=ibs(nb) !targ. index
+ if(nqs(nb).ne.0)then
+ do np=1,nqs(nb) !loop over single Pomerons in the collision
+ lnp=nnpr(np,nb) !proj. constituent parton index
+ lnt=nntg(np,nb) !targ. constituent parton index
+ wppr1(ip)=wppr1(ip)+xppr(lnp,ip)*wp0 !count Pomeron LC momentum
+ wmtg1(it)=wmtg1(it)+xmtg(lnt,it)*wm0 !count Pomeron LC momentum
+ enddo
+ endif
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb) !loop over interm. Pomerons in the collision
+ xpp=xpopin(np,nb)
+ xpm=xpomin(np,nb)
+ if(xpp*xpm*scm.gt.1.d0)then
+ wppr2(ip)=wppr2(ip)+xpp*wp0 !count Pomeron LC momentum
+ wmtg2(it)=wmtg2(it)+xpm*wm0 !count Pomeron LC momentum
+ else
+ xpopin(np,nb)=0.d0
+ xpomin(np,nb)=0.d0
+ endif
+ enddo
+ endif
+ if(npompr(nb).ne.0)then
+ do np=1,npompr(nb) !loop over proj. leg Pomerons in the collision
+ ipp=ilpr(np,nb) !proj. index
+ lnp=lnpr(np,nb) !proj. constituent parton index
+ xpp=xppr(lnp,ipp)
+ xpm=xpompr(lnp,ipp)
+ if(xpp*xpm*scm.gt.1.d0)then
+ wppr1(ipp)=wppr1(ipp)+xpp*wp0 !count Pomeron LC momentum
+ wmtg2(it)=wmtg2(it)+xpm*wm0 !count Pomeron LC momentum
+ else
+ xppr(lnp,ipp)=0.d0
+ xpompr(lnp,ipp)=0.d0
+ endif
+ enddo
+ endif
+ if(npomtg(nb).ne.0)then
+ do np=1,npomtg(nb) !loop over targ. leg Pomerons in the collision
+ itt=iltg(np,nb) !targ. index
+ lnt=lntg(np,nb) !targ. constituent parton index
+ xpp=xpomtg(lnt,itt)
+ xpm=xmtg(lnt,itt)
+ if(xpp*xpm*scm.gt.1.d0)then
+ wppr2(ip)=wppr2(ip)+xpp*wp0 !count Pomeron LC momentum
+ wmtg1(itt)=wmtg1(itt)+xpm*wm0 !count Pomeron LC momentum
+ else
+ xmtg(lnt,itt)=0.d0
+ xpomtg(lnt,itt)=0.d0
+ endif
+ enddo
+ endif
+ enddo
+ endif
+
+ do ip=1,ia(1)
+ if(wppr1(ip)+wppr2(ip).ne.0.d0)then
+ if(lqa(ip).ne.0)then
+ do i=1,lqa(ip)
+ xppr(i,ip)=xppr(i,ip)*(wp0-wppr0(ip)) !renorm. for const. partons
+ * /(wppr1(ip)+wppr2(ip))
+ enddo
+
+ do nb=1,nbpom
+ if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb)
+ xpopin(np,nb)=xpopin(np,nb)*(wp0-wppr0(ip))
+ * /(wppr1(ip)+wppr2(ip))
+ enddo
+ endif
+ if(npomtg(nb).ne.0)then
+ do np=1,npomtg(nb)
+ itt=iltg(np,nb)
+ lnt=lntg(np,nb)
+ xpomtg(lnt,itt)=xpomtg(lnt,itt)*(wp0-wppr0(ip))
+ * /(wppr1(ip)+wppr2(ip))
+ enddo
+ endif
+ endif
+ enddo
+
+ elseif(wppr2(ip).gt.wp0)then
+ wpt=wp0/sgap/2.d0*4.d0**qgran(b10)
+ do nb=1,nbpom
+ if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb)
+ xpopin(np,nb)=xpopin(np,nb)*wpt/wppr2(ip)
+ enddo
+ endif
+ if(npomtg(nb).ne.0)then
+ do np=1,npomtg(nb)
+ itt=iltg(np,nb)
+ lnt=lntg(np,nb)
+ xpomtg(lnt,itt)=xpomtg(lnt,itt)*wpt/wppr2(ip)
+ enddo
+ endif
+ endif
+ enddo
+ wppr0(ip)=wp0-wpt
+ else
+ wppr0(ip)=wp0-wppr2(ip)
+ endif
+ else !so230913
+ wppr0(ip)=wp0 !so230913
+ endif
+ enddo
+
+ do it=1,ia(2)
+ if(wmtg1(it)+wmtg2(it).ne.0.d0)then
+ if(lqb(it).ne.0)then
+ do i=1,lqb(it)
+ xmtg(i,it)=xmtg(i,it)*(wm0-wmtg0(it))/(wmtg1(it)+wmtg2(it))
+ enddo
+
+ do nb=1,nbpom
+ if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb)
+ xpomin(np,nb)=xpomin(np,nb)*(wm0-wmtg0(it))
+ * /(wmtg1(it)+wmtg2(it))
+ enddo
+ endif
+ if(npompr(nb).ne.0)then
+ do np=1,npompr(nb)
+ ipp=ilpr(np,nb)
+ lnp=lnpr(np,nb)
+ xpompr(lnp,ipp)=xpompr(lnp,ipp)*(wm0-wmtg0(it))
+ * /(wmtg1(it)+wmtg2(it))
+ enddo
+ endif
+ endif
+ enddo
+
+ elseif(wmtg2(it).gt.wm0)then
+ wmt=wm0/sgap/2.d0*4.d0**qgran(b10)
+ do nb=1,nbpom
+ if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
+ if(npomin(nb).ne.0)then
+ do np=1,npomin(nb)
+ xpomin(np,nb)=xpomin(np,nb)*wmt/wmtg2(it)
+ enddo
+ endif
+ if(npompr(nb).ne.0)then
+ do np=1,npompr(nb)
+ ipp=ilpr(np,nb)
+ lnp=lnpr(np,nb)
+ xpompr(lnp,ipp)=xpompr(lnp,ipp)*wmt/wmtg2(it)
+ enddo
+ endif
+ endif
+ enddo
+ wmtg0(it)=wm0-wmt
+ else
+ wmtg0(it)=wm0-wmtg2(it)
+ endif
+ else !so230913
+ wmtg0(it)=wm0 !so230913
+ endif
+ enddo
+
+c-------------------------------------------------
+c treatment of low mass diffraction
+ if(debug.ge.1)write (moniou,207)
+ do ip=1,ia(1) !loop over proj. nucleons
+ if(iwp(ip).eq.2)then !diffraction dissociation
+ it=iprcn(ip)
+ if(debug.ge.2)write (moniou,208)ip,it
+ if(iwt(it).eq.2)then
+ call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-2,iret)
+ elseif(iwt(it).eq.-1)then
+ call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,0,iret)
+ elseif(iwt(it).gt.0)then
+ call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-1,iret)
+ else
+ stop'wrong connection for diffraction'
+ endif
+ if(iret.eq.1)goto 1
+ endif
+ enddo
+
+ do it=1,ia(2) !loop over targ. nucleons
+ if(iwt(it).eq.2)then !diffraction dissociation
+ ip=itgcn(it)
+ if(debug.ge.2)write (moniou,209)it,ip
+ if(iwp(ip).eq.-1)then
+ call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),0,-2,iret)
+ elseif(iwp(ip).gt.0.and.iwp(ip).ne.2)then
+ call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-1,-2,iret)
+ endif
+ if(iret.eq.1)goto 1
+ endif
+ enddo
+
+c-------------------------------------------------
+c particle production for all cut Pomerons
+ s2min=4.d0*fqscal*qt0 !threshold energy for a hard process
+ if(nbpom.ne.0)then
+ if(debug.ge.1)write (moniou,210)
+ do npb=1,nbpom !loop over collisions
+ ip=ias(npb) !proj. index
+ it=ibs(npb) !targ. index
+ icdp=iddp(ip) !proj. diffr. eigenstate
+ icdt=iddt(it) !targ. diffr. eigenstate
+ bbp=bbpom(npb) !b^2 between proj. and targ.
+ vvx=vvxpom(npb) !nuclear screening factor
+ if(debug.ge.1)write (moniou,211)npb,ip,it,bbp,vvx,nqs(npb)
+ * ,npomin(npb),npompr(npb),npomtg(npb)
+
+ if(npomin(npb).ne.0)then
+ do n=1,npomin(npb) !loop over interm. Pomerons
+ wpi=xpopin(n,npb)*wp0 !LC+ for the Pomeron
+ wmi=xpomin(n,npb)*wm0 !LC- for the Pomeron
+ if(debug.ge.2)write (moniou,212)n,wpi,wmi
+ if(wpi*wmi.ne.0.d0)then
+ ic11=0
+ ic12=0
+ ic21=0
+ ic22=0
+ call qgstr(wpi,wmi,wppr0(ip),wmtg0(it)
+ * ,ic11,ic12,ic22,ic21,0,0) !string hadronization
+ endif
+ enddo
+ endif
+
+ if(nqs(npb).ne.0)then
+ do n=1,nqs(npb) !loop over single Pomerons
+ lnp=nnpr(n,npb) !index for proj. constituent
+ lnt=nntg(n,npb) !index for targ. constituent
+ lqa0(ip)=lqa0(ip)-1
+ lqb0(it)=lqb0(it)-1
+ xpi=xppr(lnp,ip)
+ xmi=xmtg(lnt,it)
+ wpi=wp0*xpi !LC+ for the Pomeron
+ wmi=wm0*xmi !LC- for the Pomeron
+ sy=wpi*wmi
+ wtot=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,1) !total
+ wsoft=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,2)!soft interaction
+ wqg=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,3) !qg-hard interaction
+ wgq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,4) !gq-hard interaction
+ wqq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,5) !qq-hard interaction
+ aks=qgran(b10)*wtot
+ if(debug.ge.2)write (moniou,213)n,wpi,wmi
+
+ if(aks.lt.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
+ if(lqa0(ip).eq.0.and.lva(ip).eq.0)then
+ call qgixxd(izp(ip),ic11,ic12,icz)
+ else
+ ic11=0
+ ic12=0
+ endif
+ if(lqb0(it).eq.0.and.lvb(it).eq.0)then
+ call qgixxd(izt(it),ic21,ic22,2)
+ else
+ ic21=0
+ ic22=0
+ endif
+ call qgstr(wpi,wmi,wppr0(ip),wmtg0(it),ic11,ic12,ic22,ic21
+ * ,1,1)
+ else !QCD evolution and hadronization for semi-hard Pomeron
+ if(lva(ip).eq.0.and.lvb(it).eq.0.and.aks.lt.wsoft+wqq)then
+ iqq=3
+ lva(ip)=1
+ lvb(it)=1
+ elseif(lva(ip).eq.0.and.aks.gt.wqg)then
+ iqq=1
+ lva(ip)=1
+ elseif(lvb(it).eq.0.and.aks.gt.wgq)then
+ iqq=2
+ lvb(it)=1
+ else
+ iqq=0
+ endif
+
+ call qghot(wpi,wmi,dsqrt(bbp),vvx,nva,nvb,izp(ip),izt(it)
+ * ,icdp,icdt,icz,iqq,0) !QCD evolution + jet hadronization
+ if(iqq.eq.1.or.iqq.eq.3)ila(ip)=nva
+ if(iqq.eq.2.or.iqq.eq.3)ilb(it)=nvb
+ endif
+ enddo
+ endif
+
+ if(npompr(npb).ne.0)then
+ do l=1,npompr(npb) !loop over proj. leg Pomerons
+ ipp=ilpr(l,npb) !proj. index
+ lnp=lnpr(l,npb) !index for proj. constituent
+ bbpr=bpompr(lnp,ipp) !b^2 for the Pomeron
+ vvxp=vvxpr(lnp,ipp) !screening factor
+ lqa0(ipp)=lqa0(ipp)-1
+ xpi=xppr(lnp,ipp)
+ xmi=xpompr(lnp,ipp)
+ wpi=wp0*xpi !LC+ for the Pomeron
+ wmi=wm0*xmi !LC- for the Pomeron
+ sy=wpi*wmi
+ if(sy.ne.0.d0)then
+ wtot=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,9) !total
+ wsoft=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,10) !soft interaction
+ wqg=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,11) !qg-hard interaction
+ else
+ wsoft=1.d0
+ wtot=1.d0
+ wqg=0.d0
+ endif
+ aks=qgran(b10)*wtot
+ if(debug.ge.2)write (moniou,214)l,wpi,wmi
+
+ if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
+ if(lqa0(ipp).eq.0.and.lva(ipp).eq.0.and.sy.ne.0.d0)then
+ call qgixxd(izp(ipp),ic11,ic12,icz)
+ else
+ ic11=0
+ ic12=0
+ endif
+ ic21=0
+ ic22=0
+ call qgstr(wpi,wmi,wppr0(ipp),wmtg0(it),ic11,ic12,ic22,ic21
+ * ,1,0)
+
+ else !QCD evolution and hadronization for semi-hard Pomeron
+ if(lva(ipp).eq.0.and.aks.gt.wqg)then
+ iqq=1
+ lva(ipp)=1
+ else
+ iqq=0
+ endif
+
+ call qghot(wpi,wmi,dsqrt(bbpr),vvxp,nva,nvb,izp(ipp),izt(it)
+ * ,iddp(ipp),icdt,icz,iqq,1) !QCD evolution + jet hadronization
+ if(iqq.eq.1)ila(ipp)=nva
+ endif
+ call qglead(wppr0(ipp),wmtg0(it),lqa(ipp)+1-iwp(ipp)
+ * ,lqb(it)+1-iwt(it),lqa0(ipp)+ncola0(ipp),lqb0(it)+ncolb0(it)
+ * ,lva(ipp),lvb(it),izp(ipp),izt(it),ila(ipp),ilb(it),iret) !remnants
+ if(iret.ne.0)goto 1
+ enddo
+ endif
+
+ if(npomtg(npb).ne.0)then
+ do l=1,npomtg(npb) !loop over targ. leg Pomerons
+ itt=iltg(l,npb) !targ. index
+ lnt=lntg(l,npb) !index for targ. constituent
+ bbtg=bpomtg(lnt,itt) !b^2 for the Pomeron
+ vvxt=vvxtg(lnt,itt) !screening factor
+ lqb0(itt)=lqb0(itt)-1
+ xmi=xmtg(lnt,itt)
+ wmi=wm0*xmi !LC- for the Pomeron
+ wpi=wp0*xpomtg(lnt,itt) !LC+ for the Pomeron
+ sy=wpi*wmi
+ if(sy.ne.0.d0)then
+ wtot=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,9) !tot
+ wsoft=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,10)!soft interaction
+ wqg=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,11) !qg-hard interaction
+ else
+ wtot=1.d0
+ wsoft=1.d0
+ wqg=0.d0
+ endif
+ aks=qgran(b10)*wtot
+ if(debug.ge.2)write (moniou,215)l,wpi,wmi
+
+ if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
+ ic11=0
+ ic12=0
+ if(lqb0(itt).eq.0.and.lvb(itt).eq.0.and.sy.ne.0.d0)then
+ call qgixxd(izt(itt),ic21,ic22,2)
+ else
+ ic21=0
+ ic22=0
+ endif
+ call qgstr(wpi,wmi,wppr0(ip),wmtg0(itt),ic11,ic12,ic22,ic21
+ * ,0,1)
+
+ else !QCD evolution and hadronization for semi-hard Pomeron
+ if(lvb(itt).eq.0.and.aks.gt.wqg)then
+ iqq=2
+ lvb(itt)=1
+ else
+ iqq=0
+ endif
+
+ call qghot(wpi,wmi,dsqrt(bbtg),vvxt,nva,nvb,izp(ip),izt(itt)
+ * ,icdp,iddt(itt),icz,iqq,2) !QCD evolution + jet hadronization
+ if(iqq.eq.2)ilb(itt)=nvb
+ endif
+ call qglead(wppr0(ip),wmtg0(itt),lqa(ip)+1-iwp(ip),lqb(itt)
+ * +1-iwt(itt),lqa0(ip)+ncola0(ip),lqb0(itt)+ncolb0(itt)
+ * ,lva(ip),lvb(itt),izp(ip),izt(itt),ila(ip),ilb(itt),iret) !remnants
+ if(iret.ne.0)goto 1
+ enddo
+ endif
+ ncola0(ip)=ncola0(ip)-1
+ ncolb0(it)=ncolb0(it)-1
+ call qglead(wppr0(ip),wmtg0(it),lqa(ip)+1-iwp(ip),lqb(it)
+ * +1-iwt(it),lqa0(ip)+ncola0(ip),lqb0(it)+ncolb0(it)
+ * ,lva(ip),lvb(it),izp(ip),izt(it),ila(ip),ilb(it),iret) !remnants
+ if(iret.ne.0)goto 1
+ enddo !end of collision loop
+ endif
+
+ if(nj.ne.0)then !arrangement of parton color connections
+ if(debug.ge.1)write (moniou,216)nj
+ call qgjarr(jfl)
+ if(jfl.eq.0)then
+ iret=1
+ goto 1
+ endif
+ if(debug.ge.1)write (moniou,217)
+ call qgxjet !jet hadronization
+ endif
+ if(debug.ge.1)write (moniou,218)
+
+201 format(2x,'qgsha - inelastic interaction, N of Pomeron blocks:'
+ *,i4)
+202 format(2x,'qgsha: energy-momentum sharing between Pomerons')
+203 format(2x,'qgsha: log of acceptance probability - ',e10.3
+ */4x,'N of rejections - ',i4,2x,'N of renorm. - ',i3)
+204 format(2x,'qgsha: new normalization of acceptance,'
+ *,' N of renorm. - ',i3)
+205 format(2x,'qgsha: leading remnant LC momenta')
+206 format(2x,'qgsha: momentum conservation '
+ *,'(correction for 3p-vertexes)')
+207 format(2x,'qgsha: treatment of low mass diffraction')
+208 format(2x,'qgsha: diffraction of ',i3,'-th proj. nucleon,'
+ *,' recoil of ',i3,'-th targ. nucleon')
+209 format(2x,'qgsha: diffraction of ',i3,'-th targ. nucleon,'
+ *,' recoil of ',i3,'-th proj. nucleon')
+210 format(2x,'qgsha: particle production for all cut Pomerons')
+211 format(2x,'qgsha: ',i4,'-th collision, proj. index - ',i3,2x
+ *,'targ. index - ',i3
+ */4x,'b^2=',e10.3,2x,'vvx=',e10.3,2x,'N of single Pomerons - ',i3
+ *,2x,' N of interm. Pomerons - ',i3
+ */4x,'N of proj. legs - ',i3,2x,'N of targ. legs - ',i3)
+212 format(2x,'qgsha: particle production for '
+ *,i3,'-th interm. Pomeron'
+ */4x,'light cone momenta for the Pomeron:',2e10.3)
+213 format(2x,'qgsha: particle production for '
+ *,i3,'-th single Pomeron'
+ */4x,'light cone momenta for the Pomeron:',2e10.3)
+214 format(2x,'qgsha: particle production for '
+ *,i3,'-th proj. leg Pomeron'
+ */4x,'light cone momenta for the Pomeron:',2e10.3)
+215 format(2x,'qgsha: particle production for '
+ *,i3,'-th targ. leg Pomeron'
+ */4x,'light cone momenta for the Pomeron:',2e10.3)
+216 format(2x,'qgsha: arrangement of color connections for '
+ *,i5,' final partons')
+217 format(2x,'qgsha: jet hadronization')
+218 format(2x,'qgsha - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qgprox(imode)
+c-------------------------------------------------------------------------
+c qgprox - propose Pomeron end LC momenta
+c imod = 0 - to define normalization
+c imod = 1 - propose values according to x^delf * (1 - sum_i x_i)^ahl
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
+ *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
+ *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
+ *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
+ *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
+ *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
+ *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
+ *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
+ common /qgarr11/ b10
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr19/ ahl(3)
+ common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
+ *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
+ *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
+ *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
+ *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
+ *,bpomin(npmax,npbmax)
+ common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.3)write (moniou,201)imode
+
+ delf=dels
+ if(imode.eq.0)then !0-configuration (for normalization)
+ do ip=1,ia(1) !loop over proj. nucleons
+ if(lqa(ip).ne.0)then
+ do n=1,lqa(ip) !loop over proj. constituents
+ if(idnpi(n,ip).eq.0)then
+ xppr(n,ip)=1.d0/wp0 !LC+ for single Pomeron
+ else
+ xppr(n,ip)=1.d0/xpompr(n,ip)/scm !LC+ for leg Pomeron
+ endif
+ enddo
+ endif
+ enddo
+ do it=1,ia(2) !loop over targ. nucleons
+ if(lqb(it).ne.0)then
+ do n=1,lqb(it) !loop over targ. constituents
+ if(idnti(n,it).eq.0)then
+ xmtg(n,it)=1.d0/wm0 !LC- for single Pomeron
+ else
+ xmtg(n,it)=1.d0/xpomtg(n,it)/scm !LC- for leg Pomeron
+ endif
+ enddo
+ endif
+ enddo
+
+ else !proposed configuration
+ do ip=1,ia(1) !loop over proj. nucleons
+ if(lqa(ip).ne.0)then
+ xpt=1.d0
+ do n=1,lqa(ip) !loop over proj. constituents
+ nrej=0
+ alfl=ahl(icz)+(lqa(ip)-n)*(1.d0+delf)
+c if(icz.eq.2)alfl=alfl-float(lqa(ip)-1)/lqa(ip) !baryon "junction"
+ gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
+ * *exp(alfl*(1.d0+delf)*.11d0)*2.d0
+1 continue
+c proposal functions are chosen depending on the parameters
+c to assure an efficient procedure
+ if(delf.ge.0.d0.and.alfl.ge.0.d0
+ * .or.delf.lt.0.d0.and.alfl.le.0.d0)then
+ up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
+ if(1.d0-up.lt.1.d-20)goto 1
+ tp=1.d0-up**(1.d0/(1.d0+alfl))
+ gb=(tp/(1.d0-up))**delf
+ elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
+ up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
+ * /alfl/(1.d0+delf)
+ tp=up**(1.d0/(1.d0+delf))
+ gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
+ else
+ tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
+ gb=tp**delf
+ endif
+ if(qgran(b10).gt.gb)then
+ nrej=nrej+1
+ goto 1
+ endif
+ xppr(n,ip)=tp*xpt !proposed LC+ for the constituent
+ xpt=xpt-xppr(n,ip) !LC+ of the remnant
+ enddo
+ endif
+ enddo
+
+ do it=1,ia(2) !loop over targ. nucleons
+ if(lqb(it).ne.0)then
+ xmt=1.d0
+ do n=1,lqb(it) !loop over targ. constituents
+ nrej=0
+ alfl=ahl(2)+(lqb(it)-n)*(1.d0+delf)
+c * -float(lqb(it)-1)/lqb(it) !baryon "junction"
+ gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
+ * *exp(alfl*(1.d0+delf)*.11d0)*2.d0
+2 continue
+ if(delf.ge.0.d0.and.alfl.ge.0.d0
+ * .or.delf.lt.0.d0.and.alfl.le.0.d0)then
+ up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
+ if(1.d0-up.lt.1.d-20)goto 2
+ tp=1.d0-up**(1.d0/(1.d0+alfl))
+ gb=(tp/(1.d0-up))**delf
+ elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
+ up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
+ * /alfl/(1.d0+delf)
+ tp=up**(1.d0/(1.d0+delf))
+ gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
+ else
+ tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
+ gb=tp**delf
+ endif
+ if(qgran(b10).gt.gb)then
+ nrej=nrej+1
+ goto 2
+ endif
+ if(qgran(b10).gt.gb)goto 2
+ xmtg(n,it)=tp*xmt !proposed LC- for the constituent
+ xmt=xmt-xmtg(n,it) !LC- of the remnant
+ enddo
+ endif
+ enddo
+ endif
+ if(debug.ge.4)write (moniou,202)
+
+201 format(2x,'qgprox - propose Pomeron end LC momenta, imode=',i2)
+202 format(2x,'qgprox - end')
+ return
+ end
+
+c=============================================================================
+ double precision function qgweix(nbpom)
+c-------------------------------------------------------------------------
+c qgweix - log-weight of x-configuration
+c imod = 0 - to define normalization
+c imod = 1 - propose values according to x^delf * (1 - sum_i x_i)^ahl
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
+ *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
+ *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
+ *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
+ *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
+ *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
+ *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
+ *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
+ *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
+ *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
+ *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
+ *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
+ *,bpomin(npmax,npbmax)
+ common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)nbpom
+
+ delf=dels
+ qgweix=0.d0
+ do npb=1,nbpom !loop over collisions
+ ip=ias(npb) !proj. index
+ it=ibs(npb) !targ. index
+ icdp=iddp(ip) !proj. diffr. eigenstate
+ icdt=iddt(it) !targ. diffr. eigenstate
+ bbp=bbpom(npb) !b^2 between proj. and targ.
+ vvx=vvxpom(npb) !nuclear screening factor
+ if(nqs(npb).ne.0)then
+ do n=1,nqs(npb) !loop over single Pomerons
+ lnp=nnpr(n,npb) !proj. constituent index
+ lnt=nntg(n,npb) !targ. constituent index
+ xpp=xppr(lnp,ip) !LC+ for the Pomeron
+ xpm=xmtg(lnt,it) !LC- for the Pomeron
+ qgweix=qgweix+dlog(qgpomc(scm*xpp*xpm,xpp,xpm,bbp,vvx
+ * ,icdp,icdt,icz,1)/(xpp*xpm)**delf) !add single Pomeron contrib.
+ enddo
+ endif
+ if(npompr(npb).ne.0)then
+ do l=1,npompr(npb) !loop over proj. leg Pomerons
+ ipp=ilpr(l,npb) !proj. index
+ lnp=lnpr(l,npb) !proj. constituent index
+ xpp=xppr(lnp,ipp) !LC+ for the Pomeron
+ xpomr=1.d0/xpompr(lnp,ipp)/scm !LC+ for the 3P vertex
+ vvxp=vvxpr(lnp,ipp) !screening factor
+ bbpr=bpompr(lnp,ipp) !b^2 for the Pomeron
+ qgweix=qgweix+dlog(qglegc(xpp/xpomr,xpp,bbpr,vvxp
+ * ,iddp(ipp),icz,9)/xpp**delf) !add leg Pomeron contrib.
+ enddo
+ endif
+ if(npomtg(npb).ne.0)then
+ do l=1,npomtg(npb) !loop over targ. leg Pomerons
+ itt=iltg(l,npb) !targ. index
+ lnt=lntg(l,npb) !targ. constituent index
+ xpm=xmtg(lnt,itt) !LC- for the Pomeron
+ xpomr=xpomtg(lnt,itt) !LC+ for the 3P vertex
+ vvxt=vvxtg(lnt,itt) !screening factor
+ bbtg=bpomtg(lnt,itt) !b^2 for the Pomeron
+ qgweix=qgweix+dlog(qglegc(xpomr*scm*xpm,xpm,bbtg,vvxt
+ * ,iddt(itt),2,9)/xpm**delf) !add leg Pomeron contrib.
+ enddo
+ endif
+ enddo
+ if(debug.ge.4)write (moniou,202)qgweix
+
+201 format(2x,'qgweix - log-weight of x-configuration,'
+ *,' N of collisions - ',i4)
+202 format(2x,'qgweix=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qghot(wpp,wpm,b,vvx,nva,nvb,izp,izt,icdp,icdt,icz,iqq
+ *,jpt)
+c---------------------------------------------------------------------------
+c qghot - semi-hard process
+c wpp,wpm - LC momenta for the constituent partons,
+c b - impact parameter for the semi-hard Pomeron,
+c izp, izt - types of proj. and targ. remnants,
+c icdp,icdt - proj. and targ. diffractive eigenstates,
+c iqq - type of the semi-hard process: 0 - gg, 1 - q_vg, 2 - gq_v, 3 - q_vq_v
+c jpt=0 - single Pomeron,
+c jpt=1 - proj. leg Pomeron,
+c jpt=2 - targ. leg Pomeron
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ character*2 tyq
+ parameter(njmax=50000)
+ dimension ept(4),ep3(4),ey(3),ebal(4),
+ *qmin(2),wp(2),iqc(2),iqp(2),nqc(2),ncc(2,2),
+ *qv1(30,50),zv1(30,50),qm1(30,50),iqv1(30,50),
+ *ldau1(30,49),lpar1(30,50),
+ *qv2(30,50),zv2(30,50),qm2(30,50),iqv2(30,50),
+ *ldau2(30,49),lpar2(30,50)
+ parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr10/ am(7),ammu
+ common /qgarr11/ b10
+ common /qgarr12/ nsp
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
+ common /qgarr42/ tyq(16)
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.1)write (moniou,201)iqq,wpp,wpm,izp,izt,icdp,icdt
+ *,icz,jpt,nj
+
+ wwgg=0.d0
+ wwqg=0.d0
+ wwgq=0.d0
+ wwqq=0.d0
+ wpi=0.d0
+ wmi=0.d0
+ sjqg=0.d0
+ sjqq=0.d0
+ sea1=0.d0
+ sea2=0.d0
+ glu1=0.d0
+ glu2=0.d0
+ nj0=nj !store number of final partons
+ nsp0=nsp !store number of final particles
+
+1 sy=wpp*wpm !energy squared for semi-hard inter. (including preevolution)
+ nj=nj0
+ nsp=nsp0
+ s2min=4.d0*fqscal*qt0 !threshold energy
+ if(sy.lt.s2min)stop'qghot: sy<s2min!!!'
+
+ if(iqq.eq.3)then !q_vq_v-ladder
+ wpi=wpp !LC+ for the hard interaction
+ wmi=wpm !LC- for the hard interaction
+ else
+
+c-------------------------------------------------
+c normalization of acceptance
+ xmin=s2min/sy
+ iq=(iqq+1)/2+1 !auxilliary type of parton (1 - g, 2 - q(q~))
+ sj=qgjit(qt0,qt0,sy,1,iq) !inclusive parton-parton cross-sections
+ if(iqq.eq.0)then
+ gb0=-dlog(xmin)*(1.d0-dsqrt(xmin))**(2.d0*betp)*sj
+ else
+ gb0=(1.d0-xmin)**betp*sj
+ endif
+ if(jpt.eq.0)then !single Pomeron
+ if(iqq.eq.0)then
+ rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/s2min))
+ * *4.d0*.0389d0
+ gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/sy))
+ * *exp(-b*b/rp0)
+ elseif(iqq.eq.1)then
+ rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpp*wm0/s2min))
+ * *4.d0*.0389d0
+ gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wm0/wpm))
+ * *exp(-b*b/rp0)
+ elseif(iqq.eq.2)then
+ rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpm*wp0/s2min))
+ * *4.d0*.0389d0
+ gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wp0/wpp))
+ * *exp(-b*b/rp0)
+ endif
+ elseif(jpt.eq.1)then !proj. leg Pomeron
+ if(iqq.eq.0)then
+ rp0=(rq(icdp,icz)+alfp*dlog(wp0*wpm/s2min))*4.d0*.0389d0
+ gb0=gb0/(rq(icdp,icz)+alfp*dlog(wp0/wpp))*exp(-b*b/rp0)
+ elseif(iqq.eq.1)then
+ rp0=(rq(icdp,icz)+alfp*dlog(sy/s2min))*4.d0*.0389d0
+ gb0=gb0/rq(icdp,icz)*exp(-b*b/rp0)
+ endif
+ elseif(jpt.eq.2)then !targ. leg Pomeron
+ if(iqq.eq.0)then
+ rp0=(rq(icdt,2)+alfp*dlog(wm0*wpp/s2min))*4.d0*.0389d0
+ gb0=gb0/(rq(icdt,2)+alfp*dlog(wm0/wpm))*exp(-b*b/rp0)
+ elseif(iqq.eq.2)then
+ rp0=(rq(icdt,2)+alfp*dlog(sy/s2min))*4.d0*.0389d0
+ gb0=gb0/rq(icdt,2)*exp(-b*b/rp0)
+ endif
+ endif
+
+c-------------------------------------------------
+c sharing of LC momenta between soft preevolution and hard ladder
+2 zpm=(1.d0-qgran(b10)*(1.d0-xmin**(delh-dels)))
+ * **(1.d0/(delh-dels))
+ sjqq=qgjit(qt0,qt0,zpm*sy,2,2) !inclusive qq cross-section
+ sjqg=qgjit(qt0,qt0,zpm*sy,1,2) !inclusive qg cross-section
+ sjgg=qgjit(qt0,qt0,zpm*sy,1,1) !inclusive gg cross-section
+
+ if(iqq.eq.0)then !gg-ladder
+ xp=zpm**qgran(b10) !LC+ momentum share
+ xm=zpm/xp !LC- momentum share
+ wpi=wpp*xp !LC+ for the hard interaction
+ wmi=wpm*xm !LC- for the hard interaction
+ if(jpt.eq.0)then !single Pomeron
+ rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
+ rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+
+ xpomr=wpi/wp0
+ if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
+ vvx1=0.d0
+ else
+ v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
+ v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
+ nn=0
+21 nn=nn+1
+ vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
+ vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
+ v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
+ v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
+ if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
+ * .and.nn.lt.100)then
+ v1pnu0=v1pnu
+ v1tnu0=v1tnu
+ goto 21
+ endif
+ vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
+ endif
+
+ xpomr=wm0/wmi/scm
+ if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
+ vvx2=0.d0
+ else
+ v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
+ v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
+ nn=0
+22 nn=nn+1
+ vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
+ vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
+ v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
+ v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
+ if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
+ * .and.nn.lt.100)then
+ v1pnu0=v1pnu
+ v1tnu0=v1tnu
+ goto 22
+ endif
+ vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
+ endif
+
+ glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
+ sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
+ glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12) !lower gluon PDF
+ sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13) !lower quark PDF
+ elseif(jpt.eq.1)then !proj. leg Pomeron
+ rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
+ rp2=-alfp*dlog(xm)*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+
+ glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,12) !upper gluon PDF
+ sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,13) !upper quark PDF
+ glu2=qgppdi(xm,0)
+ sea2=qgppdi(xm,1)
+ elseif(jpt.eq.2)then !proj. leg Pomeron
+ rp1=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
+ rp2=-alfp*dlog(xp)*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+
+ glu1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,12) !upper gluon PDF
+ sea1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,13) !upper quark PDF
+ glu2=qgppdi(xp,0)
+ sea2=qgppdi(xp,1)
+ endif
+ wwgg=glu1*glu2*sjgg
+ wwqg=sea1*glu2*sjqg
+ wwgq=glu1*sea2*sjqg
+ wwqq=sea1*sea2*sjqq
+ gbyj=-dlog(zpm)*(wwgg+wwqg+wwgq+wwqq)
+ if(jpt.eq.0)then
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(zpm*sy/scm)
+ elseif(jpt.eq.1)then
+ rh=rq(icdp,icz)-alfp*dlog(wpp/wp0*zpm)
+ elseif(jpt.eq.2)then
+ rh=rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
+ else
+ rh=0.d0
+ stop 'Should not happen in qghot'
+ endif
+ gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
+
+ else !q_vg-(gq_v-)ladder
+ if(iqq.eq.1)then !q_vg-ladder
+ wpi=wpp
+ wmi=wpm*zpm
+ xm=zpm
+ if(jpt.eq.0)then !single Pomeron
+ rp1=rq(icdp,icz)*4.d0*.0389d0
+ rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+
+ xpomr=wm0/wmi/scm
+ if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
+ vvx2=0.d0
+ else
+ v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
+ v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
+ nn=0
+23 nn=nn+1
+ vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
+ vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
+ v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
+ v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
+ if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
+ * .and.nn.lt.100)then
+ v1pnu0=v1pnu
+ v1tnu0=v1tnu
+ goto 23
+ endif
+ vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
+ endif
+
+ glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12) !upper gluon PDF
+ sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13) !upper quark PDF
+ wwqg=glu2*sjqg
+ wwqq=sea2*sjqq
+ else !leg Pomeron
+ wwqg=qgppdi(xm,0)*sjqg
+ wwqq=qgppdi(xm,1)*sjqq
+ endif
+ elseif(iqq.eq.2)then !gq_v-ladder
+ wpi=wpp*zpm
+ wmi=wpm
+ xp=zpm
+ if(jpt.eq.0)then !single Pomeron
+ rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
+ rp2=rq(icdt,2)*4.d0*.0389d0
+ rp=rp1*rp2/(rp1+rp2)
+ z=qgran(b10)
+ phi=pi*qgran(b10)
+ b0=dsqrt(-rp*dlog(z))
+ bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
+ bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
+
+ xpomr=wpi/wp0
+ if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
+ vvx1=0.d0
+ else
+ v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
+ v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
+ nn=0
+24 nn=nn+1
+ vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
+ vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
+ v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
+ v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
+ if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
+ * .and.nn.lt.100)then
+ v1pnu0=v1pnu
+ v1tnu0=v1tnu
+ goto 24
+ endif
+ vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
+ endif
+
+ glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
+ sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
+ wwqg=glu1*sjqg
+ wwqq=sea1*sjqq
+ else !leg Pomeron
+ wwqg=qgppdi(xp,0)*sjqg
+ wwqq=qgppdi(xp,1)*sjqq
+ endif
+ endif
+ gbyj=wwqg+wwqq
+ if(jpt.eq.0)then
+ if(iqq.eq.1)then
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
+ else
+ rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpp/wp0*zpm)
+ endif
+ elseif(jpt.eq.1)then
+ rh=rq(icdp,icz)-alfp*dlog(zpm)
+ elseif(jpt.eq.2)then
+ rh=rq(icdt,2)-alfp*dlog(zpm)
+ else
+ rh=0.d0
+ stop 'Should not happen in qghot'
+ endif
+ gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
+ endif
+
+ gbyj=gbyj/gb0/zpm**delh
+ if(qgran(b10).gt.gbyj)goto 2
+ endif
+ if(debug.ge.2)write (moniou,202)wpi*wmi
+
+11 wpi1=wpi
+ wmi1=wmi
+ wpq=0.d0
+ wmq=0.d0
+ nj=nj0 !initialization for the number of final partons
+ rrr=qgran(b10)
+ jqq=0 !gg-ladder
+ if(iqq.eq.1.or.iqq.eq.2)then
+ if(rrr.lt.wwqq/(wwqg+wwqq))jqq=1 !q_vq_s-laddder
+ elseif(iqq.eq.0)then
+ if(rrr.lt.wwqg/(wwgg+wwqg+wwgq+wwqq))then
+ jqq=1 !q_sg-ladder
+ elseif(rrr.lt.(wwqg+wwgq)/(wwgg+wwqg+wwgq+wwqq))then
+ jqq=2 !gq_s-ladder
+ elseif(rrr.lt.(wwqg+wwgq+wwqq)/(wwgg+wwqg+wwgq+wwqq))then
+ jqq=3 !q_sq_s-ladder
+ endif
+ endif
+
+c-------------------------------------------------
+c parton types for the ladder legs and for the leading jets
+c iqc(1) - flavor for the upper quark (0 in case of gluon),
+c iqc(2) - the same for the lower one
+ if(iqq.ne.0.and.iqq.ne.2)then !q_v from the proj.
+ call qgvdef(izp,ic1,ic2,icz) !leading state flavor
+ iqc(1)=ic1 !upper leg parton
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ nva=nj
+ iqj(nj)=ic2 !leading jet parton
+ ncc(1,1)=nj !color connection with leading jet
+ ncc(2,1)=0
+ else !g(q_s) from the proj.
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ if(qgran(b10).lt.dc(2))then
+ iqj(nj)=-4
+ else
+ iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
+ endif
+ iqj(nj+1)=-iqj(nj)
+ wp1=wpp-wpi
+ wp2=wp1*qgran(b10)
+ wp1=wp1-wp2
+ eqj(1,nj)=.5d0*wp1
+ eqj(2,nj)=eqj(1,nj)
+ eqj(3,nj)=0.d0
+ eqj(4,nj)=0.d0
+ eqj(1,nj+1)=.5d0*wp2
+ eqj(2,nj+1)=eqj(1,nj+1)
+ eqj(3,nj+1)=0.d0
+ eqj(4,nj+1)=0.d0
+ if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.2)then
+ iqc(1)=0
+ ncc(1,1)=nj
+ ncc(2,1)=nj+1
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ else
+ if(qgran(b10).lt..3333d0)then
+ iqc(1)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
+ else
+ iqc(1)=int(2.d0*qgran(b10)+1.d0)
+ * *(2.d0*int(.5d0+qgran(b10))-1.d0)
+ endif
+12 zg=xp+qgran(b10)*(1.d0-xp) !gluon splitting into qq~
+ if(qgran(b10).gt.zg**dels*((1.d0-xp/zg)/ (1.d0-xp))**betp)
+ * goto 12
+ xg=xp/zg
+ wpq0=wpp*(xg-xp)
+ wmq=1.d0/wpq0
+ wmi1=wmi1-wmq
+ if(wmi1*wpi1.le.s2min)goto 11
+ nj=nj+2
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ iqj(nj)=-iqc(1)
+ if(iabs(iqc(1)).eq.3)iqj(nj)=iqj(nj)*4/3
+ eqj(1,nj)=.5d0*wmq
+ eqj(2,nj)=-.5d0*wmq
+ eqj(3,nj)=0.d0
+ eqj(4,nj)=0.d0
+ if(iqc(1).gt.0)then
+ ncj(1,nj)=nj-1
+ ncj(1,nj-1)=nj
+ ncj(2,nj)=0
+ ncj(2,nj-1)=0
+ ncc(1,1)=nj-2
+ ncc(2,1)=0
+ else
+ ncj(1,nj)=nj-2
+ ncj(1,nj-2)=nj
+ ncj(2,nj)=0
+ ncj(2,nj-2)=0
+ ncc(1,1)=nj-1
+ ncc(2,1)=0
+ endif
+ endif
+ endif
+
+ if((iqq-2)*(iqq-3)*(iqq-4).eq.0)then !q_v from the targ.
+ call qgvdef(izt,ic1,ic2,2) !leading state flavor
+ iqc(2)=ic1 !lower leg parton
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ nvb=nj
+ iqj(nj)=ic2
+ ncc(1,2)=nj
+ ncc(2,2)=0
+ else
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ if(qgran(b10).lt.dc(2))then
+ iqj(nj)=-4
+ else
+ iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
+ endif
+ iqj(nj+1)=-iqj(nj)
+ wm1=wpm-wmi
+ wm2=wm1*qgran(b10)
+ wm1=wm1-wm2
+ eqj(1,nj)=.5d0*wm1
+ eqj(2,nj)=-eqj(1,nj)
+ eqj(3,nj)=0.d0
+ eqj(4,nj)=0.d0
+ eqj(1,nj+1)=.5d0*wm2
+ eqj(2,nj+1)=-eqj(1,nj+1)
+ eqj(3,nj+1)=0.d0
+ eqj(4,nj+1)=0.d0
+ if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.1)then
+ iqc(2)=0
+ ncc(1,2)=nj
+ ncc(2,2)=nj+1
+ nj=nj+1
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ else
+ if(qgran(b10).lt..3333d0)then
+ iqc(2)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
+ else
+ iqc(2)=int(2.d0*qgran(b10)+1.d0)
+ * *(2.d0*int(.5d0+qgran(b10))-1.d0)
+ endif
+14 zg=xm+qgran(b10)*(1.d0-xm) !gluon splitting into qq~
+ if(qgran(b10).gt.zg**dels*((1.d0-xm/zg)/ (1.d0-xm))**betp)
+ * goto 14
+ xg=xm/zg
+ wmq0=wpm*(xg-xm)
+ wpq=1.d0/wmq0
+ wpi1=wpi1-wpq
+ if(wmi1*wpi1.le.s2min)goto 11
+ nj=nj+2
+ if(nj.gt.njmax)stop'increase njmax!!!'
+ iqj(nj)=-iqc(2)
+ if(iabs(iqc(2)).eq.3)iqj(nj)=iqj(nj)*4/3
+ eqj(1,nj)=.5d0*wpq
+ eqj(2,nj)=.5d0*wpq
+ eqj(3,nj)=0.d0
+ eqj(4,nj)=0.d0
+ if(iqc(2).gt.0)then
+ ncj(1,nj)=nj-1
+ ncj(1,nj-1)=nj
+ ncj(2,nj)=0
+ ncj(2,nj-1)=0
+ ncc(1,2)=nj-2
+ ncc(2,2)=0
+ else
+ ncj(1,nj)=nj-2
+ ncj(1,nj-2)=nj
+ ncj(2,nj)=0
+ ncj(2,nj-2)=0
+ ncc(1,2)=nj-1
+ ncc(2,2)=0
+ endif
+ endif
+ endif
+
+ if(jqq.ne.0)then
+ if(iqq.ne.0.or.iqq.eq.0.and.jqq.eq.3)then
+ sjqq1=qgjit(qt0,qt0,wpi1*wmi1,2,2)
+ gbs=sjqq1/sjqq
+ else
+ sjqg1=qgjit(qt0,qt0,wpi1*wmi1,1,2)
+ gbs=sjqg1/sjqg
+ endif
+ if(qgran(b10).gt.gbs)goto 11
+ endif
+ wpi=wpi1
+ wmi=wmi1
+
+ ept(1)=.5d0*(wpi+wmi) !ladder 4-momentum
+ ept(2)=.5d0*(wpi-wmi)
+ ept(3)=0.d0
+ ept(4)=0.d0
+ qmin(1)=qt0 !q^2 cutoff for the upper leg
+ qmin(2)=qt0 !q^2 cutoff for the downer leg
+ qminn=max(qmin(1),qmin(2)) !overall q^2 cutoff
+ si=qgnrm(ept)
+ jini=1
+ jj=int(1.5d0+qgran(b10)) !1st parton at upper (jj=1) or downer (jj=2) leg
+
+3 continue
+
+ aaa=qgnrm(ept) !ladder mass squared
+ if(debug.ge.3)write (moniou,203)si,iqc,ept,aaa
+
+ pt2=ept(3)**2+ept(4)**2
+ pt=dsqrt(pt2)
+ ww=si+pt2
+
+ iqp(1)=min(1,iabs(iqc(1)))+1
+ iqp(2)=min(1,iabs(iqc(2)))+1
+ wp(1)=ept(1)+ept(2) !LC+ for the ladder
+ wp(2)=ept(1)-ept(2) !LC- for the ladder
+ s2min=4.d0*fqscal*qminn !minimal energy squared for 2-parton production
+ if(jini.eq.1)then !general ladder
+ sj=qgjit(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj)) !total ladder contribution
+ sj1=qgjit1(qmin(3-jj),qmin(jj),si,iqp(3-jj),iqp(jj)) !one-way ordered
+ sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2)) !born contribution
+ aks=qgran(b10)
+ if(aks.lt.sjb/sj)then
+ goto 6 !born process sampled
+ elseif(aks.lt.sj1/sj)then !change to one-way ordered ladder
+ jj=3-jj
+ sj=sj1
+ jini=0
+ endif
+ else !one-way ordered ladder
+ sj=qgjit1(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj)) !one-way ordered
+ sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2)) !born contribution
+ if(qgran(b10).lt.sjb/sj)goto 6 !born process sampled
+ endif
+ wwmin=(s2min+qmin(jj)+pt2-2.d0*pt*dsqrt(qmin(jj)*epsxmn))
+ */(1.d0-epsxmn) !minimal energy squared for 3-parton production
+
+ if(debug.ge.3)write (moniou,204)s2min,wwmin,sj,sjb
+
+ if(ww.lt.1.1d0*wwmin)goto 6 !energy too low -> born process
+
+ xxx=pt*dsqrt(qmin(jj))/ww
+ xmin=(s2min+qmin(jj)+pt2)/ww
+ xmin=xmin-2.d0*xxx*(xxx+dsqrt(xxx**2+1.d0-xmin))
+
+ xmax=1.d0-epsxmn
+ if(debug.ge.3)write (moniou,205)xmin,xmax
+
+ qqmax=(pt*dsqrt(epsxmn)+dsqrt(max(0.d0,pt2*epsxmn
+ *+(1.d0+4.d0*fqscal)*(xmax*ww-pt2))))/(1.d0+4.d0*fqscal)
+ qqmin=qmin(jj) !minimal parton virtuality in the current rung
+ if(debug.ge.3)write (moniou,206)qqmin,qqmax
+
+ qm0=qqmin
+ xm0=xmax
+ s2max=xm0*ww
+
+ if(jini.eq.1)then
+ sj0=qgjit(qm0,qmin(3-jj),s2max,1,iqp(3-jj))*qgfap(xm0,iqp(jj),1)
+ * +qgjit(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
+ else
+ sj0=qgjit1(qm0,qmin(3-jj),s2max,1,iqp(3-jj))
+ * *qgfap(xm0,iqp(jj),1)
+ * +qgjit1(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
+ endif
+
+ gb0=sj0*qm0*qgalf(qm0/alm)*qgsudx(qm0,iqp(jj)) *4.5d0 !normal. of accept.
+ if(xm0.le..5d0)then
+ gb0=gb0*xm0**(1.d0-delh)
+ else
+ gb0=gb0*(1.d0-xm0)*2.d0**delh
+ endif
+ if(debug.ge.3)write (moniou,208)xm0,xmin,xmax,gb0
+
+ xmin2=max(.5d0,xmin)
+ xmin1=xmin**delh
+ xmax1=min(xmax,.5d0)**delh
+ if(xmin.ge..5d0)then !choose proposal function
+ djl=1.d0
+ elseif(xmax.lt..5d0)then
+ djl=0.d0
+ else
+ djl=1.d0/(1.d0+((2.d0*xmin)**delh-1.d0)/delh
+ * /dlog(2.d0*(1.d0-xmax)))
+ endif
+
+c-------------------------------------------------
+c propose x, q^2
+4 continue
+ if(qgran(b10).gt.djl)then
+ x=(xmin1+qgran(b10)*(xmax1-xmin1))**(1.d0/delh) !parton LC share
+ else
+ x=1.d0-(1.d0-xmin2)*((1.d0-xmax)/(1.d0-xmin2))**qgran(b10)
+ endif
+ qq=qqmin/(1.d0+qgran(b10)*(qqmin/qqmax-1.d0)) !parton virtuality
+ qt2=qq*(1.d0-x) !parton p_t^2
+ if(debug.ge.4)write (moniou,209)qq,qqmin,qqmax,x,qt2
+
+ if(qq.gt.qminn)then !update virtuality cutoff
+ qmin2=qq
+ else
+ qmin2=qminn
+ endif
+ qt=dsqrt(qt2)
+ call qgcs(c,s)
+ ep3(3)=qt*c !final parton p_x, p_y
+ ep3(4)=qt*s
+ pt2new=(ept(3)-ep3(3))**2+(ept(4)-ep3(4))**2!p_t^2 for the remained ladder
+ s2min2=max(s2min,4.d0*fqscal*qmin2) !new ladder kinematic limit
+ s2=x*ww-qt2*x/(1.d0-x)-pt2new !mass squared for the remained ladder
+ if(s2.lt.s2min2)goto 4 !ladder mass below threshold -> rejection
+
+ if(jini.eq.1)then !weights for g- and q-legs
+ sj1=qgjit(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
+ sj2=qgjit(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
+ else
+ sj1=qgjit1(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
+ sj2=qgjit1(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
+ endif
+ gb7=(sj1+sj2)*qgalf(qq/alm)*qq*qgsudx(qq,iqp(jj))/gb0 /2.d0
+ !acceptance probability for x and q**2 simulation
+ if(x.le..5d0)then
+ gb7=gb7*x**(1.d0-delh)
+ else
+ gb7=gb7*(1.d0-x)*2.d0**delh
+ endif
+ if(debug.ge.4)write (moniou,210)gb7,s2,sj1,sj2,jj,jini
+ if(qgran(b10).gt.gb7)goto 4 !rejection
+
+c-------------------------------------------------
+c define color flow for the emitted jet; perform final state emission
+ nqc(2)=0
+ if(qgran(b10).lt.sj1/(sj1+sj2))then !new gluon-leg ladder
+ if(iqc(jj).eq.0)then !g -> gg
+ jt=1
+ jq=int(1.5d0+qgran(b10))
+ nqc(1)=ncc(jq,jj) !color connection for the jet
+ nqc(2)=0
+ else !q -> qg
+ jt=2
+ if(iqc(jj).gt.0)then !orientation of color flow
+ jq=1
+ else
+ jq=2
+ endif
+ nqc(1)=0
+ ncc(jq,jj)=ncc(1,jj) !color connection for the jet
+ endif
+ iq1=iqc(jj) !jet flavor (type)
+ iqc(jj)=0 !new ladder leg flavor (type)
+
+ else !new quark-leg ladder
+ if(iqc(jj).ne.0)then !q -> gq
+ iq1=0
+ jt=3
+ if(iqc(jj).gt.0)then !orientation of color flow
+ jq=1
+ else
+ jq=2
+ endif
+ nqc(1)=ncc(1,jj) !color connection for the jet
+ nqc(2)=0
+
+ else !g -> qq~
+ jq=int(1.5d0+qgran(b10)) !orientation of color flow
+ iq1=int(3.d0*qgran(b10)+1.d0)*(3-2*jq) !jet flavor (type)
+ iqc(jj)=-iq1 !new ladder leg flavor (type)
+ jt=4
+ nqc(1)=ncc(jq,jj) !color connections for the jet
+ ncc(1,jj)=ncc(3-jq,jj)
+ endif
+ endif
+ if(debug.ge.3)write (moniou,211)jt
+
+ call qgcjet(qt2,iq1,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq) !final state emission
+ si=x*ww-(qt2+qm1(1,1))*x/(1.d0-x)-pt2new !mass squared for the new ladder
+ if(si.gt.s2min2)then
+ iq=min(1,iabs(iqc(jj)))+1
+ if(jini.eq.1)then
+ gb=qgjit(qq,qmin(3-jj),si,iq,iqp(3-jj))
+ * /qgjit(qq,qmin(3-jj),s2,iq,iqp(3-jj))
+ else
+ gb=qgjit1(qq,qmin(3-jj),si,iq,iqp(3-jj))
+ * /qgjit1(qq,qmin(3-jj),s2,iq,iqp(3-jj))
+ endif
+ if(qgran(b10).gt.gb)goto 1 !jet mass correction for the acceptance
+ else !below threshold -> rejection
+ goto 1
+ endif
+
+ wp3=wp(jj)*(1.d0-x)
+ wm3=(qt2+qm1(1,1))/wp3
+ ep3(1)=.5d0*(wp3+wm3) !jet 4-momentum
+ ep3(2)=.5d0*(wp3-wm3)*(3-2*jj)
+ call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
+ !reconstruction of 4-momenta of all final partons
+c-------------------------------------------------
+c define color connections for the new ladder
+ if(jt.eq.1)then
+ if(ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)ncc(3-jq,jj)=nqc(1)
+ ncc(jq,jj)=nqc(2)
+ elseif(jt.eq.2)then
+ ncc(3-jq,jj)=nqc(1)
+ elseif(jt.eq.3)then
+ ncc(1,jj)=nqc(2)
+ elseif(jt.eq.4.and.ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)then
+ ncc(1,jj)=nqc(1)
+ endif
+
+ if(iabs(iq1).eq.3)then
+ iqqq=8+iq1/3*4
+ else
+ iqqq=8+iq1
+ endif
+ if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
+ do i=1,4
+ ept(i)=ept(i)-ep3(i) !new ladder 4-momentum
+ enddo
+ qmin(jj)=qq !new virtuality cutoffs
+ qminn=qmin2
+ goto 3 !consider next parton emission
+
+c------------------------------------------------
+c born process - last parton pair production in the ladder
+6 continue
+ if(debug.ge.2)write (moniou,214)si,qminn,iqc
+ tmin=qminn*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qminn*fqscal/si)))
+ qtmin=tmin*(1.d0-tmin/si)
+ if(iqc(1).ne.0.or.iqc(2).ne.0)then
+ gb0=tmin**2*qgalf(qtmin/fqscal/alm)**2
+ * *qgfbor(si,tmin,iqc(1),iqc(2),1) *1.1d0
+ else
+ gb0=.25d0*si**2*qgalf(qtmin/fqscal/alm)**2
+ * *qgfbor(si,.5d0*si,iqc(1),iqc(2),1)
+ endif
+ gb0=gb0*qgsudx(qtmin/fqscal,iqp(1))*qgsudx(qtmin/fqscal,iqp(2))
+ !normalization of acceptance
+ if(debug.ge.3)write (moniou,215)gb0
+
+7 q2=tmin/(1.d0-qgran(b10)*(1.d0-2.d0*tmin/si)) !proposed q^2
+ z=q2/si !parton LC momentum share
+ qt2=q2*(1.d0-z) !parton p_t^2
+ if(qgran(b10).lt..5d0)then
+ jm=2
+ tq=si-q2
+ else
+ jm=1
+ tq=q2
+ endif
+ gb=q2**2*qgalf(qt2/fqscal/alm)**2*qgfbor(si,tq,iqc(1),iqc(2),1)
+ **qgsudx(qt2/fqscal,iqp(1))*qgsudx(qt2/fqscal,iqp(2))/gb0
+ !acceptance probabilty
+ if(debug.ge.4)write (moniou,216)gb,q2,z,qt2
+ if(qgran(b10).gt.gb)goto 7 !rejection
+
+c-------------------------------------------------
+c define color connections for the 1st emitted jet
+ nqc(2)=0
+ if(iqc(1).eq.0.and.iqc(2).eq.0)then !gg-process
+ jq=int(1.5d0+qgran(b10)) !orientation of color flow
+ nqc(1)=ncc(jq,jm)
+
+ if(qgran(b10).lt..5d0)then
+ jt=1 !gg -> gg
+ nqc(2)=0
+ njc1=ncc(3-jq,jm) !color connections for 1st jet
+ njc2=ncc(jq,3-jm)
+ if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
+ if(jm.eq.1)nqc(1)=njc2
+ else
+ if(iqj(njc1).ne.0)then
+ ncj(1,njc1)=njc2
+ else
+ ncj(jq,njc1)=njc2
+ endif
+ if(iqj(njc2).ne.0)then
+ ncj(1,njc2)=njc1
+ else
+ ncj(3-jq,njc2)=njc1
+ endif
+ endif
+ else !gg -> gg (inverse color connection)
+ jt=2
+ nqc(2)=ncc(3-jq,3-jm)
+ endif
+
+ elseif(iqc(1)*iqc(2).eq.0)then !qg -> qg
+ if(iqc(1)+iqc(2).gt.0)then !orientation of color flow
+ jq=1
+ else
+ jq=2
+ endif
+ if(qgran(b10).lt..5d0)then
+ if(iqc(jm).eq.0)then
+ jt=3
+ nqc(1)=ncc(jq,jm)
+ nqc(2)=0
+ njc1=ncc(3-jq,jm)
+ njc2=ncc(1,3-jm)
+ if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
+ nqc(1)=njc2
+ else
+ if(iqj(njc1).ne.0)then
+ ncj(1,njc1)=njc2
+ else
+ ncj(jq,njc1)=njc2
+ endif
+ if(iqj(njc2).ne.0)then
+ ncj(1,njc2)=njc1
+ else
+ ncj(3-jq,njc2)=njc1
+ endif
+ endif
+ else
+ jt=4
+ nqc(1)=0
+ njc1=ncc(1,jm)
+ njc2=ncc(3-jq,3-jm)
+ if(njc2.ne.0)then
+ if(iqj(njc1).ne.0)then
+ ncj(1,njc1)=njc2
+ else
+ ncj(3-jq,njc1)=njc2
+ endif
+ if(iqj(njc2).ne.0)then
+ ncj(1,njc2)=njc1
+ else
+ ncj(jq,njc2)=njc1
+ endif
+ endif
+ endif
+ else
+ if(iqc(jm).eq.0)then
+ jt=5
+ nqc(2)=ncc(3-jq,jm)
+ nqc(1)=ncc(1,3-jm)
+ else
+ jt=6
+ nqc(1)=ncc(jq,3-jm)
+ endif
+ endif
+
+ elseif(iqc(1)*iqc(2).gt.0)then !qq (q~q~) -> qq (q~q~)
+ jt=7
+ if(iqc(1).gt.0)then
+ jq=1
+ else
+ jq=2
+ endif
+ nqc(1)=ncc(1,3-jm)
+ else !qq~ -> qq~
+ jt=8
+ if(iqc(jm).gt.0)then
+ jq=1
+ else
+ jq=2
+ endif
+ nqc(1)=0
+ njc1=ncc(1,jm)
+ njc2=ncc(1,3-jm)
+ if(iqj(njc1).ne.0)then
+ ncj(1,njc1)=njc2
+ else
+ ncj(3-jq,njc1)=njc2
+ endif
+ if(iqj(njc2).ne.0)then
+ ncj(1,njc2)=njc1
+ else
+ ncj(jq,njc2)=njc1
+ endif
+ endif
+ if(jt.ne.8)then
+ jq2=jq
+ else
+ jq2=3-jq
+ endif
+ if(debug.ge.3)write (moniou,211)jt
+ call qgcjet(qt2,iqc(jm),qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)!final state emis.
+ call qgcjet(qt2,iqc(3-jm),qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
+ amt1=qt2+qm1(1,1)
+ amt2=qt2+qm2(1,1)
+ if(dsqrt(si).gt.dsqrt(amt1)+dsqrt(amt2))then
+ z=qgtwd(si,amt1,amt2)
+ else
+ if(debug.ge.4)write (moniou,217)dsqrt(si),dsqrt(amt1),dsqrt(amt2)
+ goto 1 !below threshold -> rejection
+ endif
+
+ call qgdeft(si,ept,ey)
+ wp3=z*dsqrt(si)
+ wm3=(qt2+qm1(1,1))/wp3
+ ep3(1)=.5d0*(wp3+wm3) !1st jet 4-momentum
+ ep3(2)=.5d0*(wp3-wm3)
+ qt=dsqrt(qt2)
+ call qgcs(c,s)
+ ep3(3)=qt*c
+ ep3(4)=qt*s
+
+ call qgtran(ep3,ey,1)
+ call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
+ !reconstruction of 4-momenta of all final partons
+ if(iabs(iqc(jm)).eq.3)then
+ iqqq=8+iqc(jm)/3*4
+ else
+ iqqq=8+iqc(jm)
+ endif
+ if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
+
+ wp3=(1.d0-z)*dsqrt(si)
+ wm3=(qt2+qm2(1,1))/wp3
+ ep3(1)=.5d0*(wp3+wm3) !2nd jet 4-momentum
+ ep3(2)=.5d0*(wp3-wm3)
+ ep3(3)=-qt*c
+ ep3(4)=-qt*s
+ call qgtran(ep3,ey,1)
+
+c-------------------------------------------------
+c define color connections for the 2nd emitted jet
+ if(jt.eq.1)then
+ nqc(1)=nqc(2)
+ if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
+ nqc(2)=ncc(3-jq,jm)
+ else
+ nqc(2)=ncc(3-jq,3-jm)
+ endif
+ elseif(jt.eq.2)then
+ if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
+ if(jm.eq.1)then
+ nqc(2)=nqc(1)
+ nqc(1)=ncc(jq,3-jm)
+ else
+ nqc(1)=nqc(2)
+ nqc(2)=ncc(3-jq,jm)
+ endif
+ else
+ nqc(2)=ncc(3-jq,jm)
+ nqc(1)=ncc(jq,3-jm)
+ endif
+ elseif(jt.eq.3)then
+ nqc(1)=nqc(2)
+ elseif(jt.eq.4)then
+ nqc(2)=nqc(1)
+ if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
+ nqc(1)=ncc(1,jm)
+ else
+ nqc(1)=ncc(jq,3-jm)
+ endif
+ elseif(jt.eq.5)then
+ if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
+ nqc(1)=nqc(2)
+ else
+ nqc(1)=ncc(jq,jm)
+ endif
+ elseif(jt.eq.6)then
+ if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
+ nqc(2)=nqc(1)
+ else
+ nqc(2)=ncc(3-jq,3-jm)
+ endif
+ nqc(1)=ncc(1,jm)
+ elseif(jt.eq.7)then
+ nqc(1)=ncc(1,jm)
+ endif
+ call qgrec(ep3,nqc,qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
+ !reconstruction of 4-momenta of all final partons
+ if(iabs(iqc(3-jm)).eq.3)then
+ iqqq=8+iqc(3-jm)/3*4
+ else
+ iqqq=8+iqc(3-jm)
+ endif
+ if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
+
+ ebal(1)=.5d0*(wpp+wpm) !balans of 4-momentum
+ ebal(2)=.5d0*(wpp-wpm)
+ ebal(3)=0.d0
+ ebal(4)=0.d0
+ do i=nj0+1,nj
+ if(iqq.eq.0.or.iqq.eq.1.and.i.ne.nva.or.iqq.eq.2
+ * .and.i.ne.nvb.or.iqq.eq.3.and.i.ne.nva.and.i.ne.nvb)then
+ do j=1,4
+ ebal(j)=ebal(j)-eqj(j,i)
+ enddo
+ endif
+ enddo
+ if(debug.ge.2)write (moniou,218)nj
+ if(debug.ge.5)write (moniou,219)ebal
+ if(debug.ge.1)write (moniou,220)
+
+201 format(2x,'qghot - semihard interaction:'/
+ *4x,'type of the interaction - ',i2/
+ *4x,'initial light cone momenta - ',2e10.3/
+ *4x,'remnant types - ',2i3,2x,'diffr. eigenstates - ',2i2/
+ *4x,'proj. class - ',i2,2x,'Pomeron type - ',i2/
+ *4x,'initial number of final partons - ',i4)
+202 format(2x,'qghot: mass squared for parton ladder - ',e10.3)
+203 format(2x,'qghot: ',' mass squared for the laddder:',e10.3/
+ *4x,'ladder end flavors:',2i3/4x,'ladder 5-momentum: ',5e10.3)
+204 format(2x,'qghot: kinematic bounds s2min=',e10.3,
+ *2x,'wwmin=',e10.3/4x,'jet cross section sj=',e10.3,
+ *2x,'born cross section sjb=',e10.3)
+205 format(2x,'qghot: xmin=',e10.3,2x,'xmax=',e10.3)
+206 format(2x,'qghot: qqmin=',e10.3,2x,'qqmax=',e10.3)
+208 format(2x,'qghot: xm0=',e10.3,2x,'xmin=',e10.3,2x,
+ *'xmax=',e10.3,2x,'gb0=',e10.3)
+209 format(2x,'qghot: qq=',e10.3,2x,'qqmin=',e10.3,2x,
+ *'qqmax=',e10.3,2x,'x=',e10.3,2x,'qt2=',e10.3)
+210 format(2x,'qghot: gb7=',e10.3,2x,'s2=',e10.3,2x,'sj1=',e10.3
+ *,2x,'sj2=',e10.3,2x,'jj=',i2,2x,'jini=',i2)
+211 format(2x,'qghot: colour connection jt=:',i1)
+212 format(2x,'qghot: new jet flavor:',a2,
+ *' pt squared for the jet:',e10.3/4x,'jet 4-momentum:',4e10.3)
+214 format(2x,'qghot - highest virtuality subprocess in the ladder:'/
+ *4x,'mass squared for the process:',e10.3/4x,'q^2-cutoff:',e10.3
+ *,2x,'iqc=',2i3)
+215 format(2x,'qghot - normalization of acceptance:',' gb0=',e10.3)
+216 format(2x,'qghot - acceptance probabilty:'/
+ *4x,'gb=',e10.3,2x,'q2=',e10.3,2x,'z=',e10.3,2x,'qt2=',e10.3)
+217 format(2x,'qghot: ecm=',e10.3,2x,'mt1=',e10.3,2x,'mt2=',e10.3)
+218 format(2x,'qghot: total number of jets - ',i4)
+219 format(2x,'qghot: 4-momentum balans - ',4e10.3)
+220 format(2x,'qghot - end')
+ return
+ end
+
+c------------------------------------------------------------------------
+ function npgen(vv,npmin,npmax)
+c-----------------------------------------------------------------------
+c npgen - Poisson distribution
+c vv - average number
+c npmin - minimal number
+c npmax - maximal number
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(npmin.eq.0)then
+ aks=qgran(b10)
+ vvn=exp(-vv)
+ do n=1,npmax
+ aks=aks-vvn
+ if(aks.lt.0.d0)goto 1
+ vvn=vvn*vv/dble(n)
+ enddo
+ elseif(npmin.eq.1)then
+ aks=qgran(b10)*(1.d0-exp(-vv))
+ vvn=exp(-vv)
+ do n=1,npmax
+ vvn=vvn*vv/dble(n)
+ aks=aks-vvn
+ if(aks.lt.0.d0)goto 2
+ enddo
+ elseif(npmin.eq.2)then
+ aks=qgran(b10)*(1.d0-exp(-vv)*(1.d0+vv))
+ vvn=vv*exp(-vv)
+ do n=2,npmax
+ vvn=vvn*vv/dble(n)
+ aks=aks-vvn
+ if(aks.lt.0.d0)goto 2
+ enddo
+ else
+ stop'npgen'
+ endif
+1 n=n-1
+2 npgen=n
+ return
+ end
+
+c=============================================================================
+ subroutine qglead(wppr0,wmtg0,lqa,lqb,lqa0,lqb0,lva,lvb
+ *,izp,izt,ila,ilb,iret)
+c-------------------------------------------------------------------------
+c qglead-treatment of leading hadron states
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(njmax=50000)
+ common /qgdebug/ debug
+ common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
+
+ iret=0
+ if(lqa0.eq.0.and.lqb0.eq.0)then
+ if(lva.eq.0.and.lvb.eq.0)then
+ call qgdifr(wppr0,wmtg0,izp,izt,lqa,lqb,iret)
+ elseif(lva.eq.0)then
+ call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
+ elseif(lvb.eq.0)then
+ call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
+ endif
+ if(lva.eq.1)then
+ eqj(1,ila)=.5d0*wppr0
+ eqj(2,ila)=eqj(1,ila)
+ eqj(3,ila)=0.d0
+ eqj(4,ila)=0.d0
+ endif
+ if(lvb.eq.1)then
+ eqj(1,ilb)=.5d0*wmtg0
+ eqj(2,ilb)=-eqj(1,ilb)
+ eqj(3,ilb)=0.d0
+ eqj(4,ilb)=0.d0
+ endif
+ elseif(lqa0.eq.0)then
+ if(lva.eq.0)then
+ call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
+ else
+ eqj(1,ila)=.5d0*wppr0
+ eqj(2,ila)=eqj(1,ila)
+ eqj(3,ila)=0.d0
+ eqj(4,ila)=0.d0
+ endif
+ elseif(lqb0.eq.0)then
+ if(lvb.eq.0)then
+ call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
+ else
+ eqj(1,ilb)=.5d0*wmtg0
+ eqj(2,ilb)=-eqj(1,ilb)
+ eqj(3,ilb)=0.d0
+ eqj(4,ilb)=0.d0
+ endif
+ endif
+ return
+ end
+
+c=============================================================================
+ double precision function qgbit(qi,qj,s,m,l)
+c------------------------------------------------------------------------
+c qgbit - born cross-section interpolation
+c qi,qj - effective momentum cutoffs for the scattering,
+c s - total c.m. energy squared for the scattering,
+c m - parton type at current end of the ladder (1 - g, 2 - q)
+c l - parton type at opposite end of the ladder (1 - g, 2 - q)
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wi(3),wk(3)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr26/ factk,fqscal
+ common /qgarr31/ csj(40,160)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)qi,qj,s,m,l
+ qgbit=0.d0
+ qq=max(qi,qj)
+ s2min=qq*4.d0*fqscal
+ if(s.le..99d0*s2min)then
+ if(debug.ge.3)write (moniou,202)qgbit
+ return
+ endif
+
+ tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
+ ml=40*(m-1)+80*(l-1)
+ qli=dlog(qq)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
+ sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
+ i=min(38,int(qli))
+ k=min(38,int(sl))
+
+ wk(2)=sl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ wi(2)=qli-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ do k1=1,3
+ k2=k+k1-1+ml
+ do i1=1,3
+ qgbit=qgbit+csj(i+i1-1,k2)*wi(i1)*wk(k1)
+ enddo
+ enddo
+ qgbit=exp(qgbit)*(1.d0/tmin-2.d0/s)
+ if(qi.lt.qq)qgbit=qgbit*qgsudx(qq,m)/qgsudx(qi,m)
+ if(qj.lt.qq)qgbit=qgbit*qgsudx(qq,l)/qgsudx(qj,l)
+
+ if(debug.ge.3)write (moniou,202)qgbit
+201 format(2x,'qgbit: qi=',e10.3,2x,'qj=',e10.3
+ *,2x,'s= ',e10.3,2x,'m= ',i1,2x,'l= ',i1)
+202 format(2x,'qgbit=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgfbor(s,t,iq1,iq2,n)
+c---------------------------------------------------------------------------
+c qgfbor - integrand for the born cross-section (matrix element squared)
+c s - total c.m. energy squared for the scattering,
+c t - invariant variable for the scattering abs[(p1-p3)**2],
+c iq1 - parton type at current end of the ladder (0 - g, 1,2 - q)
+c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)s,t,iq1,iq2
+
+ u=s-t
+ if(n.eq.1)then
+ if(iq1.eq.0.and.iq2.eq.0)then !gluon-gluon
+ qgfbor=(3.d0-t*u/s**2+s*u/t**2+s*t/u**2)*4.5d0
+ elseif(iq1*iq2.eq.0)then !gluon-quark
+ qgfbor=(s**2+u**2)/t**2+(s/u+u/s)/2.25d0
+ elseif(iq1.eq.iq2)then !quark-quark (same flavor)
+ qgfbor=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25d0
+ * -s**2/t/u/3.375d0
+ elseif(iq1+iq2.eq.0)then !quark-antiquark (same flavor)
+ qgfbor=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25d0
+ * +u**2/t/s/3.375d0
+ else !quark-antiquark (different flavors)
+ qgfbor=(s**2+u**2)/t**2/2.25d0
+ endif
+ elseif(n.eq.2)then
+ if(iq1.eq.0.and.iq2.eq.0)then !gluon-gluon->quark-antiquark
+ qgfbor=.5d0*(t/u+u/t)-1.125d0*(t*t+u*u)/s**2
+ elseif(iq1+iq2.eq.0)then !quark-antiquark->quark-antiquark
+ qgfbor=(t*t+u*u)/s**2/1.125d0 !(different flavor)
+ else
+ qgfbor=0.d0
+ endif
+ elseif(n.eq.3)then
+ if(iq1.ne.0.and.iq1+iq2.eq.0)then !quark-antiquark->gluon-gluon
+ qgfbor=32.d0/27.d0*(t/u+u/t)-(t*t+u*u)/s**2/.375d0
+ else
+ qgfbor=0.d0
+ endif
+ endif
+
+ if(debug.ge.2)write (moniou,202)qgfbor
+201 format(2x,'qgfbor - hard scattering matrix element squared:'/
+ *4x,'s=',e10.3,2x,'|t|=',e10.3,2x,'iq1=',i1,2x,'iq2=',i1)
+202 format(2x,'qgfbor=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgborn(qi,qj,s,iq1,iq2)
+c-----------------------------------------------------------------------------
+c qgborn - hard 2->2 parton scattering born cross-section
+c s is the c.m. energy square for the scattering process,
+c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
+c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
+
+ qgborn=0.d0
+ qq=max(qi,qj)
+ tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
+ do i=1,7
+ do m=1,2
+ t=2.d0*tmin/(1.d0+2.d0*tmin/s-x1(i)*(2*m-3)*(1.d0-2.d0*tmin/s))
+ qt=t*(1.d0-t/s)
+
+ fb=0.d0
+ do n=1,3
+ fb=fb+qgfbor(s,t,iq1,iq2,n)+qgfbor(s,s-t,iq1,iq2,n)
+ enddo
+ fb=fb*qgsudx(qt/fqscal,iabs(iq1)+1)
+ * *qgsudx(qt/fqscal,iabs(iq2)+1)
+
+ qgborn=qgborn+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
+ enddo
+ enddo
+ qgborn=qgborn*2.d0*pi**3/s**2
+
+ qgborn=qgborn/qgsudx(qi,iabs(iq1)+1)/qgsudx(qj,iabs(iq2)+1)
+ if(iq1.eq.iq2)qgborn=qgborn*.5d0
+
+ if(debug.ge.3)write (moniou,202)qgborn
+201 format(2x,'qgborn: qi=',e10.3,2x,'qj=',e10.3,2x,
+ *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
+202 format(2x,'qgborn=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgcjet(qq,iq1,qv,zv,qm,iqv,ldau,lpar,jq)
+c-----------------------------------------------------------------------------
+c final state emission process (all branchings as well as parton masses
+c are determined)
+c qq - maximal effective momentum transfer for the first branching
+c iq1 - initial jet flavour (0 - for gluon)
+c qv(i,j) - effective momentum for the branching of the parton in i-th row
+c on j-th level (0 - in case of no branching) - to be determined
+c zv(i,j) - z-value for the branching of the parton in i-th row
+c on j-th level - to be determined
+c qm(i,j) - mass squared for the parton in i-th row
+c on j-th level - to be determined
+c iqv(i,j) - flavour for the parton in i-th row on j-th level
+c - to be determined
+c ldau(i,j) - first daughter row for the branching of the parton in i-th row
+c on j-th level - to be determined
+c lpar(i,j) - the parent row for the parton in i-th row
+c on j-th level - to be determined
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension qmax(30,50),iqm(2),lnv(50),
+ *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
+ *ldau(30,49),lpar(30,50)
+ common /qgarr11/ b10
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)qq,iq1,jq
+
+ do i=2,50
+ lnv(i)=0
+ enddo
+ lnv(1)=1
+ qmax(1,1)=qq
+ iqv(1,1)=iq1
+ nlev=1
+ nrow=1
+
+2 qlmax=dlog(qmax(nrow,nlev)/qtf/16.d0)
+ iq=min(1,iabs(iqv(nrow,nlev)))+1
+
+ if(qgran(b10).gt.qgsudi(qlmax,iq))then
+ q=qgqint(qlmax,qgran(b10),iq)
+ z=qgzsim(q,iq)
+ ll=lnv(nlev+1)+1
+ ldau(nrow,nlev)=ll
+ lpar(ll,nlev+1)=nrow
+ lpar(ll+1,nlev+1)=nrow
+ lnv(nlev+1)=ll+1
+
+ if(iq.ne.1)then
+ if((3-2*jq)*iqv(nrow,nlev).gt.0)then
+ iqm(1)=0
+ iqm(2)=iqv(nrow,nlev)
+ else
+ iqm(2)=0
+ iqm(1)=iqv(nrow,nlev)
+ z=1.d0-z
+ endif
+ else
+ wg=qgfap(z,1,1)
+ wg=wg/(wg+qgfap(z,1,2))
+ if(qgran(b10).lt.wg)then
+ iqm(1)=0
+ iqm(2)=0
+ else
+ iqm(1)=int(3.d0*qgran(b10)+1.d0)*(3-2*jq)
+ iqm(2)=-iqm(1)
+ endif
+ if(qgran(b10).lt..5d0)z=1.d0-z
+ endif
+ qv(nrow,nlev)=q
+ zv(nrow,nlev)=z
+ nrow=ll
+ nlev=nlev+1
+ qmax(nrow,nlev)=q*z**2
+ qmax(nrow+1,nlev)=q*(1.d0-z)**2
+ iqv(nrow,nlev)=iqm(1)
+ iqv(nrow+1,nlev)=iqm(2)
+ if(debug.ge.3)write (moniou,203)nlev,nrow,q,z
+ goto 2
+ else
+ qv(nrow,nlev)=0.d0
+ zv(nrow,nlev)=0.d0
+ qm(nrow,nlev)=0.d0
+ if(debug.ge.3)write (moniou,204)nlev,nrow
+ endif
+
+3 continue
+ if(nlev.eq.1)then
+ if(debug.ge.3)write (moniou,202)
+ return
+ endif
+
+ lprow=lpar(nrow,nlev)
+ if(ldau(lprow,nlev-1).eq.nrow)then
+ nrow=nrow+1
+ goto 2
+ else
+ z=zv(lprow,nlev-1)
+ qm(lprow,nlev-1)=z*(1.d0-z)*qv(lprow,nlev-1)
+ * +qm(nrow-1,nlev)/z+qm(nrow,nlev)/(1.d0-z)
+ nrow=lprow
+ nlev=nlev-1
+ if(debug.ge.3)write (moniou,205)nlev,nrow,qm(lprow,nlev)
+ goto 3
+ endif
+
+201 format(2x,'qgcjet: qq=',e10.3,2x,'iq1= ',i1,2x,'jq=',i1)
+202 format(2x,'qgcjet - end')
+203 format(2x,'qgcjet: new branching at level nlev=',i2,' nrow=',i2
+ */4x,' effective momentum q=',e10.3,2x,' z=',e10.3)
+204 format(2x,'qgcjet: new final jet at level nlev=',i2,' nrow=',i2)
+205 format(2x,'qgcjet: jet mass at level nlev=',i2,' nrow=',i2
+ *,' - qm=',e10.3)
+ end
+
+c===========================================================================
+ subroutine qgcs(c,s)
+c---------------------------------------------------------------------------
+c c,s - cos and sin generation for uniformly distributed angle 0<fi<2*pi
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)
+1 s1=2.d0*qgran(b10)-1.d0
+ s2=2.d0*qgran(b10)-1.d0
+ s3=s1*s1+s2*s2
+ if(s3.gt.1.d0)goto 1
+ s3=dsqrt(s3)
+ c=s1/s3
+ s=s2/s3
+
+ if(debug.ge.3)write (moniou,202)c,s
+201 format(2x,'qgcs - cos(fi) and sin(fi) are generated',
+ *' (0<fi<2*pi)')
+202 format(2x,'qgcs: c=',e10.3,2x,'s=',e10.3)
+ return
+ end
+
+c===========================================================================
+ subroutine qgdeft(s,ep,ey)
+c---------------------------------------------------------------------------
+c determination of the parameters for the lorentz transform to the rest frame
+c system for 4-vector ep
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ey(3),ep(4)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)ep,s
+
+ do i=1,3
+ if(ep(i+1).eq.0.d0)then
+ ey(i)=1.d0
+ else
+ wp=ep(1)+ep(i+1)
+ wm=ep(1)-ep(i+1)
+ if(wm/wp.lt.1.d-8)then
+ ww=s
+ do l=1,3
+ if(l.ne.i)ww=ww+ep(l+1)**2
+ enddo
+ wm=ww/wp
+ endif
+ ey(i)=dsqrt(wm/wp)
+ ep(1)=wp*ey(i)
+ ep(i+1)=0.d0
+ endif
+ enddo
+
+ if(debug.ge.3)write (moniou,202)ey
+201 format(2x,'qgdeft - lorentz boost parameters:'
+ */4x,'4-vector ep=',4e10.3/4x,'4-vector squared s=',e10.3)
+202 format(2x,'qgdeft: lorentz boost parameters ey(i)=',2x,3e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgdefr(ep,s0x,c0x,s0,c0)
+c-----------------------------------------------------------------------------
+c determination of the parameters the spacial rotation to the lab. system
+c for 4-vector ep
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ep(4)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)ep
+
+c transverse momentum square for the current parton (ep)
+ pt2=ep(3)**2+ep(4)**2
+ if(pt2.ne.0.d0)then
+ pt=dsqrt(pt2)
+c system rotation to get pt=0 - euler angles are determined (c0x = cos theta,
+c s0x = sin theta, c0 = cos phi, s0 = sin phi)
+ c0x=ep(3)/pt
+ s0x=ep(4)/pt
+c total momentum for the gluon
+ pl=dsqrt(pt2+ep(2)**2)
+ s0=pt/pl
+ c0=ep(2)/pl
+ else
+ c0x=1.d0
+ s0x=0.d0
+ pl=abs(ep(2))
+ s0=0.d0
+ c0=ep(2)/pl
+ endif
+ ep(2)=pl
+ ep(3)=0.d0
+ ep(4)=0.d0
+
+ if(debug.ge.3)write (moniou,202)s0x,c0x,s0,c0,ep
+201 format(2x,'qgdefr - spacial rotation parameters'/4x,
+ *'4-vector ep=',2x,4(e10.3,1x))
+202 format(2x,'qgdefr: spacial rotation parameters'/
+ *4x,'s0x=',e10.3,2x,'c0x=',e10.3,2x,'s0=',e10.3,2x,'c0=',e10.3/
+ *4x,'rotated 4-vector ep=',4(e10.3,1x))
+ return
+ end
+
+c=============================================================================
+ double precision function qgfap(x,j,l)
+c------------------------------------------------------------------------
+c qgfap - altarelli-parisi function (multiplied by x)
+c x - light cone momentum share value,
+c j - type of the parent parton (1-g,2-q)
+c l - type of the daughter parton (1-g,2-q)
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)x,j,l
+
+ if(j.eq.1)then
+ if(l.eq.1)then
+ qgfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
+ else
+ qgfap=(x**2+(1.d0-x)**2)*3.d0
+ endif
+ else
+ if(l.eq.1)then
+ qgfap=(1.d0+(1.d0-x)**2)/x/.75d0
+ else
+ qgfap=(x**2+1.d0)/(1.d0-x)/.75d0
+ endif
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgfap
+201 format(2x,'qgfap - altarelli-parisi function:'
+ *,2x,'x=',e10.3,2x,'j=',i1,2x,'l=',i1)
+202 format(2x,'qgfap=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qggea(ia,xa,jj)
+c-----------------------------------------------------------------------------
+c qggea - nuclear configuration simulation (nucleons positions)
+c ia - number of nucleons to be considered
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension xa(iapmax,3)
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)jj,ia
+
+ if(ia.ge.10)then
+ do i=1,ia
+1 zuk=qgran(b10)*cr1(jj)-1.d0
+c if(zuk)2,2,3
+ if(zuk.le.0.d0)then
+ tt=rnuc(jj)/wsnuc(jj)*(qgran(b10)**.3333d0-1.d0)
+ goto 6
+ else
+ if(zuk.gt.cr2(jj))goto 4
+ tt=-dlog(qgran(b10))
+ goto 6
+4 if(zuk.gt.cr3(jj))goto 5
+ tt=-dlog(qgran(b10))-dlog(qgran(b10))
+ goto 6
+5 tt=-dlog(qgran(b10))-dlog(qgran(b10))-dlog(qgran(b10))
+ endif
+6 rim=tt*wsnuc(jj)+rnuc(jj)
+ if(qgran(b10).gt.(1.d0+wbnuc(jj)*rim**2/rnuc(jj)**2)
+ * /(1.d0+exp(-abs(tt))))goto 1
+ z=rim*(2.d0*qgran(b10)-1.d0)
+ rim=dsqrt(rim*rim-z*z)
+ xa(i,3)=z
+ call qgcs(c,s)
+ xa(i,1)=rim*c
+ xa(i,2)=rim*s
+ enddo
+ else
+ do l=1,3
+ summ=0.d0
+ do i=1,ia-1
+ j=ia-i
+ aks=rnuc(jj)*(qgran(b10)+qgran(b10)+qgran(b10)-1.5d0)
+ k=j+1
+ xa(k,l)=summ-aks*sqrt(float(j)/k)
+ summ=summ+aks/sqrt(float(j*k))
+ enddo
+ xa(1,l)=summ
+ enddo
+ endif
+
+ if(debug.ge.3)then
+ write (moniou,203)
+ do i=1,ia
+ write (moniou,204)i,(xa(i,l),l=1,3)
+ enddo
+ write (moniou,202)
+ endif
+201 format(2x,'qggea - configuration of the nucleus ',i1,';',2x,
+ *'coordinates for ',i2,' nucleons')
+202 format(2x,'qggea - end')
+203 format(2x,'qggea: positions of the nucleons')
+204 format(2x,'qggea: ',i2,' - ',3(e10.3,1x))
+ return
+ end
+
+c=============================================================================
+ double precision function qgapi(x,j,l)
+c-----------------------------------------------------------------------------
+c qgapi - integrated altarelli-parisi function
+c x - light cone momentum share value,
+c j - type of initial parton (1 - g, 2 - q)
+c l - type of final parton (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)x,j,l
+
+ if(j.eq.1)then
+ if(l.eq.1)then
+ qgapi=6.d0*(dlog(x/(1.d0-x))-x**3/3.d0+x**2/2.d0-2.d0*x)
+ else
+ qgapi=3.d0*(x+x**3/1.5d0-x*x)
+ endif
+ else
+ if(l.eq.1)then
+ qgapi=(dlog(x)-x+.25d0*x*x)/.375d0
+ else
+ z=1.d0-x
+ qgapi=-(dlog(z)-z+.25d0*z*z)/.375d0
+ endif
+ endif
+
+ if(debug.ge.2)write (moniou,202)qgapi
+201 format(2x,'qgapi: x=',e10.3,2x,'j= ',i1,2x,'l= ',i1)
+202 format(2x,'qgapi=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgjarr(jfl)
+c-----------------------------------------------------------------------------
+c final jets rearrangement according to their colour connections
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(njmax=50000)
+ dimension mark(njmax),ept(4)
+ common /qgarr10/ am(7),ammu
+ common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
+ common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)nj
+ if(debug.ge.2.and.nj.ne.0)then
+ do i=1,nj
+ write (moniou,203)i,iqj(i),(eqj(l,i),l=1,4)
+ if(iqj(i).eq.0)then
+ write (moniou,204)ncj(1,i),ncj(2,i)
+ else
+ ncdum=0
+ write (moniou,204)ncj(1,i),ncdum
+ endif
+ enddo
+ endif
+
+ njpar=0
+ jfl=0
+ do i=1,nj
+ mark(i)=1
+ enddo
+ njtot=0
+
+2 continue
+ do ij=1,nj
+ if(mark(ij).ne.0.and.iqj(ij).ne.0)goto 4
+ enddo
+4 continue
+
+ jfirst=1
+ if(iabs(iqj(ij)).le.2)then
+ am1=am(1)
+ elseif(iabs(iqj(ij)).eq.4)then
+ am1=am(3)
+ else
+ am1=am(2)
+ endif
+ do i=1,4
+ ept(i)=0.d0
+ enddo
+
+6 mark(ij)=0
+ njtot=njtot+1
+ ipjet(njtot)=iqj(ij)
+ do i=1,4
+ ept(i)=ept(i)+eqj(i,ij)
+ epjet(i,njtot)=eqj(i,ij)
+ enddo
+
+ if(iqj(ij).ne.0)then
+ if(jfirst.ne.1)then
+ if(iabs(iqj(ij)).le.2)then
+ am2=am(1)
+ elseif(iabs(iqj(ij)).eq.4)then
+ am2=am(3)
+ else
+ am2=am(2)
+ endif
+ amj=(am1+am2)**2
+ if(amj.gt.qgnrm(ept))then
+ if(debug.ge.3)write (moniou,202)jfl
+ return
+ endif
+
+ if(njtot.lt.nj)then
+ goto 2
+ else
+ jfl=1
+ nj=0
+ if(debug.ge.3)write (moniou,202)jfl
+ return
+ endif
+ else
+ jfirst=0
+ njpar=ij
+ ij=ncj(1,ij)
+ goto 6
+ endif
+ else
+ if(ncj(1,ij).eq.njpar)then
+ njdau=ncj(2,ij)
+ else
+ njdau=ncj(1,ij)
+ endif
+ njpar=ij
+ ij=njdau
+ goto 6
+ endif
+
+201 format(2x,'qgjarr: total number of jets nj=',i4)
+202 format(2x,'qgjarr - end,jfl=',i2)
+203 format(2x,'qgjarr: ij=',i3,2x,'iqj=',i2,2x,'eqj=',4e10.3)
+204 format(2x,'qgjarr: ncj=',2i3)
+ end
+
+c=============================================================================
+ double precision function qgjet(q1,q2,s,s2min,j,l)
+c-----------------------------------------------------------------------------
+c qgjet - inclusive hard cross-section calculation (one more run is added
+c to the ladder) - for any ordering
+c q1 - effective momentum cutoff for current end of the ladder,
+c q2 - effective momentum cutoff for opposide end of the ladder,
+c s - total c.m. energy squared for the ladder,
+c s2min - minimal c.m. energy squared for born process (above q1 and q2)
+c j - parton type at current end of the ladder (1 - g, 2 - q)
+c l - parton type at opposite end of the ladder (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
+
+ qgjet=0.d0
+ qmax=s/4.d0/fqscal*(1.d0-epsxmn)
+ qmin=q1
+ if(debug.ge.3)write (moniou,203)qmin,qmax
+
+ if(qmax.gt.qmin)then
+c numerical integration over transverse momentum square;
+c gaussian integration is used
+ do i=1,7
+ do m=1,2
+ qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
+ zmax=(1.d0-epsxmn)**delh
+ zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
+ fsj=0.d0
+ if(debug.ge.3)write (moniou,204)qi,zmin,zmax
+
+ if(zmax.gt.zmin)then
+ do i1=1,7
+ do m1=1,2
+ z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
+ s2=z*s
+
+ sj=0.d0
+ do k=1,2
+ sj=sj+qgjit(qi,q2,s2,k,l)*qgfap(z,j,k)*z
+ enddo
+ fsj=fsj+a1(i1)*sj/z**delh
+ enddo
+ enddo
+ fsj=fsj*(zmax-zmin)
+ endif
+ qgjet=qgjet+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
+ enddo
+ enddo
+ qgjet=qgjet*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgjet
+201 format(2x,'qgjet - unordered ladder cross section:'
+ */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
+ *e10.3,2x,'j=',i1,2x,'l=',i1)
+202 format(2x,'qgjet=',e10.3)
+203 format(2x,'qgjet:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
+204 format(2x,'qgjet:',2x,'qi=',e10.3,2x,'zmin=',e10.3
+ *,2x,'zmax=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgjet1(q1,q2,s,s2min,j,l)
+c-----------------------------------------------------------------------------
+c qgjet1 - inclusive hard cross-section calculation (one more run is added
+c to the ladder) - for strict ordering
+c q1 - effective momentum cutoff for current end of the ladder,
+c q2 - effective momentum cutoff for opposide end of the ladder,
+c s - total c.m. energy squared for the ladder,
+c s2min - minimal c.m. energy squared for born process (above q1 and q2)
+c j - parton type at current end of the ladder (1 - g, 2 - q)
+c l - parton type at opposite end of the ladder (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
+
+ qgjet1=0.d0
+ qmax=s/4.d0/fqscal*(1.d0-epsxmn)
+ qmin=q1
+ if(debug.ge.3)write (moniou,203)qmin,qmax
+
+ if(qmax.gt.qmin)then
+c numerical integration over transverse momentum square;
+c gaussian integration is used
+ do i=1,7
+ do m=1,2
+ qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
+ zmax=(1.d0-epsxmn)**delh
+ zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
+ fsj=0.d0
+ if(debug.ge.3)write (moniou,204)qi,zmin,zmax
+
+ if(zmax.gt.zmin)then
+ do i1=1,7
+ do m1=1,2
+ z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
+ s2=z*s
+
+ sj=0.d0
+ do k=1,2
+ sj=sj+qgjit1(qi,q2,s2,k,l)*qgfap(z,j,k)*z
+ enddo
+ fsj=fsj+a1(i1)*sj/z**delh
+ enddo
+ enddo
+ fsj=fsj*(zmax-zmin)
+ endif
+ qgjet1=qgjet1+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
+ enddo
+ enddo
+ qgjet1=qgjet1*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgjet1
+201 format(2x,'qgjet1 - strictly ordered ladder cross section:'
+ */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
+ *e10.3,2x,'j=',i1,2x,'l=',i1)
+202 format(2x,'qgjet1=',e10.3)
+203 format(2x,'qgjet1:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
+204 format(2x,'qgjet1:',2x,'qi=',e10.3,2x,'zmin=',e10.3
+ *,2x,'zmax=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgjit(q1,q2,s,m,l)
+c-----------------------------------------------------------------------------
+c qgjit - inclusive hard cross-section interpolation - for any ordering
+c in the ladder
+c q1 - effective momentum cutoff for current end of the ladder,
+c q2 - effective momentum cutoff for opposide end of the ladder,
+c s - total c.m. energy squared for the ladder,
+c m - parton type at current end of the ladder (1 - g, 2 - q)
+c l - parton type at opposite end of the ladder (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wi(3),wj(3),wk(3)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr26/ factk,fqscal
+ common /qgarr29/ csj(40,40,160)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
+
+ qgjit=0.d0
+ qq=max(q1,q2)
+ s2min=qq*4.d0*fqscal
+ if(s.le..99d0*s2min)then
+ if(debug.ge.3)write (moniou,202)qgjit
+ return
+ endif
+
+ if(q1.le.q2)then
+ qi=q1
+ qj=q2
+ ml=40*(m-1)+80*(l-1)
+ else
+ qi=q2
+ qj=q1
+ ml=40*(l-1)+80*(m-1)
+ endif
+
+ tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
+ qli=dlog(qi)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
+ if(qi.lt..99d0*spmax/4.d0/fqscal)then
+ qlj=dlog(qj/qi)/dlog(spmax/4.d0/fqscal/qi)*39.d0+1.d0
+ else
+ qlj=1.d0
+ endif
+ sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
+ i=min(38,int(qli))
+ j=min(38,int(qlj))
+ k=min(38,int(sl))
+
+ wk(2)=sl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ wi(2)=qli-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ wj(2)=qlj-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+ do k1=1,3
+ k2=k+k1-1+ml
+ do i1=1,3
+ do j1=1,3
+ qgjit=qgjit+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
+ enddo
+ enddo
+ enddo
+ qgjit=exp(qgjit)*(1.d0/tmin-2.d0/s)
+
+ if(debug.ge.3)write (moniou,202)qgjit
+201 format(2x,'qgjit - unordered ladder cross section interpol.:'/4x,
+ *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
+202 format(2x,'qgjit=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgjit1(q1,q2,s,m,l)
+c-----------------------------------------------------------------------------
+c qgjit1 - inclusive hard cross-section interpolation - for strict ordering
+c in the ladder
+c q1 - effective momentum cutoff for current end of the ladder,
+c q2 - effective momentum cutoff for opposide end of the ladder,
+c s - total c.m. energy squared for the ladder,
+c m - parton type at current end of the ladder (1 - g, 2 - q)
+c l - parton type at opposite end of the ladder (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wi(3),wj(3),wk(3)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr26/ factk,fqscal
+ common /qgarr30/ csj(40,40,160)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
+
+ qgjit1=0.d0
+ qq=max(q1,q2)
+ s2min=qq*4.d0*fqscal
+ if(s.le.s2min)then
+ if(debug.ge.3)write (moniou,202)qgjit1
+ return
+ endif
+
+ tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
+ ml=40*(m-1)+80*(l-1)
+ qli=dlog(q1)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
+ if(q1.lt..99d0*spmax/4.d0/fqscal)then
+ qlj=dlog(qq/q1)/dlog(spmax/4.d0/fqscal/q1)*39.d0+1.d0
+ else
+ qlj=1.d0
+ endif
+ sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
+ i=min(38,int(qli))
+ j=min(38,int(qlj))
+ k=min(38,int(sl))
+ wk(2)=sl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ wi(2)=qli-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ wj(2)=qlj-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+
+ do k1=1,3
+ k2=k+k1-1+ml
+ do i1=1,3
+ do j1=1,3
+ qgjit1=qgjit1+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
+ enddo
+ enddo
+ enddo
+ qgjit1=exp(qgjit1)*(1.d0/tmin-2.d0/s)
+ if(q2.lt.q1)qgjit1=qgjit1*qgsudx(q1,l)/qgsudx(q2,l)
+
+ if(debug.ge.3)write (moniou,202)qgjit1
+201 format(2x,'qgjit1 - ordered ladder cross section interpol.:'/4x,
+ *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
+202 format(2x,'qgjit1=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qglam(s,a,b)
+c-----------------------------------------------------------------------------
+c kinematical function for two particle decay - maximal pt-value
+c a - first particle mass squared,
+c b - second particle mass squared,
+c s - two particle invariant mass
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)s,a,b
+
+ qglam=max(0.d0,.25d0/s*(s+a-b)**2-a)
+
+ if(debug.ge.3)write (moniou,202)qglam
+201 format(2x,'qglam - kinematical function s=',e10.3,2x,'a='
+ *,e10.3,2x,'b=',e10.3)
+202 format(2x,'qglam=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgnrm(ep)
+c-----------------------------------------------------------------------------
+c 4-vector squared calculation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ep(4)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)ep
+ qgnrm=(ep(1)-ep(2))*(ep(1)+ep(2))-ep(3)**2-ep(4)**2
+
+ if(debug.ge.3)write (moniou,202)qgnrm
+201 format(2x,'qgnrm - 4-vector squared for ','ep=',4(e10.3,1x))
+202 format(2x,'qgnrm=',e10.3)
+ return
+ end
+
+c===========================================================================
+ subroutine qgrec(ep,nqc,qv,zv,qm,iqv,ldau,lpar,jq)
+c---------------------------------------------------------------------------
+c jet reconstructuring procedure - 4-momenta for all final jets are determ.
+c ep(i) - jet 4-momentum
+c---------------------------------------------------------------------------
+c qv(i,j) - effective momentum for the branching of the parton in i-th row
+c on j-th level (0 - in case of no branching)
+c zv(i,j) - z-value for the branching of the parton in i-th row
+c on j-th level
+c qm(i,j) - mass squared for the parton in i-th row
+c on j-th level
+c iqv(i,j) - flavours for the parton in i-th row on j-th level
+c ldau(i,j) - first daughter row for the branching of the parton in i-th row
+c on j-th level
+c lpar(i,j) - the parent row for the parton in i-th row on j-th level
+c----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(njmax=50000)
+ dimension ep(4),ep3(4),epv(4,30,50),nqc(2),ncc(2,30,50),
+ *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
+ *ldau(30,49),lpar(30,50)
+c eqj(i,nj) - 4-momentum for the final jet nj
+c iqj(nj) - flavour for the final jet nj
+c ncj(m,nj) - colour connections for the final jet nj
+ common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)jq,ep,iqv(1,1),nqc
+
+ do i=1,4
+ epv(i,1,1)=ep(i)
+ enddo
+ ncc(1,1,1)=nqc(1)
+ if(iqv(1,1).eq.0)ncc(2,1,1)=nqc(2)
+ nlev=1
+ nrow=1
+
+2 continue
+ if(qv(nrow,nlev).eq.0.d0)then
+ nj=nj+1
+ do i=1,4
+ eqj(i,nj)=epv(i,nrow,nlev)
+ enddo
+ iqj(nj)=iqv(nrow,nlev)
+ if(iabs(iqj(nj)).eq.3)iqj(nj)=iqj(nj)*4/3
+
+ if(iqj(nj).ne.0)then
+ njc=ncc(1,nrow,nlev)
+ if(njc.ne.0)then
+ ncj(1,nj)=njc
+ iqc=iqj(njc)
+ if(iqc.ne.0)then
+ ncj(1,njc)=nj
+ else
+ if(iqj(nj).gt.0)then
+ ncj(2,njc)=nj
+ else
+ ncj(1,njc)=nj
+ endif
+ endif
+ else
+ ncc(1,nrow,nlev)=nj
+ endif
+ else
+
+ do m=1,2
+ if(jq.eq.1)then
+ m1=m
+ else
+ m1=3-m
+ endif
+ njc=ncc(m1,nrow,nlev)
+ if(njc.ne.0)then
+ ncj(m,nj)=njc
+ iqc=iqj(njc)
+ if(iqc.ne.0)then
+ ncj(1,njc)=nj
+ else
+ ncj(3-m,njc)=nj
+ endif
+ else
+ ncc(m1,nrow,nlev)=nj
+ endif
+ enddo
+ endif
+ if(debug.ge.3)write (moniou,204)
+ * nj,nlev,nrow,iqj(nj),(eqj(i,nj),i=1,4)
+
+ else
+ do i=1,4
+ ep3(i)=epv(i,nrow,nlev)
+ enddo
+ call qgdefr(ep3,s0x,c0x,s0,c0)
+ z=zv(nrow,nlev)
+ qt2=(z*(1.d0-z))**2*qv(nrow,nlev)
+ ldrow=ldau(nrow,nlev)
+
+ wp0=ep3(1)+ep3(2)
+ wpi=z*wp0
+ wmi=(qt2+qm(ldrow,nlev+1))/wpi
+ ep3(1)=.5d0*(wpi+wmi)
+ ep3(2)=.5d0*(wpi-wmi)
+ qt=dsqrt(qt2)
+ call qgcs(c,s)
+ ep3(3)=qt*c
+ ep3(4)=qt*s
+ call qgrota(ep3,s0x,c0x,s0,c0)
+ do i=1,4
+ epv(i,ldrow,nlev+1)=ep3(i)
+ enddo
+ if(debug.ge.3)write (moniou,206)nlev+1,ldrow,ep3
+
+ wpi=(1.d0-z)*wp0
+ wmi=(qt2+qm(ldrow+1,nlev+1))/wpi
+ ep3(1)=.5d0*(wpi+wmi)
+ ep3(2)=.5d0*(wpi-wmi)
+ ep3(3)=-qt*c
+ ep3(4)=-qt*s
+ call qgrota(ep3,s0x,c0x,s0,c0)
+ do i=1,4
+ epv(i,ldrow+1,nlev+1)=ep3(i)
+ enddo
+ if(debug.ge.3)write (moniou,206)nlev+1,ldrow+1,ep3
+
+ if(iqv(nrow,nlev).eq.0)then
+ if(iqv(ldrow,nlev+1).ne.0)then
+ ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
+ ncc(1,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
+ else
+ ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
+ ncc(2,ldrow,nlev+1)=0
+ ncc(1,ldrow+1,nlev+1)=0
+ ncc(2,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
+ endif
+ else
+ if(iqv(ldrow,nlev+1).eq.0)then
+ ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
+ ncc(2,ldrow,nlev+1)=0
+ ncc(1,ldrow+1,nlev+1)=0
+ else
+ ncc(1,ldrow,nlev+1)=0
+ ncc(1,ldrow+1,nlev+1)=0
+ ncc(2,ldrow+1,nlev+1)=ncc(1,nrow,nlev)
+ endif
+ endif
+
+ nrow=ldrow
+ nlev=nlev+1
+ goto 2
+ endif
+
+8 continue
+ if(nlev.eq.1)then
+ if(nqc(1).eq.0)nqc(1)=ncc(1,1,1)
+ if(iqv(1,1).eq.0.and.nqc(2).eq.0)nqc(2)=ncc(2,1,1)
+ if(debug.ge.3)write (moniou,202)
+ return
+ endif
+
+ lprow=lpar(nrow,nlev)
+ if(ldau(lprow,nlev-1).eq.nrow)then
+ if(iqv(nrow,nlev).eq.0)then
+ if(ncc(1,lprow,nlev-1).eq.0)ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
+ ncc(1,nrow+1,nlev)=ncc(2,nrow,nlev)
+ else
+ if(iqv(lprow,nlev-1).eq.0)then
+ if(ncc(1,lprow,nlev-1).eq.0)
+ * ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
+ else
+ ncc(1,nrow+1,nlev)=ncc(1,nrow,nlev)
+ endif
+ endif
+ nrow=nrow+1
+ goto 2
+ else
+ if(iqv(nrow,nlev).eq.0)then
+ if(iqv(lprow,nlev-1).eq.0)then
+ if(ncc(2,lprow,nlev-1).eq.0)
+ * ncc(2,lprow,nlev-1)=ncc(2,nrow,nlev)
+ else
+ if(ncc(1,lprow,nlev-1).eq.0)
+ * ncc(1,lprow,nlev-1)=ncc(2,nrow,nlev)
+ endif
+ else
+ if(iqv(lprow,nlev-1).eq.0.and.ncc(2,lprow,nlev-1).eq.0)
+ * ncc(2,lprow,nlev-1)=ncc(1,nrow,nlev)
+ endif
+ nrow=lprow
+ nlev=nlev-1
+ goto 8
+ endif
+
+201 format(2x,'qgrec - jet reconstructuring: jq=',i1
+ */4x,'jet 4-momentum ep=',4(e10.3,1x)
+ */4x,'jet flavor: ',i2,2x,'colour connections: ',2i3)
+202 format(2x,'qgrec - end')
+204 format(2x,'qgrec: ',i3,'-th final jet at level nlev=',i2,' nrow='
+ *,i2/4x,'jet flavor: ',i3,2x,'jet 4-momentum:',4(e10.3,1x))
+206 format(2x,'qgrec: jet at level nlev='
+ *,i2,' nrow=',i2/4x,'jet 4-momentum:',4(e10.3,1x))
+ end
+
+c=============================================================================
+ double precision function qgroot(qlmax,g,j)
+c-----------------------------------------------------------------------------
+c qgroot - effective momentum tabulation for given set of random number
+c values and maximal effective momentum qmax values - according to the
+c probability of branching: (1 - timelike sudakov formfactor)
+c qlmax - ln qmax/16/qtf,
+c g - dzeta number (some function of ksi)
+c j - type of the parton (1-g,2-q)
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)qlmax,g,j
+
+ ql0=0.d0
+ ql1=qlmax
+ f0=-g
+ f1=1.d0-g
+ sud0=-dlog(qgsudi(qlmax,j))
+
+1 ql2=ql1-(ql1-ql0)*f1/(f1-f0)
+ if(ql2.lt.0.d0)then
+ ql2=0.d0
+ f2=-g
+ elseif(ql2.gt.qlmax)then
+ ql2=qlmax
+ f2=1.d0-g
+ else
+ f2=-dlog(qgsudi(ql2,j))/sud0-g
+ endif
+ if(abs(f2).gt.1.d-3)then
+ if(f1*f2.lt.0.d0)then
+ ql0=ql1
+ f0=f1
+ endif
+ ql1=ql2
+ f1=f2
+ goto 1
+ else
+ qgroot=ql2
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgroot
+201 format(2x,'qgqint - branching momentum tabulation:'
+ */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
+202 format(2x,'qgroot=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgrota(ep,s0x,c0x,s0,c0)
+c-----------------------------------------------------------------------------
+c spacial rotation to the lab. system for 4-vector ep
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ep(4),ep1(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)ep,s0x,c0x,s0,c0
+
+ ep1(3)=ep(4)
+ ep1(2)=ep(2)*s0+ep(3)*c0
+ ep1(1)=ep(2)*c0-ep(3)*s0
+ ep(2)=ep1(1)
+ ep(4)=ep1(2)*s0x+ep1(3)*c0x
+ ep(3)=ep1(2)*c0x-ep1(3)*s0x
+
+ if(debug.ge.3)write (moniou,202)ep
+201 format(2x,'qgrota - spacial rotation:'/4x,'4-vector ep=',4(e10.3
+ *,1x)/4x,'s0x=',e10.3,'c0x=',e10.3,2x,'s0=',e10.3,'c0=',e10.3)
+202 format(2x,'qgrota: rotated 4-vector ep=',2x,4e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgqint(qlmax,g,j)
+c-----------------------------------------------------------------------------
+c qgqint - effective momentum interpolation for given random number g
+c and maximal effective momentum qmax
+c qlmax - ln qmax/16/qtf,
+c g - random number (0<g<1)
+c j - type of the parton (1-g,2-q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wi(3),wk(3)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr34/ qrt(10,101,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)qlmax,g,j
+
+ qli=qlmax/1.38629d0
+ sud0=1.d0/qgsudi(qlmax,j)
+ sl=100.d0*dlog(1.d0-g*(1.d0-sud0))/dlog(sud0)
+ i=int(qli)
+ k=int(sl)
+ if(k.gt.98)k=98
+ wk(2)=sl-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+ qgqint=0.d0
+ if(i.gt.7)i=7
+ wi(2)=qli-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+ do k1=1,3
+ do i1=1,3
+ qgqint=qgqint+qrt(i+i1,k+k1,j)*wi(i1)*wk(k1)
+ enddo
+ enddo
+ if(qgqint.le.0.d0)qgqint=0.d0
+ qgqint=16.d0*qtf*exp(qgqint)
+
+ if(debug.ge.3)write (moniou,202)qgqint
+201 format(2x,'qgqint - branching momentum interpolation:'
+ */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
+202 format(2x,'qgqint=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgalf(qq)
+c-----------------------------------------------------------------------------
+c qgalf - alpha_s(qq)/2/pi
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ qgalf=2.d0/9.d0/dlog(qq)
+ return
+ end
+
+c=============================================================================
+ subroutine qgtran(ep,ey,jj)
+c-----------------------------------------------------------------------------
+c lorentz transform according to parameters ey ( determining lorentz shift
+c along the z,x,y-axis respectively (ey(1),ey(2),ey(3)))
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ey(3),ep(4)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)ep,ey
+
+ if(jj.eq.1)then
+c lorentz transform to lab. system according to 1/ey(i) parameters
+ do i=1,3
+ if(ey(4-i).ne.1.d0)then
+ wp=(ep(1)+ep(5-i))/ey(4-i)
+ wm=(ep(1)-ep(5-i))*ey(4-i)
+ ep(1)=.5d0*(wp+wm)
+ ep(5-i)=.5d0*(wp-wm)
+ endif
+ enddo
+ else
+c lorentz transform to lab. system according to ey(i) parameters
+ do i=1,3
+ if(ey(i).ne.1.d0)then
+ wp=(ep(1)+ep(i+1))*ey(i)
+ wm=(ep(1)-ep(i+1))/ey(i)
+ ep(1)=.5d0*(wp+wm)
+ ep(i+1)=.5d0*(wp-wm)
+ endif
+ enddo
+ endif
+
+ if(debug.ge.3)write (moniou,202)ep
+201 format(2x,'qgtran - lorentz boost for 4-vector'/4x,'ep='
+ *,2x,4(e10.3,1x)/4x,'boost parameters ey=',3e10.3)
+202 format(2x,'qgtran: transformed 4-vector ep=',2x,4(e10.3,1x))
+ return
+ end
+
+c=============================================================================
+ double precision function qgsudi(qlmax,j)
+c-----------------------------------------------------------------------------
+c qgsudi - timelike sudakov formfactor interpolation
+c qlmax - ln qmax/16/qtf,
+c j - type of the parton (1-g,2-q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3)
+ common /qgarr33/ fsud(10,2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)j,qlmax
+
+ ql=qlmax/1.38629d0
+ if(ql.le.0.d0)then
+ qgsudi=1.d0
+ else
+ k=int(ql)
+ if(k.gt.7)k=7
+ wk(2)=ql-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ qgsudi=0.d0
+ do k1=1,3
+ qgsudi=qgsudi+fsud(k+k1,j)*wk(k1)
+ enddo
+ if(qgsudi.le.0.d0)qgsudi=0.d0
+ qgsudi=exp(-qgsudi)
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgsudi
+201 format(2x,'qgsudi - spacelike form factor interpolation:'
+ */4x,'parton type j=',i1,2x,'momentum logarithm qlmax=',e10.3)
+202 format(2x,'qgsudi=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgsudx(q,j)
+c-----------------------------------------------------------------------------
+c qgsudx - spacelike sudakov formfactor
+c q - maximal value of the effective momentum,
+c j - type of parton (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)j,q
+
+ if(q.gt.1.d0)then
+ qgsudx=dlog(dlog(q/alm)/dlog(1.d0/alm))*(.75d0+dlog(epsxmn))
+ if(j.eq.1)then
+ qgsudx=exp(qgsudx/.75d0)
+ else
+ qgsudx=exp(qgsudx*16.d0/27.d0)
+ endif
+ else
+ qgsudx=1.d0
+ endif
+
+ if(debug.ge.3)write (moniou,202)qgsudx
+201 format(2x,'qgsudx - spacelike form factor: parton type j='
+ *,i1,2x,'momentum q=',e10.3)
+202 format(2x,'qgsudx=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgsudt(qmax,j)
+c-----------------------------------------------------------------------------
+c qgsudt - timelike sudakov formfactor
+c qmax - maximal value of the effective momentum,
+c j - type of parton (1 - g, 2 - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common/arr3/x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)j,qmax
+
+ qgsudt=0.d0
+ qlmax=dlog(dlog(qmax/16.d0/alm))
+ qfl=dlog(dlog(qtf/alm))
+c numerical integration over transverse momentum square;
+c gaussian integration is used
+ do i=1,7
+ do m=1,2
+ qtl=.5d0*(qlmax+qfl+(2*m-3)*x1(i)*(qlmax-qfl))
+ qt=alm*exp(exp(qtl))
+ if(qt.ge.qmax/16.d0)qt=qmax/16.0001d0
+ zmin=.5d0-dsqrt((.25d0-dsqrt(qt/qmax)))
+ zmax=1.d0-zmin
+
+ if(j.eq.1)then
+ ap=(qgapi(zmax,1,1)-qgapi(zmin,1,1)+
+ * qgapi(zmax,1,2)-qgapi(zmin,1,2))*.5d0
+ else
+ ap=qgapi(zmax,2,1)-qgapi(zmin,2,1)
+ endif
+ qgsudt=qgsudt+a1(i)*ap
+ enddo
+ enddo
+ qgsudt=qgsudt*(qlmax-qfl)/9.d0
+
+ if(debug.ge.3)write (moniou,202)qgsudt
+201 format(2x,'qgsudt - timelike form factor: parton type j='
+ *,i1,2x,'momentum qmax=',e10.3)
+202 format(2x,'qgsudt=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgtwd(s,a,b)
+c-----------------------------------------------------------------------------
+c kinematical function for two particle decay - light cone momentum share
+c for the particle of mass squared a,
+c b - partner's mass squared,
+c s - two particle invariant mass
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)s,a,b
+
+ x=.5d0*(1.d0+(a-b)/s)
+ dx=x-dsqrt(a/s)
+ if(dx.gt.0.d0)then
+ x=x+dsqrt(dx)*dsqrt(x+dsqrt(a/s))
+ else
+ x=dsqrt(a/s)
+ endif
+ qgtwd=x
+
+ if(debug.ge.3)write (moniou,202)qgtwd
+201 format(2x,'qgtwd: s=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
+202 format(2x,'qgtwd=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgvdef(ich,ic1,ic2,icz)
+c-----------------------------------------------------------------------------
+c determination of valence quark flavour -
+c for valence quark hard scattering
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)ich,icz
+
+ is=iabs(ich)/ich
+ if(icz.eq.1)then
+ ic1=ich*(1-3*int(.5d0+qgran(b10)))
+ ic2=-ic1-ich
+ elseif(icz.eq.2)then
+ if(qgran(b10).gt..33333d0.or.ich.lt.0)then
+ ic1=ich-is
+ ic2=3*is
+ else
+ ic1=4*is-ich
+ ic2=ich+4*is
+ endif
+ elseif(icz.eq.3)then
+ ic1=ich-3*is
+ ic2=-4*is
+ elseif(icz.eq.4)then
+ ic1=ich-9*is
+ ic2=5*is
+ endif
+
+ if(debug.ge.3)write (moniou,202)ic1,ic2
+201 format(2x,'qgvdef: hadron type ich=',i2,' auxilliary type icz='
+ *,i1)
+202 format(2x,'qgvdef-end: parton flavors ic1=',i2,
+ *'ic2=',i2)
+ return
+ end
+
+c=============================================================================
+ double precision function qgzsim(qq,j)
+c-----------------------------------------------------------------------------
+c qgzsim - light cone momentum share simulation (for the timelike
+c branching)
+c qq - effective momentum value,
+c j - type of the parent parton (1-g,2-q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr11/ b10
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)qq,j
+
+ zmin=.5d0-dsqrt(.25d0-dsqrt(qtf/qq))
+ qlf=dlog(qtf/alm)
+1 continue
+ if(j.eq.1)then
+ qgzsim=.5d0*(2.d0*zmin)**qgran(b10)
+ gb=qgzsim*(qgfap(qgzsim,1,1)+qgfap(qgzsim,1,2))/7.5d0
+ else
+ qgzsim=zmin*((1.d0-zmin)/zmin)**qgran(b10)
+ gb=qgzsim*qgfap(qgzsim,2,1)*.375d0
+ endif
+ qt=qq*(qgzsim*(1.d0-qgzsim))**2
+ gb=gb/dlog(qt/alm)*qlf
+ if(debug.ge.3)write (moniou,203)qt,gb
+ if(qgran(b10).gt.gb)goto 1
+
+ if(debug.ge.3)write (moniou,202)qgzsim
+201 format(2x,'qgzsim - z-share simulation: qq=',e10.3,2x,'j=',i1)
+202 format(2x,'qgzsim=',e10.3)
+203 format(2x,'qgzsim: qt=',e10.3,2x,'gb=',e10.3)
+ return
+ end
+
+c===========================================================================
+ subroutine qgixxd(ich,ic1,ic2,icz)
+c---------------------------------------------------------------------------
+c determination of parton flavours for valence quark soft interaction
+c (charge exchange)
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)ich,icz
+
+ is=iabs(ich)/ich
+ if(icz.eq.1)then !pion
+ ic1=ich*(1-3*int(.5d0+qgran(b10)))
+ if(qgran(b10).lt.dc(2))then
+ ic2=-4*ic1/iabs(ic1)
+ if(iabs(ic1).eq.1)then
+ ich1=-5*is
+ else
+ ich1=4*is
+ endif
+ else
+ ich1=ich*int(.5d0+qgran(b10))
+ ic2=-ic1*iabs(ich1)-(ich+ic1)*iabs(ich-ich1)
+ endif
+ elseif(icz.eq.2)then
+c valence quark type simulation ( for proton )
+ ic1=int(1.3333d0+qgran(b10))
+c leading nucleon type simulation ( flavors combinatorics )
+ if(ic1.eq.1)then
+ ich1=int(qgran(b10)+.5d0)+2
+ ic2=1-ich1
+ elseif(qgran(b10).lt..5d0)then
+ ich1=2
+ ic2=-2
+ else
+ ich1=7 !uuu
+ ic2=-1
+ endif
+ if(iabs(ich).eq.3)then !neutron
+ ic1=3-ic1
+ ic2=-3-ic2
+ if(ich1.eq.7)then
+ ich1=8 !ddd
+ else
+ ich1=5-ich1
+ endif
+ endif
+ if(ich.lt.0)then
+ ic1=-ic1
+ ic2=-ic2
+ ich1=-ich1
+ endif
+ elseif(icz.eq.3)then
+ ic1=ich-3*is
+ ic2=-is*int(1.5d0+qgran(b10))
+ ich1=3*is-ic2
+ elseif(icz.eq.4)then
+ ic1=ich-9*is
+ ic2=is*int(1.5d0+qgran(b10))
+ ich1=9*is-ic2
+ elseif(icz.eq.5)then
+ ic1=is*int(1.5d0+qgran(b10))
+ ic2=-ic1
+ ich1=ich
+ else
+ ich1=0
+ stop 'Should not happen in qgixxd !'
+ endif
+ ich=ich1
+
+ if(debug.ge.3)write (moniou,202)ic1,ic2,ich
+201 format(2x,'qgixxd: hadron type ich=',i2,' auxilliary type icz='
+ *,i1)
+202 format(2x,'qgixxd-end: parton flavors ic1=',i2,' ic2='
+ *,i2,'new hadron type ich=',i2)
+ return
+ end
+
+c=============================================================================
+ subroutine qgdifr(wppr,wmtg,izp,izt,jexpr,jextg,iret)
+c-----------------------------------------------------------------------------
+c qgdifr - treatment of diffraction dissociation / leading hadron states
+c wppr - LC momentum for projectile remnant;
+c wptg - LC momentum for target remnant;
+c izp - projectile remnant type;
+c izt - target remnant type;
+c jexpr/jextg = -2 - low mass diffraction;
+c = -1 - more collisions to follow;
+c = 0 - no excitation;
+c > 0 - low mass excitation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ey(3),ep(4)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr2/ scm,wp0,wm0
+ common /qgarr6/ pi,bm,amws
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr10/ am(7),ammu
+ common /qgarr11/ b10
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)izp,izt,wppr,wmtg
+
+ iret=0
+ jexip=0
+ jexit=0
+ ddmin1=0.d0
+ ddmax1=0.d0
+c check if remnants are excited to low mass states
+ if(jexpr.eq.-2.or.jexpr.gt.0.and.qgran(b10)
+ *.lt.1.d0-(1.d0-wex(icz))**dble(jexpr).and.iabs(izp).lt.7)jexip=1
+ if(jextg.eq.-2.or.jextg.gt.0.and.qgran(b10)
+ *.lt.1.d0-(1.d0-wex(2))**dble(jextg).and.iabs(izt).lt.7)jexit=1
+c add low mass excitations if no particles produced before
+ if(wppr.ge.wp0.and.jexpr.gt.0.and.jexip.eq.0.and.iabs(izp).lt.7)
+ *jexip=1
+ if(wmtg.ge.wm0.and.jextg.gt.0.and.jexit.eq.0.and.iabs(izt).lt.7)
+ *jexit=1
+
+ sd0=wppr*wmtg !energy squared available
+ if(jextg.eq.-1)then !more collisions to follow
+ dmass2=0.d0
+ ddmin2=0.d0
+ elseif(jexit.eq.0)then !no excitation
+ if(iabs(izt).eq.7.or.iabs(izt).eq.8)then !delta++/-
+ dmass2=dmmin(2)
+ else
+ dmass2=am(2)
+ endif
+ ddmin2=dmass2
+ else !low mass excitation
+ ddmin2=dmmin(2)
+ if(jextg.eq.-2)ddmin2=dmres(2) !low mass diffraction
+ endif
+ if(jexpr.eq.-1)then !more collisions to follow
+ dmass1=0.d0
+ elseif(jexip.eq.0)then !no excitation
+ if(iabs(izp).eq.7.or.iabs(izp).eq.8)then !delta++/-
+ dmass1=dmmin(2)
+ elseif(izp.eq.0)then !rho0
+ dmass1=dmmin(1)
+ izp=-10
+ else
+ dmass1=am(icz)
+ endif
+ else !low mass excitation
+ ddmin1=dmmin(icz)
+ if(jexpr.eq.-2)ddmin1=dmres(icz) !low mass diffraction
+ ddmax1=dsqrt(sd0)-ddmin2
+ endif
+
+
+c determine mass for projectile excited remnant
+ if(jexip.eq.1)then
+ if(jexpr.ne.-2)then !low mass excitation (dM/M^2)
+ if(ddmax1.gt.ddmin1)then
+ dmass1=ddmin1/(1.d0-qgran(b10)*(1.d0-ddmin1/ddmax1))
+ else
+ dmass1=ddmin1
+ endif
+ else !low mass diffraction (res. + PPR)
+ ddmin=dmmin(icz)+am(1)
+ ddmax=min(ddmax1,dmres(icz)+.5d0*wdres(icz))
+ ddmax=max(ddmax,ddmin)
+ wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(icz)/wdres(icz))
+ * *(1.d0-(dmres(icz)+.5d0*wdres(icz))
+ * /max(ddmax1,dmres(icz)+.5d0*wdres(icz)))
+ * /(.25d0*pi+atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
+ if(qgran(b10).gt.wres)then !PPR contribution
+ dmass1=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax1))
+ else !resonance contribution
+ dmass1=dmres(icz)+.5d0*wdres(icz)
+ * *tan(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
+ * -qgran(b10)*(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
+ * +atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
+ jexip=0
+ izp=izp+10*izp/iabs(izp)
+ endif
+ endif
+ endif
+
+c determine mass for target excited remnant
+ if(jexit.eq.1)then
+ ddmax2=dsqrt(sd0)-dmass1
+ if(jextg.ne.-2)then !low mass excitation (dM/M^2)
+ if(ddmax2.gt.ddmin2)then
+ dmass2=ddmin2/(1.d0-qgran(b10)*(1.d0-ddmin2/ddmax2))
+ else !low mass diffraction
+ dmass2=ddmin2
+ endif
+ else !low mass diffraction (res. + PPR)
+ ddmin=dmmin(2)+am(1)
+ ddmax=min(ddmax2,dmres(2)+.5d0*wdres(2))
+ ddmax=max(ddmax,ddmin)
+ wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(2)/wdres(2))
+ * *(1.d0-(dmres(2)+.5d0*wdres(2))/max(ddmax2,dmres(2)+.5d0
+ * *wdres(2)))/(.25d0*pi+atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
+ if(qgran(b10).gt.wres)then !PPR contribution
+ dmass2=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax2))
+ else !resonance contribution
+ dmass2=dmres(2)+.5d0*wdres(2)*tan(atan(2.d0*(ddmax-dmres(2))
+ * /wdres(2))-qgran(b10)*(atan(2.d0*(ddmax-dmres(2))/wdres(2))
+ * +atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
+ izt=izt+10*izt/iabs(izt)
+ jexit=0
+ endif
+ endif
+ endif
+
+ wpp=wppr
+ wpm=wmtg
+ if(sd0.lt.(dmass1+dmass2)**2)then
+ iret=1
+ return
+ endif
+ dmass1=dmass1**2
+ dmass2=dmass2**2
+
+ if(jexpr.ne.-1.and.jextg.ne.-1)then
+ ptmax=max(0.d0,qglam(sd0,dmass1,dmass2))
+ if(jexpr.eq.-2.or.jextg.eq.-2)then
+ ptmean=ptdif
+ else
+ ptmean=ptndi*dsqrt(dble(max(jexpr,jextg)))
+ endif
+ if(ptmax.lt.ptmean**2)then
+1 pti=ptmax*qgran(b10)
+ if(qgran(b10).gt.exp(-dsqrt(pti)/ptmean))goto 1
+ else
+2 pti=(ptmean*dlog(qgran(b10)*qgran(b10)))**2
+ if(pti.gt.ptmax)goto 2
+ endif
+ else
+ pti=0.d0
+ endif
+ amt1=dmass1+pti
+ amt2=dmass2+pti
+ wpd1=wpp*qgtwd(sd0,amt1,amt2)
+ if(wpd1.gt.0.d0)then
+ wmd1=amt1/wpd1
+ else
+ wmd1=0.d0
+ endif
+ wmd2=wpm-wmd1
+ if(wmd2.gt.0.d0)then
+ wpd2=amt2/wmd2
+ else
+ wpd2=0.d0
+ endif
+ pt=dsqrt(pti)
+ call qgcs(c,s)
+
+ if(jexpr.eq.-1)then
+ wppr=wpd1
+ if(wmd1.ne.0.d0)stop'wmd1.ne.0!!!'
+ else
+ ep(1)=.5d0*(wpd1+wmd1)
+ ep(2)=.5d0*(wpd1-wmd1)
+ ep(3)=pt*c
+ ep(4)=pt*s
+ wppr=0.d0
+ if(jexip.eq.0)then
+ call qgreg(ep,izp)
+ else
+ is=0
+ if(izp.ne.0)is=iabs(izp)/izp
+ if(icz.eq.1)then
+ if(iabs(izp).ge.4)then
+ ic2=-4*is
+ ic1=izp-3*is
+ elseif(izp.ne.0)then
+ ic1=izp*(1-3*int(.5d0+qgran(b10)))
+ ic2=-izp-ic1
+ else
+ ic1=int(1.5d0+qgran(b10))*(2*int(.5d0+qgran(b10))-1)
+ ic2=-ic1
+ endif
+ elseif(icz.eq.2)then
+ if(qgran(b10).gt..33333d0)then
+ ic1=3*is
+ ic2=izp-is
+ else
+ ic1=izp+4*is
+ ic2=4*is-izp
+ endif
+ elseif(icz.eq.3)then
+ ic1=-4*is
+ ic2=izp-3*is
+ endif
+ call qgdeft(dmass1,ep,ey)
+ call qggene(dsqrt(dmass1),dsqrt(dmass1),ey
+ * ,0.d0,1.d0,0.d0,1.d0,ic1,ic2)
+ endif
+ endif
+
+ if(jextg.eq.-1)then
+ wmtg=wmd2
+ if(wpd2.ne.0.d0)stop'wpd2.ne.0!!!'
+ else
+ ep(1)=.5d0*(wpd2+wmd2)
+ ep(2)=.5d0*(wpd2-wmd2)
+ ep(3)=-pt*c
+ ep(4)=-pt*s
+ wmtg=0.d0
+ if(jexit.eq.0)then
+ call qgreg(ep,izt)
+ else
+ is=iabs(izt)/izt
+ if(qgran(b10).gt..33333d0)then
+ ic1=3*is
+ ic2=izt-is
+ else
+ ic1=izt+4*is
+ ic2=4*is-izt
+ endif
+ call qgdeft(dmass2,ep,ey)
+ call qggene(dsqrt(dmass2),dsqrt(dmass2),ey
+ * ,0.d0,1.d0,0.d0,1.d0,ic2,ic1)
+ endif
+ endif
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgdifr - leading clusters hadronization:'
+ */4x,'cluster types izp=',i2,2x,
+ *'izt=',i2/4x,'available light cone momenta: wppr=',e10.3,
+ *' wmtg=',e10.3)
+202 format(2x,'qgdifr - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qgfau(b,gz)
+c-----------------------------------------------------------------------------
+c integrands for hadron-hadron and hadron-nucleus cross-sections calculation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension gz(3),gz0(5)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)b
+
+ do l=1,3
+ gz(l)=0.d0
+ enddo
+
+ ab=float(ia(2))
+ do iddp1=1,2
+ do iddp2=1,2
+ call qgfz(b,gz0,iddp1,iddp2)
+ if(iddp1.eq.iddp2)gz(1)=gz(1)+(1.d0-gz0(1)*anorm)**ab
+ * *cc(iddp1,icz)
+ do l=2,3
+ gz(l)=gz(l)+(1.d0-gz0(l-1)*anorm)**ab
+ * *cc(iddp1,icz)*cc(iddp2,icz)
+ enddo
+ enddo
+ enddo
+
+ gz(3)=gz(2)-gz(3)
+ gz(2)=gz(1)-gz(2)
+ gz(1)=1.d0-gz(1)
+
+ if(debug.ge.2)write (moniou,203)gz
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgfau - integrands for hadron-hadron and hadron'
+ *,'-nucleus cross-sections calculation'/4x,'b=',e10.3)
+202 format(2x,'qgfau - end')
+203 format(2x,'qgfau: gz=',3e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgfrag(sa,na,rc)
+c-----------------------------------------------------------------------------
+c connected nucleon clasters extraction - used for the nuclear spectator part
+c multifragmentation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(iapmax=208)
+ dimension sa(iapmax,3)
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)na
+ if(debug.ge.3)then
+ write (moniou,203)
+ do i=1,na
+ write (moniou,204)(sa(i,l),l=1,3)
+ enddo
+ endif
+
+ ni=1
+ ng=1
+ j=0
+1 j=j+1
+ j1=ni+1
+
+ do 4 i=j1,na
+ ri=0.d0
+ do m=1,3
+ ri=ri+(sa(j,m)-sa(i,m))**2
+ enddo
+ if(ri.gt.rc)goto 4
+
+ ni=ni+1
+ ng=ng+1
+ if(i.eq.ni)goto 4
+ do m=1,3
+ s0=sa(ni,m)
+ sa(ni,m)=sa(i,m)
+ sa(i,m)=s0
+ enddo
+4 continue
+
+ if(j.lt.ni.and.na-ni.gt.0)goto 1
+ nsf=nsf+1
+ iaf(nsf)=ng
+ if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
+
+ ng=1
+ j=ni
+ ni=ni+1
+ if(na.eq.ni)then
+ nsf=nsf+1
+ iaf(nsf)=1
+ if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
+ elseif(na.gt.ni)then
+ goto 1
+ endif
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgfrag-multifragmentation: nucleus mass number: na='
+ *,i2)
+202 format(2x,'qgfrag - end')
+203 format(2x,'nucleons coordinates:')
+204 format(2x,3e10.3)
+206 format(2x,'qgfrag: fragment n',i2,2x,'fragment mass - ',i2)
+ return
+ end
+
+c=============================================================================
+ subroutine qgfrgm(ns,xa)
+c-----------------------------------------------------------------------------
+c fragmentation of the spectator part of the nucleus
+c xa - array for spectator nucleons positions
+c ns - total number of spectators
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ parameter(iapmax=208)
+ dimension xa(iapmax,3)
+ integer debug
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr3/ rmin,emax,eev
+ common /qgarr11/ b10
+c nsf - number of secondary fragments;
+c iaf(i) - mass of the i-th fragment
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)ns
+
+ nsf=0
+ if(ns.eq.0)then !no fragments
+ return
+ elseif(ns.eq.1)then !single spectator nucleon recorded
+ nsf=nsf+1
+ iaf(nsf)=1
+ if(debug.ge.3)write (moniou,205)
+ return
+ endif
+
+ eex=0.d0 !excitation energy for spectator part
+ !sum of excitations due to wounded nucleons (including diffractive)
+ do i=1,ia(1)-ns
+c partial excitation according to f(e) ~ 1/sqrt(e) * exp(-e/(2*<e>))
+ eex=eex+(qgran(b10)+qgran(b10)+qgran(b10)+
+ * qgran(b10)+qgran(b10)-2.5d0)**2*2.4d0
+ enddo
+ if(debug.ge.3)write (moniou,203)eex
+
+ if(eex/ns.gt.emax)then !if eex>emax -> multifragmentation
+ call qgfrag(xa,ns,rmin) !multifragmentation (percolation algorithm)
+ else !otherwise eveporation
+ nf=npgen(eex/eev,0,ns-1) !number of eveporated nucleons (mean=eex/eev)
+ nsf=nsf+1
+ iaf(nsf)=ns-nf !recording of the fragment produced
+ if(debug.ge.3)write (moniou,206)iaf(nsf)
+
+ nal=nf/4 !number of evapotared alphas (taken as nf/4)
+ if(nal.ne.0)then
+ do i=1,nal !recording the evaporated alphas
+ nsf=nsf+1
+ iaf(nsf)=4
+ enddo
+ endif
+ nf=nf-4*nal
+
+ if(nf.ne.0)then
+ do i=1,nf !recording the evaporated nucleons
+ nsf=nsf+1
+ iaf(nsf)=1
+ enddo
+ endif
+ if(debug.ge.3)write (moniou,204)nf,nal
+ endif
+c6 continue
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qgfrgm: number of spectators: ns=',i2)
+202 format(2x,'qgfrgm - end')
+203 format(2x,'qgfrgm: excitation energy: eex=',e10.3)
+204 format(2x,'qgfrgm - evaporation: number of nucleons nf='
+ *,i2,'number of alphas nal=',i2)
+205 format(2x,'qgfrgm - single spectator')
+206 format(2x,'qgfrgm - evaporation: mass number of the fragment:',i2)
+ return
+ end
+
+c=============================================================================
+ subroutine qggau(gz)
+c-----------------------------------------------------------------------------
+c impact parameter integration for impact parameters <bm -
+c for hadron-hadron and hadron-nucleus cross-sections calculation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension gz(3),gz0(3)
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /arr3/ x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)
+
+ do i=1,3
+ gz(i)=0.d0
+ enddo
+ do i=1,7
+ do m=1,2
+ b=bm*dsqrt(.5d0+x1(i)*(m-1.5d0))
+ call qgfau(b,gz0)
+ do l=1,3
+ gz(l)=gz(l)+gz0(l)*a1(i)
+ enddo
+ enddo
+ enddo
+
+ do l=1,3
+ gz(l)=gz(l)*bm**2*pi*.5d0
+ enddo
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qggau - nuclear cross-sections calculation')
+202 format(2x,'qggau - end')
+ return
+ end
+
+c=============================================================================
+ subroutine qggau1(gz)
+c-----------------------------------------------------------------------------
+c impact parameter integration for impact parameters >bm -
+c for hadron-hadron and hadron-nucleus cross-sections calculation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension gz(3),gz0(3)
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr43/ moniou
+ common /arr3/ x1(7),a1(7)
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)
+
+ do i=1,7
+ do m=1,2
+ b=bm-wsnuc(2)*dlog(.5d0+x1(i)*(m-1.5d0))
+ call qgfau(b,gz0)
+ do l=1,3
+ gz(l)=gz(l)+gz0(l)*a1(i)*exp((b-bm)/wsnuc(2))*b*pi*wsnuc(2)
+ enddo
+ enddo
+ enddo
+
+ if(debug.ge.3)write (moniou,202)
+201 format(2x,'qggau1 - nuclear cross-sections calculation')
+202 format(2x,'qggau1 - end')
+ return
+ end
+
+c=============================================================================
+ double precision function qganrm(rnuc,wsnuc,wbnuc)
+c-----------------------------------------------------------------------------
+c impact parameter integration for impact parameters <bm -
+c for hadron-hadron and hadron-nucleus cross-sections calculation
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /arr3/ x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)
+
+ qganrm=0.d0
+ do i=1,7
+ do m=1,2
+ r=rnuc*(.5d0+x1(i)*(m-1.5d0))**(1.d0/3.d0)
+ quq=(r-rnuc)/wsnuc
+ if(quq.lt.1.d80)qganrm=qganrm+a1(i)/(1.d0+exp(quq))
+ * *(1.d0+wbnuc*(r/rnuc)**2)
+ enddo
+ enddo
+ qganrm=qganrm*rnuc**3*pi/1.5d0
+
+ dnrm=0.d0
+ do i=1,7
+ do m=1,2
+ t=.5d0+x1(i)*(m-1.5d0)
+ r=rnuc-wsnuc*log(t)
+ dnrm=dnrm+a1(i)/(1.d0+t)*r*r
+ * *(1.d0+wbnuc*(r/rnuc)**2)
+ enddo
+ enddo
+ qganrm=1.d0/(qganrm+dnrm*2.d0*pi*wsnuc)
+
+ if(debug.ge.3)write (moniou,202)qganrm
+201 format(2x,'qganrm - nuclear density normalization')
+202 format(2x,'qganrm=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qggene(wp0,wm0,ey0,s0x,c0x,s0,c0,ic1,ic2)
+c-----------------------------------------------------------------------------
+c to simulate the fragmentation of the string into secondary hadrons
+c the algorithm conserves energy-momentum;
+c wp0, wm0 are initial longitudinal momenta ( e+p, e-p ) of the quarks
+c at the ends of the string; ic1, ic2 - their types
+c the following partons types are used: 1 - u, -1 - U, 2 - d, -2 - D,
+c 3 - ud, -3 - UD, 4 - s, -4 - S, 6 - uu, -6 - UU, 7 - dd, -7 - DD,
+c 8 - us, -8 - US
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ character *2 tyq
+ dimension wp(2),ic(2),ept(4),ep(4),ey(3),ey0(3)
+c wp(1), wp(2) - current longitudinal momenta of the partons at the string
+c ends, ic(1), ic(2) - their types
+ common /qgarr8/ wwm,bep,ben,bek,bec,dc(5),deta,almpt,ptdif
+ *,ptndi
+ common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
+ common /qgarr11/ b10
+ common /qgarr19/ ahl(3)
+ common /qgarr28/ arr(5)
+ common /qgarr42/ tyq(16)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.2)write (moniou,201)tyq(8+ic1),tyq(8+ic2)
+ *,wp0,wm0,ey0,s0x,c0x,s0,c0
+
+ ww=wp0*wm0 !mass squared for the string
+ ept(1)=.5d0*(wp0+wm0) !4-momentum for the string
+ ept(2)=.5d0*(wp0-wm0)
+ ept(3)=0.d0
+ ept(4)=0.d0
+
+ if(iabs(ic1).eq.5.or.iabs(ic2).eq.5.or.iabs(ic1).gt.8
+ *.or.iabs(ic2).gt.8)stop'qggene: problem with parton types'
+
+ ic(1)=ic1 !parton types at string ends
+ ic(2)=ic2
+
+1 sww=dsqrt(ww)
+ call qgdeft(ww,ept,ey) !boost to c.m. for the string
+ j=int(2.d0*qgran(b10))+1 !choose string end to start
+
+ if(debug.ge.3)then
+ iqt=8+ic(j)
+ write (moniou,203)j,tyq(iqt),ww
+ endif
+
+ iab=iabs(ic(j))
+ is=ic(j)/iab
+ if(iab.eq.8)then
+ iab=6
+ elseif(iab.gt.5)then
+ iab=3
+ endif
+ iaj=iabs(ic(3-j))
+ if(iaj.eq.8)then
+ iaj=6
+ elseif(iaj.gt.5)then
+ iaj=3
+ endif
+ if(iab.eq.5)stop'no charm anymore!'
+
+ if(iaj.eq.3)then
+ restm=amn
+ elseif(iaj.eq.4)then
+ restm=amk
+ elseif(iaj.eq.5)then
+ stop'no charm anymore!'
+ elseif(iaj.eq.6)then
+ restm=amlam
+ else
+ restm=am0
+ endif
+
+ if(iab.le.2.and.sww.gt.restm+2.d0*am0+wwm
+ *.or.iab.eq.3.and.sww.gt.restm+am0+amn+wwm
+ *.or.iab.eq.4.and.sww.gt.restm+am0+amk+wwm
+ *.or.iab.eq.6.and.sww.gt.restm+am0+amlam+wwm)then !more than 2 particles
+ blf=0.d0
+ bet=0.d0
+ alf=0.d0
+ if(iab.le.2)then !light quark string end
+ if(iab.eq.2.and.iabs(ic(3-j)).ne.7
+ * .and.sww.gt.restm+2.d0*amlam.and.qgran(b10).lt.dc(1)*dc(2))then
+c lambda generation
+ restm=(restm+amlam)**2
+ bet=ben
+ ami=amlam**2
+ alf=almpt-arr(2)+arr(1)-arr(3)
+ blf=1.d0-arr(2)-arr(3)
+ ic0=6*is !(anti-)lambda
+ ic(j)=-8*is !US(us)
+ elseif(sww.gt.restm+2.d0*amn.and.qgran(b10).lt.dc(1))then
+c nucleon generation
+ restm=(restm+amn)**2
+ bet=ben
+ ami=amn**2
+ alf=almpt-arr(2)
+ blf=1.d0-arr(1)-arr(2)
+ ic0=ic(j)+is
+ ic(j)=-3*is
+ elseif(sww.gt.restm+2.d0*amk.and.qgran(b10).lt.dc(2))then
+c kaon generation
+ restm=(restm+amk)**2
+ bet=bek
+ ami=amk**2
+ alf=almpt-arr(3)
+ blf=1.d0-arr(1)-arr(3)
+ ic0=ic(j)+3*is
+ ic(j)=4*is
+ elseif(sww.gt.restm+ameta+am0.and.qgran(b10).lt.deta)then
+c eta generation
+ restm=(restm+am0)**2
+ bet=bek
+ ami=ameta**2
+ alf=almpt-arr(1)
+ blf=1.d0-2.d0*arr(1)
+ ic0=10
+ else
+c pion generation
+ restm=(restm+am0)**2
+ bet=bep
+ ami=am0**2
+ alf=almpt-arr(1)
+ blf=1.d0-2.d0*arr(1)
+ if(qgran(b10).lt..3333d0)then
+ ic0=0
+ else
+ ic0=3*is-2*ic(j)
+ ic(j)=3*is-ic(j)
+ endif
+ endif
+
+ elseif(iab.eq.3)then
+ if(sww.gt.restm+amk+amlam.and.qgran(b10).lt.dc(4)
+ * .and.iabs(ic(j)).eq.3)then
+c lambda generation
+ restm=(restm+amk)**2
+ bet=bek
+ ami=amlam**2
+ alf=almpt-arr(3)
+ blf=1.d0-arr(2)-arr(3)
+ ic0=6*is
+ ic(j)=-4*is
+ else
+c nucleon generation
+ restm=(restm+am0)**2
+ bet=ben
+ ami=amn**2
+ alf=almpt-arr(1)
+ blf=1.d0-arr(1)-arr(2)
+ if(iabs(ic(j)).eq.3)then
+ ic0=is*int(2.5d0+qgran(b10))
+ ic(j)=is-ic0
+ else
+ ic0=ic(j)-4*is
+ ic(j)=ic0-4*is
+ endif
+ endif
+
+ elseif(iab.eq.4)then
+ if(sww.gt.restm+amn+amlam.and.qgran(b10).lt.dc(1))then
+c lambda generation
+ restm=(restm+amn)**2
+ bet=ben
+ ami=amlam**2
+ alf=almpt-arr(2)
+ blf=1.d0-arr(2)-arr(3)
+ ic0=6*is
+ ic(j)=-3*is
+ else
+c kaon generation
+ restm=(restm+am0)**2
+ bet=bep
+ ami=amk**2
+ alf=almpt-arr(1)
+ blf=1.d0-arr(1)-arr(3)
+ ic(j)=is*int(1.5d0+qgran(b10))
+ ic0=-3*is-ic(j)
+ endif
+
+ elseif(iab.eq.6)then
+c lambda generation
+ restm=(restm+am0)**2
+ bet=bep
+ ami=amlam**2
+ alf=almpt-arr(1)
+ blf=1.d0-arr(2)-arr(3)
+ ic0=6*is
+ ic(j)=-2*is
+ endif
+
+ ptmax=qglam(ww,restm,ami)
+ if(ptmax.lt.0.)ptmax=0.
+
+ if(ptmax.lt.bet**2)then
+2 pti=ptmax*qgran(b10)
+ if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 2
+ else
+3 pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
+ if(pti.gt.ptmax)goto 3
+ endif
+
+ amt=ami+pti
+ restm1=restm+pti
+ zmin=1.d0-qgtwd(ww,restm1,amt)
+ zmax=qgtwd(ww,amt,restm1)
+
+ z1=(1.d0-zmax)**alf
+ z2=(1.d0-zmin)**alf
+4 z=1.-(z1+(z2-z1)*qgran(b10))**(1./alf)
+ if(qgran(b10).gt.(z/zmax)**blf)goto 4
+ wp(j)=z*sww
+ wp(3-j)=amt/wp(j)
+ ep(1)=.5d0*(wp(1)+wp(2))
+ ep(2)=.5d0*(wp(1)-wp(2))
+ pti=dsqrt(pti)
+ call qgcs(c,s)
+ ep(3)=pti*c
+ ep(4)=pti*s
+ ept(1)=sww-ep(1)
+ do i=2,4
+ ept(i)=-ep(i)
+ enddo
+ ww=qgnrm(ept)
+ if(ww.lt.restm)goto 4
+
+ call qgtran(ep,ey,1)
+ call qgtran(ept,ey,1)
+ if(s0x.ne.0.d0.or.s0.ne.0.d0)then
+ call qgrota(ep,s0x,c0x,s0,c0)
+ endif
+ if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
+ call qgtran(ep,ey0,1)
+ endif
+ call qgreg(ep,ic0)
+
+ else
+ ami2=restm**2
+ bet=bep
+ if(iab.eq.6.or.iaj.eq.6)then
+ if(iab.eq.6)then
+ ami=amlam**2
+ ic(j)=6*is
+ if(iaj.eq.6)then
+ ic(3-j)=-6*is
+ elseif(iaj.eq.4)then
+ ic(3-j)=-5*is
+ elseif(iaj.le.2)then
+ ic(3-j)=2*is-ic(3-j)
+ else
+ if(iabs(ic(3-j)).eq.3)then
+ ic(3-j)=-3*is
+ elseif(iabs(ic(3-j)).eq.6)then
+ ic(3-j)=-2*is
+ else
+ stop'wrong parton types'
+ endif
+ endif
+ elseif(iab.eq.4)then
+ ami=amk**2
+ ic(j)=-5*is
+ ic(3-j)=6*is
+ elseif(iab.le.2)then
+ ami=am0**2
+ ic(j)=2*is-ic(j)
+ ic(3-j)=6*is
+ else
+ ami=amn**2
+ ic(3-j)=-6*is
+ if(iabs(ic(j)).eq.3)then
+ ic(j)=3*is
+ elseif(iabs(ic(j)).eq.6)then
+ ic(j)=2*is
+ else
+ stop'wrong parton types'
+ endif
+ endif
+
+ elseif(iab.le.2.and.iaj.le.2)then
+ if(sww.gt.2.d0*amk.and.qgran(b10).lt.dc(2))then
+ bet=bek
+ ami=amk**2
+ ami2=ami
+ ic(j)=ic(j)+3*is
+ ic(3-j)=ic(3-j)-3*is
+ else
+ ami=am0**2
+ ic0=-ic(1)-ic(2)
+ if(ic0.ne.0)then
+ ic(j)=ic0*int(.5d0+qgran(b10))
+ ic(3-j)=ic0-ic(j)
+ else
+ if(qgran(b10).lt..2d0)then
+ ic(j)=0
+ ic(3-j)=0
+ else
+ ic(j)=3*is-2*ic(j)
+ ic(3-j)=-ic(j)
+ endif
+ endif
+ endif
+
+ elseif(iab.eq.3.or.iaj.eq.3)then
+ if(iab.eq.3)then
+ ami=amn**2
+ if(iabs(ic(j)).eq.3)then
+ if(iaj.eq.3)then
+ if(iabs(ic(3-j)).eq.3)then
+ if(sww.gt.2.d0*amlam.and.qgran(b10).lt.dc(4))then
+ bet=bek
+ ami=amlam**2
+ ami2=ami
+ ic(j)=6*is
+ ic(3-j)=-6*is
+ else
+ ic(j)=is*int(2.5d0+qgran(b10))
+ ic(3-j)=-ic(j)
+ endif
+ else
+ ic(3-j)=ic(3-j)+4*is
+ ic(j)=5*is+ic(3-j)
+ endif
+ elseif(iaj.lt.3)then
+ if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
+ bet=bek
+ ami=amlam**2
+ ami2=amk**2
+ ic(j)=6*is
+ ic(3-j)=ic(3-j)+3*is
+ else
+ if(qgran(b10).lt..3333d0)then
+ ic(j)=ic(3-j)+is
+ ic(3-j)=0
+ else
+ ic(j)=is*(4-iaj)
+ ic(3-j)=is*(3-2*iaj)
+ endif
+ endif
+ elseif(iaj.eq.4)then
+ ic(j)=is*int(2.5d0+qgran(b10))
+ ic(3-j)=-ic(j)-2*is
+ endif
+ else
+ if(iabs(ic(3-j)).gt.4)stop'qggene: problem with parton types'
+ ic(j)=ic(j)-4*is
+ ic0=ic(j)-4*is
+ if(iaj.eq.3)then
+ ic(3-j)=ic0-is
+ elseif(iaj.lt.3)then
+ ic(3-j)=-ic(3-j)-ic0
+ elseif(iaj.eq.4)then
+ ic(3-j)=ic0-3*is
+ endif
+ endif
+ else
+ if(iabs(ic(3-j)).eq.3)then
+ if(iab.lt.3)then
+ if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
+ bet=bek
+ ami2=amlam**2
+ ami=amk**2
+ ic(j)=ic(j)+3*is
+ ic(3-j)=6*is
+ else
+ ami=am0**2
+ if(qgran(b10).lt..3333d0)then
+ ic(3-j)=ic(j)+is
+ ic(j)=0
+ else
+ ic(3-j)=is*(4-iab)
+ ic(j)=is*(3-2*iab)
+ endif
+ endif
+ elseif(iab.eq.4)then
+ ami=amk**2
+ ic(3-j)=is*int(2.5d0+qgran(b10))
+ ic(j)=-ic(3-j)-2*is
+ endif
+ else
+ ic(3-j)=ic(3-j)-4*is
+ ic0=ic(3-j)-4*is
+ if(iab.lt.3)then
+ ami=am0**2
+ ic(j)=-ic0-ic(j)
+ elseif(iab.eq.4)then
+ ami=amk**2
+ ic(j)=ic0-3*is
+ endif
+ endif
+ endif
+ elseif(iab.eq.4.or.iaj.eq.4)then
+ if(iab.eq.4)then
+ ami=amk**2
+ if(iaj.eq.4)then
+ ic(j)=-is*int(4.5d0+qgran(b10))
+ ic(3-j)=-ic(j)
+ else
+ ic0=ic(3-j)+int(.6667d0+qgran(b10))*(-3*is-2*ic(3-j))
+ ic(j)=ic0-3*is
+ ic(3-j)=ic0-ic(3-j)
+ endif
+ else
+ ami=am0**2
+ ic0=ic(j)+int(.6667d0+qgran(b10))*(3*is-2*ic(j))
+ ic(j)=ic0-ic(j)
+ ic(3-j)=ic0+3*is
+ endif
+ endif
+
+ ptmax=qglam(ww,ami2,ami)
+ if(ptmax.lt.0.)ptmax=0.
+ if(ptmax.lt.bet**2)then
+5 pti=ptmax*qgran(b10)
+ if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 5
+ else
+6 pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
+ if(pti.gt.ptmax)goto 6
+ endif
+ amt1=ami+pti
+ amt2=ami2+pti
+ z=qgtwd(ww,amt1,amt2)
+ wp(j)=z*sww
+ wp(3-j)=amt1/wp(j)
+ ep(1)=.5d0*(wp(1)+wp(2))
+ ep(2)=.5d0*(wp(1)-wp(2))
+ pti=dsqrt(pti)
+ call qgcs(c,s)
+ ep(3)=pti*c
+ ep(4)=pti*s
+ ept(1)=sww-ep(1)
+ do i=2,4
+ ept(i)=-ep(i)
+ enddo
+ call qgtran(ep,ey,1)
+ call qgtran(ept,ey,1)
+ if(s0x.ne.0.d0.or.s0.ne.0.d0)then
+ call qgrota(ep,s0x,c0x,s0,c0)
+ call qgrota(ept,s0x,c0x,s0,c0)
+ endif
+ if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
+ call qgtran(ep,ey0,1)
+ call qgtran(ept,ey0,1)
+ endif
+
+ call qgreg(ep,ic(j))
+ call qgreg(ept,ic(3-j))
+ if(debug.ge.3)write (moniou,202)
+ return
+ endif
+ goto 1
+
+201 format(2x,'qggene: parton flavors at the ends of the string:'
+ *,2x,a2,2x,a2/4x,'light cone momenta of the string: ',e10.3
+ *,2x,e10.3/4x,'ey0=',3e10.3/4x,'s0x=',e10.3,2x,'c0x=',e10.3
+ *,2x,'s0=',e10.3,2x,'c0=',e10.3)
+202 format(2x,'qggene - end')
+203 format(2x,'qggene: current parton flavor at the end '
+ *,i1,' of the string: ',a2/4x,' string mass: ',e10.3)
+ end
+
+c=============================================================================
+ subroutine qgxjet
+c-----------------------------------------------------------------------------
+c procedure for jet hadronization
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(njmax=50000)
+ dimension ep(4),ept(4),ept1(4),ey(3)
+ *,epj(4,2,2*njmax),ipj(2,2*njmax)
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr10/ am(7),ammu
+ common /qgarr11/ b10
+ common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.2)write (moniou,201)njtot
+201 format(2x,'qgxjet: total number of jets njtot=',i4)
+
+ nj0=1
+ njet0=0
+ nrej=0
+
+1 njet=njet0
+ do i=1,4
+ ept(i)=epjet(i,nj0)
+ epj(i,1,njet+1)=ept(i)
+ enddo
+ iq1=ipjet(nj0)
+ ipj(1,njet+1)=iq1
+
+ if(iabs(iq1).le.2)then
+ am1=am(1)
+ if(iq1.gt.0)then
+ jq=1
+ else
+ jq=2
+ endif
+ elseif(iabs(iq1).eq.4)then
+ am1=am(3)
+ if(iq1.gt.0)then
+ jq=1
+ else
+ jq=2
+ endif
+ else
+ am1=am(2)
+ if(iq1.gt.0)then
+ jq=2
+ else
+ jq=1
+ endif
+ endif
+
+ ij=nj0
+2 ij=ij+1
+ njet=njet+1
+ iq2=ipjet(ij)
+
+ if(iq2.eq.0)then
+ aks=qgran(b10)
+ do i=1,4
+ epi=epjet(i,ij)*aks
+ epj(i,2,njet)=epi
+ ept(i)=ept(i)+epi
+ enddo
+ if(qgran(b10).lt.dc(2))then
+ ipj(2,njet)=4*(2*jq-3)
+ amj=am(3)
+ else
+ ipj(2,njet)=int(1.5d0+qgran(b10))*(2*jq-3)
+ amj=am(1)
+ endif
+
+ if(qgnrm(ept).gt.(am1+amj)**2)then
+ if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
+ * ,qgnrm(ept),ept
+
+ ipj(1,njet+1)=-ipj(2,njet)
+ do i=1,4
+ ept(i)=epjet(i,ij)-epj(i,2,njet)
+ epj(i,1,njet+1)=ept(i)
+ enddo
+ am1=amj
+ goto 2
+ elseif(nrej.lt.100000)then
+ nrej=nrej+1
+ goto 1
+ else
+3 continue
+ do i=1,4
+ ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij+1)
+ ep(i)=epjet(i,ij-1)
+ ept1(i)=ept(i)
+ enddo
+ ww=qgnrm(ept1)
+ if(ww.le.0.)then
+ if(ij.gt.nj0+1)then
+ ij=ij-1
+ goto 3
+ else
+ ij=ij+1
+ goto 3
+ endif
+ endif
+ ipjet(ij)=ipjet(ij+1)
+ sww=sqrt(ww)
+ call qgdeft(ww,ept1,ey)
+ call qgtran(ep,ey,-1)
+ call qgdefr(ep,s0x,c0x,s0,c0)
+ ep(1)=.5d0*sww
+ ep(2)=.5d0*sww
+ ep(3)=0.d0
+ ep(4)=0.d0
+ call qgrota(ep,s0x,c0x,s0,c0)
+ call qgtran(ep,ey,1)
+ do i=1,4
+ epjet(i,ij-1)=ep(i)
+ epjet(i,ij)=ept(i)-ep(i)
+ enddo
+
+ if(njtot.gt.ij+1)then
+ do j=ij+1,njtot-1
+ ipjet(j)=ipjet(j+1)
+ do i=1,4
+ epjet(i,j)=epjet(i,j+1)
+ enddo
+ enddo
+ endif
+ nrej=0
+ njtot=njtot-1
+ goto 1
+ endif
+
+ else
+ ipj(2,njet)=iq2
+ do i=1,4
+ epi=epjet(i,ij)
+ epj(i,2,njet)=epi
+ ept(i)=ept(i)+epi
+ enddo
+
+ if(iabs(iq2).le.2)then
+ am2=am(1)
+ elseif(iabs(iq2).eq.4)then
+ am2=am(3)
+ else
+ am2=am(2)
+ endif
+
+ if(qgnrm(ept).gt.(am1+am2)**2)then
+ if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
+ * ,qgnrm(ept),ept
+
+ nj0=ij+1
+ njet0=njet
+ nrej=0
+ if(ij.lt.njtot)then
+ goto 1
+ else
+ goto 5
+ endif
+ elseif(nrej.lt.100000)then
+ nrej=nrej+1
+ goto 1
+ else
+4 continue
+ do i=1,4
+ ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij-2)
+ ep(i)=epjet(i,ij-2)
+ ept1(i)=ept(i)
+ enddo
+ ww=qgnrm(ept1)
+ if(ww.lt.0.d0)then
+ ij=ij-1
+ goto 4
+ endif
+ ipjet(ij-1)=ipjet(ij)
+ sww=sqrt(ww)
+ call qgdeft(ww,ept1,ey)
+ call qgtran(ep,ey,-1)
+ call qgdefr(ep,s0x,c0x,s0,c0)
+ ep(1)=.5d0*sww
+ ep(2)=.5d0*sww
+ ep(3)=0.d0
+ ep(4)=0.d0
+ call qgrota(ep,s0x,c0x,s0,c0)
+ call qgtran(ep,ey,1)
+ do i=1,4
+ epjet(i,ij-2)=ep(i)
+ epjet(i,ij-1)=ept(i)-ep(i)
+ enddo
+
+ if(ij.lt.njtot)then
+ do j=ij,njtot-1
+ ipjet(j)=ipjet(j+1)
+ do i=1,4
+ epjet(i,j)=epjet(i,j+1)
+ enddo
+ enddo
+ endif
+
+ nrej=0
+ njtot=njtot-1
+ goto 1
+ endif
+ endif
+
+5 continue
+ do ij=1,njet
+ do i=1,4
+ ep(i)=epj(i,1,ij)
+ ept(i)=ep(i)+epj(i,2,ij)
+ enddo
+c invariant mass squared for the jet
+ ww=qgnrm(ept)
+
+ if(debug.ge.3)write (moniou,208)
+ * ij,njet,ww,ipj(1,ij),ipj(2,ij)
+
+ sww=dsqrt(ww)
+ call qgdeft(ww,ept,ey)
+ call qgtran(ep,ey,-1)
+ call qgdefr(ep,s0x,c0x,s0,c0)
+ call qggene(sww,sww,ey,s0x,c0x,s0,c0,ipj(1,ij),ipj(2,ij))
+ enddo
+
+ if(debug.ge.3)write (moniou,202)
+202 format(2x,'qgxjet - end')
+208 format(2x,'qgxjet: ij=',i2,2x,'njet=',i3,2x,'ww=',e10.3
+ *,2x,'ic=',2i3)
+211 format(2x,'qgxjet: njet=',i3,2x,'ic=',2i2,2x,'mass=',e10.3
+ *,2x,'ep=',4e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgrot(b,s)
+c-----------------------------------------------------------------------------
+c convolution of nuclear profile functions (axial angle integration)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /arr8/ x2(4),a2
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)b,s
+
+ qgrot=0.d0
+ do i=1,4
+ sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
+ sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
+ qgrot=qgrot+(qgt(sb1)+qgt(sb2))
+ enddo
+ qgrot=qgrot*a2
+
+ if(debug.ge.2)write (moniou,202)qgrot
+201 format(2x,'qgrot - axial angle integration of the ',
+ *'nuclear profile function'/4x,
+ *'impact parameter b=',e10.3,2x,'nucleon coordinate s=',e10.3)
+202 format(2x,'qgrot=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgstr(wpi0,wmi0,wp0,wm0,ic10,ic120,ic210,ic20,jp,jt)
+c-----------------------------------------------------------------------------
+c fragmentation process for the pomeron ( quarks and antiquarks types at the
+c ends of the two strings are determined, energy-momentum is shared
+c between them and strings fragmentation is simulated )
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ey(3)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
+ common /qgarr10/ am(7),ammu
+ common /qgarr11/ b10
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)wpi0,wmi0,wp0,wm0
+
+ do i=1,3
+ ey(i)=1.d0
+ enddo
+ wpi=wpi0
+ wmi=wmi0
+c quark-antiquark types (1 - u, 2 - d, -1 - u~, -2 - d~); s- and d- quarks are
+c taken into consideration at the fragmentation step
+ if(ic10.eq.0)then
+ if(qgran(b10).lt.dc(2))then
+ ic1=4
+ ic12=-4
+ else
+ ic1=int(1.5+qgran(b10))
+ ic12=-ic1
+ endif
+ elseif(ic10.gt.0)then
+ ic1=ic10
+ ic12=ic120
+ else
+ ic1=ic120
+ ic12=ic10
+ endif
+
+ if(ic20.eq.0)then
+ if(qgran(b10).lt.dc(2))then
+ ic2=4
+ ic21=-4
+ else
+ ic2=int(1.5+qgran(b10))
+ ic21=-ic2
+ endif
+ elseif(ic20.gt.0)then
+ ic2=ic20
+ ic21=ic210
+ else
+ ic2=ic210
+ ic21=ic20
+ endif
+
+c longitudinal momenta for the strings
+ if(jp.eq.0)then
+ wp1=wpi*cos(pi*qgran(b10))**2
+ else
+1 xp=.5d0*qgran(b10)**2
+ if(qgran(b10).gt.(2.d0*(1.d0-xp))**(-.5d0))goto 1
+ wp1=wpi*xp
+ if(qgran(b10).lt..5d0)wp1=wpi-wp1
+ endif
+ if(jt.eq.0)then
+ wm1=wmi*cos(pi*qgran(b10))**2
+ else
+2 xm=.5d0*qgran(b10)**2
+ if(qgran(b10).gt.(2.d0*(1.d0-xm))**(-.5d0))goto 2
+ wm1=wmi*xm
+ if(qgran(b10).lt..5d0)wm1=wmi-wm1
+ endif
+ wpi=wpi-wp1
+ wmi=wmi-wm1
+c string masses
+ sm1=wp1*wm1
+ sm2=wpi*wmi
+
+c mass thresholds
+ if(iabs(ic1).le.2)then
+ am1=am(1)
+ elseif(iabs(ic1).eq.3)then
+ am1=am(2)
+ elseif(iabs(ic1).eq.4)then
+ am1=am(3)
+ else
+ am1=0.d0
+ stop 'should not happen in qgstr 1 !'
+ endif
+ if(iabs(ic2).le.2)then
+ am2=am(1)
+ elseif(iabs(ic2).eq.3)then
+ am2=am(2)
+ elseif(iabs(ic2).eq.4)then
+ am2=am(3)
+ else
+ am2=0.d0
+ stop 'should not happen in qgstr 2 !'
+ endif
+ if(iabs(ic12).le.2)then
+ am12=am(1)
+ elseif(iabs(ic12).eq.3)then
+ am12=am(2)
+ elseif(iabs(ic12).eq.4)then
+ am12=am(3)
+ else
+ am12=0.d0
+ stop 'should not happen in qgstr 3 !'
+ endif
+ if(iabs(ic21).le.2)then
+ am21=am(1)
+ elseif(iabs(ic21).eq.3)then
+ am21=am(2)
+ elseif(iabs(ic21).eq.4)then
+ am21=am(3)
+ else
+ am21=0.d0
+ stop 'should not happen in qgstr 4 !'
+ endif
+
+c too short strings are neglected (energy is given to partner string
+c or to the hadron (nucleon) to which the pomeron is connected)
+ if(sm1.gt.am1+am21.and.sm2.gt.am2+am12)then
+c strings fragmentation is simulated - gener
+ call qggene(wp1,wm1,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
+ call qggene(wpi,wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
+ elseif((wpi+wp1)*(wmi+wm1).gt.am1+am21)then
+ call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
+ elseif((wpi+wp1)*(wmi+wm1).gt.am2+am12)then
+ call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
+ else
+ wp0=wp0+wp1+wpi
+ wm0=wm0+wm1+wmi
+ endif
+
+ if(debug.ge.3)write (moniou,202)wp0,wm0
+201 format(2x,'qgstr: wpi0=',e10.3,2x,'wmi0=',e10.3
+ *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
+202 format(2x,'qgstr - returned light cone momenta:'
+ *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
+ return
+ end
+
+c===========================================================================
+ double precision function qgt(b)
+c---------------------------------------------------------------------------
+c nuclear profile function value at impact parameter squared b
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /arr3/ x1(7),a1(7)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.2)write (moniou,201)b
+
+ qgt=0.
+ zm=rnuc(2)**2-b
+ if(zm.gt.4.*b)then
+ zm=dsqrt(zm)
+ else
+ zm=2.*dsqrt(b)
+ endif
+
+ do i=1,7
+ do m=1,2
+ z1=zm*(.5d0+x1(i)*(m-1.5d0))
+ r=dsqrt(b+z1**2)
+ quq=(r-rnuc(2))/wsnuc(2)
+ if (quq.lt.85.)qgt=qgt+a1(i)/(1.+exp(quq))
+ * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
+ enddo
+ enddo
+ qgt=qgt*zm*0.5d0
+
+ dt=0.
+ do i=1,7
+ do m=1,2
+ z1=zm-wsnuc(2)*log(.5d0+x1(i)*(m-1.5d0))
+ r=dsqrt(b+z1**2)
+ quq=(r-rnuc(2)-z1+zm)/wsnuc(2)
+ if (quq.lt.85.)dt=dt+a1(i)/(exp((zm-z1)/wsnuc(2))+exp(quq))
+ * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
+ enddo
+ enddo
+ qgt=qgt+dt*wsnuc(2)/2.d0
+
+ if(debug.ge.3)write (moniou,202)qgt
+201 format(2x,'qgt - nuclear profile function value at impact'
+ *,' parameter squared b=',e10.3)
+202 format(2x,'qgt=',e10.3)
+ return
+ end
+
+c=============================================================================
+ block data qgdata
+c-----------------------------------------------------------------------------
+c constants for numerical integration (gaussian weights)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
+ common /arr3/ x1(7),a1(7)
+ common /arr4/ x4(2),a4(2)
+ common /arr5/ x5(2),a5(2)
+ common /arr8/ x2(4),a2
+ common /arr9/ x9(3),a9(3)
+ data x1/.9862838d0,.9284349d0,.8272013d0,.6872929d0,.5152486d0,
+ *.3191124d0,.1080549d0/
+ data a1/.03511946d0,.08015809d0,.1215186d0,.1572032d0,
+ *.1855384d0,.2051985d0,.2152639d0/
+ data x2/.00960736d0,.0842652d0,.222215d0,.402455d0/
+ data a2/.392699d0/
+ data x4/ 0.339981,0.861136/
+ data a4/ 0.652145,0.347855/
+ data x5/.585786d0,3.41421d0/
+ data a5/.853553d0,.146447d0/
+ data x9/.93247d0,.661209d0,.238619d0/
+ data a9/.171324d0,.360762d0,.467914d0/
+ data trnuc/0.69d0,1.71d0,1.53d0,1.37d0,1.37d0,2.09d0,1.95d0
+ *,1.95d0,2.06d0,1.76d0,1.67d0,1.74d0,1.66d0,2.57d0,2.334d0
+ *,2.608d0,2.201d0,2.331d0,2.58d0,2.791d0,2.791d0,2.782d0,2.74d0
+ *,3.192d0,3.22d0,3.05d0,3.07d0,3.34d0,3.338d0,3.252d0
+ *,3.369d0,3.244d0,3.244d0,3.313d0,3.476d0,3.54d0,3.554d0
+ *,3.554d0,3.743d0,3.73d0,3.744d0,3.759d0,3.774d0,3.788d0
+ *,3.802d0,3.815d0,3.829d0,3.843d0,3.855d0,3.941d0
+ *,3.94d0,3.984d0,4.d0,4.074d0,3.89d0,4.111d0/
+ data twsnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
+ *,0.55d0,0.55d0,0.56d0,0.56d0,0.5052d0,0.498d0,0.513d0
+ *,0.55d0,0.55d0,0.567d0,0.698d0,0.698d0,0.549d0,0.55d0
+ *,0.604d0,0.58d0,0.523d0,0.519d0,0.58d0,0.547d0,0.553d0
+ *,0.582d0,0.55d0,0.55d0,0.7d0,0.599d0,0.507d0,0.588d0
+ *,0.588d0,0.585d0,0.62d0,0.55d0,0.55d0,0.55d0,0.55d0
+ *,0.55d0,0.55d0,0.55d0,0.588d0,0.588d0
+ *,0.566d0,0.505d0,0.542d0,0.557d0,0.536d0,0.567d0,0.558d0/
+ data twbnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
+ *,0.d0,0.d0,0.d0,0.d0,-0.18d0,0.139d0,-0.051d0,0.d0,0.d0
+ *,0.d0,-0.168d0,0.d0,0.d0,0.d0,-0.249d0,-0.236d0,0.d0,0.d0
+ *,0.233d0,-0.203d0,-0.078d0,-0.173d0,0.d0,0.d0,0.d0,-0.1d0
+ *,0.d0,-0.13d0,-0.13d0,-0.201d0,-0.19d0,0.d0,0.d0,0.d0,0.d0
+ *,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
+ *,0.d0,0.d0/
+ end
+
+c-----------------------------------------------------------------------
+ real function qggamfun(x)
+c-----------------------------------------------------------------------
+c gamma fctn
+c-----------------------------------------------------------------------
+ dimension c(13)
+ data c
+ 1/ 0.00053 96989 58808, 0.00261 93072 82746, 0.02044 96308 23590,
+ 2 0.07309 48364 14370, 0.27964 36915 78538, 0.55338 76923 85769,
+ 3 0.99999 99999 99998,-0.00083 27247 08684, 0.00469 86580 79622,
+ 4 0.02252 38347 47260,-0.17044 79328 74746,-0.05681 03350 86194,
+ 5 1.13060 33572 86556/
+ qggamfun=0
+ z=x
+ if(x .gt. 0.0) goto1
+ if(x .eq. aint(x)) goto5
+ z=1.0-z
+ 1 f=1.0/z
+ if(z .le. 1.0) goto4
+ f=1.0
+ 2 continue
+ if(z .lt. 2.0) goto3
+ z=z-1.0
+ f=f*z
+ goto2
+ 3 z=z-1.0
+ 4 qggamfun=
+ 1 f*((((((c(1)*z+c(2))*z+c(3))*z+c(4))*z+c(5))*z+c(6))*z+c(7))/
+ 2 ((((((c(8)*z+c(9))*z+c(10))*z+c(11))*z+c(12))*z+c(13))*z+1.0)
+ if(x .gt. 0.0) return
+ qggamfun=3.141592653589793/(sin(3.141592653589793*x)*qggamfun)
+ return
+ 5 write(*,10)x
+ 10 format(1x,'argument of gamma fctn = ',e20.5)
+ stop
+ end
+
+c-------------------------------------------------------------------------------
+ subroutine qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
+c-------------------------------------------------------------------------------
+c nucleus-nucleus (nucleus-hydrogen) interaction cross sections
+c gtot - total cross section
+c gprod - production cross section (projectile diffraction included)
+c gabs - cut pomerons cross section
+c gdd - projectile diffraction cross section
+c gqel - quasielastic (projectile nucleon knock-out) cross section
+c gcoh - coherent (elastic with respect to the projectile) cross section
+c (target diffraction is not treated explicitely and contributes to
+c gdd, gqel, gcoh).
+c-------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ parameter(iapmax=208)
+ dimension wabs(28),wdd(28),wqel(28),wcoh(28)
+ *,wprod(28),b0(28),ai(28),xa(iapmax,3),xb(iapmax,3)
+ common /qgarr1/ ia(2),icz,icp
+ common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
+ *,cr1(2),cr2(2),cr3(2)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr11/ b10
+ common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
+ common /arr3/ x1(7),a1(7)
+ EXTERNAL qgran
+
+ e1=exp(-1.d0)
+
+ do i=1,7
+ b0(15-i)=bm*sqrt((1.d0+x1(i))/2.d0)
+ b0(i)=bm*sqrt((1.d0-x1(i))/2.d0)
+ ai(i)=a1(i)*bm**2*5.d0*pi
+ ai(15-i)=ai(i)
+ enddo
+
+ do i=1,7
+ tp=(1.d0+x1(i))/2.d0
+ tm=(1.d0-x1(i))/2.d0
+ b0(14+i)=bm-log(tp)*max(wsnuc(1),wsnuc(2))
+ b0(29-i)=bm-log(tm)*max(wsnuc(1),wsnuc(2))
+ ai(14+i)=a1(i)*b0(14+i)/tp*10.d0*max(wsnuc(1),wsnuc(2))*pi
+ ai(29-i)=a1(i)*b0(29-i)/tm*10.d0*max(wsnuc(1),wsnuc(2))*pi
+ enddo
+
+ do i=1,28
+ wabs(i)=0.
+ wdd(i)=0.
+ wqel(i)=0.
+ wcoh(i)=0.
+ enddo
+
+ do nc=1,niter
+ do i=1,ia(2)
+ iddt(i)=1+int(qgran(b10)+cc(2,2))
+ enddo
+
+ if(ia(1).eq.1)then
+ xa(1,1)=0.d0
+ xa(1,2)=0.d0
+ xa(1,3)=0.d0
+ else
+ call qggea(ia(1),xa,1)
+ endif
+ if(ia(2).eq.1)then
+ xb(1,1)=0.d0
+ xb(1,2)=0.d0
+ xb(1,3)=0.d0
+ else
+ call qggea(ia(2),xb,2)
+ endif
+
+ do i=1,28
+ call qggcr(b0(i),gabs,gdd,gqel,gcoh,xa,xb,ia(1))
+ wabs(i)=wabs(i)+gabs
+ wdd(i)=wdd(i)+gdd
+ wqel(i)=wqel(i)+gqel
+ wcoh(i)=wcoh(i)+gcoh
+ enddo
+ enddo
+
+ gabs=0.
+ gdd=0.
+ gqel=0.
+ gcoh=0.
+ do i=1,28
+ wabs(i)=wabs(i)/niter
+ wdd(i)=wdd(i)/niter
+ wqel(i)=wqel(i)/niter
+ wcoh(i)=wcoh(i)/niter
+ wprod(i)=wabs(i)+wdd(i)
+ gabs=gabs+ai(i)*wabs(i)
+ gdd=gdd+ai(i)*wdd(i)
+ gqel=gqel+ai(i)*wqel(i)
+ gcoh=gcoh+ai(i)*wcoh(i)
+ enddo
+ gprod=gabs+gdd
+ gtot=gprod+gqel+gcoh
+ return
+ end
+
+c-------------------------------------------------------------------------------
+ subroutine qggcr(b,gabs,gdd,gqel,gcoh,xa,xb,ia)
+c-------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ parameter(iapmax=208)
+ dimension xa(iapmax,3),xb(iapmax,3),vabs(2)
+
+ gabs=1.
+ gdd=1.
+ gqel=1.
+ gcoh=1.
+ do n=1,ia
+ call qgv(xa(n,1)+b,xa(n,2),xb,vin,vdd,vabs)
+ gabs=gabs*(vdd-vin+1.d0) !prod_n^A [sum_i c_i exp(-2chi_i(n))]
+ gdd=gdd*(1.-vin) !prod_n^A [sum_i c_i exp(-chi_i(n))]^2
+ gqel=gqel*(2.d0*dsqrt(1.d0-vin)-1.d0)
+ !prod_n^A [sum_i c_i exp(-chi_i(n)) - 1]
+ gcoh=gcoh*dsqrt(1.d0-vin)
+ enddo
+ gcoh=1.-2.*gcoh+gqel
+ gqel=gdd-gqel
+ gdd=gabs-gdd
+ gabs=1.-gabs
+ return
+ end
+
+c-------------------------------------------------------------------------------
+ double precision function qgsect(e0n,icz,iap0,iat0) !so18032013
+c-------------------------------------------------------------------------------
+c qgsect - hadron-nucleus (hadron-nucleus) particle production cross section
+c e0n - lab. energy per projectile nucleon (hadron),
+c icz - hadron class,
+c iap - projectile mass number (1=<iap<=iapmax),
+c iat - target mass number (1=<iat<=iapmax)
+c-------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension wk(3),wa(3),wb(3)
+ common /qgarr47/ gsect(10,5,6)
+ common /qgarr48/ qgsasect(10,6,6)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(debug.ge.3)write (moniou,201)e0n,icz,iap0,iat0
+ qgsect=0.d0
+
+ iap=iap0 !so18032013-beg
+ iat=iat0
+ if(iat.eq.1.and.iap.ne.1)then
+ iap=iat0
+ iat=iap0
+ endif !so18032013-end
+
+ ye=dlog10(e0n)
+ if(ye.lt.1.d0)ye=1.d0
+ je=int(ye)
+ if(je.gt.8)je=8
+
+ wk(2)=ye-je
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ yb=iat
+ yb=dlog(yb)/1.38629d0+1.d0
+ jb=min(int(yb),2)
+ wb(2)=yb-jb
+ wb(3)=wb(2)*(wb(2)-1.d0)*.5d0
+ wb(1)=1.d0-wb(2)+wb(3)
+ wb(2)=wb(2)-2.d0*wb(3)
+
+ if(iap.eq.1)then
+ if(iat.eq.14)then
+ do i=1,3
+ qgsect=qgsect+gsect(je+i-1,icz,5)*wk(i)
+ enddo
+ elseif(iat.eq.40)then
+ do i=1,3
+ qgsect=qgsect+gsect(je+i-1,icz,6)*wk(i)
+ enddo
+ else
+ do i=1,3
+ do l=1,3
+ qgsect=qgsect+gsect(je+i-1,icz,jb+l-1)*wk(i)*wb(l)
+ enddo
+ enddo
+ endif
+ else
+ ya=iap
+ ya=dlog(ya/2.d0)/.69315d0+1.d0
+ ja=min(int(ya),4)
+ wa(2)=ya-ja
+ wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
+ wa(1)=1.d0-wa(2)+wa(3)
+ wa(2)=wa(2)-2.d0*wa(3)
+ if(iat.eq.14)then
+ do i=1,3
+ do m=1,3
+ qgsect=qgsect+qgsasect(je+i-1,ja+m-1,5)*wk(i)*wa(m)
+ enddo
+ enddo
+ elseif(iat.eq.40)then
+ do i=1,3
+ do m=1,3
+ qgsect=qgsect+qgsasect(je+i-1,ja+m-1,6)*wk(i)*wa(m)
+ enddo
+ enddo
+ else
+ do i=1,3
+ do m=1,3
+ do l=1,3
+ qgsect=qgsect+qgsasect(je+i-1,ja+m-1,jb+l-1)*wk(i)*wa(m)*wb(l)
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+ qgsect=exp(qgsect)
+ if(debug.ge.4)write (moniou,202)
+
+201 format(2x,'qgsect - nucleus-nucleus production cross section'
+ */4x,'lab. energy per nucleon - ',e10.3,2x,'hadron class - ',i2
+ */4x,'proj. mass N - ',i3,2x,'targ. mass N - ',i3)
+202 format(2x,'qgsect=',e10.3)
+ return
+ end
+
+c=============================================================================
+ subroutine qgreg(ep0,ic)
+c-----------------------------------------------------------------------
+c qgreg - registration of produced hadron
+c ep0 - 4-momentum,
+c ic - hadron type
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ parameter(nptmax=95000)
+ dimension ep(4),ep0(4),ep1(4),ep2(4),ep3(4)
+ common /qgarr4/ ey0(3)
+ common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
+ common /qgarr11/ b10
+ common /qgarr12/ nsh
+ common /qgarr14/ esp(4,nptmax),ich(nptmax)
+ common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ external qgran
+
+ if(debug.ge.3)write (moniou,201)ic,ep0,nsh
+ nsh=nsh+1
+
+ nstprev = nsh
+
+ if(nsh.gt.nptmax)stop'increase nptmax!!!'
+ iab=iabs(ic)
+ do i=1,4
+ ep(i)=ep0(i)
+ enddo
+
+c call qgtran(ep,ey0,1)
+
+ if(iab.eq.7.or.iab.eq.8)then !delta++(-)
+ call qgdec2(ep,ep1,ep2,dmmin(2)**2,amn**2,am0**2)
+ ich(nsh)=ic-5*ic/iab
+ do i=1,4
+ esp(i,nsh)=ep1(i)
+ ep(i)=ep2(i)
+ enddo
+ nsh=nsh+1
+ ich(nsh)=15*ic/iab-2*ic
+
+ctp elseif(iab.eq.-10)then !rho0 -> pi+ + pi-
+ctp call qgdec2(ep,ep1,ep2,dmmin(1)**2,am0**2,am0**2)
+ctp ich(nsh)=2*int(.5d0+qgran(b10))-1
+ctp do i=1,4
+ctp esp(i,nsh)=ep1(i)
+ctp ep(i)=ep2(i)
+ctp enddo
+ctp nsh=nsh+1
+ctp ich(nsh)=-ich(nsh-1)
+
+ elseif(iab.eq.11)then !pi* -> rho + pi
+ am2=qgnrm(ep)
+ call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,am0**2)
+ctp call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
+ if(qgran(b10).lt..5d0)then !rho0 + pi+/-
+ ich(nsh)=-10
+ ich(nsh+1)=ic/iab
+ctp ich(nsh+1)=2*int(.5d0+qgran(b10))-1
+ctp ich(nsh+2)=-ich(nsh+1)
+ do i=1,4
+ esp(i,nsh)=ep1(i)
+ ep(i)=ep2(i)
+ enddo
+ nsh=nsh+1
+ else !rho+/- + pi0 -> pi+/- + 2 pi0
+ call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
+ ich(nsh)=0
+ ich(nsh+1)=ic/iab
+ ich(nsh+2)=0
+ do i=1,4
+ esp(i,nsh)=ep2(i)
+ esp(i,nsh+1)=ep3(i)
+ enddo
+ nsh=nsh+2
+ endif
+ctp do i=1,4
+ctp esp(i,nsh)=ep2(i)
+ctp esp(i,nsh+1)=ep3(i)
+ctp enddo
+ctp nsh=nsh+2
+
+ elseif(iab.eq.12.or.iab.eq.13)then !N*
+ am2=qgnrm(ep)
+ if(6.d0*qgran(b10).lt.1.d0)then !delta + pi
+ call qgdec2(ep,ep1,ep2,am2,dmmin(2)**2,am0**2)
+ call qgdec2(ep1,ep3,ep,dmmin(2)**2,amn**2,am0**2)
+ ich(nsh)=2*ic-25*ic/iab
+ ich(nsh+1)=ic-10*ic/iab
+ ich(nsh+2)=-ich(nsh)
+ do i=1,4
+ esp(i,nsh)=ep2(i)
+ esp(i,nsh+1)=ep3(i)
+ enddo
+ nsh=nsh+2
+ else !N + pi
+ call qgdec2(ep,ep1,ep2,am2,amn**2,am0**2)
+ do i=1,4
+ esp(i,nsh)=ep1(i)
+ ep(i)=ep2(i)
+ enddo
+ if(qgran(b10).lt..4d0)then
+ ich(nsh)=ic-10*ic/iab
+ ich(nsh+1)=0
+ else
+ ich(nsh)=15*ic/iab-ic
+ ich(nsh+1)=25*ic/iab-2*ic
+ endif
+ nsh=nsh+1
+ endif
+
+ elseif(iab.eq.14.or.iab.eq.15)then !K1
+ am2=qgnrm(ep)
+ if(dsqrt(am2).gt.dmmin(1)+amk)then !rho + K
+ call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,amk**2)
+ctp call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
+ if(3.d0*qgran(b10).lt.1.d0)then !rho0
+ ich(nsh)=ic-10*ic/iab
+ ich(nsh+1)=-10
+c ich(nsh+1)=2*int(.5d0+qgran(b10))-1
+c ich(nsh+2)=-ich(nsh+1)
+ do i=1,4
+ esp(i,nsh)=ep2(i)
+ ep(i)=ep1(i)
+ enddo
+ nsh=nsh+1
+ else !rho+/-
+ call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
+ ich(nsh)=19*ic/iab-ic
+ ich(nsh+1)=29*ic/iab-2*ic
+ ich(nsh+2)=0
+ do i=1,4
+ esp(i,nsh)=ep2(i)
+ esp(i,nsh+1)=ep3(i)
+ enddo
+ nsh=nsh+2
+ endif
+ else !K* + pi
+ call qgdec2(ep,ep1,ep2,am2,dmmin(3)**2,am0**2)
+ call qgdec2(ep1,ep3,ep,dmmin(3)**2,amk**2,am0**2)
+ if(3.d0*qgran(b10).lt.1.d0)then
+ ich(nsh)=0
+ if(3.d0*qgran(b10).lt.1.d0)then
+ ich(nsh+1)=ic-10*ic/iab
+ ich(nsh+2)=0
+ else
+ ich(nsh+1)=19*ic/iab-ic
+ ich(nsh+2)=29*ic/iab-2*ic
+ endif
+ else
+ ich(nsh)=29*ic/iab-2*ic
+ if(3.d0*qgran(b10).lt.1.d0)then
+ ich(nsh+1)=19*ic/iab-ic
+ ich(nsh+2)=0
+ else
+ ich(nsh+1)=ic-10*ic/iab
+ ich(nsh+2)=2*ic-29*ic/iab
+ endif
+ endif
+ do i=1,4
+ esp(i,nsh)=ep2(i)
+ esp(i,nsh+1)=ep3(i)
+ enddo
+ nsh=nsh+2
+ endif
+ctp do i=1,4
+ctp esp(i,nsh)=ep2(i)
+ctp esp(i,nsh+1)=ep3(i)
+ctp enddo
+ctp nsh=nsh+2
+
+ elseif(iab.eq.5)then !K0,K0~
+ ich(nsh)=10*int(.5d0+qgran(b10))-5
+
+c elseif(iab.eq.6)then !lambda decay (switch on in CONEX!)
+c ic2=-ic/iab*int(.64d0+qgran(b10))
+c ic1=3*ic/iab+ic2
+c call qgdec2(ep,ep1,ep2,amlam**2,amn**2,am0**2)
+c do i=1,4
+c esp(i,nsh)=ep1(i)
+c ep(i)=ep2(i)
+c enddo
+c ich(nsh)=ic1
+c ich(nsh+1)=ic2
+c nsh=nsh+1
+
+ else
+ ich(nsh)=ic
+ endif
+
+ do i=1,4
+ esp(i,nsh)=ep(i)
+ enddo
+
+ do n=nstprev,nsh
+ do i=1,4
+ ep(i)=esp(i,n)
+ enddo
+ call qgtran(ep,ey0,1)
+ do i=1,4
+ esp(i,n)=ep(i)
+ enddo
+ enddo
+
+ if(debug.ge.4)write (moniou,202)
+
+201 format(2x,'qgreg: ic=',i2,2x,'c.m. 4-momentum:',2x,4(e10.3,1x)/
+ * 4x,'number of particles in the storage: ',i5)
+202 format(2x,'qgreg - end')
+ return
+ end
+
+c-----------------------------------------------------------------------------
+ subroutine qgdec2(ep,ep1,ep2,ww,a,b)
+c two particle decay
+ implicit double precision (a-h,o-z)
+ integer debug
+ dimension ep(4),ep1(4),ep2(4),ey(3)
+ common /qgarr11/ b10
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+ EXTERNAL qgran
+
+ if(debug.ge.2)write (moniou,201)ep,ww,a,b
+201 format(2x,'qgdec2: 4-momentum:',2x,4(e10.3,1x)
+ */4x,'ww=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
+
+ pl=qglam(ww,a,b)
+ ep1(1)=dsqrt(pl+a)
+ ep2(1)=dsqrt(pl+b)
+ pl=dsqrt(pl)
+ cosz=2.d0*qgran(b10)-1.d0
+ pt=pl*dsqrt(1.d0-cosz**2)
+ ep1(2)=pl*cosz
+ call qgcs(c,s)
+ ep1(3)=pt*c
+ ep1(4)=pt*s
+ do i=2,4
+ ep2(i)=-ep1(i)
+ enddo
+ call qgdeft(ww,ep,ey)
+ call qgtran(ep1,ey,1)
+ call qgtran(ep2,ey,1)
+ if(debug.ge.3)write (moniou,203)
+203 format(2x,'qgdec2 - end')
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qggrv(x,qqs,icq,iq)
+c------------------------------------------------------------------------
+c qggrv - GRV structure functions
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+
+ qggrv=0.
+ if(x.gt..99999d0.and.(qqs.ne.qt0.or.iq.ne.1.and.iq.ne.2))return
+
+ if(icq.eq.2)then
+ sq=dlog(dlog(qqs/.232d0**2)/dlog(.23d0/.232d0**2))
+ if(iq.eq.0)then !gluon
+ alg=.524d0
+ betg=1.088d0
+ aag=1.742d0-.93d0*sq
+ bbg=-.399d0*sq**2
+ ag=7.486d0-2.185d0*sq
+ bg=16.69d0-22.74d0*sq+5.779d0*sq*sq
+ cg=-25.59d0+29.71d0*sq-7.296d0*sq*sq
+ dg=2.792d0+2.215d0*sq+.422d0*sq*sq-.104d0*sq*sq*sq
+ eg=.807d0+2.005d0*sq
+ eeg=3.841d0+.361d0*sq
+ qggrv=(1.d0-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1.d0/x)**bbg
+ * +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1.d0/x))))
+ elseif(iq.eq.1.or.iq.eq.2)then !u_v or d_v
+ aau=.59d0-.024d0*sq
+ bbu=.131d0+.063d0*sq
+ auu=2.284d0+.802d0*sq+.055d0*sq*sq
+ au=-.449d0-.138d0*sq-.076d0*sq*sq
+ bu=.213d0+2.669d0*sq-.728d0*sq*sq
+ cu=8.854d0-9.135d0*sq+1.979d0*sq*sq
+ du=2.997d0+.753d0*sq-.076d0*sq*sq
+ uv=auu*x**aau*(1.d0+au*x**bbu+bu*x+cu*x**1.5d0)
+ if(qqs.ne.qt0)uv=uv*(1.d0-x)**du
+
+ aad=.376d0
+ bbd=.486d0+.062d0*sq
+ add=.371d0+.083d0*sq+.039d0*sq*sq
+ ad=-.509d0+3.31d0*sq-1.248d0*sq*sq
+ bd=12.41d0-10.52d0*sq+2.267d0*sq*sq
+ ccd=6.373d0-6.208d0*sq+1.418d0*sq*sq
+ dd=3.691d0+.799d0*sq-.071d0*sq*sq
+ dv=add*x**aad*(1.d0+ad*x**bbd+bd*x+ccd*x**1.5d0)
+ if(qqs.ne.qt0)then
+ dv=dv*(1.d0-x)**dd
+ elseif(x.gt..99999d0)then
+ dv=0.d0
+ else
+ dv=dv*(1.d0-x)**(dd-ahv(2))
+ endif
+ if(iq.eq.1)then !u_v
+ qggrv=uv
+ elseif(iq.eq.2)then !d_v
+ qggrv=dv
+ endif
+
+ elseif(iq.eq.-3)then !s_sea
+ als=.914
+ bets=.577
+ aas=1.798-.596*sq
+ as=-5.548+3.669*sqrt(sq)-.616*sq
+ bs=18.92-16.73*sqrt(sq)+5.168*sq
+ ds=6.379-.35*sq+.142*sq*sq
+ es=3.981+1.638*sq
+ ees=6.402
+ qggrv=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
+ * +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
+ elseif(iabs(iq).lt.3)then !u_sea or d_sea
+ aadel=.409-.005*sq
+ bbdel=.799+.071*sq
+ addel=.082+.014*sq+.008*sq*sq
+ adel=-38.07+36.13*sq-.656*sq*sq
+ bdel=90.31-74.15*sq+7.645*sq*sq
+ ccdel=0.
+ ddel=7.486+1.217*sq-.159*sq*sq
+ delv=addel*x**aadel*(1.-x)**ddel
+ * *(1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
+
+ alud=1.451
+ betud=.271
+ aaud=.41-.232*sq
+ bbud=.534-.457*sq
+ aud=.89-.14*sq
+ bud=-.981
+ cud=.32+.683*sq
+ dud=4.752+1.164*sq+.286*sq*sq
+ eud=4.119+1.713*sq
+ eeud=.682+2.978*sq
+ udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
+ * *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud
+ * *log(1./x))))
+
+ if(iq.eq.-1)then !u_sea
+ qggrv=(udsea-delv)/2.
+ elseif(iq.eq.-2)then !d_sea
+ qggrv=(udsea+delv)/2.
+ endif
+ else
+ qggrv=0.
+ endif
+
+ elseif(icq.eq.1.or.icq.eq.3)then
+ sq=dlog(dlog(qqs/.204d0**2)/dlog(.26d0/.204d0**2))
+ if(iq.eq.1.or.iq.eq.2)then
+ aapi=.517-.02*sq
+ api=-.037-.578*sq
+ bpi=.241+.251*sq
+ dpi=.383+.624*sq
+ anorm=1.212+.498*sq+.009*sq**2
+ qggrv=.5*anorm*x**aapi*(1.+api*sqrt(x)+bpi*x)
+ if(qqs.ne.qt0)qggrv=qggrv*(1.d0-x)**dpi
+ elseif(iq.eq.0)then
+ alfpi=.504
+ betpi=.226
+ aapi=2.251-1.339*sqrt(sq)
+ api=2.668-1.265*sq+.156*sq**2
+ bbpi=0.
+ bpi=-1.839+.386*sq
+ cpi=-1.014+.92*sq-.101*sq**2
+ dpi=-.077+1.466*sq
+ epi=1.245+1.833*sq
+ eppi=.51+3.844*sq
+ qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
+ * log(1./x)**bbpi+sq**alfpi*
+ * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
+ elseif(iq.eq.-3)then
+ alfpi=.823
+ betpi=.65
+ aapi=1.036-.709*sq
+ api=-1.245+.713*sq
+ bpi=5.58-1.281*sq
+ dpi=2.746-.191*sq
+ epi=5.101+1.294*sq
+ eppi=4.854-.437*sq
+ qggrv=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
+ * (1.+api*sqrt(x)+bpi*x)*
+ * exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
+ elseif(iabs(iq).lt.3)then
+ alfpi=1.147
+ betpi=1.241
+ aapi=.309-.134*sqrt(sq)
+ api=.219-.054*sq
+ bbpi=.893-.264*sqrt(sq)
+ bpi=-.593+.24*sq
+ cpi=1.1-.452*sq
+ dpi=3.526+.491*sq
+ epi=4.521+1.583*sq
+ eppi=3.102
+ qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
+ * log(1./x)**bbpi+sq**alfpi*
+ * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
+ else
+ qggrv=0.
+ endif
+ else
+ qggrv=0.
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgev(q1,qj,qq,xx,j,l)
+c------------------------------------------------------------------------
+c qgev - PDF evolution
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr51/ epsxmn
+ common /arr3/ x1(7),a1(7)
+
+ qgev=0.d0
+ zmax=1.d0-epsxmn
+ zmin=xx/zmax
+ if(zmin.ge.zmax)return
+
+ if(qj.eq.qq)then
+ do i1=1,7
+ do m1=1,2
+ qi=q1*(qq/q1)**(.5d0+x1(i1)*(m1-1.5d0))
+
+ fz1=0.d0
+ fz2=0.d0
+ fz3=0.d0
+ zmin1=max(.2d0,zmin)
+ zmax1=min(.2d0,zmax)
+ zmax1=min(5.d0*xx,zmax1)
+ zmax2=min(zmin1,zmax)
+ zmin2=max(zmax1,zmin)
+
+ if(zmax1.gt.zmin)then
+ do i=1,7
+ do m=1,2
+ z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
+ do k=1,2
+ if(j.ne.3.or.k.ne.1)then
+ fz1=fz1+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)*(1.d0-xx/z)
+ endif
+ enddo
+ enddo
+ enddo
+ fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
+ endif
+ if(zmin1.lt.zmax)then
+ do i=1,7
+ do m=1,2
+ z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
+ * **(.5d0+x1(i)*(m-1.5d0))
+ do k=1,2
+ if(j.ne.3.or.k.ne.1)then
+ fz2=fz2+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
+ * *(1.d0/z-1.d0)
+ endif
+ enddo
+ enddo
+ enddo
+ fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
+ endif
+ if(zmax2.gt.zmin2)then
+ do i=1,7
+ do m=1,2
+ z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
+ do k=1,2
+ if(j.ne.3.or.k.ne.1)then
+ fz3=fz3+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
+ endif
+ enddo
+ enddo
+ enddo
+ fz3=fz3*dlog(zmax2/zmin2)
+ endif
+ qgev=qgev+a1(i1)*(fz1+fz2+fz3)/qgsudx(qi,l)*qgalf(qi/alm)
+ enddo
+ enddo
+ qgev=qgev*dlog(qq/q1)/4.d0*qgsudx(qq,l)
+
+ else
+ fz1=0.d0
+ fz2=0.d0
+ fz3=0.d0
+ zmin1=max(.2d0,zmin)
+ zmax1=min(.2d0,zmax)
+ zmax1=min(5.d0*xx,zmax1)
+ zmax2=min(zmin1,zmax)
+ zmin2=max(zmax1,zmin)
+
+ if(zmax1.gt.zmin)then
+ do i=1,7
+ do m=1,2
+ z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
+ do k=1,2
+ if(j.ne.3)then
+ fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
+ * *(1.d0-xx/z)
+ elseif(k.ne.1)then
+ fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
+ * *(1.d0-xx/z)
+ endif
+ enddo
+ enddo
+ enddo
+ fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
+ endif
+ if(zmin1.lt.zmax)then
+ do i=1,7
+ do m=1,2
+ z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
+ * **(.5d0+x1(i)*(m-1.5d0))
+ do k=1,2
+ if(j.ne.3)then
+ fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
+ * *(1.d0/z-1.d0)
+ elseif(k.ne.1)then
+ fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
+ * *(1.d0/z-1.d0)
+ endif
+ enddo
+ enddo
+ enddo
+ fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
+ endif
+ if(zmax2.gt.zmin2)then
+ do i=1,7
+ do m=1,2
+ z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
+ do k=1,2
+ if(j.ne.3)then
+ fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
+ elseif(k.ne.1)then
+ fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
+ endif
+ enddo
+ enddo
+ enddo
+ fz3=fz3*dlog(zmax2/zmin2)
+ endif
+ qgev=(fz1+fz2+fz3)/2.d0
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgevi(q1,qq,xx,m,l)
+c------------------------------------------------------------------------
+c qgevi - PDF evolution - interpolation
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ dimension wi(3),wj(3),wk(3)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr20/ spmax
+ common /qgarr51/ epsxmn
+ common /qgarr52/ evk(40,40,100,3,2)
+
+ qgevi=0.d0
+ if(q1.ge..9999d0*spmax)goto 1
+
+ if(xx.le..1d0)then
+ yx=37.d0-dlog(.1d0/xx)/dlog(.1d0*spmax)*36.d0
+ k=max(1,int(yx))
+ k=min(k,35)
+ elseif(xx.le..9d0)then
+ yx=(xx-.1d0)*40.d0+37.d0
+ k=max(37,int(yx))
+ k=min(k,67)
+ else
+ yx=dlog(10.d0*(1.d0-xx))/log(10.d0*epsxmn)*31.d0+69.d0
+ k=max(69,int(yx))
+ k=min(k,98)
+ endif
+ wk(2)=yx-k
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ qli=log(q1)/dlog(spmax)*39.d0+1.d0
+ qlj=log(qq/q1)/dlog(spmax/q1)*39.d0+1.d0
+ i=max(1,int(1.0001d0*qli))
+ i=min(i,38)
+ wi(2)=qli-i
+ wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
+ wi(1)=1.d0-wi(2)+wi(3)
+ wi(2)=wi(2)-2.d0*wi(3)
+
+ j=max(1,int(1.0001d0*qlj))
+ j=min(j,38)
+ wj(2)=qlj-j
+ wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
+ wj(1)=1.d0-wj(2)+wj(3)
+ wj(2)=wj(2)-2.d0*wj(3)
+
+ do i1=1,3
+ do j1=1,3
+ do k1=1,3
+ k2=k+k1-1
+ qgevi=qgevi+evk(i+i1-1,j+j1-1,k2,m,l)*wi(i1)*wj(j1)*wk(k1)
+ enddo
+ enddo
+ enddo
+1 qgevi=exp(qgevi)*qgfap(xx,m,l)
+ if(m.eq.1.and.l.eq.1.or.m.ne.1.and.l.ne.1)then
+ qgevi=qgevi/4.5d0/qgsudx(q1,m)*qgsudx(qq,m)
+ * *dlog(dlog(qq/alm)/dlog(q1/alm))
+ else
+ qgevi=qgevi*.3d0/(dlog(epsxmn)+.75d0)
+ * *(qgsudx(qq,1)/qgsudx(q1,1)-qgsudx(qq,2)/qgsudx(q1,2))
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpdf(xx,qq,icz,jj)
+c-----------------------------------------------------------------------
+c qgpdf - parton distribution function for proton
+c qq - virtuality scale,
+c xx - light cone x,
+c icz - hadron type,
+c jj - parton type (0 - gluon, 1 - u_v, 2 - d_v, -1 - q_sea)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+ common /qgarr51/ epsxmn
+ common /arr3/ x1(7),a1(7)
+
+ if(jj.eq.0)then
+ qgpdf=qggpdf(xx,icz)
+ elseif(jj.eq.1.or.jj.eq.2)then
+ qgpdf=qggrv(xx,qt0,icz,jj)*(1.d0-xx)**ahv(icz)
+ else
+ qgpdf=qgspdf(xx,icz)
+ endif
+ qgpdf=qgpdf*qgsudx(qq,iabs(jj)+1)/qgsudx(qt0,iabs(jj)+1)
+
+ xmin=xx/(1.d0-epsxmn)
+ if(xmin.lt.1.d0.and.qq.gt.qt0)then
+ dpd1=0.d0
+ dpd2=0.d0
+ xm=max(xmin,.3d0)
+ do i=1,7 !numerical integration over zx
+ do m=1,2
+ zx=1.d0-(1.d0-xm)*(.5d0+(m-1.5d0)*x1(i))**.25d0
+ z=xx/zx
+
+ gl=qggpdf(zx,icz)
+ uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
+ dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
+ sea=qgspdf(zx,icz)
+ if(jj.eq.0)then
+ fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
+ elseif(jj.eq.1)then
+ fz=qgevi(qt0,qq,z,3,2)*uv
+ elseif(jj.eq.2)then
+ fz=qgevi(qt0,qq,z,3,2)*dv
+ else
+ akns=qgevi(qt0,qq,z,3,2) !nonsinglet contribution
+ aks=(qgevi(qt0,qq,z,2,2)-akns) !singlet contribution
+ fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
+ endif
+ dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
+ enddo
+ enddo
+ dpd1=dpd1*(1.d0-xm)**4/8.d0*xx
+
+ if(xm.gt.xmin)then
+ do i=1,7 !numerical integration
+ do m=1,2
+ zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
+ z=xx/zx
+
+ gl=qggpdf(zx,icz)
+ uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
+ dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
+ sea=qgspdf(zx,icz)
+ if(jj.eq.0)then
+ fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
+ elseif(jj.eq.1)then
+ fz=qgevi(qt0,qq,z,3,2)*uv
+ elseif(jj.eq.2)then
+ fz=qgevi(qt0,qq,z,3,2)*dv
+ else
+ akns=qgevi(qt0,qq,z,3,2) !nonsinglet contribution
+ aks=(qgevi(qt0,qq,z,2,2)-akns) !singlet contribution
+ fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
+ endif
+ dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
+ enddo
+ enddo
+ dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
+ endif
+ qgpdf=qgpdf+dpd2+dpd1
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgpdfd(xx,xpomr,qq,icz)
+c-----------------------------------------------------------------------
+c qgpdfd - diffractive sf f2_d^(3)
+c qq - virtuality scale,
+c xx - parton light cone x,
+c xpomr - pomeron lc x,
+c icz - hadron type
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /qgarr6/ pi,bm,amws
+ common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr25/ ahv(3)
+ common /qgarr51/ epsxmn
+ common /arr3/ x1(7),a1(7)
+
+ qgpdfd=(qgdpdf(xx,xpomr,icz,1)+qgdpdf(xx,xpomr,icz,2))
+ **qgsudx(qq,2)/qgsudx(qt0,2)
+ xmin=xx/(1.d0-epsxmn)
+ if(xmin.lt.xpomr.and.qq.gt.qt0)then
+ dpd1=0.d0
+ dpd2=0.d0
+ xm=max(xmin,.3d0)
+ if(xm.lt.xpomr)then
+ do i=1,7 !numerical integration over zx
+ do m=1,2
+ zx=1.d0-(1.d0-xm)*(1.d0-(.5d0+(m-1.5d0)*x1(i))
+ * *(1.d0-((1.d0-xpomr)/(1.d0-xm))**4))**.25d0
+ z=xx/zx
+
+ glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
+ sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
+ fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
+ dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
+ enddo
+ enddo
+ dpd1=dpd1*((1.d0-xm)**4-(1.d0-xpomr)**4)/8.d0*xx
+ endif
+
+ xm=min(xm,xpomr)
+ if(xm.gt.xmin)then
+ do i=1,7 !numerical integration
+ do m=1,2
+ zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
+ z=xx/zx
+
+ glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
+ sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
+ fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
+ dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
+ enddo
+ enddo
+ dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
+ endif
+ qgpdfd=qgpdfd+dpd2+dpd1
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgf2c(xx,qq,icz)
+c-----------------------------------------------------------------------
+c qgf2c - c-quark contribution to f2
+c qq - virtuality scale,
+c xx - light cone x,
+c icz - hadron type,
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /arr3/ x1(7),a1(7)
+
+ qgf2c=0.d0
+ qcmass=1.3d0
+ s2min=4.*qcmass**2+qq
+ xmin=s2min*xx/qq
+
+ if(xmin.lt.1.d0)then
+ do i=1,7 !numerical integration over z1
+ do m=1,2
+ z1=xmin**(.5d0+x1(i)*(m-1.5d0))
+ sdc=qgdbor(qq,xx/z1,qcmass**2)
+ glu=qgpdf(z1,s2min-qq,icz,0)
+ qgf2c=qgf2c+a1(i)*sdc*glu
+ enddo
+ enddo
+ qgf2c=-qgf2c*dlog(xmin)*.5d0
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgf2cd(xx,xpomr,qq,icz)
+c-----------------------------------------------------------------------
+c qgf2cd - c-quark contribution to diffractive sf
+c qq - virtuality scale,
+c xx - light cone x,
+c icz - hadron type,
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /arr3/ x1(7),a1(7)
+
+ qgf2cd=0.d0
+ qcmass=1.3d0
+ s2min=4.*qcmass**2+qq
+ xmin=s2min*xx/qq
+
+ if(xmin.lt.xpomr)then
+ do i=1,7 !numerical integration over z1
+ do m=1,2
+ z1=xpomr*(xmin/xpomr)**(.5d0+x1(i)*(m-1.5d0))
+ sdc=qgdbor(qq,xx/z1,qcmass**2)
+ glu=qgdgdf(z1,xpomr,icz,1)+qgdgdf(z1,xpomr,icz,2)
+ qgf2cd=qgf2cd+a1(i)*sdc*glu
+ enddo
+ enddo
+ qgf2cd=qgf2cd*dlog(xpomr/xmin)*.5d0
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------
+ double precision function qgdbor(qq,zz,q2mass)
+c-----------------------------------------------------------------------
+c qgdbor - DIS c-quark cross-section
+c qq - photon virtuality
+c s=2(pq) - s_true + qq,
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+
+ qgdbor=0.
+ qtq=4.d0*q2mass*zz/qq/(1.d0-zz)
+ if(qtq.ge.1.d0)return
+ bet=dsqrt(1.d0-qtq)
+
+ qgdbor=qgalf(4.d0*q2mass/alm)/2.25d0*zz
+ **(dlog((1.d0+bet)/(1.d0-bet))*(1.d0-2.d0*zz*(1.d0-zz)
+ *-8.d0*(zz*q2mass/qq)**2+4.d0*zz*(1.d0-3.d0*zz)*q2mass/qq)
+ *+bet*(-1.d0-4.d0*zz*(1.d0-zz)*q2mass/qq+8.d0*zz*(1.d0-zz)))
+ return
+ end
+
+c=============================================================================
+ double precision function qgjeto(qi,qj,s,iq1,iq2)
+c-----------------------------------------------------------------------------
+c qgjeto - hard 2->2 parton scattering born cross-section
+c s is the c.m. energy square for the scattering process,
+c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
+c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
+
+ qgjeto=0.d0
+ qq=max(qi,qj)
+
+ zmin=qq*fqscal*4.d0/s
+ zmax=1.d0-epsxmn
+ if(zmin.ge.zmax)return
+
+ dpx1=0.d0
+ zmin1=min(.2d0,1.d0-zmin)
+ do i1=1,7
+ do m1=1,2
+ z=1.d0-epsxmn*(zmin1/epsxmn)**(.5d0+x1(i1)*(m1-1.5d0))
+
+ si=z*s
+ fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
+ dpx1=dpx1+a1(i1)*fb*(1.d0-z)
+ enddo
+ enddo
+ dpx1=dpx1*dlog(zmin1/epsxmn)
+
+ dpx2=0.d0
+ if(zmin.lt..8d0)then
+ zmin1=zmin**(-delh)
+ zmax1=.8d0**(-delh)
+ do i1=1,7
+ do m1=1,2
+ z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
+ * **(-1.d0/delh)
+
+ si=z*s
+ fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
+ dpx2=dpx2+a1(i1)*fb*z**(1.d0+delh)
+ enddo
+ enddo
+ dpx2=dpx2*(zmin1-zmax1)/delh
+ endif
+ qgjeto=(dpx1+dpx2)/qgsudx(qj,iabs(iq2)+1)*pi**3
+
+ if(debug.ge.3)write (moniou,202)qgjeto
+201 format(2x,'qgjeto: qi=',e10.3,2x,'qj=',e10.3,2x,
+ *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
+202 format(2x,'qgjeto=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgjett(qi,qj,s,iq1,iq2)
+c-----------------------------------------------------------------------------
+c qgjett - hard 2->2 parton scattering born cross-section
+c s is the c.m. energy square for the scattering process,
+c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
+c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
+c-----------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
+
+ qgjett=0.d0
+ qq=max(qi,qj)
+
+ zmin=qq*fqscal*4.d0/s
+ zmax=(1.d0-epsxmn)**2
+ if(zmin.ge.zmax)return
+ zmin1=zmin**(-delh)
+ zmax1=zmax**(-delh)
+ do i1=1,7
+ do m1=1,2
+ z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
+ * **(-1.d0/delh)
+
+ si=z*s
+ fb1=0.d0
+ zmin2=min(.2d0,1.d0-dsqrt(z))
+ do i2=1,7
+ do m2=1,2
+ z1=1.d0-epsxmn*(zmin2/epsxmn)**(.5d0+x1(i2)*(m2-1.5d0))
+ z2=z/z1
+
+ fb1=fb1+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
+ * +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))*(1.d0/z1-1.d0)
+ enddo
+ enddo
+ fb1=fb1*dlog(zmin2/epsxmn)
+
+ fb2=0.d0
+ if(z.lt..64d0)then
+ do i2=1,7
+ do m2=1,2
+ z1=.8d0*(dsqrt(z)/.8d0)**(.5d0+x1(i2)*(m2-1.5d0))
+ z2=z/z1
+
+ fb2=fb2+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
+ * +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))
+ enddo
+ enddo
+ fb2=fb2*dlog(.64d0/z)/2.d0
+ endif
+
+ qgjett=qgjett+a1(i1)*(fb1+fb2)*z**(1.d0+delh)
+ enddo
+ enddo
+ qgjett=qgjett*(zmin1-zmax1)/delh*pi**3/2.d0
+
+ if(debug.ge.3)write (moniou,202)qgjett
+201 format(2x,'qgjett: qi=',e10.3,2x,'qj=',e10.3,2x,
+ *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
+202 format(2x,'qgjett=',e10.3)
+ return
+ end
+
+c=============================================================================
+ double precision function qgjeti(qi,qj,si,z1,z2,iq1,iq2,jj)
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgjeti=0.d0
+ qq=max(qi,qj)
+ tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/si)))
+ if(tmin.ge.si/2.d0)return
+ do i=1,7
+ do m=1,2
+ t=2.d0*tmin/(1.d0+2.d0*tmin/si
+ * -x1(i)*(2*m-3)*(1.d0-2.d0*tmin/si))
+ qt=t*(1.d0-t/si)
+
+ fb=0.d0
+ if(jj.eq.1)then
+ do iql=1,2
+ iq=2*iql-2
+ dfb=0.d0
+ do n=1,3
+ dfb=dfb+qgfbor(si,t,iq,iq2,n)+qgfbor(si,si-t,iq,iq2,n)
+ enddo
+ if(iq.eq.iq2)dfb=dfb/2.d0
+ fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
+ enddo
+ fb=fb*qgsudx(qt/fqscal,iabs(iq2)+1)
+ else
+ do iql=1,2
+ iq=2*iql-2
+ do iqr=1,2
+ dfb=0.d0
+ do n=1,3
+ dfb=dfb+qgfbor(si,t,iq,iqr-1,n)+qgfbor(si,si-t,iq,iqr-1,n)
+ enddo
+ if(iq.eq.iqr-1)dfb=dfb/2.d0
+ fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
+ * *qgevi(qj,qt/fqscal,z2,iabs(iq2)+1,iqr)
+ enddo
+ enddo
+ endif
+
+ qgjeti=qgjeti+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
+ enddo
+ enddo
+ qgjeti=qgjeti*(1.d0/tmin-2.d0/si)/si**2
+ return
+ end
+
+c=============================================================================
+ double precision function qgptj(s,pt,y0,sigin)
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr6/ pi,bm,amws
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgarr51/ epsxmn
+ common /qgdebug/ debug
+ common /arr3/ x1(7),a1(7)
+
+ qgptj=0.d0
+ zmin=4.d0*pt**2/s
+ xt=2.d0*pt*exp(y0)/dsqrt(s)
+ zmax=min(1.d0,xt**2/(2.d0*xt-zmin))
+ if(zmax.le.zmin)return
+
+ qq=pt**2/fqscal
+ do i1=1,7
+ do m1=1,2
+ z=zmax*(zmin/zmax)**(.5d0+x1(i1)*(m1-1.5d0))
+ si=z*s
+ t=2.d0*pt**2/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z)))
+
+ xmax=min(1.d0,xt/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z))))
+ xmin=max(z,xmax*exp(-2.d0*y0))
+ do i2=1,7
+ do m2=1,2
+ xp=xmax*(xmin/xmax)**(.5d0+x1(i2)*(m2-1.5d0))
+ xm=z/xp
+
+ glu1=qgpdf(xp,qq,2,0)
+ glu2=qgpdf(xm,qq,2,0)
+ seav2=qgpdf(xm,qq,2,-1)+qgpdf(xm,qq,2,1)+qgpdf(xm,qq,2,2)
+
+ qgptj=qgptj+a1(i1)*a1(i2)*(qgptjb(si,pt**2,t,1)*glu1*glu2
+ * +qgptjb(si,pt**2,t,2)*glu1*seav2)
+ * *dlog(xmax/xmin)/(1.d0-2.d0*t/si)
+ enddo
+ enddo
+ enddo
+ enddo
+ qgptj=qgptj*dlog(zmax/zmin)*pi**3*.39d0/sigin *2. !2 jets
+ return
+ end
+
+c=============================================================================
+ double precision function qgptjb(si,qt,t,jj)
+ implicit double precision (a-h,o-z)
+ integer debug
+ common /qgarr18/ alm,qt0,qtf,betp,dgqq
+ common /qgarr26/ factk,fqscal
+ common /qgarr43/ moniou
+ common /qgdebug/ debug
+
+ if(jj.eq.1)then
+ qgptjb=qgfbor(si,t,0,0,1)
+ else !if(jj.eq.2)then
+ qgptjb=qgfbor(si,t,0,1,1)
+ endif
+ qgptjb=qgptjb*qgalf(qt/fqscal/alm)**2/si**2
+ return
+ end
diff --git a/Processes/QGSJetII/qgsjet-II-04.h b/Processes/QGSJetII/qgsjet-II-04.h
new file mode 100644
index 0000000000000000000000000000000000000000..352ce650dc845e3c2f30dba35eadc7d637e65eaa
--- /dev/null
+++ b/Processes/QGSJetII/qgsjet-II-04.h
@@ -0,0 +1,112 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#ifndef _include_qgsjetII_interface_h_
+#define _include_qgsjetII_interface_h_
+
+#include <string>
+
+//----------------------------------------------
+// C++ interface for the QGSJetII event generator
+//----------------------------------------------
+// wrapper
+
+extern "C" {
+
+// data memory layout
+
+extern struct { int nsp; } qgarr12_;
+
+const int nptmax = 95000;
+const int iapmax = 208;
+
+extern struct {
+ double esp[nptmax][4];
+ int ich[nptmax];
+} qgarr14_;
+
+extern struct {
+ // c nsf - number of secondary fragments;
+ // c iaf(i) - mass of the i-th fragment
+ int nsf;
+ int iaf[iapmax];
+} qgarr13_;
+
+extern struct {
+ int nwt;
+ int nwp;
+} qgarr55_;
+
+/**
+ Small helper class to provide a data-directory name in the format qgsjetII expects
+ */
+class datadir {
+private:
+ datadir operator=(const std::string& dir);
+ datadir operator=(const datadir&);
+
+public:
+ datadir(const std::string& dir);
+ char data[132];
+};
+
+// functions
+void qgset_();
+void qgaini_(
+ const char* datdir); // Note: there is a length limiation 132 from fortran-qgsjet here
+
+/**
+ @function qgini_
+
+ additional initialization procedure per event
+
+ @parameter e0n - interaction energy (per hadron/nucleon),
+ @parameter icp0 - hadron type (+-1 - pi+-, +-2 - p(p~), +-3 - n(n~), +-4 - K+-, +-5 -
+ K_l/s),
+ @parameter iap - projectile mass number (1 - for a hadron),
+ @parameter iat - target mass number
+*/
+void qgini_(const double& e0n, const int& icp0, const int& iap, const int& iat);
+
+/**
+ @function qgconf_
+
+ generate one event configuration
+*/
+void qgconf_();
+
+/**
+ @function qgsect_
+
+ hadron-nucleus (hadron-nucleus) particle production cross section
+
+ @parameter e0n lab. energy per projectile nucleon (hadron)
+ @parameter icz hadron class (1 - pion, 2 - nucleon, 3 - kaon)
+ @parameter iap projectile mass number (1=<iap<=iapmax),
+ @parameter iat target mass number (1=<iat<=iapmax)
+ */
+double qgsect_(const double& e0n, const int& icz, const int& iap0, const int& iat0);
+
+/**
+ @function qgran
+
+ link to random number generation
+ */
+double qgran_(int&);
+
+/**
+ dummy function from CRMC
+ */
+void lzmaopenfile_(const char* name, int length);
+void lzmaclosefile_();
+void lzmafillarray_(const double& dum, const int& idum);
+}
+
+#endif
diff --git a/Processes/QGSJetII/testQGSJetII.cc b/Processes/QGSJetII/testQGSJetII.cc
new file mode 100644
index 0000000000000000000000000000000000000000..4f284e056992a9987ae4cd70b4a5f471f5caca6a
--- /dev/null
+++ b/Processes/QGSJetII/testQGSJetII.cc
@@ -0,0 +1,126 @@
+/*
+ * (c) Copyright 2020 CORSIKA Project, corsika-project@lists.kit.edu
+ *
+ * See file AUTHORS for a list of contributors.
+ *
+ * This software is distributed under the terms of the GNU General Public
+ * Licence version 3 (GPL Version 3). See file LICENSE for a full version of
+ * the license.
+ */
+
+#include <corsika/process/qgsjetII/Interaction.h>
+#include <corsika/process/qgsjetII/ParticleConversion.h>
+
+#include <corsika/random/RNGManager.h>
+
+#include <corsika/particles/ParticleProperties.h>
+
+#include <corsika/geometry/Point.h>
+#include <corsika/units/PhysicalUnits.h>
+
+#include <catch2/catch.hpp>
+
+using namespace corsika;
+using namespace corsika::process::qgsjetII;
+
+TEST_CASE("QgsjetII", "[processes]") {
+
+ SECTION("QgsjetII -> Corsika") {
+ REQUIRE(particles::PiPlus::GetCode() == process::qgsjetII::ConvertFromQgsjetII(
+ process::qgsjetII::QgsjetIICode::PiPlus));
+ }
+
+ SECTION("Corsika -> QgsjetII") {
+ REQUIRE(process::qgsjetII::ConvertToQgsjetII(particles::PiMinus::GetCode()) ==
+ process::qgsjetII::QgsjetIICode::PiMinus);
+ REQUIRE(process::qgsjetII::ConvertToQgsjetIIRaw(particles::Proton::GetCode()) == 2);
+ }
+
+ SECTION("canInteractInQgsjetII") {
+
+ REQUIRE(process::qgsjetII::CanInteract(particles::Proton::GetCode()));
+ REQUIRE(process::qgsjetII::CanInteract(particles::Code::KPlus));
+ REQUIRE(process::qgsjetII::CanInteract(particles::Nucleus::GetCode()));
+ // REQUIRE(process::qgsjetII::CanInteract(particles::Helium::GetCode()));
+
+ REQUIRE_FALSE(process::qgsjetII::CanInteract(particles::EtaC::GetCode()));
+ REQUIRE_FALSE(process::qgsjetII::CanInteract(particles::SigmaC0::GetCode()));
+ }
+
+ SECTION("cross-section type") {
+
+ REQUIRE(process::qgsjetII::GetQgsjetIIXSCode(particles::Code::Neutron) == 2);
+ REQUIRE(process::qgsjetII::GetQgsjetIIXSCode(particles::Code::K0Long) == 3);
+ REQUIRE(process::qgsjetII::GetQgsjetIIXSCode(particles::Code::Proton) == 2);
+ REQUIRE(process::qgsjetII::GetQgsjetIIXSCode(particles::Code::PiMinus) == 1);
+ }
+}
+
+#include <corsika/geometry/Point.h>
+#include <corsika/geometry/RootCoordinateSystem.h>
+#include <corsika/geometry/Vector.h>
+
+#include <corsika/units/PhysicalUnits.h>
+
+#include <corsika/particles/ParticleProperties.h>
+#include <corsika/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+
+#include <corsika/environment/Environment.h>
+#include <corsika/environment/HomogeneousMedium.h>
+#include <corsika/environment/NuclearComposition.h>
+#include <corsika/process/qgsjetII/qgsjet-II-04.h>
+
+using namespace corsika::units::si;
+using namespace corsika::units;
+
+TEST_CASE("QgsjetIIInterface", "[processes]") {
+
+ // setup environment, geometry
+ environment::Environment<environment::IMediumModel> env;
+ auto& universe = *(env.GetUniverse());
+
+ auto theMedium =
+ environment::Environment<environment::IMediumModel>::CreateNode<geometry::Sphere>(
+ geometry::Point{env.GetCoordinateSystem(), 0_m, 0_m, 0_m},
+ 1_km * std::numeric_limits<double>::infinity());
+
+ using MyHomogeneousModel = environment::HomogeneousMedium<environment::IMediumModel>;
+ theMedium->SetModelProperties<MyHomogeneousModel>(
+ 1_kg / (1_m * 1_m * 1_m),
+ environment::NuclearComposition(
+ std::vector<particles::Code>{particles::Code::Oxygen}, std::vector<float>{1.}));
+
+ auto const* nodePtr = theMedium.get();
+ universe.AddChild(std::move(theMedium));
+
+ const geometry::CoordinateSystem& cs = env.GetCoordinateSystem();
+
+ random::RNGManager::GetInstance().RegisterRandomStream("qgran");
+
+ SECTION("InteractionInterface") {
+
+ setup::Stack stack;
+ const HEPEnergyType E0 = 100_GeV;
+ HEPMomentumType P0 =
+ sqrt(E0 * E0 - particles::Proton::GetMass() * particles::Proton::GetMass());
+ auto plab = corsika::stack::MomentumVector(cs, {0_GeV, 0_GeV, -P0});
+ geometry::Point pos(cs, 0_m, 0_m, 0_m);
+ auto particle =
+ stack.AddParticle(std::tuple<particles::Code, units::si::HEPEnergyType,
+ corsika::stack::MomentumVector, geometry::Point,
+ units::si::TimeType, unsigned int, unsigned int>{
+ particles::Code::Nucleus, E0, plab, pos, 0_ns, 16, 8});
+ // corsika::stack::MomentumVector, geometry::Point, units::si::TimeType>{
+ // particles::Code::PiPlus, E0, plab, pos, 0_ns});
+
+ particle.SetNode(nodePtr);
+ corsika::stack::SecondaryView view(particle);
+ auto projectile = view.GetProjectile();
+
+ Interaction model;
+ model.Init();
+ [[maybe_unused]] const process::EProcessReturn ret = model.DoInteraction(projectile);
+ [[maybe_unused]] const GrammageType length = model.GetInteractionLength(particle);
+ }
+}