diff --git a/.gitignore b/.gitignore
index 9656bc848ff52f63938067173e1372348527c92a..13cf148097e976bcd75db46f2ada28fcbd2cd064 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,7 @@
**/*~
+**/*.bak
+**/*log
build/
Framework/Particles/GeneratedParticleProperties.inc
+flymd.html
+flymd.md
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
new file mode 100644
index 0000000000000000000000000000000000000000..f8220f9a15b0e00fe5f22c3ec7860fc86d5feca2
--- /dev/null
+++ b/.gitlab-ci.yml
@@ -0,0 +1,19 @@
+image: ubuntu:bionic
+
+variables:
+ GIT_SSL_NO_VERIFY: "1"
+
+before_script:
+ - apt-get update --yes
+ - apt-get install --yes cmake libboost-dev libeigen3-dev python3 gfortran
+
+build:
+ stage: build
+ tags:
+ - run1
+ script:
+ - mkdir build
+ - cd build
+ - cmake ..
+ - cmake --build .
+ - ctest -V
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 0000000000000000000000000000000000000000..7036fa76902c4d4368664f0b745b5ea621a7e62f
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,2 @@
+Maximilian Reininghaus, maximilian.reininghaus@kit.edu
+Ralf Ulrich, ralf.ulrich@kit.edu
diff --git a/CHANGELOG b/CHANGELOG
index a9f540121d9ebf883db73ed96c4fdd0fee6f50d6..354e583bf8dd89dc38113d5ca8228c29224b697b 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1 +1,2 @@
-Everything
\ No newline at end of file
+* milestone1 release: So 7. Okt 15:51:07 CEST 2018
+
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 5a38c4ecb422e5ea823f864deaf0df7acceb5ac9..2a5cae812b9c16161ee4f76e57ae958488d5d963 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -7,6 +7,8 @@ project (
LANGUAGES CXX
)
+enable_language (Fortran)
+
# ignore many irrelevant Up-to-date messages during install
set (CMAKE_INSTALL_MESSAGE LAZY)
@@ -14,11 +16,29 @@ set (CMAKE_INSTALL_MESSAGE LAZY)
set(CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/CMakeModules)
include (CorsikaUtilities) # a few cmake function
-# --std=c++17
+# enable warnings and disallow non-standard language
+add_definitions(-Wall -pedantic -Wextra -Wno-ignored-qualifiers)
+
set (CMAKE_CXX_STANDARD 17)
enable_testing ()
set (CTEST_OUTPUT_ON_FAILURE 1)
+# Set a default build type if none was specified
+set(default_build_type "Release")
+if(EXISTS "${CMAKE_SOURCE_DIR}/.git")
+ set(default_build_type "Debug")
+endif()
+
+if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES)
+ message(STATUS "Setting build type to '${default_bluild_type}' as no other was specified.")
+ set(CMAKE_BUILD_TYPE "${default_build_type}" CACHE
+ STRING "Choose the type of build." FORCE)
+ # Set the possible values of build type for cmake-gui
+ set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS
+ "Debug" "Release" "MinSizeRel" "RelWithDebInfo")
+endif()
+
+
# unit testing coverage, does not work yet
#include (CodeCoverage)
##set(COVERAGE_LCOV_EXCLUDES 'Documentation/*')
@@ -29,20 +49,21 @@ set (CTEST_OUTPUT_ON_FAILURE 1)
# #-j ${PROCESSOR_COUNT}
# # DEPENDENCIES corsika
# )
-
+
#add_custom_target (corsika_pre_build)
#add_custom_command (TARGET corsika_pre_build PRE_BUILD COMMAND "${PROJECT_SOURCE_DIR}/pre_compile.py")
# dependencies
-find_package (Boost 1.40 COMPONENTS program_options REQUIRED)
+find_package (Boost 1.60 REQUIRED)
find_package (Eigen3 REQUIRED)
#find_package (HDF5) # not yet needed
-# order of subdirectories
+# order of subdirectories
add_subdirectory (ThirdParty)
+#add_subdirectory (Utilities)
add_subdirectory (Framework)
add_subdirectory (Stack)
+add_subdirectory (Setup)
add_subdirectory (Processes)
add_subdirectory (Documentation)
add_subdirectory (Main)
-
diff --git a/CMakeModules/CorsikaUtilities.cmake b/CMakeModules/CorsikaUtilities.cmake
index f98a7585468a68c1845192c4ff779debb5396a76..0ba70d8ff63f1e372fd8daae3e4f06cc96343a8e 100644
--- a/CMakeModules/CorsikaUtilities.cmake
+++ b/CMakeModules/CorsikaUtilities.cmake
@@ -55,3 +55,26 @@ function (CORSIKA_COPY_HEADERS_TO_NAMESPACE for_library in_namespace)
endfunction (CORSIKA_COPY_HEADERS_TO_NAMESPACE)
+
+
+
+#
+# use: CORSIKA_ADD_FILES_ABSOLUTE varname
+#
+# add list of filenames with absolute paths (pointing to CMAKE_SOURCE_DIR) to ${varname} in PARAENT_SCOPE
+#
+
+macro (CORSIKA_ADD_FILES_ABSOLUTE varname)
+ file (RELATIVE_PATH _relPath "${PROJECT_SOURCE_DIR}" "${CMAKE_CURRENT_SOURCE_DIR}")
+ foreach (_src ${ARGN})
+ if (_relPath)
+ list (APPEND "${varname}" "${CMAKE_SOURCE_DIR}/${_relPath}/${_src}")
+ else()
+ list (APPEND "${varname}" "${CMAKE_SOURCE_DIR}/${_src}")
+ endif()
+ endforeach()
+ if (_relPath)
+ # propagate SRCS to parent directory
+ set ("${varname}" "${${varname}}" PARENT_SCOPE)
+ endif()
+endmacro(CORSIKA_ADD_FILES_ABSOLUTE)
diff --git a/COLLABORATION_AGREEMENT.md b/COLLABORATION_AGREEMENT.md
new file mode 100644
index 0000000000000000000000000000000000000000..c00bec0f76a902d205a291c14122ae6ffc09ea6f
--- /dev/null
+++ b/COLLABORATION_AGREEMENT.md
@@ -0,0 +1,103 @@
+# Collaboration agreement
+
+The CORSIKA project very much welcomes all collaboration and
+contributions. The aim of the CORSIKA project is to create a
+scientific software framework as a fundamental tool for research. The
+collaboration agreement and the licensing model are based on the
+guidelines layed out by HSF
+[[1]](https://hepsoftwarefoundation.org/activities/licensing.html) or
+CERN
+[[2]](https://www.google.com/url?sa=t&rct=j&q=&esrc=s&source=web&cd=1&ved=2ahUKEwiLqKG00dXdAhUOZFAKHdIwAh4QFjAAegQIARAC&url=https%3A%2F%2Findico.cern.ch%2Fcategory%2F4251%2Fattachments%2F101%2F505%2FOSL-2012-01-Open_Source_Licences_at_CERN-Short_version.pdf&usg=AOvVaw1n4S0PQCSeE6wbdfdhKDqF),
+[[3]](http://legal.web.cern.ch/licensing/software), and follow the
+examples of other big scientific software projects.
+
+The CORSIKA project consists of the contributions from the scientific
+community and individuals in a best effort to deliver the best
+possible computing performance and physics output.
+The MCnet guidelines developed by [www.montecarlonet.org](www.montecarlonet.org)
+are copied in [MCNET_GUIDELINES](MCNET_GUIDELINES) -- they provide a very good
+additional scope that contributors should read and follow.
+
+All possible
+liability and licensing question are only handled by the adopted
+software license.
+
+## The software license of the CORSIKA project
+The license adopted for the CORSIKA project is the explicit copyleft
+license GPLv3, as copied in full in the file
+[LICENSE](LICENSE). Each source file of the CORSIKA project contains a
+short statement of the copyright and this license. Each binary or
+source code release of CORSIKA must contain the file LICENSE. The
+code, documentation and content in the folder [ThirdParty](ThirdParty)
+is not integral part of the CORSIKA project and can be based on or
+include other licenses, which must be compatible with GPLv3. Check the
+content of this folder for details. It depends on the configuration of
+the build system to what extend this code is used to build CORSIKA.
+
+## Who is the "copyright holder"
+For legal reasons and the ability to maintain the CORSIKA project
+effectively over a very long lifespan of several decades, all
+contributors are required to transfer their copyright to the CORSIKA
+Project. Of course you will be duly credited and your name will appear
+on the contributors page and in the [AUTHORS](AUTHORS) file shipped
+with every binary and source distribution. The copyright transfer is
+necessary to be able to effectively defend the project in case of
+litigation. The copyright holder may change, if decided by the CORSIKA
+Project. The current copyright holder is the CORSIKA Project
+corsika-project@lists.kit.edu, with the current chair person Ralf Ulrich (KIT) ralf.ulrich@kit.edu.
+
+## Definition of a "contributor"
+Contributor is a person of whom at least one merge request was
+accepted for the master branch of the CORSIKA project at
+[https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika).
+All contributors will be co-listed and credited as (software) authors
+of the CORSIKA project, as well as listed indefinitely in the
+[AUTHORS](AUTHORS) file. Contributors should add their name and
+contact data to the [AUTHORS](AUTHORS) file, as part of one of their
+merge requests. This file is always distributed together with all
+source and binary releases. If you contribute to any non-master
+branch, you can add your name to the [AUTHORS](AUTHORS) file of this
+particular branch, but all official releases are normally performed
+via the master branch.
+
+If you want to contribute, you need to read
+[GUIDELINES](GUIDELINES.md) and comply with these rules, or help to
+improve them.
+
+
+## Definition and working mode of the CORSIKA Project panel
+The CORSIKA Project panel makes all decisions for the CORSIKA
+Project. It can also change the
+[COLLABORATION\_AGREEMENT](COLLABORATION\_AGREEMENT.md), the
+[GUIDELINES](GUIDELINES.md) or any other structure or document relevant for the CORSIKA Project.
+
+The CORSIKA Project *panel* consists (October 2018) of
+
+ * Ralph Engel (KIT)
+ * Dieter Heck (KIT)
+ * Tanguy Pierog (KIT)
+ * Maximilian Reininghaus (KIT)
+ * Markus Roth (KIT)
+ * Ralf Ulrich (KIT)
+ * Michael Unger (KIT)
+ * Darko Veberic (KIT)
+
+and can be contacted via corsika-project@lists.kit.edu. The chair
+person of the CORSIKA Project is Ralf Ulrich (KIT). Members of the
+CORSIKA Project *panel* are *Maintainer* of the CORSIKA Project in
+gitlab at
+[https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika),
+and have special responsibilities for this reason.
+
+## Changing to a different license, for parts, or the complete project
+
+The CORSIKA Project panel can change the license for parts or the entire project.
+
+## Planning and performing releases
+
+The CORSIKA Project panel decides on releases of the software, and about the content of it.
+
+## Changes to the Collaboration Agreement
+
+The CORSIKA Project panel decides on changes to the Collaboration
+agreement.
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
new file mode 100644
index 0000000000000000000000000000000000000000..50d23b305d872735ce7a47d237c630b27cd2c443
--- /dev/null
+++ b/CONTRIBUTING.md
@@ -0,0 +1,216 @@
+# Contributing
+
+The CORSIKA project is committed to fostering and preserving a
+diverse, welcoming community; all participants are expected to
+respect that.
+
+- [Getting Started](#getting-started)
+ - [Very first steps](#very-first-steps)
+ - [Opening issues](#opening-issues)
+ - [Participating in discussions](#participating-in-discussions)
+ - [Improving and reviewing docs](#improving-and-reviewing-docs)
+ - [Reviewing and testing changes](#reviewing-and-testing-changes)
+- [Proposing and making changes](#proposing-and-making-changes)
+ - [Finding something to work on](#finding-something-to-work-on)
+ - [Before you start](#before-you-start-work)
+ - [Before you open your PR](#before-you-open-your-pr)
+ - [Review process](#review-process)
+- [Getting more involved](#getting-more-involved)
+
+## Getting started
+
+Not sure where to start? If you haven't already, take a look at the
+[docs](http://xi-editor.github.io/xi-editor/docs.html) to get a better
+sense of the project. Read through some issues and some open PRs, to
+get a sense for the habits of existing contributors. Drop by the #xi
+channel on [irc.mozilla.org](https://mozilla.logbot.info/xi) to follow
+ongoing discussions or ask questions. Clone the repos you're
+interested in, and make sure you can build and run the tests. If you
+can't, open an issue, and someone will try to help. Once you're up and
+running, there are a a number of ways to participate:
+
+### Opening issues
+
+If you have a question or a feature request or think you've found a bug,
+please open an issue. When opening an issue, include any details that
+might be relevant: for a bug this might be the steps required to
+reproduce; for a feature request it might be a detailed explanation of
+the behaviour you are imagining, an outline of how it would be used,
+and/or examples of how this feature is used in other editors.
+
+#### Before you open an issue
+
+Before opening an issue, **try to identify where the issue belongs**.
+Is it a problem with the frontend or with core? The frontend is
+responsible for drawing windows and UI, and handling events; the core
+is responsible for most everything else. Issues with the frontend
+should be opened in that frontend's repository, and issues with
+core should be opened in the
+[xi-editor](https://github.com/xi-editor/xi-editor/issues) repo.
+
+Finally, before opening an issue, **use github's search bar** to make
+sure there isn't an existing (open or closed) issue for your particular
+problem.
+
+### Participating in discussions
+
+An _explicit_ goal of xi-editor is to be an educational resource.
+Everyone is encouraged to participate in discussion issues (issues with
+the 'discussion' or 'planning' labels), and we expect people
+participating in discussions to be respectful of the fact that we all
+have different backgrounds and levels of experience. Similarly, if
+something is confusing, feel free to ask for clarification! If you're
+confused, other people probably are as well.
+
+### Improving and reviewing docs
+
+If the docs are unclear or incomplete, please open an issue or a PR to
+improve them. This is an especially valuable form of feedback from new
+contributors, who are seeing things for the first time, and will be best
+positioned to identify areas that need improvement.
+
+### Reviewing and testing changes
+
+One of the best ways to get more familiar with the project is by reading
+other people's pull requests. If there's something in a commit that you
+don't understand, this is a great time to ask for clarification. Testing
+changes is also very helpful, especially for bug fixes or feature
+additions. Check out a change and try it out; does it work? Can you find
+edge cases? Manual testing is very valuable. For more information on
+reviews, see [code review process](#review-process).
+
+
+## Proposing and making changes
+
+### Finding something to work on
+
+If you're looking for something to work on, a good first step is to browse
+the [issues](https://github.com/xi-editor/xi-editor/issues). Specifically,
+issues that are labeled
+[help wanted](https://github.com/xi-editor/xi-editor/issues?q=is%3Aissue+is%3Aopen+label%3A%22help+wanted%22) and/or
+[easy](https://github.com/xi-editor/xi-editor/issues?q=is%3Aissue+is%3Aopen+label%3Aeasy)
+are good places to start. If you can't find anything there, feel free to ask
+on IRC, or play around with the editor and try to identify something that
+_you_ think is missing.
+
+### Before you start work
+
+Before starting to work on an issue, consider the following:
+
+- _Is it a bugfix or small change?_ If you notice a small bug somewhere,
+ and you believe you have a fix, feel free to open a pull request directly.
+
+- _Is it a feature?_ If you have an idea for a new editor feature that is
+ along the lines of something that already exists (for instance, adding a
+ new command to reverse the letters in a selected region) _consider_
+ opening a short issue beforehand, describing the feature you have in mind.
+ Other contributors might be able to identify possible issues or
+ refinements. This isn't _necessary_, but it might end up saving you work,
+ and it means you will get to close an issue when your PR gets merged,
+ which feels good.
+
+- _Is it a major feature, affecting for instance the behaviour or appearance
+ of a frontend, or the API or architecture of core?_ Before working on a
+ large change, please open a discussion/proposal issue. This should describe
+ the problem you're trying to solve, and the approach you're considering;
+ think of this as a 'lite' version of Rust's
+ [RFC](https://github.com/rust-lang/rfcs) process.
+
+
+### Before you open your PR
+
+Before pressing the 'Create pull request' button,
+
+- _Run the tests_. It's easy to accidentally break something with even a small
+ change, so always run the tests locally before submitting (or updating) a PR.
+ You can run all checks locally with the `xi-editor/rust/run_all_checks`. script.
+
+- _Add a message for your reviewers_. When submitting a PR, take advantage
+ of the opportunity to include a message. Your goal here should be to help
+ your reviewers. Are there any parts of your change that you're uncertain
+ about? Are there any non-obvious explanations for some of your decisions?
+ If your change changes some behaviour, how might it be tested?
+
+- ***Be your own first reviewer***. On the page where you enter your message,
+ you have a final opportunity to see your PR _as it will be seen by your
+ reviewers_. This is a great opportunity to give it one last review, yourself.
+ Imagine that it is someone else's work, that you're reviewing: what comments
+ would you have? If you spot a typo or a problem, you can push an update in
+ place, without losing your PR message or other state.
+
+- _Add yourself to the AUTHORS file_. If this is your first substantive pull
+request in this repo, feel free to add yourself to the AUTHORS file.
+
+### Review process
+
+Every non-trivial pull request goes through review. Everyone is welcome to
+participate in review; review is an excellent time to ask questions about
+code or design decisions that you don't understand.
+
+All pull requests must be approved by an appropriate reviewer before they
+are merged. For bug fixes and smaller changes, this can be anyone who has
+commit rights to the repo in question; larger changes (changes which add a
+feature, or significantly change behaviour or API) should also be approved by
+a maintainer.
+
+Before being merged, a change must pass
+[CI](https://en.wikipedia.org/wiki/Continuous_integration).
+
+#### Responsibilites of the approving reviewer
+
+If you approve a change, it is expected that you:
+- understand what the change is trying to do, and how it is doing it
+- have manually built and tested the change, to verify it works as intended
+- believe the change generally matches the idioms, formatting rules,
+and overall coding style of the relevant repo
+- are ready and able to help resolve any problems that may be introduced by
+merging the change.
+
+If a PR is made by a contributor who has write access to the repo in question,
+they are responsible for merging/rebasing the PR after it has been approved;
+otherwise it will be merged by the reviewer.
+
+If a patch adds or modifies behaviour that is observable in the client,
+the reviewer should build the patch and verify that it works as expected.
+
+### After submitting your change
+
+You've done all this, and submitted your patch. What now?
+
+_Read other PRs_. If you're waiting for a review, it's likely that other
+pull requests are waiting for review as well. This can be a good time
+to go and take a look at what other work is happening in the project;
+and if another PR has review comments, it might provide a clue to the
+type of feedback you might expect.
+
+_Patience_. As a general goal, we try to respond to all pull requests
+within a few days, and to do preliminary review within a week, but we
+don't always succeed. If you've opened a PR and haven't heard from
+anyone, feel free to comment on it, or stop by the IRC channel, to ask
+if anyone has had a chance to take a look. It's very possible that it's
+been lost in the shuffle.
+
+## Getting more involved
+
+If you are participating in the xi-editor project, you may receive
+additional privileges:
+
+_Organization membership_: If you are regularly making contributions
+to a xi project, in any of the forms outlined above, we will be happy to
+add you to the xi-editor organization, which will give you the ability
+to do things like add labels to issues and view active projects.
+
+_Contributor_: If you are regularly making substantive contributions
+to a specific xi project, we will be happy to add you as a contributor
+to the repo in question. Contributors are encouraged to review and
+approve changes, respond to issues, and generally help to maintain
+the project in question.
+
+_Maintainer_: If you are making substantive contributions to multiple
+repos over an extended period, you are regularly reviewing the work of
+other contributors, and you are actively participating in planning and
+discussion, you may, (at the discretion of @raphlinus) be invited to
+take on the role of _maintainer_. Maintainers are responsible for
+coordinating the general direction of the project, resolving
+architectural questions, and doing the day to day work of moving the
+project forward.
diff --git a/Documentation/Doxygen/CMakeLists.txt b/Documentation/Doxygen/CMakeLists.txt
index c12d7f7869a6856f2a97589e7752a9d00b12124a..9fdd84f380bcc183ee79a31f2f4b6aa146a0909f 100644
--- a/Documentation/Doxygen/CMakeLists.txt
+++ b/Documentation/Doxygen/CMakeLists.txt
@@ -1,7 +1,11 @@
-find_package (Doxygen REQUIRED dot OPTIONAL_COMPONENTS mscgen dia)
+find_package (Doxygen OPTIONAL_COMPONENTS dot mscgen dia)
if (DOXYGEN_FOUND)
+ if (NOT DOXYGEN_DOT_EXECUTABLE)
+ message (FATAL_ERROR "Found doxygen but not 'dot' command, please install graphviz or set DOXYGEN_DOT_EXECUTABLE")
+ endif()
+
set (DOXYGEN_IN ${CMAKE_CURRENT_SOURCE_DIR}/Doxyfile.in)
set (DOXYGEN_OUT ${CMAKE_CURRENT_BINARY_DIR}/Doxyfile)
set (DOXYGEN_GENERATE_HTML YES)
@@ -28,4 +32,3 @@ else (DOXYGEN_FOUND)
message ("Doxygen need to be installed to generate the doxygen documentation")
endif (DOXYGEN_FOUND)
-
diff --git a/Documentation/Examples/CMakeLists.txt b/Documentation/Examples/CMakeLists.txt
index 237e7a0b218718a34373fa3f503c12a5486e53f3..2a66a3470584d14733e8a4651238e13b95756879 100644
--- a/Documentation/Examples/CMakeLists.txt
+++ b/Documentation/Examples/CMakeLists.txt
@@ -14,10 +14,24 @@ add_executable (stack_example stack_example.cc)
target_link_libraries (stack_example SuperStupidStack CORSIKAunits CORSIKAlogging)
install (TARGETS stack_example DESTINATION share/examples)
+add_executable (cascade_example cascade_example.cc)
+target_link_libraries (cascade_example SuperStupidStack CORSIKAunits CORSIKAlogging
+ CORSIKArandom
+ CORSIKAsibyll
+ CORSIKAcascade
+ ProcessStackInspector
+ CORSIKAprocesses
+ CORSIKAparticles
+ CORSIKAgeometry
+ CORSIKAprocesssequence
+ )
+install (TARGETS cascade_example DESTINATION share/examples)
+
add_executable (staticsequence_example staticsequence_example.cc)
target_link_libraries (staticsequence_example
CORSIKAprocesssequence
CORSIKAunits
+ CORSIKAgeometry
CORSIKAlogging)
install (TARGETS staticsequence_example DESTINATION share/examples)
diff --git a/Documentation/Examples/cascade_example.cc b/Documentation/Examples/cascade_example.cc
new file mode 100644
index 0000000000000000000000000000000000000000..34b55476d9a4f869bd9a29c51688d0f49e680c37
--- /dev/null
+++ b/Documentation/Examples/cascade_example.cc
@@ -0,0 +1,257 @@
+
+/**
+ * (c) Copyright 2018 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/cascade/Cascade.h>
+#include <corsika/process/ProcessSequence.h>
+#include <corsika/process/stack_inspector/StackInspector.h>
+#include <corsika/process/tracking_line/TrackingLine.h>
+
+#include <corsika/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+
+#include <corsika/random/RNGManager.h>
+
+#include <corsika/cascade/SibStack.h>
+#include <corsika/cascade/sibyll2.3c.h>
+#include <corsika/process/sibyll/ParticleConversion.h>
+
+#include <corsika/units/PhysicalUnits.h>
+using namespace corsika;
+using namespace corsika::process;
+using namespace corsika::units;
+using namespace corsika::particles;
+using namespace corsika::random;
+
+#include <iostream>
+#include <typeinfo>
+using namespace std;
+
+static int fCount = 0;
+
+class ProcessSplit : public corsika::process::BaseProcess<ProcessSplit> {
+public:
+ ProcessSplit() {}
+
+ template <typename Particle>
+ double MinStepLength(Particle& p, setup::Trajectory&) const {
+
+ // beam particles for sibyll : 1, 2, 3 for p, pi, k
+ // read from cross section code table
+ int kBeam = 1;
+
+ /*
+ the target should be defined by the Environment,
+ ideally as full particle object so that the four momenta
+ and the boosts can be defined..
+ */
+ // target nuclei: A < 18
+ // FOR NOW: assume target is oxygen
+ int kTarget = 1;
+ double beamEnergy = p.GetEnergy() / 1_GeV;
+ std::cout << "ProcessSplit: "
+ << "MinStep: en: " << beamEnergy << " pid:" << kBeam << std::endl;
+ double prodCrossSection, dummy, dum1, dum2, dum3, dum4;
+ double dumdif[3];
+
+ if (kTarget == 1)
+ sib_sigma_hp_(kBeam, beamEnergy, dum1, dum2, prodCrossSection, dumdif, dum3, dum4);
+ else
+ sib_sigma_hnuc_(kBeam, kTarget, beamEnergy, prodCrossSection, dummy);
+
+ std::cout << "ProcessSplit: "
+ << "MinStep: sibyll return: " << prodCrossSection << std::endl;
+ CrossSectionType sig = prodCrossSection * 1_mbarn;
+ std::cout << "ProcessSplit: "
+ << "MinStep: CrossSection (mb): " << sig / 1_mbarn << std::endl;
+
+ const MassType nucleon_mass = 0.93827_GeV / corsika::units::si::constants::cSquared;
+ std::cout << "ProcessSplit: "
+ << "nucleon mass " << nucleon_mass << std::endl;
+ // calculate interaction length in medium
+ double int_length = kTarget * (nucleon_mass / 1_g) / (sig / 1_cmeter / 1_cmeter);
+ // pick random step lenth
+ std::cout << "ProcessSplit: "
+ << "interaction length (g/cm2): " << int_length << std::endl;
+ // add exponential sampling
+ int a = 0;
+ const double next_step = -int_length * log(s_rndm_(a));
+ /*
+ what are the units of the output? slant depth or 3space length?
+
+ */
+ std::cout << "ProcessSplit: "
+ << "next step (g/cm2): " << next_step << std::endl;
+ return next_step;
+ }
+
+ template <typename Particle, typename Stack>
+ EProcessReturn DoContinuous(Particle&, Trajectory&, Stack&) const {
+ // corsika::utls::ignore(p);
+ return EProcessReturn::eOk;
+ }
+
+ template <typename Particle, typename Stack>
+ void DoDiscrete(Particle& p, Stack& s) const {
+ cout << "DoDiscrete: " << p.GetPID() << " interaction? "
+ << process::sibyll::CanInteract(p.GetPID()) << endl;
+ if (process::sibyll::CanInteract(p.GetPID())) {
+
+ // get energy of particle from stack
+ /*
+ stack is in GeV in lab. frame
+ convert to GeV in cm. frame
+ (assuming proton at rest as target AND
+ assuming no pT, i.e. shower frame-z is aligned with hadron-int-frame-z)
+ */
+ EnergyType E = p.GetEnergy();
+ EnergyType Ecm = sqrt(2. * E * 0.93827_GeV);
+
+ int kBeam = process::sibyll::ConvertToSibyllRaw(p.GetPID());
+
+ /*
+ the target should be defined by the Environment,
+ ideally as full particle object so that the four momenta
+ and the boosts can be defined..
+ */
+ // FOR NOW: set target to proton
+ int kTarget = 1; // p.GetPID();
+
+ std::cout << "ProcessSplit: "
+ << " DoDiscrete: E(GeV):" << E / 1_GeV << " Ecm(GeV): " << Ecm / 1_GeV
+ << std::endl;
+ if (E < 8.5_GeV || Ecm < 10_GeV) {
+ std::cout << "ProcessSplit: "
+ << " DoDiscrete: dropping particle.." << std::endl;
+ p.Delete();
+ fCount++;
+ } else {
+ // Sibyll does not know about units..
+ double sqs = Ecm / 1_GeV;
+ // running sibyll, filling stack
+ sibyll_(kBeam, kTarget, sqs);
+ // running decays
+ // decsib_();
+ // print final state
+ int print_unit = 6;
+ sib_list_(print_unit);
+
+ // delete current particle
+ p.Delete();
+
+ // add particles from sibyll to stack
+ // link to sibyll stack
+ SibStack ss;
+ /*
+ get transformation between Stack-frame and SibStack-frame
+ for EAS Stack-frame is lab. frame, could be different for CRMC-mode
+ the transformation should be derived from the input momenta
+ in general transformation is rotation + boost
+ */
+ const EnergyType proton_mass = 0.93827_GeV;
+ const double gamma = (E + proton_mass) / (Ecm);
+ const double gambet = sqrt(E * E - proton_mass * proton_mass) / Ecm;
+
+ // SibStack does not know about momentum yet so we need counter to access momentum
+ // array in Sibyll
+ int i = -1;
+ for (auto& p : ss) {
+ ++i;
+ // transform to lab. frame, primitve
+ const double en_lab = gambet * s_plist_.p[2][i] + gamma * p.GetEnergy();
+ // add to corsika stack
+ auto pnew = s.NewParticle();
+ pnew.SetEnergy(en_lab * 1_GeV);
+ pnew.SetPID(process::sibyll::ConvertFromSibyll(p.GetPID()));
+ }
+ }
+ } else
+ p.Delete();
+ }
+
+ void Init() {
+ fCount = 0;
+
+ // define reference frame? --> defines boosts between corsika stack and model stack.
+
+ // initialize random numbers for sibyll
+ // FOR NOW USE SIBYLL INTERNAL !!!
+ // rnd_ini_();
+
+ corsika::random::RNGManager& rmng = corsika::random::RNGManager::GetInstance();
+ ;
+ const std::string str_name = "s_rndm";
+ rmng.RegisterRandomStream(str_name);
+
+ // // corsika::random::RNG srng;
+ // auto srng = rmng.GetRandomStream("s_rndm");
+
+ // test random number generator
+ std::cout << "ProcessSplit: "
+ << " test sequence of random numbers." << std::endl;
+ int a = 0;
+ for (int i = 0; i < 8; ++i) std::cout << i << " " << s_rndm_(a) << std::endl;
+
+ // initialize Sibyll
+ sibyll_ini_();
+
+ // set particles stable / unstable
+ // use stack to loop over particles
+ setup::Stack ds;
+ ds.NewParticle().SetPID(Code::Proton);
+ ds.NewParticle().SetPID(Code::Neutron);
+ ds.NewParticle().SetPID(Code::PiPlus);
+ ds.NewParticle().SetPID(Code::PiMinus);
+ ds.NewParticle().SetPID(Code::KPlus);
+ ds.NewParticle().SetPID(Code::KMinus);
+ ds.NewParticle().SetPID(Code::K0Long);
+ ds.NewParticle().SetPID(Code::K0Short);
+
+ for (auto& p : ds) {
+ int s_id = process::sibyll::ConvertToSibyllRaw(p.GetPID());
+ // set particle stable by setting table value negative
+ cout << "ProcessSplit: Init: setting " << p.GetPID() << "(" << s_id << ")"
+ << " stable in Sibyll .." << endl;
+ s_csydec_.idb[s_id] = -s_csydec_.idb[s_id - 1];
+ p.Delete();
+ }
+ }
+
+ int GetCount() { return fCount; }
+
+private:
+};
+
+double s_rndm_(int&) {
+ static corsika::random::RNG& rmng =
+ corsika::random::RNGManager::GetInstance().GetRandomStream("s_rndm");
+ ;
+ return rmng() / (double)rmng.max();
+}
+
+int main() {
+
+ tracking_line::TrackingLine<setup::Stack> tracking;
+ stack_inspector::StackInspector<setup::Stack> p0(true);
+ ProcessSplit p1;
+ const auto sequence = p0 + p1;
+ setup::Stack stack;
+
+ corsika::cascade::Cascade EAS(tracking, sequence, stack);
+
+ stack.Clear();
+ auto particle = stack.NewParticle();
+ EnergyType E0 = 100_GeV;
+ particle.SetEnergy(E0);
+ particle.SetPID(Code::Proton);
+ EAS.Init();
+ EAS.Run();
+ cout << "Result: E0=" << E0 / 1_GeV << "GeV, count=" << p1.GetCount() << endl;
+}
diff --git a/Documentation/Examples/geometry_example.cc b/Documentation/Examples/geometry_example.cc
index 6a05974fd6d5e0224d809072b99979e29578f7d2..5bacd1489ab9bff7add254ad8edc70ccada9ea43 100644
--- a/Documentation/Examples/geometry_example.cc
+++ b/Documentation/Examples/geometry_example.cc
@@ -1,5 +1,16 @@
-#include <corsika/geometry/CoordinateSystem.h>
+
+/**
+ * (c) Copyright 2018 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/geometry/Point.h>
+#include <corsika/geometry/RootCoordinateSystem.h>
#include <corsika/geometry/Sphere.h>
#include <corsika/geometry/Vector.h>
#include <corsika/units/PhysicalUnits.h>
@@ -8,12 +19,14 @@
#include <iostream>
#include <typeinfo>
+using namespace corsika;
using namespace corsika::geometry;
using namespace corsika::units::si;
int main() {
// define the root coordinate system
- CoordinateSystem root;
+ geometry::CoordinateSystem& root =
+ geometry::RootCoordinateSystem::GetInstance().GetRootCS();
// another CS defined by a translation relative to the root CS
CoordinateSystem cs2 = root.translate({0_m, 0_m, 1_m});
@@ -39,10 +52,10 @@ int main() {
std::cout << "p2-p1 norm^2: " << norm << std::endl;
Sphere s(p1, 10_m); // define a sphere around a point with a radius
- std::cout << "p1 inside s: " << s.isInside(p2) << std::endl;
+ std::cout << "p1 inside s: " << s.Contains(p2) << std::endl;
Sphere s2(p1, 3_um); // another sphere
- std::cout << "p1 inside s2: " << s2.isInside(p2) << std::endl;
+ std::cout << "p1 inside s2: " << s2.Contains(p2) << std::endl;
// let's try parallel projections:
auto const v1 = Vector<length_d>(root, {1_m, 1_m, 0_m});
diff --git a/Documentation/Examples/helix_example.cc b/Documentation/Examples/helix_example.cc
index 9d6cdb23c5de0e2f4dd879cc63179a0ba3dd6ab7..c51afce291181a4629b4fceaf776b0bfa9fc40cd 100644
--- a/Documentation/Examples/helix_example.cc
+++ b/Documentation/Examples/helix_example.cc
@@ -1,18 +1,30 @@
-#include <corsika/geometry/CoordinateSystem.h>
+
+/**
+ * (c) Copyright 2018 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/geometry/Helix.h>
#include <corsika/geometry/Point.h>
+#include <corsika/geometry/RootCoordinateSystem.h>
#include <corsika/geometry/Vector.h>
#include <corsika/units/PhysicalUnits.h>
#include <array>
#include <cstdlib>
#include <iostream>
+using namespace corsika;
using namespace corsika::geometry;
using namespace corsika::units::si;
int main() {
-
- CoordinateSystem root;
+ geometry::CoordinateSystem& root =
+ geometry::RootCoordinateSystem::GetInstance().GetRootCS();
Point const r0(root, {0_m, 0_m, 0_m});
auto const omegaC = 2 * M_PI * 1_Hz;
diff --git a/Documentation/Examples/logger_example.cc b/Documentation/Examples/logger_example.cc
index 94fcb588a2b4ebe225dd7750a17d5beb66abda38..1bd72012ec936e33d9caf791f240d1f7b24dde0b 100644
--- a/Documentation/Examples/logger_example.cc
+++ b/Documentation/Examples/logger_example.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/logging/Logger.h>
#include <boost/format.hpp>
#include <fstream>
diff --git a/Documentation/Examples/stack_example.cc b/Documentation/Examples/stack_example.cc
index 691cdb38440e916ee97f637705ea2bbfe3db89ba..f0a04f79be09dff2c58a74bc4822c443c12061f0 100644
--- a/Documentation/Examples/stack_example.cc
+++ b/Documentation/Examples/stack_example.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/stack/super_stupid/SuperStupidStack.h>
#include <iomanip>
diff --git a/Documentation/Examples/staticsequence_example.cc b/Documentation/Examples/staticsequence_example.cc
index 6b840673999e3066ac6a21d8cb6229593b74198f..07cc7561e0a8222e26d9e5b7eeba8ced68f6f63b 100644
--- a/Documentation/Examples/staticsequence_example.cc
+++ b/Documentation/Examples/staticsequence_example.cc
@@ -1,9 +1,25 @@
+
+/**
+ * (c) Copyright 2018 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 <array>
#include <iomanip>
#include <iostream>
#include <corsika/process/ProcessSequence.h>
+#include <corsika/setup/SetupTrajectory.h> // TODO: try to break this dependence later
+using corsika::setup::Trajectory;
+#include <corsika/units/PhysicalUnits.h> // dito
+using namespace corsika::units::si;
+
using namespace std;
using namespace corsika::process;
@@ -11,8 +27,9 @@ class Process1 : public BaseProcess<Process1> {
public:
Process1() {}
template <typename D, typename T, typename S>
- void DoContinuous(D& d, T& t, S& s) const {
+ EProcessReturn DoContinuous(D& d, T&, S&) const {
for (int i = 0; i < 10; ++i) d.p[i] += 1;
+ return EProcessReturn::eOk;
}
};
@@ -21,8 +38,9 @@ public:
Process2() {}
template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
+ inline EProcessReturn DoContinuous(D&, T&, S&) const {
// for (int i=0; i<10; ++i) d.p[i] *= 2;
+ return EProcessReturn::eOk;
}
};
@@ -32,8 +50,9 @@ public:
Process3() {}
template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
+ inline EProcessReturn DoContinuous(D& /*d*/, T& /*t*/, S& /*s*/) const {
// for (int i=0; i<10; ++i) d.p[i] += fV;
+ return EProcessReturn::eOk;
}
private:
@@ -45,8 +64,9 @@ public:
// Process4(const int v) : fV(v) {}
Process4() {}
template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
+ inline EProcessReturn DoContinuous(D& /*d*/, T& /*t*/, S& /*s*/) const {
// for (int i=0; i<10; ++i) d.p[i] /= fV;
+ return EProcessReturn::eOk;
}
private:
@@ -57,7 +77,6 @@ struct DummyData {
double p[10];
};
struct DummyStack {};
-struct DummyTrajectory {};
void modular() {
@@ -69,8 +88,8 @@ void modular() {
const auto sequence = m1 + m2 + m3 + m4;
DummyData p;
- DummyTrajectory t;
DummyStack s;
+ Trajectory t;
const int n = 100000000;
for (int i = 0; i < n; ++i) { sequence.DoContinuous(p, t, s); }
diff --git a/Environment/FlatAtmosphere/FlatAtmosphere.h b/Environment/FlatAtmosphere/FlatAtmosphere.h
index 8b137891791fe96927ad78e64b0aad7bded08bdc..90582b3dfb00d2d85850b81455a2a4c0c061413b 100644
--- a/Environment/FlatAtmosphere/FlatAtmosphere.h
+++ b/Environment/FlatAtmosphere/FlatAtmosphere.h
@@ -1 +1,10 @@
+/**
+ * (c) Copyright 2018 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.
+ */
diff --git a/Framework/CMakeLists.txt b/Framework/CMakeLists.txt
index 836d6711076f67f13e889f6d051b4222a6e04e9d..2f7cd2b3e6f04e403e40c72946aa0a241b8f91bb 100644
--- a/Framework/CMakeLists.txt
+++ b/Framework/CMakeLists.txt
@@ -1,4 +1,5 @@
+add_subdirectory (Utilities)
add_subdirectory (Units)
add_subdirectory (Geometry)
add_subdirectory (Particles)
@@ -6,3 +7,4 @@ add_subdirectory (Logging)
add_subdirectory (StackInterface)
add_subdirectory (ProcessSequence)
add_subdirectory (Cascade)
+add_subdirectory (Random)
diff --git a/Framework/Cascade/CMakeLists.txt b/Framework/Cascade/CMakeLists.txt
index 63fe2cb858b3709bccb3d12fda1b3d5160327dff..ad48313530b2df7dfcbda79cf8dcaf2791a0bf18 100644
--- a/Framework/Cascade/CMakeLists.txt
+++ b/Framework/Cascade/CMakeLists.txt
@@ -9,16 +9,33 @@ set (
set (
CORSIKAcascade_HEADERS
Cascade.h
+ sibyll2.3c.h
+ SibStack.h
)
#set (
# CORSIKAcascade_SOURCES
+# TrackingStep.cc
# Cascade.cc
# )
+set (
+ CORSIKAsibyll_NAMESPACE
+ corsika/cascade
+ )
+
+set (
+ CORSIKAsibyll_SOURCES
+ sibyll2.3c.f
+ gasdev.f
+ )
+add_library (CORSIKAsibyll STATIC ${CORSIKAsibyll_SOURCES})
+
#add_library (CORSIKAcascade STATIC ${CORSIKAcascade_SOURCES})
add_library (CORSIKAcascade INTERFACE)
+
+
CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKAcascade ${CORSIKAcascade_NAMESPACE} ${CORSIKAcascade_HEADERS})
#target_link_libraries (
@@ -51,11 +68,16 @@ add_executable (
target_link_libraries (
testCascade
+ # CORSIKAutls
+ CORSIKArandom
+ CORSIKAsibyll
CORSIKAcascade
+ ProcessStackInspector
+ CORSIKAstackinterface
+ CORSIKAprocesses
CORSIKAparticles
CORSIKAgeometry
CORSIKAprocesssequence
- SuperStupidStack
CORSIKAunits
CORSIKAthirdparty # for catch2
)
diff --git a/Framework/Cascade/Cascade.cc b/Framework/Cascade/Cascade.cc
index 1bd6b5b2b1c2681edb48e77f51028ad54d10bf08..5844785262187001c913927b3fd7bbc7e87b5d44 100644
--- a/Framework/Cascade/Cascade.cc
+++ b/Framework/Cascade/Cascade.cc
@@ -1,20 +1,25 @@
+
+/**
+ * (c) Copyright 2018 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/cascade/Cascade.h>
using namespace corsika::cascade;
-template <typename ProcessList, typename Particle, typename Trajectory, typename Stack>
-Cascade<ProcessList, Particle, Trajectory, Stack>::Cascade() {
- // kkk;
- // kk;
-}
-
-template <typename ProcessList, typename Particle, typename Trajectory, typename Stack>
+template <typename ProcessList, typename Stack> //, typename Trajectory>
void Cascade::Init() {
fStack.Init();
fProcesseList.Init();
}
-template <typename ProcessList, typename Particle, typename Trajectory, typename Stack>
+template <typename ProcessList, typename Stack> //, typename Trajectory>
void Cascade::Run() {
if (!fStack.IsEmpty()) {
if (!fStack.IsEmpty()) {
@@ -27,10 +32,12 @@ void Cascade::Run() {
}
}
-template <typename Sequence, typename Trajectory>
+template <typename ProcessList, typename Stack> //, typename Trajectory>
void Cascade::Step(Particle& particle) {
double nextStep = fProcesseList.MinStepLength(particle);
- Trajectory trajectory = fProcesseList.Transport(particle, nextStep);
+ corsika::geometry::LineTrajectory trajectory =
+ fProcesseList.Transport(particle, nextStep);
sequence.DoContinuous(particle, trajectory);
+ // whats going on here? Everywhere else DoDiscrete is passed a Stack reference as well
sequence.DoDiscrete(particle);
}
diff --git a/Framework/Cascade/Cascade.h b/Framework/Cascade/Cascade.h
index 3ef8ce9289cd1240e1d9897ddf87e881fb447c1a..e46960dc9c3d8e8c33254c2751a601ab72843a18 100644
--- a/Framework/Cascade/Cascade.h
+++ b/Framework/Cascade/Cascade.h
@@ -1,46 +1,57 @@
-#ifndef _include_Cascade_h_
-#define _include_Cascade_h_
-#include <corsika/geometry/LineTrajectory.h> // to be removed
-#include <corsika/geometry/Point.h> // to be removed
+/**
+ * (c) Copyright 2018 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_corsika_cascade_Cascade_h_
+#define _include_corsika_cascade_Cascade_h_
+
+#include <corsika/process/ProcessReturn.h>
#include <corsika/units/PhysicalUnits.h>
+#include <type_traits>
+
+#include <corsika/setup/SetupTrajectory.h>
+
using namespace corsika::units::si;
namespace corsika::cascade {
- template <typename Trajectory, typename ProcessList, typename Stack>
+ template <typename Tracking, typename ProcessList, typename Stack>
class Cascade {
typedef typename Stack::ParticleType Particle;
+ Cascade() = delete;
+
public:
- Cascade(ProcessList& pl, Stack& stack)
- : fProcesseList(pl)
- , fStack(stack) {}
+ Cascade(Tracking& tr, ProcessList& pl, Stack& stack)
+ : fTracking(tr)
+ , fProcesseList(pl)
+ , fStack(stack) {
+ // static_assert(std::is_member_function_pointer<decltype(&ProcessList::DoDiscrete)>::value,
+ //"ProcessList has not function DoDiscrete.");
+ // static_assert(std::is_member_function_pointer<decltype(&ProcessList::DoContinuous)>::value,
+ // "ProcessList has not function DoContinuous.");
+ }
void Init() {
- fStack.Init();
+ fTracking.Init();
fProcesseList.Init();
+ fStack.Init();
}
void Run() {
while (!fStack.IsEmpty()) {
while (!fStack.IsEmpty()) {
- //Particle& p = *fStack.GetNextParticle();
- EnergyType Emin;
- typename Stack::StackIterator pMin(fStack, 0);
- bool first = true;
- for (typename Stack::StackIterator ip = fStack.begin(); ip!=fStack.end(); ++ip)
- {
- if (first || ip.GetEnergy()<Emin) {
- first = false;
- pMin = ip;
- Emin = pMin.GetEnergy();
- }
- }
-
- Step(pMin);
+ Particle& pNext = *fStack.GetNextParticle();
+ Step(pNext);
}
// do cascade equations, which can put new particles on Stack,
// thus, the double loop
@@ -49,24 +60,25 @@ namespace corsika::cascade {
}
void Step(Particle& particle) {
- double nextStep = fProcesseList.MinStepLength(particle);
- corsika::geometry::CoordinateSystem root;
- Trajectory trajectory(
- corsika::geometry::Point(root, {0_m, 0_m, 0_m}),
- corsika::geometry::Vector<corsika::units::si::SpeedType::dimension_type>(
- root, 0 * 1_m / second, 0 * 1_m / second, 1 * 1_m / second));
- fProcesseList.DoContinuous(particle, trajectory, fStack);
- // if (particle.IsMarkedToBeDeleted())
- {
- // std::cout << "DELETET THISSKSKJD!" << std::endl;
- // fStack.Delete(particle);
+ corsika::setup::Trajectory step = fTracking.GetTrack(particle);
+ fProcesseList.MinStepLength(particle, step);
+
+ /// here the particle is actually moved along the trajectory to new position:
+ std::visit(corsika::setup::ParticleUpdate<Particle>{particle}, step);
+
+ corsika::process::EProcessReturn status =
+ fProcesseList.DoContinuous(particle, step, fStack);
+ if (status == corsika::process::EProcessReturn::eParticleAbsorbed) {
+ fStack.Delete(particle); // TODO: check if this is really needed
+ } else {
+ fProcesseList.DoDiscrete(particle, fStack);
}
- fProcesseList.DoDiscrete(particle, fStack);
}
private:
- Stack& fStack;
+ Tracking& fTracking;
ProcessList& fProcesseList;
+ Stack& fStack;
};
} // namespace corsika::cascade
diff --git a/Framework/Cascade/SibStack.h b/Framework/Cascade/SibStack.h
new file mode 100644
index 0000000000000000000000000000000000000000..7e9bd3bac3bc743bea8fcb0c2b0d1d401e16efae
--- /dev/null
+++ b/Framework/Cascade/SibStack.h
@@ -0,0 +1,59 @@
+#ifndef _include_sibstack_h_
+#define _include_sibstack_h_
+
+#include <string>
+#include <vector>
+
+#include <corsika/cascade/sibyll2.3c.h>
+#include <corsika/process/sibyll/ParticleConversion.h>
+#include <corsika/stack/Stack.h>
+
+using namespace std;
+using namespace corsika::stack;
+
+class SibStackData {
+
+public:
+ void Init();
+
+ void Clear() { s_plist_.np = 0; }
+
+ int GetSize() const { return s_plist_.np; }
+ int GetCapacity() const { return 8000; }
+
+ void SetId(const int i, const int v) { s_plist_.llist[i] = v; }
+ void SetEnergy(const int i, const double v) { s_plist_.p[3][i] = v; }
+
+ int GetId(const int i) const { return s_plist_.llist[i]; }
+ double GetEnergy(const int i) const { return s_plist_.p[3][i]; }
+
+ void Copy(const int i1, const int i2) {
+ s_plist_.llist[i1] = s_plist_.llist[i2];
+ s_plist_.p[3][i1] = s_plist_.p[3][i2];
+ }
+
+protected:
+ void IncrementSize() { s_plist_.np++; }
+ void DecrementSize() {
+ if (s_plist_.np > 0) { s_plist_.np--; }
+ }
+};
+
+template <typename StackIteratorInterface>
+class ParticleInterface : public ParticleBase<StackIteratorInterface> {
+ using ParticleBase<StackIteratorInterface>::GetStackData;
+ using ParticleBase<StackIteratorInterface>::GetIndex;
+
+public:
+ void SetEnergy(const double v) { GetStackData().SetEnergy(GetIndex(), v); }
+ double GetEnergy() const { return GetStackData().GetEnergy(GetIndex()); }
+ void SetPID(const int v) { GetStackData().SetId(GetIndex(), v); }
+ corsika::process::sibyll::SibyllCode GetPID() const {
+ return static_cast<corsika::process::sibyll::SibyllCode>(
+ GetStackData().GetId(GetIndex()));
+ }
+};
+
+typedef Stack<SibStackData, ParticleInterface> SibStack;
+
+#endif
diff --git a/Framework/Cascade/Step.cc b/Framework/Cascade/Step.cc
index 60349c748f8438857a5dc4ffda338063a180634f..503bc80b1644ce66d60e9e80e9627c8d9c3daefa 100644
--- a/Framework/Cascade/Step.cc
+++ b/Framework/Cascade/Step.cc
@@ -1,4 +1,13 @@
+/**
+ * (c) Copyright 2018 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.
+ */
namespace cascade;
diff --git a/Framework/Cascade/gasdev.f b/Framework/Cascade/gasdev.f
new file mode 100644
index 0000000000000000000000000000000000000000..70dca8c8fbc6062b47d8b8734340fba597d1ea98
--- /dev/null
+++ b/Framework/Cascade/gasdev.f
@@ -0,0 +1,27 @@
+ DOUBLE PRECISION FUNCTION GASDEV(Idum)
+C***********************************************************************
+C Gaussian deviation
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /RNDMGAS/ ISET
+ SAVE
+ DATA ISET/0/
+ gasdev=idum
+ IF (ISET.EQ.0) THEN
+1 V1=2.D0*S_RNDM(0)-1.D0
+ V2=2.D0*S_RNDM(1)-1.D0
+ R=V1**2+V2**2
+ IF(R.GE.1.D0)GO TO 1
+ FAC=SQRT(-2.D0*LOG(R)/R)
+ GSET=V1*FAC
+ GASDEV=V2*FAC
+ ISET=1
+ ELSE
+ GASDEV=GSET
+ ISET=0
+ ENDIF
+ RETURN
+ END
+C***********************************************************************
+
diff --git a/Framework/Cascade/rndm_dbl.f b/Framework/Cascade/rndm_dbl.f
new file mode 100644
index 0000000000000000000000000000000000000000..42db719788f480150f95c2a68d73cc706647586c
--- /dev/null
+++ b/Framework/Cascade/rndm_dbl.f
@@ -0,0 +1,416 @@
+C***********************************************************************
+C
+C interface to PHOJET double precision random number generator
+C for SIBYLL \FR'14
+C
+C***********************************************************************
+ DOUBLE PRECISION FUNCTION S_RNDM(IDUMMY)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DUMMY = dble(IDUMMY)
+ S_RNDM= PHO_RNDM(DUMMY)
+ END
+
+C***********************************************************************
+C
+C initialization routine for double precision random number generator
+C calls PHO_RNDIN \FR'14
+C
+C***********************************************************************
+ SUBROUTINE RND_INI
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ COMMON /RNDMGAS/ ISET
+ ISET = 0
+ CALL PHO_RNDIN(12,34,56,78)
+ END
+
+
+ DOUBLE PRECISION FUNCTION GASDEV(Idum)
+C***********************************************************************
+C Gaussian deviation
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /RNDMGAS/ ISET
+ SAVE
+ DATA ISET/0/
+ gasdev=idum
+ IF (ISET.EQ.0) THEN
+1 V1=2.D0*S_RNDM(0)-1.D0
+ V2=2.D0*S_RNDM(1)-1.D0
+ R=V1**2+V2**2
+ IF(R.GE.1.D0)GO TO 1
+ FAC=SQRT(-2.D0*LOG(R)/R)
+ GSET=V1*FAC
+ GASDEV=V2*FAC
+ ISET=1
+ ELSE
+ GASDEV=GSET
+ ISET=0
+ ENDIF
+ RETURN
+ END
+C***********************************************************************
+
+
+ DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
+C***********************************************************************
+C
+C random number generator
+C
+C initialization by call to PHO_RNDIN needed!
+C
+C the algorithm is taken from
+C G.Marsaglia, A.Zaman: 'Toward a unversal random number generator'
+C Florida State Univ. preprint FSU-SCRI-87-70
+C
+C implementation by K. Hahn (Dec. 88), changed to include possibility
+C of saving / reading generator registers to / from file (R.E. 10/98)
+C
+C generator should not depend on the hardware (if a real has
+C at least 24 significant bits in internal representation),
+C the period is about 2**144,
+C
+C internal registers:
+C U(97),C,CD,CM,I,J - seed values as initialized in PHO_RNDIN
+C
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /PORAND/ U(97),C,CD,CM,I,J
+
+ 100 CONTINUE
+ RNDMI = DUMMY
+ RNDMI = U(I)-U(J)
+ IF ( RNDMI.LT.0.D0 ) RNDMI = RNDMI+1.D0
+ U(I) = RNDMI
+ I = I-1
+ IF ( I.EQ.0 ) I = 97
+ J = J-1
+ IF ( J.EQ.0 ) J = 97
+ C = C-CD
+ IF ( C.LT.0.D0 ) C = C+CM
+ RNDMI = RNDMI-C
+ IF ( RNDMI.LT.0.D0 ) RNDMI = RNDMI+1.D0
+
+ IF((ABS(RNDMI).LT.0.D0).OR.(ABS(RNDMI-1.D0).LT.1.D-10)) GOTO 100
+ PHO_RNDM = RNDMI
+
+ END
+
+
+CDECK ID>, PHO_RNDIN
+ SUBROUTINE PHO_RNDIN(NA1,NA2,NA3,NB1)
+C***********************************************************************
+C
+C initialization of PHO_RNDM, has to be called before using PHO_RNDM
+C
+C input:
+C NA1,NA2,NA3,NB1 - values for initializing the generator
+C NA? must be in 1..178 and not all 1;
+C 12,34,56 are the standard values
+C NB1 must be in 1..168;
+C 78 is the standard value
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ COMMON /PORAND/ U(97),C,CD,CM,I,J
+ MA1 = NA1
+ MA2 = NA2
+ MA3 = NA3
+ MB1 = NB1
+ I = 97
+ J = 33
+ DO 20 II2 = 1,97
+ S = 0.D0
+ T = 0.5D0
+ DO 10 II1 = 1,24
+ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
+ MA1 = MA2
+ MA2 = MA3
+ MA3 = MAT
+ MB1 = MOD(53*MB1+1,169)
+ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
+ T = 0.5D0*T
+ 10 CONTINUE
+ U(II2) = S
+ 20 CONTINUE
+ C = 362436.D0/16777216.D0
+ CD = 7654321.D0/16777216.D0
+ CM = 16777213.D0/16777216.D0
+
+ END
+
+
+CDECK ID>, PHO_RNDSI
+ SUBROUTINE PHO_RNDSI(UIN,CIN,CDIN,CMIN,IIN,JIN)
+C***********************************************************************
+C
+C updates internal random number generator registers using
+C registers given as arguments
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION UIN(97)
+ COMMON /PORAND/ U(97),C,CD,CM,I,J
+ DO 10 KKK = 1,97
+ U(KKK) = UIN(KKK)
+ 10 CONTINUE
+ C = CIN
+ CD = CDIN
+ CM = CMIN
+ I = IIN
+ J = JIN
+
+ END
+
+
+CDECK ID>, PHO_RNDSO
+ SUBROUTINE PHO_RNDSO(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
+C***********************************************************************
+C
+C copies internal registers from randon number generator
+C to arguments
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+ DIMENSION UOUT(97)
+ COMMON /PORAND/ U(97),C,CD,CM,I,J
+ DO 10 KKK = 1,97
+ UOUT(KKK) = U(KKK)
+ 10 CONTINUE
+ COUT = C
+ CDOUT = CD
+ CMOUT = CM
+ IOUT = I
+ JOUT = J
+
+ END
+
+
+CDECK ID>, PHO_RNDTE
+ SUBROUTINE PHO_RNDTE(IO)
+C***********************************************************************
+C
+C test of random number generator PHO_RNDM
+C
+C input:
+C IO defines output
+C 0 output only if an error is detected
+C 1 output independend on an error
+C
+C uses PHO_RNDSI and PHO_RNDSO to bring the random number generator
+C to same status as it had before the test run
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ SAVE
+
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+ DIMENSION UU(97)
+ DIMENSION U(6),X(6),D(6)
+ DATA U / 6533892.D0 , 14220222.D0 , 7275067.D0 ,
+ & 6172232.D0 , 8354498.D0 , 10633180.D0 /
+
+ CALL PHO_RNDSO(UU,CC,CCD,CCM,II,JJ)
+
+ CALL PHO_RNDIN(12,34,56,78)
+ DO 10 II1 = 1,20000
+ XX = PHO_RNDM(SD)
+ 10 CONTINUE
+
+ SD = 0.D0
+ DO 20 II2 = 1,6
+ X(II2) = 4096.D0*(4096.D0*PHO_RNDM(XX))
+ D(II2) = X(II2)-U(II2)
+ SD = SD+ABS(D(II2))
+ 20 CONTINUE
+
+ CALL PHO_RNDSI(UU,CC,CCD,CCM,II,JJ)
+
+ IF ((IO.EQ.1).OR.(ABS(SD).GT.0.D-10)) THEN
+ WRITE(LO,50) (U(I),X(I),D(I),I=1,6)
+ ENDIF
+
+ 50 FORMAT(/,' PHO_RNDTE: test of the random number generator:',/,
+ & ' expected value calculated value difference',/,
+ & 6(F17.1,F20.1,F15.3,/),
+ & ' generator has the same status as before calling PHO_RNDTE',/)
+
+ END
+
+
+CDECK ID>, PHO_RNDST
+ SUBROUTINE PHO_RNDST(MODE,FILENA)
+C***********************************************************************
+C
+C read / write random number generator status from / to file
+C
+C input: MODE 1 read registers from file
+C 2 dump registers to file
+C
+C FILENA file name
+C
+C***********************************************************************
+
+ IMPLICIT NONE
+
+
+
+ SAVE
+
+ INTEGER MODE
+ CHARACTER*(*) FILENA
+
+
+C input/output channels
+ INTEGER LI,LO
+ COMMON /POINOU/ LI,LO
+
+
+ DOUBLE PRECISION UU,CC,CCD,CCM
+ DIMENSION UU(97)
+
+ INTEGER I,II,JJ
+
+ CHARACTER*80 CH_DUMMY
+
+ IF(MODE.EQ.1) THEN
+
+ WRITE(LO,'(/,1X,2A,A,/)') 'PHO_RNDST: ',
+ & 'reading random number registers from file ',FILENA
+
+ OPEN(12,FILE=FILENA,ERR=1010,STATUS='OLD')
+ READ(12,*,ERR=1010) CH_DUMMY
+ DO I=1,97
+ READ(12,*,ERR=1010) UU(I)
+ ENDDO
+ READ(12,*,ERR=1010) CC
+ READ(12,*,ERR=1010) CCD
+ READ(12,*,ERR=1010) CCM
+ READ(12,*,ERR=1010) II,JJ
+ CLOSE(12)
+ CALL PHO_RNDSI(UU,CC,CCD,CCM,II,JJ)
+
+ ELSE IF(MODE.EQ.2) THEN
+
+ WRITE(LO,'(/,1X,2A,A,/)') 'PHO_RNDST: ',
+ & 'dumping random number registers to file ',FILENA
+
+ OPEN(12,FILE=FILENA,ERR=1010,STATUS='UNKNOWN')
+ CALL PHO_RNDSO(UU,CC,CCD,CCM,II,JJ)
+ WRITE(12,'(1X,A)',ERR=1020) 'random number status registers:'
+ DO I=1,97
+ WRITE(12,'(1X,1P,E28.20)',ERR=1020) UU(I)
+ ENDDO
+ WRITE(12,'(1X,1P,E28.20)',ERR=1020) CC
+ WRITE(12,'(1X,1P,E28.20)',ERR=1020) CCD
+ WRITE(12,'(1X,1P,E28.20)',ERR=1020) CCM
+ WRITE(12,'(1X,2I4)',ERR=1020) II,JJ
+ CLOSE(12)
+
+ ELSE
+
+ WRITE(LO,'(/,1X,2A,I6,/)') 'PHO_RNDST: ',
+ & 'called with invalid mode, nothing done (mode)',MODE
+
+ ENDIF
+
+ RETURN
+
+ 1010 CONTINUE
+ WRITE(LO,'(1X,2A,A,/)') 'PHO_RNDST: ',
+ & 'cannot open or read file ',FILENA
+ RETURN
+
+ 1020 CONTINUE
+ WRITE(LO,'(1X,A,A,/)') 'PHO_RNDST: ',
+ & 'cannot open or write file ',FILENA
+ RETURN
+
+ END
+
+C----------------------------------------
+C standard generator
+C----------------------------------------
+ REAL FUNCTION S_RNDM_std(IDUMMY)
+C...Generator from the LUND montecarlo
+C...Purpose: to generate random numbers uniformly distributed between
+C...0 and 1, excluding the endpoints.
+ COMMON/LUDATR/MRLU(6),RRLU(100)
+ SAVE /LUDATR/
+ EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
+ &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
+ &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
+
+C... Initialize generation from given seed.
+ S_RNDM_std = real(idummy)
+ IF(MRLU2.EQ.0) THEN
+ IF (MRLU1 .EQ. 0) MRLU1 = 19780503 ! initial seed
+ IJ=MOD(MRLU1/30082,31329)
+ KL=MOD(MRLU1,30082)
+ I=MOD(IJ/177,177)+2
+ J=MOD(IJ,177)+2
+ K=MOD(KL/169,178)+1
+ L=MOD(KL,169)
+ DO 110 II=1,97
+ S=0.
+ T=0.5
+ DO 100 JJ=1,24
+ M=MOD(MOD(I*J,179)*K,179)
+ I=J
+ J=K
+ K=M
+ L=MOD(53*L+1,169)
+ IF(MOD(L*M,64).GE.32) S=S+T
+ T=0.5*T
+ 100 CONTINUE
+ RRLU(II)=S
+ 110 CONTINUE
+ TWOM24=1.
+ DO 120 I24=1,24
+ TWOM24=0.5*TWOM24
+ 120 CONTINUE
+ RRLU98=362436.*TWOM24
+ RRLU99=7654321.*TWOM24
+ RRLU00=16777213.*TWOM24
+ MRLU2=1
+ MRLU3=0
+ MRLU4=97
+ MRLU5=33
+ ENDIF
+
+C...Generate next random number.
+ 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
+ IF(RUNI.LT.0.) RUNI=RUNI+1.
+ RRLU(MRLU4)=RUNI
+ MRLU4=MRLU4-1
+ IF(MRLU4.EQ.0) MRLU4=97
+ MRLU5=MRLU5-1
+ IF(MRLU5.EQ.0) MRLU5=97
+ RRLU98=RRLU98-RRLU99
+ IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
+ RUNI=RUNI-RRLU98
+ IF(RUNI.LT.0.) RUNI=RUNI+1.
+ IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
+
+C...Update counters. Random number to output.
+ MRLU3=MRLU3+1
+ IF(MRLU3.EQ.1000000000) THEN
+ MRLU2=MRLU2+1
+ MRLU3=0
+ ENDIF
+ S_RNDM_std=RUNI
+
+ END
diff --git a/Framework/Cascade/sibyll2.3c.f b/Framework/Cascade/sibyll2.3c.f
new file mode 100644
index 0000000000000000000000000000000000000000..7f7d524d3c84fc2d5645a7d05d6b3ff134184c3e
--- /dev/null
+++ b/Framework/Cascade/sibyll2.3c.f
@@ -0,0 +1,23906 @@
+C=======================================================================
+C SSSSSS IIIIIII BBBBB YY YY L L
+C S I B B YY YY L L
+C SSSSS I BBBBB YY L L
+C S I B B YY L L
+C SSSSSS IIIIIII BBBBB YY LLLLLLL LLLLLLL
+C=======================================================================
+C Code for SIBYLL: hadronic interaction Monte Carlo event generator
+C=======================================================================
+C Version 2.3c02 (Jun-01-2017, modified Dec-11-2017)
+C
+C with CHARM production
+C
+C By Eun-Joo Ahn
+C Ralph Engel
+C R.S. Fletcher
+C T.K. Gaisser
+C Paolo Lipari
+C Felix Riehn
+C Todor Stanev
+C
+C-----------------------------------------------------------------------
+C*** Please have people who want this code contact one of the authors.
+C*** Please report any problems. ****
+C
+C For a correct copy contact:
+C sein@fnal.gov
+C ralph.engel@kit.edu
+C gaisser@bartol.udel.edu
+C paolo.lipari@roma1.infn.it
+C friehn@lip.pt
+C stanev@bartol.udel.edu
+C
+C last changes relative to Sibyll 2.3c:
+C * no remnant in high mass diff. events (pi0-had scattering)
+C * repaired had-nuc. cross section routine for kaon beams
+C routine remains inactive in ordinary calls.
+C
+C=======================================================================
+
+ SUBROUTINE SIBYLL (K_beam, IATARG, Ecm)
+
+C-----------------------------------------------------------------------
+C...Main routine for the production of hadronic events,
+C. generates an inelastic hadronic interaction of
+C. a `projectile particle' of code K_beam with a
+C. target nucleus of mass number A = IATARG (integer)
+C. IATARG = 0 is an "air" nucleus (superposition of oxygen and nitrogen)
+C. with c.m. energy for the hadron-nucleon system Ecm (GeV)
+C.
+C. Allowed values of K_beam: 7,8,9,10,11,12,13,14,-13,-14
+C. pi+-,K+-,KL,KS,p,n,pbar,nbar
+C. also:
+C. hyperons: 34,35,36,37,38,39
+C. Sig+-,Sig0,Xi0-,Lam0
+C.
+C. charmed: 59,60,71,72,74,75
+C. D+,D-,D0,D0b,Ds+,Ds-
+C. 87,88,89,99
+C. Xic+,Xic0,LamC+,OmC0
+C. rho0:27 is allowed as well to emulate photons!
+C.
+C. The output is contained in COMMON /S_PLIST/ that contains:
+C.
+C. NP number of final particles
+C. P(1:NP, 1:5) 4-momenta + masses of the final particles
+C. LLIST (1:NP) codes of final particles.
+C. the reaction is studied in the c.m. of hadron-nucleon system
+C.
+C. The COMMON block /S_CHIST/ contains information about
+C. the structure of the generated event:
+C. NW = number of wounded nucleons
+C. NJET = total number of hard interactions
+C. NSOF = total number of soft interactions
+C. NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C. NNJET (1:NW) = number of minijets produced in each interaction
+C. XJ1 (1:Index) = x1 for each string
+C. XJ2 (1:Index) = x2 " " "
+C. PTJET (1:Index) = pT " " "
+C. NNPJET (1:Index) = total number of particles in each string
+C. NNPSTR (1:2*NW) = number of particles in each `beam string'
+C. JDIF(1:NW) = diffraction code
+C----------------------------------------------------------------------
+ IMPLICIT NONE
+c external type declarations
+ DOUBLE PRECISION ECM
+ INTEGER K_beam, IATARG
+
+c COMMONs
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER LDIFF
+ COMMON /S_CLDIF/ LDIFF
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c internal type declarations
+ DOUBLE PRECISION Esum,PXsum,PYsum,PZsum,xchgRate
+ INTEGER LL,IATARGET,IAIR,KBM,L,NW,IREJ,NF,J
+ DIMENSION LL(99)
+ SAVE
+ DATA LL /5*0,7*2,2*1,12*0,2,6*0,6*1,19*0,2,2,10*0,
+ & 2,2,0,2,2,11*0,1,1,1,9*0,1/
+
+ if(Ndebug.gt.0)then
+ WRITE(LUN,'(A42,I3,I3,1X,F10.2)')
+ & ' SIBYLL: called with (K_beam,IATARG,Ecm):',
+ & K_beam,IATARG,Ecm
+ WRITE(LUN,*)'Event type selection LDIFF: ',LDIFF
+ endif
+
+ 100 CONTINUE
+
+ Ncall = Ncall+1
+
+ IATARGET = IATARG
+ IAIR = IABS(MIN(IATARG-1,0))
+ KBM = K_beam
+
+ CALL INI_EVENT(ECM,KBM,IATARGET,1)
+
+ L = LL(IABS(K_beam))
+ IF(L.eq.0) THEN
+ WRITE(LUN,*)'SIB_MAIN: unknown beam particle! kbeam=',k_beam
+ WRITE(6,*)'SIB_MAIN: unknown beam particle! kbeam=',k_beam
+ CALL SIB_REJECT('SIB_MAIN ')
+ endif
+
+C...Generate number NW wounded nucleons, and diffraction code.
+
+1000 continue
+ CALL SIB_START_EV (Ecm, L, IATARGET, IAIR, NWD, JDIF)
+ NW = NWD
+C...limits on simulation of pure diffraction dissociation
+ IF((LDIFF.NE.0).and.(NW.EQ.1)) THEN
+ IF((LDIFF.EQ.-1) .AND. (JDIF(1).NE.0) ) GOTO 1000
+ IF((LDIFF.EQ. 1) .AND. ((JDIF(1).NE.0).AND.(JDIF(1).NE.3)))
+ + GOTO 1000
+ IF((LDIFF.EQ. 5) .AND. (JDIF(1).EQ.2)) GOTO 1000
+ IF((LDIFF.GE. 2) .AND. (LDIFF.LE.4)) THEN
+ JDIF(1) = LDIFF-1
+ ENDIF
+ ENDIF
+
+C...Diffractive/non-diffractive interactions
+
+ IF((NW.EQ.1).and.(JDIF(1).NE.0)) THEN
+ CALL SIB_DIFF (KBM, JDIF(1), Ecm, 1, IREJ)
+ ELSE
+ CALL SIB_NDIFF (KBM, NW, Ecm, 1, IREJ)
+ ENDIF
+
+ IF (IREJ.NE.0) THEN
+ if(Ndebug.gt.0) WRITE(LUN,'(A38,F10.2,I3,I3,I3)')
+ & ' SIBYLL: rejection (Ecm,Ncall,Nw,JDIF):',Ecm,Ncall,NW,JDIF(1)
+ GOTO 100
+ ENDIF
+
+ do J=1,NP
+ if (P(J,4).lt.0.D0 ) then
+ if(Ndebug.gt.0)then
+ WRITE(LUN,*)' negative energy particle!' , P(J,4)
+ CALL SIB_LIST(LUN)
+ endif
+ goto 100
+ endif
+ enddo
+
+C...Check energy-momentum conservation
+
+ CALL PFSUM(1,NP,Esum,PXsum,PYsum,PZsum,NF)
+ IF (ABS(Esum/(0.5D0*Ecm*DBLE(NW+1)) - 1.D0) .GT. EPS3) THEN
+ WRITE(LUN,*) ' SIBYLL: energy not conserved (L,call): ',L,Ncall
+ WRITE(LUN,*) ' sqs_inp = ', Ecm, ' sqs_out = ', Esum
+ CALL PRNT_PRTN_STCK
+ CALL SIB_LIST(LUN)
+ WRITE(LUN,*) ' SIBYLL: event rejected'
+c a = -1.D0
+c a = log(a)
+c stop
+ goto 100
+ ENDIF
+ IF (ABS(PZsum+0.5D0*Ecm*DBLE(NW-1)) .GT. 0.1D0) THEN
+ if(Ndebug.gt.0)THEN
+ WRITE(LUN,*) ' SIBYLL: momentum not conserved (L,call): ',
+ & L,Ncall
+ WRITE(LUN,*) ' pz_inp = ', 0., ' pz_out = ', pzsum
+ ENDIF
+ IF(ndebug.gt.0)then
+ CALL PRNT_PRTN_STCK
+ CALL SIB_LIST(LUN)
+ WRITE(LUN,*) ' SIBYLL: event rejected'
+ endif
+c a = -1.D0
+c a = log(a)
+c stop
+ goto 100
+ ENDIF
+
+c exchange pions with vector mesons
+ IF(IPAR(45).ne.0) then
+ xchgRate = PAR(75)
+ CALL FORCE_VECTORS(xchgRate,1,NP)
+ endif
+
+c exchange pi0 with charged pions for meson projectiles
+ IF(IPAR(50).ne.0.and.IABS(KBM).lt.13) then
+ xchgrate = PAR(136)
+ CALL REMOVE_PI0(xchgRate,1,NP)
+ endif
+
+
+C...list final state particles
+ if(Ndebug.gt.10) CALL SIB_LIST(LUN)
+
+ END
+
+
+C======================================================================
+
+ SUBROUTINE SIBNUC (IAB, IATG, ECM)
+
+C-----------------------------------------------------------------------
+C. Routine that generates the interaction of a nucleus of
+C. mass number IAB with a target nucleus of mass IATG
+C. (IATG=0 : air).
+C. SQS (GeV) is the center of mass energy of each
+C. nucleon - nucleon cross section
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ COMMON /S_PLNUC/ PA(5,40000), LLA(40000), NPA
+ COMMON /CKFRAG/ KODFRAG
+ PARAMETER (IAMAX=56)
+ COMMON /CNUCMS/ B, BMAX, NTRY, NA, NB, NI, NAEL, NBEL
+ + ,JJA(IAMAX), JJB(IAMAX), JJINT(IAMAX,IAMAX)
+ + ,JJAEL(IAMAX), JJBEL(IAMAX)
+ COMMON /FRAGMENTS/ PPP(3,60)
+ DIMENSION SIGDIF(3)
+ DIMENSION IAF(60)
+ DOUBLE PRECISION FOX
+ SAVE
+ DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air
+
+C...Target mass
+ IF (IATG .EQ. 0) THEN
+c select target IATARGET from air composition
+ R = S_RNDM(0)
+ IATARGET = 14
+ IF (R .LT. FOX) IATARGET = 16
+ ELSE
+ IATARGET = IATG
+ ENDIF
+
+C...Single nucleon (proton) case
+
+ IF (IAB .EQ. 1) THEN
+ NPA = 0
+ CALL SIBYLL (13,IATARGET, ECM)
+ CALL DECSIB
+ DO J=1,NP
+ LA = IABS(LLIST(J))
+ IF (LA .LT. 10000) THEN
+ NPA = NPA + 1
+ LLA(NPA) = LLIST(J)
+ DO K=1,5
+ PA(K,NPA) = P(J,K)
+ ENDDO
+ ENDIF
+ ENDDO
+ RETURN
+ ENDIF
+
+
+C...Nuclei
+
+ CALL SIB_SIGMA_HP(1,ECM,SIGT,SIGEL,SIG0,SIGDIF,SLOPE,RHO)
+ CALL INT_NUC (IATARGET, IAB, SIG0, SIGEL)
+
+C...fragment spectator nucleons
+ NBT = NB + NBEL
+ IF (KODFRAG .EQ. 1) THEN
+ CALL FRAGM1(IAB,NBT, NF, IAF)
+ ELSE IF(KODFRAG .EQ. 2) THEN
+ CALL FRAGM2(IAB,NBT, NF, IAF)
+ ELSE
+ CALL FRAGM (IATARGET, IAB, NBT,B, NF, IAF)
+ ENDIF
+
+C...Spectator fragments
+ NPA = 0
+ DO J=1,NF
+ NPA = NPA+1
+ if(NPA.gt.40000) then
+ write(6,'(1x,a,2i8)')
+ & ' SIBNUC: no space left in S_PLNUC (NPA,NF)',NPA,NF
+ NPA = NPA-1
+ return
+ endif
+ LLA(NPA) = 1000+IAF(J)
+ PA(1,NPA) = 0.D0
+ PA(2,NPA) = 0.D0
+ PA(3,NPA) = ECM/2.D0
+ PA(4,NPA) = ECM/2.D0
+ PA(5,NPA) = DBLE(IAF(J))*0.5D0*(AM(13)+AM(14))
+ ENDDO
+
+C...Elastically scattered fragments
+ DO J=1,NBEL
+ NPA = NPA+1
+ if(NPA.gt.40000) then
+ write(6,'(1x,a,2i8)')
+ & ' SIBNUC: no space left in S_PLNUC (NPA,NBEL)',NPA,NBEL
+ NPA = NPA-1
+ return
+ endif
+ LLA(NPA) = 1001
+ PA(1,NPA) = 0.D0
+ PA(2,NPA) = 0.D0
+ PA(3,NPA) = ECM/2.D0
+ PA(4,NPA) = ECM/2.D0
+ PA(5,NPA) = 0.5D0*(AM(13)+AM(14))
+ ENDDO
+
+C...Superimpose NB nucleon interactions
+ DO JJ=1,NB
+ CALL SIBYLL (13,IATARGET, ECM)
+ CALL DECSIB
+ DO J=1,NP
+ LA = IABS(LLIST(J))
+ IF (LA .LT. 10000) THEN
+ NPA = NPA + 1
+ if(NPA.gt.40000) then
+ write(6,'(1x,a,2i8)')
+ & ' SIBNUC: no space left in S_PLNUC (NPA,NP)',NPA,NP
+ NPA = NPA-1
+ return
+ endif
+ LLA(NPA) = LLIST(J)
+ DO K=1,5
+ PA(K,NPA) = P(J,K)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIBYLL_INI
+
+C-----------------------------------------------------------------------
+C...Initialization routine for SYBILL
+C.
+C. the routine fills the COMMON block /CCSIG/ that contains
+C. important information for the generation of events
+C.
+C PARAMETER (NS_max = 20, NH_max = 80)
+C COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+C & SSIGN(61,3),SSIGNSD(61,3) ALINT(61,3), ASQSMIN, ASQSMAX, DASQS, NSQS
+C.
+C. NSQS = number of energy points (61 is current version)
+C. ASQSMIN = log_10 [sqrt(s) GeV] minimum value
+C. ASQSMIN = log_10 [sqrt(s) GeV] maximum value
+C. DASQS = step in log_10[sqrt(s)]
+C. DASQS = (ASQSMAX - ASQSMIN)/(NSQS-1)
+C.
+C. SSIG(J,1) inelastic cross section for pp interaction
+C. at energy: sqrt(s)(GeV) = 10**[ASQSMIN+DASQS*(J-1)]
+C. SSIG(J,2) inelastic cross section for pi-p interaction
+C. SSIGN(J,1) inelastic cross section for p-Air interaction
+C. SSIGN(J,2) inelastic cross section for pi-Air interaction
+C.
+C. PJETC(n_s,n_j,J,1) Cumulative probability distribution
+C. for the production of n_s soft interactions and
+C. n_j (n_j=0:30) jet pairs at sqrt(s) labeled
+C. by J, for p-p interaction
+C. PJETC(n_s,n_j,J,2) Same as above for pi-p interaction
+C. ALINT(J,1) proton-air interaction length (g cm-2)
+C. ALINT(J,2) pi-air interaction length (g cm-2)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ WRITE(*,100)
+ 100 FORMAT(' ','====================================================',
+ * /,' ','| |',
+ * /,' ','| S I B Y L L 2.3c |',
+ * /,' ','| |',
+ * /,' ','| HADRONIC INTERACTION MONTE CARLO |',
+ * /,' ','| BY |',
+ * /,' ','| Eun-Joo AHN, Felix RIEHN |',
+ * /,' ','| R. ENGEL, R.S. FLETCHER, T.K. GAISSER |',
+ * /,' ','| P. LIPARI, T. STANEV |',
+ * /,' ','| |',
+ * /,' ','| Publication to be cited when using this program: |',
+ * /,' ','| Eun-Joo AHN et al., Phys.Rev. D80 (2009) 094003 |',
+ * /,' ','| F. RIEHN et al., Proc. 35th Int. Cosmic Ray Conf.|',
+ * /,' ','| Bexco, Busan, Korea, cont. 301 (2017) |',
+ * /,' ','| |',
+ * /,' ','| last modifications: F. Riehn (12/11/2017) |',
+ * /,' ','====================================================',
+ * /)
+
+ CALL PAR_INI
+ CALL DIFF_INI
+ CALL JET_INI
+ CALL PDF_INI
+ CALL BLOCK_INI
+ CALL NUC_GEOM_INI
+ CALL SIG_AIR_INI
+ CALL DEC_INI
+c... charm frag. normalisation
+ CALL ZNORMAL
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE NO_CHARM
+ IMPLICIT NONE
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+c turn off charm production
+c global charm rate
+ PAR(24) = 0.D0
+c minijet string charm rate
+ PAR(156) = 0.D0
+c remnant string charm rate
+ PAR(107) = 0.D0
+c soft sea charm rate
+ PAR(97) = 0.D0
+c valence string charm rate
+ PAR(25) = 0.D0
+c minijet charm rate
+ PAR(27) = 0.D0
+ END
+
+C=======================================================================
+
+ SUBROUTINE PAR_INI
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+ DOUBLE PRECISION FAs1, fAs2
+ COMMON /S_CZDISs/ FAs1, fAs2
+ DOUBLE PRECISION ZDMAX, EPSI
+ COMMON /S_CZDISc/ ZDMAX, EPSI
+
+ DOUBLE PRECISION CLEAD, FLEAD
+ COMMON /S_CZLEAD/ CLEAD, FLEAD
+ DOUBLE PRECISION CCHIK
+ COMMON /S_CPSPL/ CCHIK(4,99)
+
+ PARAMETER ( NPARFIT = 22 )
+ DOUBLE PRECISION PARS
+ COMMON /XSCTN_FIT/ PARS( 50 , 2 )
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ SAVE
+ DATA (PARS(K,1),K= 1,NPARFIT) /
+ &3.9223D+01,4.2055D+01,5.0913D-02,-4.0000D-01,2.0000D-01,
+ &5.0000D-01,0.0000D+00,6.0000D-01,9.0000D-02,1.0000D+00,
+ &2.0000D+00,3.2327D+00,2.5000D-01,5.4000D-01,1.0000D+00,
+ &-8.8000D-01,5.4000D-01,5.0000D-01,9.0000D-01,5.4000D-01,
+ &6.5000D-02,9.0000D-01/
+ DATA (PARS(K,2),K= 1,NPARFIT) /
+ &2.0590D+01,9.6579D+01,5.6069D-02,-7.6393D-01,2.0000D-01,
+ &5.0000D-01,0.0000D+00,6.0000D-01,9.0000D-02,1.0000D+00,
+ &2.0000D+00,2.9191D+00,2.5000D-01,5.4000D-01,1.0000D+00,
+ &-8.8000D-01,5.4000D-01,5.4895D-01,9.0000D-01,5.4000D-01,
+ &6.5000D-02,9.0000D-01/
+c
+c adjusted central particle production
+c 23rc5.4frgB1 aka retune5 aka Sibyll 2.3.5
+ PAR(1) = 4.0000D-02
+ PAR(2) = 2.5000D-01
+ PAR(3) = 5.0000D-01
+ PAR(4) = 1.4000D-01
+ PAR(5) = 3.0000D-01
+ PAR(6) = 3.0000D-01
+ PAR(7) = 1.5000D-01
+ PAR(8) = 1.3903D-02
+ PAR(9) = 7.0000D+00
+ PAR(10) = 1.0000D+00
+ PAR(11) = 6.5000D-02
+ PAR(12) = 9.0000D-01
+ PAR(13) = 1.0000D-01
+ PAR(14) = 6.0000D-02
+ PAR(15) = 1.3000D-01
+ PAR(16) = 4.0000D-02
+ PAR(17) = 4.0000D-02
+ PAR(18) = 5.0000D-01
+ PAR(19) = 8.0000D-01
+ PAR(20) = 8.0000D-01
+ PAR(21) = 6.0000D-01
+ PAR(22) = 4.0000D+00
+ PAR(23) = 7.0000D-01
+ PAR(24) = 4.0000D-03
+ PAR(25) = 4.0000D-03
+ PAR(26) = 2.0000D+01
+ PAR(27) = 2.0000D-02
+ PAR(28) = 2.0000D+01
+ PAR(29) = 0.0000D+00
+ PAR(30) = 2.0000D+00
+ PAR(31) = 3.3000D-01
+ PAR(32) = 0.0000D+00
+ PAR(33) = 1.0000D-01
+ PAR(34) = 0.0000D+00
+ PAR(35) = 0.0000D+00
+ PAR(36) = 7.0000D-01
+ PAR(37) = 0.0000D+00
+ PAR(38) = 5.0000D-01
+ PAR(39) = 8.0000D-01
+ PAR(40) = 0.0000D+00
+ PAR(41) = 1.0000D+00
+ PAR(42) = 0.0000D+00
+ PAR(43) = 2.3564D-01
+ PAR(44) = 9.9000D-01
+ PAR(45) = 1.0000D+00
+ PAR(46) = 1.8000D-01
+ PAR(47) = 2.8000D-01
+ PAR(48) = 2.7000D-01
+ PAR(49) = 1.0000D-01
+ PAR(50) = 6.0000D-01
+ PAR(51) = 6.0000D-03
+ PAR(52) = 6.0000D-03
+ PAR(53) = 6.0000D+00
+ PAR(54) = 2.0000D-01
+ PAR(55) = 0.0000D+00
+ PAR(56) = 0.0000D+00
+ PAR(57) = 0.0000D+00
+ PAR(58) = 0.0000D+00
+ PAR(59) = 6.8345D-01
+ PAR(60) = 8.0000D-01
+ PAR(61) = 6.6000D-01
+ PAR(62) = 0.0000D+00
+ PAR(63) = 1.0000D+00
+ PAR(64) = 2.5000D-01
+ PAR(65) = 3.0000D-01
+ PAR(66) = 3.0000D-01
+ PAR(67) = 6.0000D-01
+ PAR(68) = 6.0000D-03
+ PAR(69) = 5.0000D-02
+ PAR(70) = 7.0000D-03
+ PAR(71) = 1.0000D+00
+ PAR(72) = 3.8000D-01
+ PAR(73) = 5.0000D-01
+ PAR(74) = 6.0000D-01
+ PAR(75) = 0.0000D+00
+ PAR(76) = 3.5298D-01
+ PAR(77) = 7.0000D-01
+ PAR(78) = 2.0000D+00
+ PAR(79) = 1.0000D+01
+ PAR(80) = 5.0816D-01
+ PAR(81) = 1.0000D+04
+ PAR(82) = 1.0000D-01
+ PAR(83) = 0.0000D+00
+ PAR(84) = 6.0000D+00
+ PAR(85) = 1.0000D+00
+ PAR(86) = 1.0000D+00
+ PAR(87) = 3.0000D-01
+ PAR(88) = 8.0000D-01
+ PAR(89) = 6.0000D-01
+ PAR(90) = 1.1000D+01
+ PAR(91) = -7.2000D+00
+ PAR(92) = 3.5000D+00
+ PAR(93) = 1.0000D+00
+ PAR(94) = 4.0000D+00
+ PAR(95) = 0.0000D+00
+ PAR(96) = 1.0000D+00
+ PAR(97) = 2.0000D-03
+ PAR(98) = 1.5000D+00
+ PAR(99) = 5.0000D-01
+ PAR(100) = 2.0000D+00
+ PAR(101) = 1.0000D+00
+ PAR(102) = 0.0000D+00
+ PAR(103) = 2.0000D+00
+ PAR(104) = 4.0000D-01
+ PAR(105) = 1.0000D-01
+ PAR(106) = 0.0000D+00
+ PAR(107) = 0.0000D+00
+ PAR(108) = 0.0000D+00
+ PAR(109) = 2.0000D+01
+ PAR(110) = 1.5000D+00
+ PAR(111) = 0.0000D+00
+ PAR(112) = 7.0000D-01
+ PAR(113) = 8.0000D-01
+ PAR(114) = 2.0000D+00
+ PAR(115) = 0.0000D+00
+ PAR(116) = 1.0000D+00
+ PAR(117) = 0.0000D+00
+ PAR(118) = 5.0000D-03
+ PAR(119) = 0.0000D+00
+ PAR(120) = 1.0000D+00
+ PAR(121) = 3.0000D-01
+ PAR(122) = 0.0000D+00
+ PAR(123) = 3.0000D-01
+ PAR(124) = 1.0000D+00
+ PAR(125) = 1.0000D+00
+ PAR(126) = 1.0000D+00
+ PAR(127) = 6.0000D+00
+ PAR(128) = 1.0000D+00
+ PAR(129) = 8.0000D-02
+ PAR(130) = 1.2000D+01
+ PAR(131) = 5.0000D-01
+ PAR(132) = 5.0000D-01
+ PAR(133) = 1.0000D+01
+ PAR(134) = -5.0000D+00
+ PAR(135) = 6.0000D+00
+ PAR(136) = 0.0000D+00
+ PAR(137) = 1.2000D+00
+ PAR(138) = 0.0000D+00
+ PAR(139) = 5.0000D-01
+ PAR(140) = 4.5000D-01
+ PAR(141) = 1.5000D+00
+ PAR(142) = 0.0000D+00
+ PAR(143) = 5.0000D-01
+ PAR(144) = 9.5000D-01
+ PAR(145) = 8.5000D-01
+ PAR(146) = 0.0000D+00
+ PAR(147) = 3.0000D-01
+ PAR(148) = 5.0000D-01
+ PAR(149) = 3.0000D-01
+ PAR(150) = 4.0000D-03
+ PAR(151) = 2.0000D+00
+ PAR(152) = 4.0000D+00
+ PAR(153) = 1.0000D+01
+ PAR(154) = 3.0000D-01
+ PAR(155) = 0.0000D+00
+ PAR(156) = 5.0000D-01
+ PAR(157) = 8.0000D-01
+ PAR(158) = 0.0000D+00
+ PAR(159) = 0.0000D+00
+ PAR(160) = 0.0000D+00
+ PAR(161) = 0.0000D+00
+ PAR(162) = 0.0000D+00
+ PAR(163) = 0.0000D+00
+ PAR(164) = 0.0000D+00
+ PAR(165) = 0.0000D+00
+ PAR(166) = 0.0000D+00
+ PAR(167) = 0.0000D+00
+ PAR(168) = 0.0000D+00
+ PAR(169) = 0.0000D+00
+ PAR(170) = 0.0000D+00
+ PAR(171) = 0.0000D+00
+ PAR(172) = 0.0000D+00
+ PAR(173) = 0.0000D+00
+ PAR(174) = 0.0000D+00
+ PAR(175) = 0.0000D+00
+ PAR(176) = 0.0000D+00
+ PAR(177) = 0.0000D+00
+ PAR(178) = 0.0000D+00
+ PAR(179) = 0.0000D+00
+ PAR(180) = 0.0000D+00
+ PAR(181) = 0.0000D+00
+ PAR(182) = 0.0000D+00
+ PAR(183) = 0.0000D+00
+ PAR(184) = 0.0000D+00
+ PAR(185) = 0.0000D+00
+ PAR(186) = 0.0000D+00
+ PAR(187) = 0.0000D+00
+ PAR(188) = 0.0000D+00
+ PAR(189) = 0.0000D+00
+ PAR(190) = 0.0000D+00
+ PAR(191) = 0.0000D+00
+ PAR(192) = 0.0000D+00
+ PAR(193) = 0.0000D+00
+ PAR(194) = 0.0000D+00
+ PAR(195) = 0.0000D+00
+ PAR(196) = 0.0000D+00
+ PAR(197) = 0.0000D+00
+ PAR(198) = 0.0000D+00
+ PAR(199) = 0.0000D+00
+ PAR(200) = 0.0000D+00
+ IPAR(1) = 1
+ IPAR(2) = 0
+ IPAR(3) = 8
+ IPAR(4) = 0
+ IPAR(5) = 1
+ IPAR(6) = 0
+ IPAR(7) = 0
+ IPAR(8) = 1
+ IPAR(9) = 1
+ IPAR(10) = 1
+ IPAR(11) = 0
+ IPAR(12) = 3
+ IPAR(13) = 0
+ IPAR(14) = -2
+ IPAR(15) = 9
+ IPAR(16) = 8
+ IPAR(17) = 1
+ IPAR(18) = 4
+ IPAR(19) = 1
+ IPAR(20) = 0
+ IPAR(21) = 0
+ IPAR(22) = 0
+ IPAR(23) = 0
+ IPAR(24) = 0
+ IPAR(25) = 1
+ IPAR(26) = 0
+ IPAR(27) = 0
+ IPAR(28) = 4
+ IPAR(29) = 1
+ IPAR(30) = 0
+ IPAR(31) = 1
+ IPAR(32) = 0
+ IPAR(33) = 0
+ IPAR(34) = 0
+ IPAR(35) = 0
+ IPAR(36) = 1
+ IPAR(37) = 0
+ IPAR(38) = 1
+ IPAR(39) = 0
+ IPAR(40) = 0
+ IPAR(41) = 0
+ IPAR(42) = 3
+ IPAR(43) = 1
+ IPAR(44) = 0
+ IPAR(45) = 0
+ IPAR(46) = 2
+ IPAR(47) = 6
+ IPAR(48) = 1
+ IPAR(49) = 4
+ IPAR(50) = 0
+ IPAR(51) = 2
+ IPAR(52) = 0
+ IPAR(53) = 1
+ IPAR(54) = 0
+ IPAR(55) = 0
+ IPAR(56) = 0
+ IPAR(57) = 1
+ IPAR(58) = 3
+ IPAR(59) = 1
+ IPAR(60) = 0
+ IPAR(61) = 100
+ IPAR(62) = 1
+ IPAR(63) = 0
+ IPAR(64) = 0
+ IPAR(65) = 1
+ IPAR(66) = 3
+ IPAR(67) = 0
+ IPAR(68) = 0
+ IPAR(69) = 1
+ IPAR(70) = 1
+ IPAR(71) = 0
+ IPAR(72) = 0
+ IPAR(73) = 0
+ IPAR(74) = 1
+ IPAR(75) = 0
+ IPAR(76) = 0
+ IPAR(77) = 0
+ IPAR(78) = 2
+ IPAR(79) = 1
+ IPAR(80) = 1
+ IPAR(81) = 5
+ IPAR(82) = 2
+ IPAR(83) = 0
+ IPAR(84) = 2
+ IPAR(85) = 1
+ IPAR(86) = 0
+ IPAR(87) = 3
+ IPAR(88) = 1
+ IPAR(89) = 0
+ IPAR(90) = 1
+ IPAR(91) = 0
+ IPAR(92) = 1
+ IPAR(93) = 1
+ IPAR(94) = 0
+ IPAR(95) = 0
+ IPAR(96) = 0
+ IPAR(97) = 0
+ IPAR(98) = 0
+ IPAR(99) = 0
+ IPAR(100) = 0
+
+C... valence quark distribution function
+c large x suppression
+ do i=1,3 ! quark flavors
+ CCHIK(i,13)=PAR(62)
+ CCHIK(i,14)=PAR(62)
+ enddo
+C...string fragmentation parameters
+c effective quark mass
+ STR_mass_val = PAR(36)
+ STR_mass_sea = PAR(41)
+
+C...energy dependence of PTmin
+c pt_cut offset
+ PAR(10) = PARS(10 , 1)
+c lambda
+ PAR(11) = PARS(21 , 1)
+c c parameter
+ PAR(12) = PARS(22 , 1)
+
+C...fragmentation function
+ FAin = PAR(20)
+ FB0in = PAR(21)
+
+C...Strange fragmentation function
+ FAs1 = PAR(35)
+ FAs2 = PAR(35)
+
+C...leading baryon fragmentation function
+c hard proton mixing
+ CLEAD = PAR(50)
+
+ END
+C=======================================================================
+
+ SUBROUTINE PAR_INI_FROM_FILE
+ IMPLICIT NONE
+c locals
+ CHARACTER*10 FILENA
+ CHARACTER*6 CNAME
+ CHARACTER*70 NUMBER
+
+ INTEGER ISTAT,J,IVAL,I
+ DOUBLE PRECISION VAL
+c commons
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+ DOUBLE PRECISION FAs1, fAs2
+ COMMON /S_CZDISs/ FAs1, fAs2
+ DOUBLE PRECISION ZDMAX, EPSI
+ COMMON /S_CZDISc/ ZDMAX, EPSI
+
+ DOUBLE PRECISION CLEAD, FLEAD
+ COMMON /S_CZLEAD/ CLEAD, FLEAD
+ DOUBLE PRECISION CCHIK
+ COMMON /S_CPSPL/ CCHIK(4,99)
+
+ SAVE
+ DATA FILENA /'sibyll.par'/
+ 14 FORMAT(A6,A70)
+ 15 FORMAT(A5,I3,A2,I8)
+ 16 FORMAT(A5,I3,A2,F8.2)
+ OPEN(unit=4,file=filena,status='OLD')
+ istat = 1
+c set standard parameters (full set)
+ CALL PAR_INI
+c read new parameters from file
+ IF(ndebug.gt.0)WRITE(LUN,*)'reading parameter file: sibyll.par'
+ DO WHILE (istat.ge.0)
+ READ(4,14,iostat=ISTAT) CNAME,NUMBER
+ IF(CNAME.eq.'IPAR ')THEN
+ READ(NUMBER,*) j, ival
+ IF(ndebug.gt.1)write(LUN,15) 'IPAR(',j,')=', ival
+ IPAR(J) = iVAL
+ ELSEif(CNAME.eq.'PAR ')THEN
+ READ(NUMBER,*) j, val
+ PAR(J) = VAL
+ IF(ndebug.gt.1)write(LUN,16) ' PAR(',j,')=', val
+ ELSE
+ WRITE(LUN,*)'wrong format in parameter file!'
+ WRITE(6,*)'wrong format in parameter file!'
+ WRITE(LUN,*) CNAME, NUMBER
+ stop
+ ENDIF
+ ENDDO
+C copy parameter values to their respective COMMONs
+C... valence quark distribution function
+c large x suppression
+ do i=1,3 ! quark flavors
+ CCHIK(i,13)=PAR(62)
+ CCHIK(i,14)=PAR(62)
+ enddo
+C...string fragmentation parameters
+c effective quark mass
+ STR_mass_val = PAR(36)
+ STR_mass_sea = PAR(41)
+C...fragmentation function
+ FAin = PAR(20)
+ FB0in = PAR(21)
+C...Strange fragmentation function
+ FAs1 = PAR(35)
+ FAs2 = PAR(35)
+C...leading baryon fragmentation function
+c hard proton mixing
+ CLEAD = PAR(50)
+ END
+
+C=======================================================================
+
+ SUBROUTINE MESON_FLV_MRG_INI
+
+C-----------------------------------------------------------------------
+c change flavor merging for pions (favor spin)
+C-----------------------------------------------------------------------
+ INTEGER KFLV
+ COMMON /S_KFLV/ KFLV(4,43)
+
+c pi+ --> rho+
+ KFLV(2,1) = 25
+c pi- --> rho-
+ KFLV(1,2) = 26
+c pi0 --> rho0
+ KFLV(1,1) = 27
+ KFLV(2,2) = 27
+ END
+C=======================================================================
+
+ BLOCK DATA PARAM_INI
+
+C-----------------------------------------------------------------------
+C....This block data contains default values
+C. of the parameters used in fragmentation
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+ DOUBLE PRECISION FAs1, fAs2
+ COMMON /S_CZDISs/ FAs1, fAs2
+ DOUBLE PRECISION ZDMAX, EPSI
+ COMMON /S_CZDISc/ ZDMAX, EPSI
+
+ DOUBLE PRECISION CLEAD, FLEAD
+ COMMON /S_CZLEAD/ CLEAD, FLEAD
+ DOUBLE PRECISION CCHIK
+ COMMON /S_CPSPL/ CCHIK(4,99)
+
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ COMMON /CKFRAG/ KODFRAG
+ SAVE
+
+ DATA ITRY /20*0/
+ DATA NREJ /5,5,20,10,20,20,14*0/
+ DATA EPS3,EPS5,EPS8,EPS10 /1.D-3,1.D-5,1.D-8,1.D-10/
+ DATA PI,TWOPI,CMBARN/3.14159265358979D0,6.283185308D0,0.389385D0/
+ DATA FACN /2.D0,5.D0,15.D0,60.D0,250.D0,1500.D0,12000.D0,
+ & 120000.D0/
+
+C... default output unit
+ DATA LUN /7/
+c...new fragmentation for charmed particles
+ DATA EPSI /2.D0/
+C...mass cutoff for soft strings
+ data STR_mass_val /0.35D0/
+ data STR_mass_val_hyp /0.4D0/
+ data STR_mass_sea /1.D0/
+C...Longitudinal Fragmentation function
+ DATA FAin /0.5D0/, FB0in /0.8D0/
+C...Longitudinal Fragmentation function for leading baryons
+ DATA CLEAD /0.6D0/, FLEAD /0.6D0/
+c strange fragmentation
+ data FAs1 /3.D0/, fAs2 /3.D0/
+C... Splitting parameters
+ DATA CCHIK /20*0.D0,28*2.D0,8*3.D0,48*0.D0,4*2.D0,24*0.D0,
+ & 24*3.D0,76*0.D0,8*2.D0,40*0.D0,12*2.D0,40*0.D0,24*3.D0,
+ & 40*0.D0/
+C...Parameters of flavor formation
+c last in use: 158
+ DATA PAR/0.04D0,0.3D0,0.3D0,0.14D0,0.3D0,0.3D0,0.15D0,0.D0,7.D0, ! 10
+ & 2*0.D0,0.9D0,0.2D0,4*0.04D0,0.5D0,0.8D0,0.5D0, ! 20
+ & 0.8D0,6.D0,0.5D0,0.004D0,5*0.D0,0.7D0, ! 30
+ & 2*0.D0,0.1D0,0.D0,3.D0,0.35D0,0.D0,0.5D0,2*0.D0, ! 40
+ & 1.D0,2.D0,0.D0,0.99D0,0.D0,0.3D0,0.45D0,0.6D0,0.6D0,0.6D0, ! 50
+ & .03D0,.03D0,6.D0,0.2D0,4*0.D0,1.1D0,0.8D0, ! 60
+ & .33D0,3.D0,1.D0,.25D0,.3D0,0.3D0,0.6D0,.007D0,.03D0,.007D0, ! 70
+ & 1.D0,0.3D0,0.D0,0.3D0,0.0D0,0.2D0,0.5D0,1.0D0,10.D0,0.D0, ! 80
+ & 1000.D0,1000.D0,1.D0,6.D0,1.D0,0.D0,0.3D0,0.8D0,0.3D0,31.D0,! 90
+ & 1.D0,6.5D0,1.D0,1.D0,0.D0,1.0D0,0.004D0,1.D0,0.33D0,1.D0, ! 100
+ & 1.D0,0.D0,2.D0,0.3D0,0.15D0,3*0.D0,20.D0,0.25D0, ! 110
+ & 0.D0,0.7D0,0.3D0,0.D0,0.D0,1.D0,3*0.D0,1.D0, ! 120
+ & 0.3D0,0.D0,0.3D0,1.D0,1.D0,1.D0,6.D0,1.D0,1.D0,6.D0, ! 130
+ & 0.0001D0,0.5D0,31.10362D0,-15.29012D0,6.5D0, ! 135
+ & 0.D0,4 *0.D0, ! 140
+ & 1.D0,0.D0,0.5D0,0.D0,0.5D0,0.D0,0.3D0,0.8D0,0.08D0,0.004D0, ! 150
+ & 2.D0,1.D0,1.D0,1.D0,1.D0,1.D0,0.D0,1.D0,2*0.D0, ! 160
+ & 40*0.D0/ ! 200
+c last in use:93
+ DATA IPAR /9*0,1,0,1,8*0,20*0, ! 40
+ & 9*0,0,2,9*0, ! 60
+ & 100,25*0,2,1,0,0,0,1,0,7*0/ ! 100
+
+C...Fragmentation of nuclei
+ DATA KODFRAG /0/
+C...Debug label and event counter
+ DATA Ndebug /0/
+ DATA Ncall /0/
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE PARAM_PRINT(LUN)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /S_CZLEAD/ CLEAD, FLEAD
+ COMMON /S_CPSPL/ CCHIK(4,99)
+ COMMON /S_DEBUG/ Ncall, Ndebug, Lunn
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+ DOUBLE PRECISION PPT02
+ COMMON /S_CQDIS2/ PPT02(44)
+ DOUBLE PRECISION PPT0,ptflag
+ COMMON /S_CQDIS/ PPT0(35),ptflag
+ SAVE
+
+ WRITE (LUN, 25)
+25 FORMAT( /,1x,40('-'), /
+ + ' SIBYLL MONTE CARLO PROGRAM. Version 2.3.f',/,
+ + 1x,40('-'),/' List of parameters: ' )
+
+ WRITE (LUN, 31) FAin, FB0in
+31 FORMAT (' Parameters of longitudinal fragmentation: ', /,
+ + ' f(z) = (1-z)**a * exp(-b * mt**2/z) ', /,
+ + ' a = ', f9.3, 3x, ' b = ', f9.3, ' GeV**-2' )
+ WRITE (LUN, 32) CLEAD, 1.D0/FLEAD-1.D0
+32 FORMAT (' Parameters of leading fragmentation: ', /,
+ + ' f(z) = c + (1-z)**a ', /,
+ + ' c = ',f9.3,3x,' a = ',f9.3)
+
+ WRITE (LUN, 33) str_mass_val, str_mass_sea
+ 33 FORMAT (' Mass cuts ', /,
+ + ' val = ', f9.3, 3x, ' sea = ', f9.3, ' GeV' )
+
+ WRITE (LUN, 35) PPT02(1), PPT02(3), PPT02(11),ppt02(10),ppt02(20)
+35 FORMAT (' <pT> of sea partons ', /,
+ + 3x,'<pT>(u/d) ',F8.3,2x,'<pT>(s) ',f8.3,2x,'<pT>(qq) ',f8.3,
+ + 2x,'<pT>(val) ',f8.3,2x,'<pT>(sea) ',f8.3)
+
+ WRITE (LUN, 120) (PAR(K),K=1,24)
+120 FORMAT (1x, ' Parameters of flavor formation: ',/,
+ + 3x,'PAR(1) = Prob(qq)/Prob(q) = ',F10.2,/,
+ + 3x,'PAR(2) = Prob(s)/Prob(u) = ',F10.2,/,
+ + 3x,'PAR(3) = Prob(us)/Prob(ud) = ',F10.2,/,
+ + 3x,'PAR(4) = Prob(ud_0)/Prob(ud_1) = ',F10.2,/,
+ + 3x,'PAR(5) = Prob(Vector)/Prob(Scalar) = ',F10.2,/,
+ + 3x,'PAR(6) = Prob(K*)/Prob(K) = ',F10.2,/,
+ + 3x,'PAR(7) = Prob(spin 3/2)/Prob(spin=1/2) = ',F10.2,/,
+ + 3x,'PAR(8) = Prob(B-M-Bbar)/Prob(B-Bbar) = ',F10.2,/,
+ + 3x,'PAR(9) = Phase space suppression of MI = ',F10.2,/,
+ + 3x,'PAR(10)= Low-energy limit for pt cutoff= ',F10.2,/,
+ + 3x,'PAR(11)= Pt cutoff factor for exp = ',F10.2,/,
+ + 3x,'PAR(12)= Pt cutoff factor for exp = ',F10.2,/,
+ + 3x,'PAR(13)= max. mass in diffraction = ',F10.2,/,
+ + 3x,'PAR(14)= Prob(qq)/Prob(q) std. value = ',F10.2,/,
+ + 3x,'PAR(15)= Prob(qq)/Prob(q) in hard jets = ',F10.2,/,
+ + 3x,'PAR(16)= Prob(qq)/Prob(q) in diff. = ',F10.2,/,
+ + 3x,'PAR(17)= not used = ',F10.2,/,
+ + 3x,'PAR(18)= not used = ',F10.2,/,
+ + 3x,'PAR(19)= not used = ',F10.2,/,
+ + 3x,'PAR(20)= not used = ',F10.2,/,
+ + 3x,'PAR(21)= not used = ',F10.2,/,
+ + 3x,'PAR(22)= effective scale in PDF (Q2) = ',F10.2,/,
+ + 3x,'PAR(23)= not used = ',F10.2,/,
+ + 3x,'PAR(24)= Prob(s->c) = ',F10.2 )
+
+ WRITE (LUN, 130) (IPAR(K),K=1,17)
+130 FORMAT (1x, ' Model switches: ',/,
+ + 3x,'IPAR(1) = not used =',I4,/,
+ + 3x,'IPAR(2) = not used =',I4,/,
+ + 3x,'IPAR(3) = exponential pt =',I4,/,
+ + 3x,'IPAR(4) = decouple qq/q in val. strings =',I4,/,
+ + 3x,'IPAR(5) = decouple qq/q in hm. diff. =',I4,/,
+ + 3x,'IPAR(6) = decouple qq/q in hard strings =',I4,/,
+ + 3x,'IPAR(7) = remnant (not implemented yet) =',I4,/,
+ + 3x,'IPAR(8) = jet kinematic pdf set (DO/GRV)=',I4,/,
+ + 3x,'IPAR(9) = smear lowest diff. mass =',I4,/,
+ + 3x,'IPAR(10)= high mass diff. mode (d:ON) =',I4,/,
+ + 3x,'IPAR(11)= leading vec. meson prod. model=',I4,/,
+ + 3x,'IPAR(12)= inel. screening in pAir =',I4,/,
+ + 3x,'IPAR(13)= decouple qq/q in val. strings =',I4,/,
+ + 3x,'IPAR(14)= fireball model =',I4,/,
+ + 3x,'IPAR(15)= charm production =',I4,/,
+ + 3x,'IPAR(16)= charmed transverse momentum =',I4,/,
+ + 3x,'IPAR(17)= full charm model =',I4 )
+
+ WRITE (LUN, 40)
+ WRITE (LUN, 41) CCHIK (1,13), CCHIK(2,13)
+ 40 FORMAT(' Parameters of hadron splitting ' )
+ 41 FORMAT(' p -> [(ud) u] splitting: alpha = ', F10.3, /,
+ + ' p -> [(uu) d] splitting: alpha = ', F10.3 )
+c print rho0 splitting
+ WRITE (LUN, 42) CCHIK (1,27), CCHIK(2,27)
+ 42 FORMAT(' rho0 -> [u ubar] splitting: alpha = ', F10.3, /,
+ + ' rho0 -> [d dbar] splitting: alpha = ', F10.3 )
+c print d+ splitting
+ WRITE (LUN, 43) CCHIK (4,59), CCHIK(2,59)
+ 43 FORMAT(' dp -> [c ubar] splitting: alpha = ', F10.3, /,
+ + ' dp -> [dbar c] splitting: alpha = ', F10.3 )
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_LIST(LUN)
+
+C-----------------------------------------------------------------------
+C...This routine prints the event record for the
+C. current event on unit LUN
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /S_DEBUG/ Ncall, Ndebug, Lunn
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+ INTEGER LLIST1
+ COMMON /S_PLIST1/ LLIST1(8000)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ INTEGER IRMNT,KRB,KRT
+ DOUBLE PRECISION XRMASS,XRMEX
+ COMMON /S_RMNT/ XRMASS(2),XRMEX(2),IRMNT(NW_max),KRB,KRT(NW_max)
+
+ CHARACTER*7 CTGT(0:20)
+ CHARACTER CODE*18
+ CHARACTER*18 NAMDIF(0:3)
+ CHARACTER*18 NAMRMNT(0:3)
+ SAVE
+ DATA CTGT /'Air ','Proton ',19*'Nucleus'/
+ DATA NAMDIF /'Non-diff. event ',
+ & 'Beam diffraction ','Target diffraction','Double diffraction'/
+ DATA NAMRMNT /'No resolvd remnant',
+ & 'Beam remnant ','Target remnant ','Double remnant '/
+
+ 50 FORMAT(3X,88('-'),/,25X,'SIBYLL EVENT SUMMARY',25X,
+ & /,3X,88('-'))
+ 52 FORMAT( 3X,'Beam + Target @ Energy:',2X,A6,2X,'+',2X,A7,2X,
+ & '@',1p,E11.3,' GeV')
+ 53 FORMAT( 3X,'Beam + Target @ Energy:',2X,'Anti-',A6,2X,'+',2X,A7,
+ & 2X,'@',1p,E11.3,' GeV')
+
+ WRITE (LUN,50)
+ IF (KB .GT. 0 ) THEN
+ WRITE (LUN,52)
+ & NAMP(IABS(KB)),CTGT(IAT),SQS
+ ELSE
+ WRITE (LUN,53)
+ & NAMP(IABS(KB)),CTGT(IAT),SQS
+ ENDIF
+ if(NWD.eq.1)THEN
+ WRITE (LUN,*) ' ',NAMDIF(JDIF(1))
+ IF(jdif(1).eq.0)
+ & WRITE (LUN,*) ' ',NAMRMNT(abs(IRMNT(1)))
+ else
+ WRITE (LUN,*) ' ',NAMDIF(0)
+ endif
+
+ WRITE (LUN,*) ' A/N_w/N_s/N_j = ', IAT , NWD, NSOF, NJET
+ WRITE (LUN,100)
+
+C...Print particle list
+ kchar = 0
+ ibary = 0
+ ichmd = 0
+ istrg = 0
+ DO J=1,NP
+ L = MOD(LLIST(J),10000)
+ CODE = ' '
+ CODE(1:6) = NAMP(IABS(L))
+ IF (L .LT. 0) CODE(7:9) = 'bar'
+ IF(IABS(LLIST(J)) .GT. 10000) CODE(10:10) = '*'
+ WRITE (LUN,120) J, CODE, NIORIG(J),JDIF(NIORIG(J)),LLIST1(J),
+ & NPORIG(J), (P(J,K),K=1,4)
+ if(abs(LLIST(J)).LT.10000) then
+ kchar = kchar+sign(1,l)*ICHP(iabs(l))
+ ibary = ibary+sign(1,l)*IBAR(iabs(l))
+ ichmd = ichmd+sign(1,l)*ICHM(iabs(l))
+ istrg = istrg+sign(1,l)*ISTR(iabs(l))
+ endif
+ ENDDO
+ CALL PFSUM(1,NP,Esum,PXsum,PYsum,PZsum,NF)
+ WRITE(LUN,140) PXsum,PYsum,PZsum,Esum
+100 FORMAT(3X,'N Particle',12X,'Int',2x,'Jdif',2x,'Prnt',2x,'Proc'
+ + ,6x,'PX',9x,'PY',9x,'PZ',9x,'E', /, 3X,88('-'))
+120 FORMAT(I6,1X,A18,3I5,I8,2F10.3,1p,2E11.3)
+140 FORMAT(3X,88('-'),/,' Tot =',41X,2F10.3,1p,2E11.3)
+ write(LUN,'(1x,a,i3,3x,a,i3)') ' Total charge: ',kchar,
+ & 'total baryon number:',ibary
+ write(LUN,'(1x,a,i3,3x,a,i3)') ' Total strangeness:',istrg,
+ & 'total charm number: ',ichmd
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE KCODE (J,CODE,NC)
+
+C-----------------------------------------------------------------------
+C...Produce the code for parton J
+C. Input K, Output CODE, NC=number of characters
+C..................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ CHARACTER*5 CODE
+ CHARACTER*1 NAMQ(4)
+ SAVE
+ DATA NAMQ /'u','d','s','c'/
+
+ CODE = ' '
+ IF(J.EQ.0) THEN
+ CODE(1:3) = 'glu'
+ NC = 3
+ RETURN
+ ENDIF
+ JA = IABS(J)
+ J1 = MOD(JA,10)
+ J2 = (JA-J1)/10
+ IF(JA .GT. 10) THEN
+ CODE(1:1) = NAMQ(J2)
+ CODE(2:2) = NAMQ(J1)
+ NC = 2
+ ELSE
+ CODE(1:1) = NAMQ(J1)
+ NC = 1
+ ENDIF
+ IF (J .LT. 0) THEN
+ CODE(NC+1:NC+3) = 'bar'
+ NC = NC+3
+ ENDIF
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_PARTPR(LUN)
+
+C----------------------------------------------------------------
+C prints the particles known to SIBYLL with their internal
+C and PDG labels \FR'13
+C----------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ SAVE
+
+ WRITE(LUN,50)
+ 50 FORMAT(/,2X,16X,'SIBYLL PARTICLE TABLE:',/,2x,80('-'))
+ WRITE(LUN,100)
+ 100 FORMAT(2X,'Particle',4X,'SIB PID',6x,'SIB2PDG',6x,'SIB2PDG^-1',
+ & 4x,'MASS',4x,'STRG',4x,'CHRM',4x,'BRYN'/, 2X,80('-'))
+
+ DO J=1,99
+ IA = ISIB_PID2PDG( j )
+ IF(IA.ne.0)THEN
+ ISIBPDG2PIDIA=ISIB_PDG2PID( IA )
+ ELSE
+ WRITE(LUN,'(1X,A,I2)') 'PDG conversion not found! pid=', j
+ ENDIF
+ WRITE (LUN,120) NAMP(J), J, IA, ISIBPDG2PIDIA, AM(J), ISTR(J),
+ & ICHM(J), IBAR(J)
+ ENDDO
+ 120 FORMAT(4X,A6,4X,I4,7X,I7,8X,I4,5X,F9.3,3(6X,I2))
+
+ END
+
+C=======================================================================
+
+ INTEGER FUNCTION ISIB_PID2PDG(Npid)
+
+C----------------------------------------------------------------
+C conversion of SIBYLL internal particle code to PDG standard
+C
+C input: Npid internal particle number
+C output: sib_pid2pdg PDG particle number
+C
+C based on similar phojet function \FR'13
+C----------------------------------------------------------------
+ COMMON /S_PDG2PID/ ID_PDG_LIST(99),ID_LIST(577)
+ INTEGER NPIDA,NPID
+ SAVE
+
+ Npida = iabs(Npid)
+ ISIB_PID2PDG = ID_PDG_LIST(Npida)
+ IF(NPID.lt.0)ISIB_PID2PDG = isign(ISIB_PID2PDG,Npid)
+ RETURN
+ END
+
+C=======================================================================
+
+ INTEGER FUNCTION ISIB_PDG2PID(Npdg)
+
+C-----------------------------------------------------------------------
+C conversion of PDG standard particle code to SIBYLL internal
+C
+C input: Npdg PDG particle number
+C output: sib_pdg2pid internal particle id
+C
+C based on similar phojet function \FR'13
+C----------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /S_PDG2PID/ IPID_PDG_LIST(99),ID_LIST(577)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+ SAVE
+
+ Nin = abs(Npdg)
+ if((Nin.gt.999999).or.(Nin.eq.0)) then
+C invalid particle number
+ if(ndebug.gt.5) write(6,'(1x,A,I10)')
+ & ' ISIB_PDG2PID: invalid PDG ID number ',Npdg
+ ISIB_PDG2PID = 0
+ return
+ else If(Nin.le.577) then
+C simple case
+ Nout = Nin
+ else
+C use hash algorithm
+ Nout = mod(Nin,577)
+ endif
+
+ 100 continue
+
+C particle not in table
+ if(ID_list(Nout).Eq.0) then
+ if(ndebug.gt.0) write(6,'(1x,A,I10)')
+ & ' ISIB_PDG2PID: particle not in table ',Npdg
+ ISIB_PDG2PID = 0
+ return
+ endif
+ ID_out = ID_list(Nout)
+ IF(abs(ID_out).gt.99)then
+ ISIB_PDG2PID = 0
+ return
+ else
+
+ if(IPID_PDG_LIST(ID_list(Nout)).eq.Nin) then
+C particle ID found
+ ISIB_PDG2PID = ID_list(Nout)
+ if (NPDG.lt.0) ISIB_PDG2PID = lbarp( ISIB_PDG2PID )
+ return
+ else
+C increment and try again
+ Nout = Nout + 5
+ If(Nout.gt.577) Nout = Mod(Nout,577)
+ goto 100
+ endif
+ endif
+ END
+
+C=======================================================================
+
+ SUBROUTINE PDG_INI
+
+C-----------------------------------------------------------------------
+C PDG conversion blocks \FR'13
+C----------------------------------------------------------------
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER ( ID_PDG_MAX = 260 )
+ COMMON /S_PDG2PID/ ID_PDG_LIST(99),ID_LIST(577)
+ SAVE
+ DATA ID_PDG_LIST /22,-11,11,-13,13,111,211,-211,321,-321, !10
+ & 130,310,2212,2112,12,-12,14,-14,-2212,-2112, !20
+ & 311,-311,221,331,213,-213,113,323,-323,313, !30
+ & -313,223,333,3222,3212,3112,3322,3312,3122,2224, !40
+ & 2214,2114,1114,3224,3214,3114,3324,3314,3334,0, !50
+ & 202212,202112,212212,212112,4*0,411,-411, !60
+ & 900111,900211,-900211,7*0, !70
+ & 421,-421,441,431,-431,433,-433,413,-413,423, !80
+ & -423,0,443,4222,4212,4112,4232,4132,4122,-15, !90
+ & 15,-16,16,4224,4214,4114,4324,4314,4332/
+
+ IF(Ndebug.gt.2)
+ & WRITE(LUN,*) ' INITIALIZING PDG TABLES..'
+ CALL SIB_CPCINI(ID_pdg_max,ID_pdg_list,ID_list)
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_CPCINI(Nrows,Number,List)
+
+C-----------------------------------------------------------------------
+C initialization of particle hash table
+C
+C input: Number vector with Nrows entries according to PDG
+C convention
+C
+C output: List vector with hash table
+C
+C (this code is based on the function initpns written by
+C Gerry Lynch, LBL, January 1990)
+C
+C***********************************************************************
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ integer Number(*),List(*),Nrows
+ Integer Nin,Nout,Ip,I
+ SAVE
+
+ do I = 1,577
+ List(I) = 0
+ enddo
+
+C Loop over all of the elements in the Number vector
+
+ Do 500 Ip = 1,Nrows
+ Nin = Number(Ip)
+
+C Calculate a list number for this particle id number
+ If(Nin.Gt.999999.or.Nin.Le.0) Then
+ Nout = -1
+ Else If(Nin.Le.577) Then
+ Nout = Nin
+ Else
+ Nout = Mod(Nin,577)
+ End If
+
+ 200 continue
+
+ If(Nout.Lt.0) Then
+C Count the bad entries
+ IF(Ndebug.gt.3) Write(LUN,'(1x,a,i10)')
+ & ' SIB_CPCINI: invalid particle ID',Nin
+ Go to 500
+ End If
+ If(List(Nout).eq.0) Then
+ List(Nout) = Ip
+ Else
+ If(Nin.eq.Number(List(Nout))) Then
+ IF(Ndebug.gt.3)Write(LUN,'(1x,a,i10)')
+ & ' SIB_CPCINI: double particle ID',Nin
+ End If
+ Nout = Nout + 5
+ If(Nout.Gt.577) Nout = Mod(Nout, 577)
+
+ Go to 200
+ End If
+ 500 Continue
+
+ END
+C=======================================================================
+
+ SUBROUTINE PFSUM(N1,N2,ETOT,PXT,PYT,PZT,NF)
+
+C-----------------------------------------------------------------------
+C...Return the energy,px,py,pz and the number of stable
+C. particles in the list between N1 and N2
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+c COMMON /S_PLIST/ P(8000,5), LLIST(8000), NP
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ SAVE
+
+ NF=0
+ ETOT=0.D0
+ PXT=0.D0
+ PYT=0.D0
+ PZT=0.D0
+ DO J=N1,N2
+ L = LLIST(J)
+ IF (IABS(L) .LT. 10000) THEN
+ NF = NF+1
+ ETOT = ETOT + ABS( P(J,4) )
+ PXT = PXT + P(J,1)
+ PYT = PYT + P(J,2)
+ PZT = PZT + P(J,3)
+ ENDIF
+ ENDDO
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE QNUM (JQ,JS,JC,JB,JBA, NC, NF)
+
+C-----------------------------------------------------------------------
+C...Return the quantum numbers of one event
+C. JQ = charge, JB = baryon number, JS = strangeness, JC = charmedness
+C. JBA = (number of baryons+antibaryons)
+C. NC = number of charged particles
+C. NF = number of final particles
+C..................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+ SAVE
+
+ JQ = 0
+ JB = 0
+ JS = 0
+ JC = 0
+ JBA= 0
+ NC = 0
+ NF = 0
+ DO J=1,NP
+ L = LLIST(J)
+ LL = IABS(L)
+ IF (LL .LT. 10000) THEN
+ IF(ICHP(LL) .NE. 0) NC = NC + 1
+ NF = NF + 1
+ JQ = JQ + ICHP(LL)*ISIGN(1,L)
+ JB = JB + IBAR(LL)*ISIGN(1,L)
+ JBA= JBA+ IBAR(LL)
+ JS = JS + ISTR(LL)*ISIGN(1,L)
+ JC = JC + ICHM(LL)*ISIGN(1,L)
+ ENDIF
+ ENDDO
+ RETURN
+ END
+
+C=======================================================================
+
+ BLOCK DATA KFLV_INI
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER KFLV
+ COMMON /S_KFLV/ KFLV(4,43)
+ SAVE
+ DATA (KFLV(1,i),i=1,4) /6,8,10,71/
+ DATA (KFLV(1,i),i=5,43) /6*0,40,13,34,84,6*0,13,14,39,89,6*0,
+ & 34,39,37,87,6*0,84,85,87/
+ DATA (KFLV(2,i),i=1,4) /7,6,21,59/
+ DATA (KFLV(2,i),i=5,43) /6*0,13,14,39,89,6*0,14,43,36,86,6*0,
+ & 39,36,38,88,6*0,84,85,87/
+ DATA (KFLV(3,i),i=1,4) /9,22,33,74/
+ DATA (KFLV(3,i),i=5,43) /6*0,34,39,35,87,6*0,39,36,38,88,6*0,
+ & 35,36,49,99,6*0,84,85,87/
+ DATA (KFLV(4,i),i=1,4) /72,60,75,83/
+ DATA (KFLV(4,i),i=5,43) /6*0,84,85,87,0,6*0,85,86,88,0,6*0,
+ & 87,88,99,0,6*0,0,0,0/
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_I4FLAV (IFL1, IFL2_A, IRNK, IFL2, KF)
+
+C-----------------------------------------------------------------------
+C. This subroutine receives as input IFL1 the flavor code
+C. of a quark (antiquark) and generates the antiquark (quark)
+C. of flavor code IFL2 that combine with the original parton
+C. to compose an hadron of code KF.
+C.
+C. updated to 4 FLAVORS \FR'13
+C. Baryon sector is from jetset code
+C. assuming D*_s+- are J=1, only Charm=1 baryons
+C.
+C. If (IFL2_A.NE.0) returns an hadron KF composed of IFL1 and IFL2_A
+c
+c Input: IFL1 - flavor of first quark
+c IFL2_A - flavor of second quark ( if 0 randomly chosen )
+c IRNK - position in hadron chain
+c Output: IFL2 - flavor of second quark partner to be passed on
+c KF - final hadron
+C-----------------------------------------------------------------------
+Cf2py integer,intent(out) :: ifl2
+Cf2py integer,intent(out) :: kf
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DIMENSION KFLA(4,4,2), CDIAG(16), KDIAG(8)
+ DIMENSION KBAR(40), CFR(28), KFR(80)
+ SAVE
+ DATA KFLA /0,8,10,71,7,0,22,59,9,21,0,74,72,60,75,0, ! spin-zero mesons
+ + 0,26,29,80,25,0,31,78,28,30,0,76,81,79,77,0/ ! spin-one mesons
+ DATA CDIAG/.5D0,.25D0,.5D0,.25D0,1.D0,.5D0,2.D0,1.D0, !spin-zero diagonal mesons
+ + .5D0,0.D0,.5D0,0.D0,1.D0,1.D0,2.D0,1.D0/ ! spin-one diagonal mesons
+ DATA KDIAG /6,23,24,73,27,32,33,83/
+ DATA KBAR /13,14,34,35,36,37,38,84,85,86, !jetset -> sibyll part. code map
+ + 87,88,99,3*0,39,89,87,88,
+ + 40,41,42,43,44,45,46,47,48,49,
+ + 94,95,96,97,98,99,4*0/ ! spin-3/2 css baryon added to 1/2 css
+ DATA CFR /0.75D0,0.D0,0.5D0,0.D0,0.D0,1.D0,0.1667D0,0.3333D0,
+ $ 0.0833D0,0.6667D0,0.1667D0,0.3333D0,-3.D0,1.D0,-2.D0,
+ $ -2.D0,1.D0,0.D0,0.D0,-3.D0,1.D0,1.D0,1.D0,5*0.D0/
+ DATA KFR/0,16,17,19,100,104,109,115,0,26,27,29,122,126,131,137
+ + ,0,40,42,47,144,158,178,205,0,1,3,6,10,15,21,28,0,0,56,57,240,
+ + 246,256,271,0,0,1,3,6,10,15,21,60,61,64,70,292,307,328,356,
+ + 0,1,3,6,10,15,21,28,16*0/
+
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*)' SIB_FLAV: input:',IFL1, IFL2_A, IRNK, IFL2, KF
+
+c set rho0 / ( omega, phi ) ratio, i.e. I=1 to I=0
+c default: 0.5, 0.0 ( phi only created from s-sbar)
+ CDIAG(8+1) = 1.D0-PAR(143) ! u-flavor, Prob. I=1 vs 0
+ CDIAG(8+3) = 1.D0-PAR(143) ! d-flavor, Prob. I=1 vs 0
+
+ XDIQ = 1.D0
+
+ IARNK = IABS(IRNK)
+ IFLA = IABS(IFL1)
+c check if diq production allowed?
+c for strings with leading diquarks the immediate formation of another diquark may be forbidden
+ if(ifla.gt.100.and.mod(ifla,100).lt.10)then
+ XDIQ = PAR(158)
+ ifl1 = mod(ifl1,100)
+ IFLA = IABS(IFL1)
+ endif
+
+ IFL2A = IFL2_A
+ IF (IFL2A .NE. 0) THEN
+c combine existing flavors to hadron
+c three cases: input diquark (MB=2): need to sample additional quark,
+c input quark (MB=0,1): sample quark (0) or diquark (1)?
+ IFL2A = MOD(IFL2A,100)
+ IFL2 = IFL2A
+ IFLB = IABS(IFL2A)
+ MB = 0
+ IF (IFLB .GT. 10) MB=1
+ IF (IFLA .GT. 10) MB=2
+ ELSE
+c sample new flavor
+ MB = 2
+ IF (IFLA .LT. 10) THEN
+ MB = 1
+ IF ((1.D0+PAR(1))*S_RNDM(0).LT. 1.D0) MB=0
+ XDIQ = 1.D0
+c suppress baryons close to the string end
+c IPAR(55) defines largest forbidden rank
+c PAR(101) is the rejection probability
+ IF (IPAR(54).eq.1)THEN
+ IF(IARNK.le.IPAR(55).and.S_RNDM(1).lt.PAR(101)) MB=0
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 50 IF (MB .EQ. 0) THEN
+c flavor open, sample from u,d,s,c
+ IF (IFL2A.EQ.0)THEN
+ IF(IPAR(69).eq.2)THEN
+c asymmetric between u,d
+ IFL2 = MIN(2,1+INT((2.D0+PAR(115))*S_RNDM(0)))
+ IFLS = 3*INT(INT((2.D0+PAR(2))*S_RNDM(1))*0.5D0)
+ IFL2 = MAX(IFL2,IFLS)
+ IFL2 = ISIGN(IFL2,-IFL1)
+ ELSE
+c symmetric in u,d
+ IFL2=ISIGN(1+INT((2.D0+PAR(2))*S_RNDM(0)),-IFL1)
+ ENDIF
+ IF(IABS(IFL2).eq.3) THEN
+ IF(S_RNDM(1).lt.PAR(24)*PAR(125))
+ + IFL2=ISIGN(4,-IFL1)
+ ENDIF
+ ENDIF
+ IFLD = MAX(IFL1,IFL2)
+ IFLE = MIN(IFL1,IFL2)
+ GOTO 100
+ ENDIF
+
+C... Decide if the diquark must be split
+c if diquark is from previous splitting (popcorn) do NOT split diquark
+c jump to sample quark and form baryon
+ IF (MB .EQ. 2 .AND. IFLA .GT. 100) THEN
+ IFLA = MOD(IFLA,100)
+ GOTO 200
+ ENDIF
+c split diquark? if yes sample single flavor and form meson
+c diquark with any flavor combination is passed on with id+100
+ IF (MB .EQ. 2 .AND. IFL2A .EQ. 0) THEN
+ IF (S_RNDM(0) .LT. PAR(8)) THEN
+ MB = 0
+ IFLG = MOD(IFL1,10)
+ IFLH =(IFL1-IFLG)/10
+ IF (S_RNDM(1) .GT. 0.5D0) THEN
+ IFLDUM = IFLG
+ IFLG = IFLH
+ IFLH = IFLDUM
+ ENDIF
+ IFL11=IFLG
+ IFL22=ISIGN(1+INT((2.D0+PAR(2))*S_RNDM(2)),-IFL1)
+ IFLD = MAX(IFL11,IFL22)
+ IFLE = MIN(IFL11,IFL22)
+ IFL2 = -IFLH*10+IFL22
+ IF (S_RNDM(3) .GT. 0.5D0) IFL2 = IFL22*10-IFLH
+c limit diquark splitting to B-M-B (default: yes)
+ IF(IPAR(92).eq.1) IFL2 = IFL2+ISIGN(100,IFL2)
+ ENDIF
+ ENDIF
+
+C...Form a meson: consider spin and flavor mixing for the diagonal states
+ 100 IF (MB .EQ. 0) THEN
+ IF1 = IABS(IFLD)
+ IF2 = IABS(IFLE)
+ IFLC = MAX(IF1,IF2)
+ KSP = INT(PAR(5)+S_RNDM(0))
+ KSP = MIN(KSP,1)
+ IF (IFLC.EQ.3) KSP = INT(PAR(6)+S_RNDM(1))
+ IF (IFLC.EQ.4) KSP = INT(PAR(6)+S_RNDM(2))
+ IF (IF1 .NE. IF2) THEN
+ KF = KFLA(IF1,IF2,KSP+1)
+ ELSE
+ R = S_RNDM(0)
+ JF=1+INT(R+CDIAG(8*KSP+2*IF1-1))+
+ + INT(R+CDIAG(8*KSP+2*IF1))
+ JF = MIN(JF,4)
+ KF=KDIAG(JF+4*KSP)
+c suppress neutral pions
+ IF(KF.eq.6)THEN
+ IF(IPAR(82).eq.1.and.
+ + S_RNDM(kf).lt.PAR(137))then
+ IF(IFL2A.ne.0) goto 100
+ IF(IFLA.gt.10) mb = 2
+ GOTO 50
+ endif
+c suppress neutral pions, depending on rank
+ IF(IPAR(82).eq.2.and.S_RNDM(3).lt.PAR(137).and.
+ + irnk.gt.0.and.irnk.lt.2) then
+ IF(IFL2A.ne.0) goto 100
+ IF(IFLA.gt.10) mb = 2
+ GOTO 50
+ endif
+ ENDIF
+c suppress rank1 (leading) omega
+ IF(KF.eq.32)THEN
+ IF(IPAR(83).ne.0.and.
+ + S_RNDM(kf).lt.PAR(138))then
+ IF(IFL2A.ne.0) goto 100
+ IF(IFLA.gt.10) mb = 2
+ GOTO 50
+ endif
+ ENDIF
+ ENDIF
+c PRINT*,' I4FLAV returns :(IFL1,IFL2,LL)',IFL1,IFL2,KF
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*)' SIB_FLAV: output:',IFL1, IFL2_A, IRNK, IFL2, KF
+ RETURN
+ ENDIF
+
+C...Form a baryon
+ 200 IF (IFL2A .NE. 0) THEN
+ IF (MB .EQ. 1) THEN
+ IFLD = IFLA
+ IFLE = IFLB/10
+ IFLF = MOD(IFLB,10)
+ ELSE
+ IFLD = IFLB
+ IFLE = IFLA/10
+ IFLF = MOD(IFLA,10)
+ ENDIF
+ LFR = 3+2*((2*(IFLE-IFLF))/(1+IABS(IFLE-IFLF)))
+ IF(IFLD.NE.IFLE.AND.IFLD.NE.IFLF) LFR=LFR+1
+ ELSE
+ 110 CONTINUE
+ IF(MB.EQ.1) THEN ! generate diquark
+ IFLD = IFLA
+ 120 IFLE = 1+INT((2.D0+PAR(2)*PAR(3))*S_RNDM(0))
+ IFLF = 1+INT((2.D0+PAR(2)*PAR(3))*S_RNDM(1))
+ IF(IFLD.NE.4)THEN
+ IF(IFLE.EQ.3)THEN
+ IF(S_RNDM(2).lt.PAR(24)*PAR(125))
+ + IFLE=4
+ ENDIF
+ IF(IFLF.EQ.3.and.IFLE.NE.4)THEN
+ IF(S_RNDM(3).lt.PAR(24)*PAR(125))
+ + IFLF=4
+ ENDIF
+ ENDIF
+ IF(IFLE.GE.IFLF.AND.PAR(4).LT.S_RNDM(4)) GOTO 120
+ IF(IFLE.LT.IFLF.AND.PAR(4)*S_RNDM(5).GT.1.D0) GOTO 120
+ IFL2=ISIGN(10*IFLE+IFLF,IFL1)
+ ELSE ! generate quark
+ IF(IPAR(69).eq.2)THEN
+c asymmetric between u,d
+ IFL2 = MIN(2,1+INT((2.D0+PAR(115))*S_RNDM(6)))
+ IFLS = 3*(INT((2.D0+PAR(2))*S_RNDM(7))/2)
+ IFL2 = MAX(IFL2,IFLS)
+ IFL2 = ISIGN(IFL2,IFL1)
+ ELSE
+c symmetric in u,d
+ IFL2=ISIGN(1+INT((2.D0+PAR(2))*S_RNDM(8)),IFL1)
+ ENDIF
+ IFLE=IFLA/10
+ IFLF=MOD(IFLA,10)
+ IF(IABS(IFL2).EQ.3.and.IFLF.ne.4.and.IFLE.ne.4) THEN
+ IF(S_RNDM(9).lt.PAR(24)*PAR(125))
+ + IFL2=ISIGN(4,IFL1)
+ ENDIF
+ IFLD=IABS(IFL2)
+ ENDIF
+C...SU(6) factors for baryon formation
+ LFR=3+2*((2*(IFLE-IFLF))/(1+IABS(IFLE-IFLF)))
+ IF(IFLD.NE.IFLE.AND.IFLD.NE.IFLF) LFR=LFR+1
+ WT = CFR(2*LFR-1)+PAR(7)*CFR(2*LFR)
+ IF(IFLE.LT.IFLF) WT=WT/3.D0
+ IF (WT.LT.S_RNDM(0)) GOTO 110
+ ENDIF
+
+C...Form Baryon
+ IFLG=MAX(IFLD,IFLE,IFLF)
+ IFLI=MIN(IFLD,IFLE,IFLF)
+ IFLH=IFLD+IFLE+IFLF-IFLG-IFLI
+c IF(IFLG+IFLH.gt.7) GOTO 200 ! forbid double charmed
+ KSP=2+2*INT(1.D0-CFR(2*LFR-1)+(CFR(2*LFR-1)+PAR(7)*
+ 1 CFR(2*LFR))*S_RNDM(0))
+
+C...Distinguish Lambda- and Sigma- like particles
+ IF (KSP.EQ.2.AND.IFLG.GT.IFLH.AND.IFLH.GT.IFLI) THEN
+ IF(IFLE.GT.IFLF.AND.IFLD.NE.IFLG) KSP=2+INT(0.75D0+S_RNDM(1))
+ IF(IFLE.LT.IFLF.AND.IFLD.EQ.IFLG) KSP=3
+ IF(IFLE.LT.IFLF.AND.IFLD.NE.IFLG) KSP=2+INT(0.25D0+S_RNDM(2))
+ ENDIF
+ KF=KFR(16*KSP-16+IFLG)+KFR(16*KSP-8+IFLH)+IFLI
+ IF(KBAR(KF-40).eq.0)THEN
+ WRITE(LUN,*)' jetset code missing,flvs:',kf,IFLG,IFLH,IFLI
+ CALL SIB_REJECT('SIB_I4FLAV ')
+ ENDIF
+ KF=KBAR(KF-40)
+ IF(KF.le.14)THEN
+ IF(PAR(106).gt.S_RNDM(3).and.IARNK.le.IPAR(61)) KF=KF-13+51
+ & +2*INT(PAR(108)+S_RNDM(4))
+ ENDIF
+ KF=ISIGN(KF,IFL1)
+c if leading baryon, mark quark to supress baryon production in the next iteration
+c i.e. forbid: Blead-Bbar-B combination
+ if(iarnk.eq.1.and.IPAR(93).eq.1.and.iabs(mod(ifl1,100)).gt.10)then
+ IFL2 = IFL2 + ISIGN(100,IFL2)
+ endif
+
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*)' SIB_FLAV: output:',IFL1, IFL2_A, IRNK, IFL2, KF
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_ICFLAV( Q2, IS0, IS, IFL )
+
+C-----------------------------------------------------------------------
+C Routine that samples symmetric between the available flavors
+C Input: Q2 - mass scale, usually filled with s_hat
+C IS0 - input flavor sign
+C
+C Output: IFL - flavor code: u,d,s,c or anti-quarks
+C IS - flavor sign: quark or anti-quark, if 0 passed then
+C a new value is sampled
+C Parameters: kT_s and kT_c i.e. width of the fermi function
+C-----------------------------------------------------------------------
+C f2py double precision,intent(in) :: q2
+Cf2py integer,intent(in) :: is0
+Cf2py integer,intent(out) :: is
+Cf2py integer,intent(out) :: ifl
+ IMPLICIT NONE
+ DOUBLE PRECISION Q2
+ INTEGER IFL,IS
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION XMS2,XMC2,P_S,P_C,S_RNDM,QMASS,FERMI
+ INTEGER IFL1,IS0
+
+ IF( NDEBUG.gt.6 )
+ & WRITE(LUN,*)' SIB_ICFLAV: input (Q2,IFL,IS):',Q2,IFL,IS
+
+c quark or antiquark, sampled if input is zero
+ IF(IS0.eq.0) THEN
+ IS = -1 + 2*INT((2.D0-EPS8)*S_RNDM(IS0))
+ ELSE
+ IS = IS0
+ ENDIF
+
+c strange and charm quark masses
+ XMS2 = 4*QMASS(3)**2
+ XMC2 = 4*QMASS(4)**2 * PAR(153)
+
+c strange and charm parameters
+ IF(IPAR(89).eq.1)THEN
+c exponential thresholds
+ P_S = PAR(154) * EXP(-PAR(151)/Q2)
+ P_C = PAR(156) * EXP(-PAR(152)/Q2)
+ ELSE
+c fermi func. threshold
+c P_s: 0 (u,d only) --> 1 (u,d,s equal) --> 2 (u+d,s+c equal)
+c P_c: 0 (s only) --> 1 (s,c) equal
+ P_S = PAR(154) * FERMI( Q2, XMS2, -PAR(151) )
+ & + PAR(155) * FERMI( Q2, XMC2, -PAR(152) )
+ P_C = PAR(156) * 0.5D0*FERMI( Q2, XMC2, -PAR(152) )
+ ENDIF
+ IF(NDEBUG.gt.6)THEN
+ WRITE(LUN,*)' SIB_ICFLAV: (4*M_S**2, P_S, kT):',
+ & xms2, P_s, PAR(151)
+ WRITE(LUN,*)' SIB_ICFLAV: (4*M_C**2, P_C, kT):',
+ & xmc2, P_c, PAR(152)
+ ENDIF
+
+c sample u,d,s
+ IFL1 = MIN(INT((2.D0+P_S)*S_RNDM(IS0))+1,3)
+
+c replace s with c
+ IFL1 = IFL1 + IFL1/3*MIN(INT(P_C+S_RNDM(IS0)),1)
+
+ IFL = IS*IFL1
+
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*)' SIB_ICFLAV: output (Q2,IFL,IS):',Q2,IFL,IS
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_DIFF (L0, JDIF1, Ecm, Irec, IREJ)
+
+C-----------------------------------------------------------------------
+C...diffraction dissociation
+C. INPUT L0 = index of "beam particle"
+C. the target is assumed to be a proton.
+C. JDIF1 = 1 "beam diffraction"
+C. = 2 "target diffraction"
+C. = 3 "double diffraction"
+C Irec flag to avoid recursive calls of SIB_DIFF and SIB_NDIFF
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ DOUBLE PRECISION XM2MIN,ALXMIN,SLOP0,ASLOP,BSLOP,XMASS
+ COMMON /S_DIFMAss/ XM2MIN(6),ALXMIN(6),SLOP0,ASLOP,BSLOP,XMASS(2)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+ INTEGER LRNK
+ COMMON /SIB_RNK/ LRNK(8000)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DIMENSION P0(5),P1(5),P2(5)
+
+C mapping array from particle space to diff. mass
+c six groups: proton, pion, kaons, hyperons,
+c charmed mesons, charmed baryons
+ INTEGER KK,I
+ DIMENSION KK(99)
+ SAVE
+ DATA (KK(I), I= 1,39) /5*0,3*2,4*3,2*1,6*0,6*2,3,6*2,6*4/
+ DATA (KK(I), I=40,99) /19*0,5,5,10*0,5,5,0,5,5,11*0,6,6,6,9*0,6/
+
+ if(Ndebug.gt.1)
+ & WRITE(LUN,*)' SIB_DIFF: called with (L0,JDIF1,Ecm):',
+ & L0,JDIF1,Ecm
+
+ if(Irec.eq.1) THEN
+ Ipflag= -1
+ IIFLAG = 1
+c add incoming target particles
+ PZ = PAWT(ECM,AM(IABS(L0)),AM(13))
+ E2 = SQRT(PZ**2+AM2(13))
+ CALL ADD_PRTN(0.D0,0.D0,-PZ,E2,AM(13),13,-2,0,IREFout)
+
+c add interactions
+ xjdif = dble(jdif1)
+ CALL ADD_PRTN(0.D0,0.D0,xjdif,ecm,0.D0,1,-1,IREFout,IREF)
+ ENDIF
+ CALL GET_NPP(NPP_0,NPP0_0)
+
+ IDBAD = 0
+ NTRY = 0
+ 20 IREJ = 1
+ CALL INI_PRTN_STCK(NPP_0,NPP0_0)
+
+ IF(NTRY.gt.20*Irec) RETURN ! zero tolerance for recursive calls
+ NTRY = NTRY + 1
+
+ LL = L0
+ LA = IABS(L0)
+ XM2MAX = PAR(13)*Ecm*Ecm
+ if(Ndebug.gt.1)
+ & WRITE(LUN,*)' SIB_DIFF: max diff. mass (M,Xi):',XM2MAX,PAR(13)
+
+C...Double diffraction
+ IF (JDIF1 .EQ. 3) THEN
+ K = MAX(1,2-IBAR(LA)-ISTR(LA)-ICHM(LA))
+ IF(Irec.eq.1) K = KK(LA)
+c minimal mass if larger than particle mass plus one pion
+ XMMIN = XM2MIN(K)
+ IF(Irec.eq.0) XMMIN = MAX(XMMIN,(AM(LA)+AM(7)+0.02D0)**2)
+ XMB2 = XM2DIS(XMMIN,XM2MAX,1.D0)
+ XMB = SQRT (XMB2)
+ XMT2 = XM2DIS(XM2MIN(1),XM2MAX,1.D0)
+ XMT = SQRT (XMT2)
+ CALL TRANSFONSHELL(ECM,XMB,XMT,XM2MAX,0,P1,P2,IBAD)
+ IF(IBAD.ne.0) goto 20
+ XMASS(1) = XMB
+ IF(Irec.eq.1)THEN
+c add diffractive system to parton stack
+ CALL ADD_PRTN_4VEC(P1,3,0,0,Iref)
+ CALL ADD_INT_REF(Iref,1)
+ CALL ADD_PRTN_4VEC(P2,-3,0,0,Iref)
+ CALL ADD_INT_REF(Iref,1)
+ ENDIF
+ if(Ndebug.gt.1)
+ & write(lun,*)' double-diff.: (kb,xmb,kt,xmt)',LL,xmb,13,xmt
+ CALL DIFDEC (LL, Irec, IDBAD, P1)
+ IF(IDBAD.eq.1)goto 20
+ Ipflag= -2
+ XMASS(2) = XMT
+ CALL DIFDEC (13, Irec, IDBAD, P2)
+ IF(IDBAD.eq.1)goto 20
+ IREJ = 0
+ RETURN
+ ENDIF
+
+C...Single diffraction
+ IF (JDIF1.EQ. 1) THEN
+ K = MAX(1,2-IBAR(LA))
+ IF(Irec.eq.1) K = KK(LA)
+ EM = AM(13)
+ EM2 = AM2(13)
+ L = 13
+ ZD = -1.D0
+ if(Ndebug.gt.1)
+ & write(lun,*)' single-diff. (beam): (kb)',LL
+ ELSE
+ K = 1
+ EM = AM(LA)
+ EM2 = AM2(LA)
+ L = LL
+ LL = 13
+ ZD = +1.D0
+ if(Ndebug.gt.1)
+ & write(lun,*)' single-diff. (target): (kt)', LL
+
+ ENDIF
+C...Generate the mass of the diffracted system Mx (1/Mx**2 distribution)
+ XMMIN = XM2MIN(K)
+ IF(Irec.eq.0) XMMIN = MAX(XMMIN,(AM(LA)+AM(7)+0.02D0)**2)
+ XM2 = XM2DIS(XMMIN,XM2MAX,1.D0)
+ ALX = log(XM2)
+c... added part
+ X = XM2/XM2MAX*PAR(13)
+ IF (X.GT.PAR(13)-0.05D0) THEN
+ PRO = 0.5D0*(1.D0+(X-PAR(13))/0.05D0)
+ IF (S_RNDM(0).LT.PRO) X = 2.D0*PAR(13)-X
+ XM2 = XM2MAX*X/PAR(13)
+ ENDIF
+c...
+
+ XM = SQRT (XM2)
+ XMB = XM
+ XMT = XM
+ XMASS(1) = XMB
+ XMASS(2) = XMT
+
+C.. kinematics
+ CALL TRANSFONSHELL(ECM,XMB,EM,XM2MAX,0,P1,P2,IBAD)
+ IF(IBAD.ne.0) goto 20
+
+C...Generate the Kinematics of the pseudoelastic hadron
+ NP = NP+1
+ P(NP,4) = P2(4)
+ P(NP,3) = abs(P2(3))*ZD
+ P(NP,1) = p2(1)
+ P(NP,2) = p2(2)
+ P(NP,5) = EM
+ LLIST(NP) = L
+ NPORIG(NP) = IPFLAG
+ niorig(NP) = iiflag
+ LRNK(NP) = 0
+
+C...Generating the hadronic system recoiling against the produced particle
+ P0(5) = SQRT(XM2)
+ P0(4) = P1(4)
+ DO J=1,3
+ P0(J) = -P(NP,J)
+ ENDDO
+ IF(Irec.eq.1)THEN
+c add diffractive system to parton stack
+ CALL ADD_PRTN_4VEC(P1,JDIF1,0,0,Iref)
+ CALL ADD_INT_REF(Iref,1)
+ CALL ADD_PRTN_4VEC(P2,int(zd),0,0,Iref)
+ CALL ADD_INT_REF(Iref,1)
+ ENDIF
+ CALL DIFDEC (LL, Irec, IDBAD, P0)
+ IF(IDBAD.eq.1)goto 20
+ IREJ = 0
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE DIFF_INI
+
+C----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER I,NPION
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION XM2MIN,ALXMIN,SLOP0,ASLOP,BSLOP,XMASS
+ COMMON /S_DIFMAss/ XM2MIN(6),ALXMIN(6),SLOP0,ASLOP,BSLOP,XMASS(2)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ SAVE
+C... Diffractive mass parameters from Sibyll 2.1
+c minimal mass
+ DATA (XM2MIN(I), I=1,3) /1.5D0, 0.2D0, 0.6D0/ ! M_x**2(min) GeV**2
+ DATA (ALXMIN(I), I=1,3) ! log[M_x**2(min)]
+ & /0.405465D0,-1.6094379D0,-0.5108256D0/
+C... pt spectrum
+ DATA SLOP0 /6.5D0/ ! b (slope_ for Mx**2 > 5 GeV**2
+ DATA ASLOP /31.10362D0/ ! fit to the slope parameter.
+ DATA BSLOP /-15.29012D0/
+
+C minimal mass for strange and charmed hadrons:
+C m_beam + n_pi * m_pi
+ NPION = IPAR(86)
+
+C hyperons (4), lowest mass: lambda
+ XM2MIN(4) = AM2(39) + NPION * AM2(7)
+ ALXMIN(4) = log(XM2MIN(4))
+
+C charmed mesons (5), lowest mass: Dmeson
+ XM2MIN(5) = AM2(59) + NPION * AM2(7)
+ ALXMIN(5) = log(XM2MIN(5))
+
+C charmed baryons (6), lowest mass: lambda_c
+ XM2MIN(6) = AM2(89) + NPION * AM2(7)
+ ALXMIN(6) = log(XM2MIN(6))
+
+c debug output
+ IF(NDEBUG.gt.1)THEN
+ WRITE(LUN,*)'DIFF_INI: setting diff. mass parameters'
+ WRITE(LUN,*)' min mass: ', (XM2MIN(I), I=1,6)
+ WRITE(LUN,*)' log min mass: ', (ALXMIN(I), I=1,6)
+ ENDIF
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_PN(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pn/np elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 02/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pn elastic cross section
+ DATA (PTPP(K),K= 1, 18) /
+ & -1.0128D+00,-8.8365D-01,-7.8000D-01,-6.8973D-01,-5.7462D-01,
+ & -4.2138D-01,-2.9384D-01,-1.1581D-01, 1.1309D-01, 5.3273D-01,
+ & 9.6497D-01, 1.4860D+00, 2.0449D+00, 2.6798D+00, 3.5939D+00,
+ & 4.9903D+00, 6.2215D+00, 6.8942D+00/
+ DATA (STPP(K),K= 1, 18) /
+ &1.0001D+02,8.2414D+01,6.5819D+01,5.4660D+01,4.7794D+01,4.0500D+01,
+ &3.5781D+01,3.3208D+01,2.9921D+01,2.3919D+01,1.8633D+01,1.4206D+01,
+ &1.1068D+01,9.0752D+00,7.5167D+00,6.6817D+00,6.8455D+00,6.8568D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 18
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PN: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_pn = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PN: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_pn = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_PP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pp elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 02/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pp elastic cross section
+ DATA (PTPP(K),K= 1, 20) /
+ & -1.0548D+00,-9.9070D-01,-8.2516D-01,-6.8608D-01,-4.7199D-01,
+ & -2.7085D-01,-1.0784D-01,-7.6152D-03, 1.6806D-01, 3.3154D-01,
+ & 5.4551D-01, 8.2275D-01, 1.3768D+00, 2.0058D+00, 2.9862D+00,
+ & 3.7151D+00, 4.3182D+00, 5.1348D+00, 5.6750D+00, 6.2152D+00/
+ DATA (STPP(K),K= 1, 20) /
+ &4.2555D+01,3.7310D+01,2.8426D+01,2.4873D+01,2.2758D+01,2.2166D+01,
+ &2.3350D+01,2.4450D+01,2.5212D+01,2.4535D+01,2.2927D+01,1.9459D+01,
+ &1.4213D+01,1.0745D+01,8.4602D+00,7.3604D+00,6.8528D+00,6.6836D+00,
+ &6.6836D+00,6.6836D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 20
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_pp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_pp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_PN(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pn and np total cross section
+C (based on spline interpolations)
+C
+C (R.Engel 02/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pn total cross section
+ DATA (PTPP(K),K= 1, 17) /
+ & -1.0129D+00,-8.4520D-01,-7.4136D-01,-5.3626D-01,-3.3210D-01,
+ & -1.2859D-01, 8.7237D-02, 3.1519D-01, 6.7022D-01, 1.0889D+00,
+ & 1.5714D+00, 2.0792D+00, 2.6760D+00, 3.9453D+00, 4.9226D+00,
+ & 5.6207D+00, 6.7629D+00/
+ DATA (STPP(K),K= 1, 17) /
+ &1.0000D+02,7.9053D+01,6.0976D+01,4.5194D+01,3.6729D+01,3.3429D+01,
+ &3.3142D+01,3.7303D+01,4.0316D+01,4.1607D+01,4.0746D+01,3.9885D+01,
+ &3.8594D+01,3.8307D+01,3.8881D+01,3.9168D+01,4.1320D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 17
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PN: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_pn = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PN: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_pn = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_PP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pp
+C (based on spline interpolations)
+C
+C (R.Engel 02/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pp total cross section
+ DATA (PTPP(K),K= 1, 23) /
+ & -1.4202D+00,-1.2583D+00,-1.0464D+00,-8.3253D-01,-6.0471D-01,
+ & -3.6376D-01,-8.4289D-02, 6.8739D-02, 1.9666D-01, 3.2471D-01,
+ & 4.2673D-01, 5.5375D-01, 7.5675D-01, 1.0737D+00, 1.5176D+00,
+ & 2.1393D+00, 2.7230D+00, 3.5353D+00, 4.3223D+00, 5.1728D+00,
+ & 5.7949D+00, 6.2392D+00, 6.9122D+00/
+ DATA (STPP(K),K= 1, 23) /
+ &9.2081D+01,7.0000D+01,4.2437D+01,2.8579D+01,2.3858D+01,2.2335D+01,
+ &2.3858D+01,2.8883D+01,3.5888D+01,4.3807D+01,4.7157D+01,4.7766D+01,
+ &4.7157D+01,4.4569D+01,4.1523D+01,3.9695D+01,3.8782D+01,3.8173D+01,
+ &3.8173D+01,3.8477D+01,3.9391D+01,4.0000D+01,4.1523D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 23
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_pp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_pp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_PIPP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pi+p elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pi+p elastic cross section
+ DATA (PTPP(K),K= 1, 24) /
+ & -9.1117D-01,-8.4887D-01,-7.8656D-01,-6.6196D-01,-5.3736D-01,
+ & -4.4390D-01,-3.6083D-01,-2.6738D-01,-1.8431D-01,-5.9706D-02,
+ & 5.4515D-02, 1.3758D-01, 2.4142D-01, 3.5564D-01, 4.0756D-01,
+ & 5.1140D-01, 6.9830D-01, 1.0410D+00, 1.6225D+00, 2.2455D+00,
+ & 2.9620D+00, 3.7407D+00, 4.6026D+00, 5.5163D+00/
+ DATA (STPP(K),K= 1, 24) /
+ &7.3812D+01,5.8453D+01,4.5967D+01,3.1602D+01,2.2652D+01,1.6133D+01,
+ &1.2044D+01,9.2818D+00,8.3978D+00,9.9448D+00,1.2818D+01,1.4144D+01,
+ &1.6354D+01,1.8011D+01,1.7238D+01,1.2928D+01,1.0055D+01,7.1823D+00,
+ &5.5249D+00,4.6409D+00,3.6464D+00,2.9834D+00,3.2044D+00,3.0939D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 24
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PIPP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_pipp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PIPP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_pipp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_PIPP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pi+p total cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pi+p total cross section
+ DATA (PTPP(K),K= 1, 37) /
+ & -9.2155D-01,-8.6963D-01,-8.0733D-01,-7.2426D-01,-5.4774D-01,
+ & -4.7505D-01,-4.1275D-01,-3.6083D-01,-3.0891D-01,-2.2585D-01,
+ & -1.7393D-01,-8.0473D-02, 2.3363D-02, 1.5835D-01, 2.3104D-01,
+ & 2.9334D-01, 3.1411D-01, 3.5564D-01, 4.1794D-01, 4.2833D-01,
+ & 4.9063D-01, 5.7370D-01, 6.7754D-01, 7.2945D-01, 8.1252D-01,
+ & 8.8521D-01, 9.9943D-01, 1.1033D+00, 1.4044D+00, 1.7782D+00,
+ & 2.1313D+00, 2.6712D+00, 3.2942D+00, 3.8342D+00, 4.6441D+00,
+ & 5.4748D+00, 5.8382D+00/
+ DATA (STPP(K),K= 1, 37) /
+ &7.3812D+01,6.4420D+01,5.0939D+01,3.7790D+01,2.3867D+01,1.8674D+01,
+ &1.6022D+01,1.5138D+01,1.4365D+01,1.5138D+01,1.7127D+01,2.0773D+01,
+ &2.4420D+01,2.7845D+01,3.3591D+01,3.9116D+01,4.0773D+01,4.1215D+01,
+ &4.0000D+01,3.8232D+01,3.3370D+01,3.0608D+01,2.9061D+01,2.8619D+01,
+ &2.9834D+01,3.0829D+01,3.0497D+01,2.9061D+01,2.7514D+01,2.5746D+01,
+ &2.4862D+01,2.3646D+01,2.3094D+01,2.2873D+01,2.3204D+01,2.3978D+01,
+ &2.4420D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 37
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PIPP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_pipp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PIPP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_pipp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_PIMP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pi-p elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pi-p elastic cross section
+ DATA (PTPP(K),K= 1, 56) /
+ & -1.8980D+00,-1.5458D+00,-1.4323D+00,-1.3602D+00,-1.2880D+00,
+ & -1.2571D+00,-1.1845D+00,-1.1531D+00,-1.1112D+00,-1.0691D+00,
+ & -1.0063D+00,-9.1252D-01,-8.2935D-01,-7.0477D-01,-6.0118D-01,
+ & -4.6652D-01,-4.1489D-01,-3.9435D-01,-3.6334D-01,-3.4267D-01,
+ & -3.0100D-01,-2.6966D-01,-2.4866D-01,-2.1741D-01,-1.6542D-01,
+ & -1.1357D-01,-9.2992D-02,-8.2923D-02,-4.1875D-02,-1.1054D-02,
+ & 3.0281D-02, 7.2145D-02, 8.2958D-02, 1.1458D-01, 1.5645D-01,
+ & 2.6051D-01, 3.4368D-01, 3.8539D-01, 4.7900D-01, 5.3080D-01,
+ & 6.3455D-01, 7.4898D-01, 9.1527D-01, 1.1023D+00, 1.3412D+00,
+ & 1.5594D+00, 1.9541D+00, 2.4007D+00, 2.7122D+00, 3.0653D+00,
+ & 3.4392D+00, 3.8130D+00, 4.2387D+00, 5.0175D+00, 5.3602D+00,
+ & 5.8897D+00/
+ DATA (STPP(K),K= 1, 56) /
+ &2.9793D+00,9.7103D+00,1.5007D+01,1.9862D+01,2.3393D+01,2.5269D+01,
+ &2.6041D+01,2.4276D+01,2.1076D+01,1.6772D+01,1.3021D+01,1.0372D+01,
+ &9.6000D+00,9.8207D+00,1.1697D+01,1.4234D+01,1.6441D+01,1.8207D+01,
+ &1.9310D+01,2.0083D+01,1.8979D+01,1.7545D+01,1.5779D+01,1.5007D+01,
+ &1.4455D+01,1.5007D+01,1.6441D+01,1.8869D+01,2.2621D+01,2.5159D+01,
+ &2.6703D+01,2.4166D+01,2.0855D+01,1.7214D+01,1.4676D+01,1.2910D+01,
+ &1.2138D+01,1.0814D+01,9.6000D+00,1.0483D+01,1.1145D+01,9.6000D+00,
+ &8.3862D+00,7.5034D+00,6.6207D+00,6.0690D+00,4.9655D+00,4.4138D+00,
+ &4.4138D+00,3.7517D+00,3.3103D+00,3.2000D+00,3.3103D+00,3.3103D+00,
+ &3.3103D+00,3.5310D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 56
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PIMP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_pimp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_PIMP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_pimp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_PIMP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy pi-p total cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C pi-p total cross section
+ DATA (PTPP(K),K= 1, 53) /
+ & -1.9302D+00,-1.8269D+00,-1.6617D+00,-1.5490D+00,-1.4577D+00,
+ & -1.3146D+00,-1.2630D+00,-1.2211D+00,-1.1686D+00,-1.1364D+00,
+ & -1.0937D+00,-1.0305D+00,-9.4645D-01,-8.5245D-01,-7.6915D-01,
+ & -6.7584D-01,-5.2057D-01,-4.3813D-01,-4.0781D-01,-3.6669D-01,
+ & -3.1507D-01,-2.8372D-01,-2.6240D-01,-2.0995D-01,-1.7861D-01,
+ & -1.1661D-01,-9.6329D-02,-7.6149D-02,-3.5817D-02,-5.0811D-03,
+ & 1.5958D-02, 5.8095D-02, 1.1175D-01, 1.7444D-01, 1.9540D-01,
+ & 2.8868D-01, 3.7173D-01, 4.5500D-01, 5.4845D-01, 6.4176D-01,
+ & 7.1436D-01, 8.3919D-01, 9.6397D-01, 1.3069D+00, 1.7018D+00,
+ & 2.0447D+00, 2.5952D+00, 3.1249D+00, 3.6130D+00, 4.1426D+00,
+ & 4.8175D+00, 5.3159D+00, 5.9284D+00/
+ DATA (STPP(K),K= 1, 53) /
+ &1.1145D+01,1.5007D+01,2.2179D+01,3.4428D+01,5.0428D+01,6.7862D+01,
+ &7.0952D+01,6.7972D+01,6.3007D+01,5.5393D+01,4.6566D+01,3.9614D+01,
+ &3.1779D+01,2.7586D+01,2.5821D+01,2.6924D+01,3.0676D+01,3.5531D+01,
+ &4.1931D+01,4.5131D+01,4.7448D+01,4.5903D+01,4.1600D+01,3.7517D+01,
+ &3.6083D+01,3.8400D+01,4.2152D+01,4.6676D+01,5.5945D+01,5.9145D+01,
+ &5.7048D+01,5.2414D+01,3.9062D+01,3.6083D+01,3.4538D+01,3.5862D+01,
+ &3.6083D+01,3.4538D+01,3.4538D+01,3.5641D+01,3.6303D+01,3.4538D+01,
+ &3.3214D+01,3.1117D+01,2.8690D+01,2.7145D+01,2.5600D+01,2.4717D+01,
+ &2.4166D+01,2.4166D+01,2.3945D+01,2.4055D+01,2.5159D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 53
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PIMP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_pimp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_PIMP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_pimp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_KPP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy K+p elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C K+p elastic cross section
+ DATA (PTPP(K),K= 1, 22) /
+ & -1.1500D+00,-8.0733D-01,-5.4774D-01,-4.1275D-01,-2.5700D-01,
+ & -8.0474D-02, 7.5281D-02, 2.5180D-01, 3.7641D-01, 5.3216D-01,
+ & 6.8792D-01, 8.4368D-01, 1.0929D+00, 1.5913D+00, 1.9340D+00,
+ & 2.3182D+00, 2.8166D+00, 3.2215D+00, 3.4708D+00, 3.9276D+00,
+ & 4.6233D+00, 5.5475D+00/
+ DATA (STPP(K),K= 1, 22) /
+ &1.2227D+01,1.2570D+01,1.2499D+01,1.2498D+01,1.2428D+01,1.2012D+01,
+ &1.1183D+01,1.0284D+01,9.4544D+00,8.2796D+00,6.8977D+00,5.9300D+00,
+ &4.6854D+00,3.6461D+00,3.2293D+00,3.0193D+00,2.6704D+00,2.4602D+00,
+ &2.3203D+00,2.0407D+00,2.2426D+00,2.5809D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 22
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_KPP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_kpp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_KPP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_kpp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_KPP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy K+p total cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C K+p total cross section
+ DATA (PTPP(K),K= 1, 20) /
+ & -1.0981D+00,-7.1388D-01,-4.7505D-01,-3.1930D-01,-1.7393D-01,
+ & -8.0474D-02, 2.3363D-02, 9.6049D-02, 1.9989D-01, 3.2449D-01,
+ & 4.6986D-01, 6.2562D-01, 8.3329D-01, 1.0825D+00, 1.4355D+00,
+ & 2.1001D+00, 2.6920D+00, 3.5434D+00, 4.6337D+00, 5.7448D+00/
+ DATA (STPP(K),K= 1, 20) /
+ &1.2158D+01,1.2362D+01,1.2429D+01,1.2428D+01,1.3187D+01,1.4429D+01,
+ &1.5809D+01,1.7327D+01,1.8224D+01,1.8430D+01,1.7945D+01,1.7806D+01,
+ &1.7459D+01,1.7250D+01,1.7041D+01,1.7381D+01,1.7446D+01,1.7853D+01,
+ &1.8881D+01,2.0529D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 20
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_KPP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_kpp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_KPP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_kpp = FV(1)
+
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGELA_KMP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy K-p elastic cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C K-p elastic cross section
+ DATA (PTPP(K),K= 1, 36) /
+ & -1.7871D+00,-1.4709D+00,-1.2813D+00,-1.1867D+00,-1.0179D+00,
+ & -8.8055D-01,-8.0666D-01,-7.9648D-01,-7.7560D-01,-6.5951D-01,
+ & -5.6450D-01,-4.7995D-01,-3.9539D-01,-3.4256D-01,-2.7894D-01,
+ & -2.4691D-01,-2.0439D-01,-1.1952D-01,-1.3598D-02, 6.0479D-02,
+ & 1.1311D-01, 1.4462D-01, 2.0784D-01, 2.6053D-01, 3.2387D-01,
+ & 4.4022D-01, 5.5672D-01, 6.9424D-01, 8.6348D-01, 1.2127D+00,
+ & 1.6678D+00, 2.3770D+00, 3.2133D+00, 3.9226D+00, 4.6425D+00,
+ & 5.1612D+00/
+ DATA (STPP(K),K= 1, 36) /
+ &6.8962D+01,5.6135D+01,4.7307D+01,4.0271D+01,3.5582D+01,3.2549D+01,
+ &3.0480D+01,2.6617D+01,2.3858D+01,2.0410D+01,1.7927D+01,1.6549D+01,
+ &1.5308D+01,1.4343D+01,1.5310D+01,1.7794D+01,1.9451D+01,2.1108D+01,
+ &2.1661D+01,2.1386D+01,1.8490D+01,1.6144D+01,1.3386D+01,1.1041D+01,
+ &9.3860D+00,8.4219D+00,8.8376D+00,7.8738D+00,6.4965D+00,4.7080D+00,
+ &3.8869D+00,3.3456D+00,2.6682D+00,2.5409D+00,2.6896D+00,2.6974D+00/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 36
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_KMP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigela_kmp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGELA_KMP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigela_kmp = FV(1)
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIGTOT_KMP(plab)
+
+C-----------------------------------------------------------------------
+C
+C low-energy K-p total cross section
+C (based on spline interpolations)
+C
+C (R.Engel 05/01)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+
+ dimension PTPP(100),STPP(100),DERIV(100,2),Z(10),FV(10),FD(10,2)
+ logical init
+ SAVE
+ data init /.true./
+
+C K-p total cross section
+ DATA (PTPP(K),K= 1, 43) /
+ & -1.3500D+00,-1.2345D+00,-9.8216D-01,-8.2491D-01,-7.4143D-01,
+ & -6.1508D-01,-4.5679D-01,-3.7223D-01,-2.9802D-01,-2.6595D-01,
+ & -1.7037D-01,-1.0660D-01,-2.1599D-02,-2.5037D-04, 6.3445D-02,
+ & 8.4428D-02, 1.3703D-01, 1.5769D-01, 1.8898D-01, 2.4156D-01,
+ & 3.3667D-01, 3.5796D-01, 4.1106D-01, 5.1700D-01, 5.9099D-01,
+ & 6.5431D-01, 6.9651D-01, 7.7067D-01, 8.5538D-01, 9.6104D-01,
+ & 1.1303D+00, 1.3209D+00, 1.4266D+00, 1.5853D+00, 1.8075D+00,
+ & 1.9769D+00, 2.4743D+00, 3.0353D+00, 3.5222D+00, 4.0515D+00,
+ & 4.6550D+00, 5.1949D+00, 5.7455D+00/
+ DATA (STPP(K),K= 1, 43) /
+ &9.7669D+01,8.8840D+01,7.2700D+01,5.8076D+01,4.6625D+01,4.0142D+01,
+ &3.5315D+01,3.4074D+01,3.5041D+01,3.7939D+01,4.0838D+01,4.3185D+01,
+ &4.6084D+01,4.7740D+01,4.9397D+01,4.7603D+01,4.4430D+01,3.9601D+01,
+ &3.5186D+01,3.1876D+01,3.0221D+01,3.1325D+01,3.2982D+01,3.3674D+01,
+ &3.2571D+01,3.0640D+01,2.9261D+01,2.9814D+01,2.9953D+01,2.8023D+01,
+ &2.6922D+01,2.6924D+01,2.5684D+01,2.4859D+01,2.4034D+01,2.3761D+01,
+ &2.2112D+01,2.1155D+01,2.0472D+01,2.0480D+01,2.0627D+01,2.0773D+01,
+ &2.1472D+01/
+
+
+C initialize cross section tables
+
+ if(init) then
+ N = 43
+ M = 0
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,-1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_KMP: spline initialization failed: ',IERR
+ stop
+ endif
+ NXY_save = NXY
+ init = .false.
+ endif
+
+C spline interpolation
+
+ sigtot_kmp = 0.D0
+ Z(1) = log(plab)
+
+ if((Z(1).gt.PTPP(1)).and.(Z(1).lt.PTPP(N))) then
+ M = 1
+ NXY = NXY_save
+ CALL SPLIN3(PTPP,STPP,DERIV,N,100,Z,FV,FD,M,10,1)
+ if(IERR.ne.0) then
+ write(6,'(1x,a,i6)')
+ & ' SIGTOT_KMP: spline interpolation failed: ',IERR
+ return
+ endif
+ else
+ return
+ endif
+
+ sigtot_kmp = FV(1)
+
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE SPLIN3(X,Y,DERIV,N,NC,Z,FVALUE,FDERIV,M,MC,IOP)
+
+C-----------------------------------------------------------------------
+C
+C CERN LIBRARY PROGRAM NO E-209.
+C
+C REVISED VERSION JULY 1973.
+C
+C CHANGED BY R.ENGEL (10/10/93) TO CONFORM WITH F77 STANDARD
+C
+C PURPOSE = TO COMPUTE A NATURAL SPLINE APPROXIMATION OF THIRD ORDER
+C FOR A FUNCTION Y(X) GIVEN IN THE N POINTS (X(I),Y(I)) ,
+C I=1(1)N.
+C
+C PARAMETERS (IN LIST).
+C
+C X = AN ARRAY STORING THE INPUT ARGUMENTS.DIMENSION X(N).
+C Y = AN ARRAY STORING THE INPUT FUNCTION VALUES.THE ELEMENT
+C Y(I) REPRESENT THE FUNCTION VALUE Y(X) FOR X=X(I).
+C DERIV = AN ARRAY USED FOR STORING THE COMPUTED DERIVATIVES OF
+C THE FUNCTION Y(X).IN DERIV(I,1) AND DERIV(I,2) ARE STOR-
+C ED THE FIRST-AND SECOND ORDER DERIVATIVES OF Y(X) FOR
+C X=X(I) RESPECTIVELY.
+C N = NUMBER OF INPUT FUNCTION VALUES.
+C NC = ARRAY DERIV IS DIMENSIONED DERIV(NC,2) IN CALLING
+C PROGRAM.
+C Z = AN ARRAY STORING THE ARGUMENTS FOR THE INTERPOLATED
+C VALUES TO BE COMPUTED.
+C FVALUE = AN ARRAY STORING THE COMPUTED INTERPOLATED VALUES.
+C FVALUE(J) REPRESENT THE FUNCTION VALUE FVALUE(Z) FOR
+C Z=Z(J).
+C FDERIV = AN ARRAY USED FOR STORING THE DERIVATIVES OF THE COM-
+C PUTED INTERPOLATED VALUES.EXPLANATION AS FOR DERIV.
+C M = NUMBER OF INTERPOLATED VALUES TO BE COMPUTED.
+C MC = ARRAY FDERIV IS DIMENSIONED FDERIV(MC,2) IN CALLING
+C PROGRAM.
+C IOP = OPTION PARAMETER.FOR IOP.LE.0 THE DERIVATIVES FOR EACH
+C SUB-INTERVAL IN THE SPLINE APPROXIMATION ARE COMPUTED.
+C IOP=-1, THE SECOND ORDER END-POINT
+C DERIVATIVES ARE COMPUTED BY
+C LINEAR EXTRAPOLATION.
+C IOP=0 , THE SECOND ORDER END-POINT
+C DERIVATIVES ASSUMED TO BE GI-
+C VEN (SEE COMMON /SPAPPR/).
+C IOP=1 , COMPUTE SPLINE APPROXIMATIONS
+C FOR THE ARGUMENTS GIVEN IN
+C THE ARRAY Z,THE DERIVATIVES
+C BEEING ASSUMED TO HAVE BEEN
+C CALCULATED IN A PREVIOUS CALL
+C ON THE ROUTINE.
+C
+C PARAMETERS (IN COMMON BLOCK / SPAPPR /).
+C
+C SECD1 = VALUE OF THE SECOND DERIVATIVE D2Y(X)/DX2 FOR THE INPUT
+C ARGUMENT X=X(1).
+C SECDN = VALUE OF THE SECOND DERIVATIVE D2Y(X)/DX2 FOR THE INPUT
+C ARGUMENT X=X(N).
+C NB. VALUES HAVE TO BE ASSIGNED TO SECD1 AND SECDN IN THE
+C CALLING PROGRAM.IF A NATURAL SPLINE FIT IS WANTED PUT
+C SECD1=SECDN=0.
+C VOFINT = COMPUTED APPROXIMATION FOR THE INTEGRAL OF Y(X) TAKEN
+C FROM X(1) TO X(N).
+C IERR = ERROR PARAMETER.IERR=0,NO ERRORS OCCURED.
+C IERR=1,THE NUMBER OF POINTS TOO SMALL
+C I.E.N LESS THAN 4.
+C IERR=2,THE ARGUMENTS X(I) NOT IN INCREA-
+C SING ORDER.
+C IERR=3,ARGUMENT TO BE USED IN INTERPOLA-
+C TION ABOVE RANGE.
+C IERR=4,ARGUMENT TO BE USED IN INTERPOLA-
+C TION BELOW RANGE.
+C NXY = N (SEE ABOVE),HAS TO BE STORED FOR ENTRIES CORRESPONDING
+C TO IOP=1.
+C
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ DIMENSION X(NC) , Y(NC) , DERIV(NC,2) , Z(MC) , FVALUE(MC) ,
+ 1 FDERIV(MC,2)
+C
+ COMMON / SPAPPR / SECD1 , SECDN , VOFINT , IERR , NXY
+ SAVE
+ DATA THIRD , SIXTH / .333333333333333D0 , .166666666666667D0 /
+C
+C 1000
+ IF (IOP.GT.0) GO TO 1110
+C
+ IERR=0
+C
+C CHECK IF ENOUGH DATA-POINTS ARE AVAILABLEI.E. IF N LESS THAN 4 NO
+C THIRD ORDER SPLINE APPROXIMATION IS POSSIBLE.
+C
+ IF (N.GE.4) GO TO 1010
+C
+ IERR=1
+ GO TO 2000
+C
+C START CALCULATION OF COEFFICIENTS TO BE USED IN THE SYSTEM OF EQU-
+C ATIONS FOR THE SECOND ORDER DERIVATIVES OF Y(X).
+C
+ 1010 IF (IOP.NE.-1) GO TO 1015
+ SECD1=0.D0
+ SECDN = 0.D0
+ BET1=1.D0/(1.D0+0.5D0*(X(2)-X(1))/(X(3)-X(2)))
+ ALF1=BET1*(1.D0- ((X(2)-X(1))/(X(3)-X(2)))**2)
+ BETN=1.D0/(1.D0+0.5D0*(X(N)-X(N-1))/(X(N-1)-X(N-2)))
+ ALFN=BETN*(1.D0- ((X(N)-X(N-1))/(X(N-1)-X(N-2)))**2)
+C
+ 1015 DERIV(1,2)=SECD1
+ DERIV(N,2)=SECDN
+ DERIV(1,1)=0.D0
+ DXPLUS=X(2)-X(1)
+C
+C CHECK IF ARGUMENTS ARE IN INCREASING ORDER.IF NOT PRINT ERROR
+C MESSAGE AND STOP.
+C
+ IF ( DXPLUS.GT.0.D0) GO TO 1020
+ IN=1
+ IERR=2
+ GO TO 2000
+C
+ 1020 DYPLUS=(Y(2)-Y(1))/DXPLUS
+ IU=N-1
+ DO 1040 I=2,IU
+ DXMIN =DXPLUS
+ DYMIN =DYPLUS
+ DXPLUS=X(I+1)-X(I)
+C
+C CHECK IF ARGUMENTS ARE IN INCREASING ORDER.IF NOT PRINT ERROR
+C MESSAGE AND STOP.
+C
+ IF (DXPLUS.GT.0.D0) GO TO 1030
+C
+ IN=I
+ IERR=2
+ GO TO 2000
+C
+ 1030 DXINV =1.D0/(DXPLUS+DXMIN)
+ DYPLUS=(Y(I+1)-Y(I))/DXPLUS
+ DIVDIF=DXINV*(DYPLUS-DYMIN)
+ ALF =0.5D0*DXINV*DXMIN
+ BET =0.5D0-ALF
+C
+ IF (I.EQ.2) DIVDIF=DIVDIF-THIRD*ALF*DERIV(1,2)
+ IF (I.EQ.IU) DIVDIF=DIVDIF-THIRD*BET*DERIV(N,2)
+ IF (I.EQ.2) ALF=0.D0
+C
+ IF (IOP.NE.-1) GO TO 1035
+ IF (I.NE.2) GO TO 1032
+ BET=BET*ALF1
+ DIVDIF=DIVDIF*BET1
+ GO TO 1035
+ 1032 IF (I.NE.IU) GO TO 1035
+ ALF=ALF*ALFN
+ DIVDIF=DIVDIF*BETN
+C
+ 1035 DXINV =1.D0/(1.D0+ALF*DERIV(I-1,1))
+ DERIV(I,1)=-DXINV*BET
+ DERIV(I,2)= DXINV*(3.D0*DIVDIF-ALF*DERIV(I-1,2))
+ 1040 CONTINUE
+C
+C COMPUTE THE SECOND DERIVATIVES BY BACKWARDS RECURRENCE RELATION.
+C THE SECOND ORDER DERIVATIVES FOR X=X(N-1) ALREADY COMPUTED.
+C
+C 1050
+ DO 1060 I=2,IU
+ J=N-I
+ DERIV(J,2)=DERIV(J,1)*DERIV(J+1,2)+DERIV(J,2)
+ 1060 CONTINUE
+C
+ IF (IOP.NE.-1) GO TO 1070
+ DERIV(1,2)=((X(3)-X(1))/(X(3)-X(2)))*DERIV(2,2)-((X(2)-X(1))/(X(3)
+ $-X(2)))*DERIV(3,2)
+ DERIV(N,2)=-((X(N)-X(N-1))/(X(N-1)-X(N-2)))*DERIV(N-2,2)+((X(N)-X(
+ $N-2))/(X(N-1)-X(N-2)))*DERIV(N-1,2)
+C
+C CALCULATION OF THE SECOND ORDER DERIVATIVES FINISHED.START CAL-
+C CULATION OF THE FIRST ORDER DERIVATIVES AND OF THE INTEGRAL.
+C
+ 1070 VOFINT=0.D0
+ DO 1080 I=1,IU
+ DXPLUS=X(I+1)-X(I)
+ DYPLUS=Y(I+1)-Y(I)
+ DIVDIF=DYPLUS/DXPLUS
+ DERIV(I,1)=DIVDIF-DXPLUS*(THIRD*DERIV(I,2)+SIXTH*DERIV(I+1,2))
+ DXPLUS=0.5D0*DXPLUS
+ VOFINT=VOFINT+DXPLUS*(Y(I+1)+Y(I)-THIRD*(DERIV(I+1,2)+DERIV(I,2))*
+ $DXPLUS**2)
+ 1080 CONTINUE
+C
+C COMPUTE THE LAST FIRST ORDER DERIVATIVE.
+C
+ DXPLUS=X(N)-X(N-1)
+ DYPLUS=Y(N)-Y(N-1)
+ DIVDIF=DYPLUS/DXPLUS
+ DERIV(N,1)=DIVDIF+DXPLUS*(SIXTH*DERIV(N-1,2)+THIRD*DERIV(N,2))
+C
+C CALCULATION OF FIRST ORDER DERIVATIVES AND INTEGRAL FINISHED.
+C
+C SET VALUE OF N IN COMMON BLOCK / SPAPPR /.
+C
+ NXY=N
+C
+C COMPUTE INTERPOLATED VALUES IF ANY.
+C
+ 1110 IF (M.LT.1) RETURN
+C
+ XL=X(1)
+ XU=X(2)
+ IP=3
+ IL=0
+C
+C 1120
+ DO 1160 J=1,M
+ ARG=Z(J)
+ IF (ARG.GT.XU) GO TO 1170
+ IF (ARG.LT.XL) GO TO 1190
+C
+C ARGUMENT IN CORRECT RANGE.CHECK IF POLYNOMIAL COEFFICIENTS HAVE
+C TO BE CALCULATED.
+C
+C 1130
+ IF (IL.GT.0) GO TO 1150
+C
+C COMPUTE POLYNOMIAL COEFFICIENTS.
+C
+ 1140 II=IP-2
+ A0=Y(II)
+ A1=DERIV(II,1)
+ A4=DERIV(II,2)
+ A6=(DERIV(II+1,2)-A4)/(XU-XL)
+ A2=0.5D0*A4
+ A3=SIXTH*A6
+ A5=0.5D0*A6
+ IL=1
+C
+C CALCULATION OF POLYNOMIAL COEFFICIENTS FINISHED.COMPUTE VALUES.
+C
+ 1150 ARG=ARG-XL
+ FVALUE(J)=((A3*ARG+A2)*ARG+A1)*ARG+A0
+ FDERIV(J,1)=(A5*ARG+A4)*ARG+A1
+ FDERIV(J,2)=A6*ARG+A4
+C
+ 1155 CONTINUE
+ GOTO 1160
+C
+C RANGE MOVING
+C
+C
+C ARGUMENT ABOVE PRESENT RANGE.SHIFT RANGE UPWARDS.
+C
+ 1170 IF(IP.GT.NXY) GO TO 1185
+ IPP=IP
+ DO 1180 I=IPP,NXY
+ IF (ARG.GT.X(I)) GO TO 1180
+ XL=X(I-1)
+ XU=X(I)
+ IP=I+1
+ IL=0
+ GO TO 1140
+C
+ 1180 CONTINUE
+C
+C ARGUMENT OUT OF RANGE,I.E. ARG GREATER THAN X(N).
+C
+ 1185 IERR=3
+ IP=NXY+1
+ GO TO 2010
+C
+C ARGUMENT BELOW PRESENT RANGE.SHIFT DOWNWARDS.
+C
+ 1190 IPP=IP
+ DO 1200 I=1,IPP
+ II=IP-I-2
+ IF (II.EQ.0) GO TO 1210
+ IF (ARG.LT.X(II)) GO TO 1200
+ XL=X(II)
+ XU=X(II+1)
+ IP=II+2
+ IL=0
+ GO TO 1140
+C
+ 1200 CONTINUE
+C
+C ARGUMENT OUT OF RANGE,I.E. ARG LESS THAN X(1).
+C
+ 1210 IERR=4
+ IP=3
+ GO TO 2010
+C
+ 2010 WRITE(6,3000) IERR , ARG
+C
+ FVALUE(J)=0.D0
+ FDERIV(J,1)=0.D0
+ FDERIV(J,2)=0.D0
+C
+ II=IP-2
+ XL=X(II)
+ XU=X(II+1)
+ IL=0
+ GO TO 1155
+C
+C
+C END OF INTERPOLATION LOOP
+C
+ 1160 CONTINUE
+C
+C CALCULATION OF INTERPOLATED VALUES FINISHED.
+C
+ RETURN
+C
+C PRINT ERROR MESSAGES.
+C
+ 2000 IF (IERR.EQ.1) WRITE(6,3000) IERR
+ IF (IERR.EQ.2) WRITE(6,3000) IERR , X(IN) , X(IN+1)
+ RETURN
+C
+ 3000 FORMAT(//5X,'*** SUBROUTINE SPLIN3 ERROR NO ',I2,' ***',
+ $ 2(4X,E21.14))
+C
+ END
+C=======================================================================
+
+ SUBROUTINE FRAG_VLNCE(IDX,LBAD)
+
+C-----------------------------------------------------------------------
+C routine that fragments a quark - quark system \FR'14
+C
+C INPUT: IDX : parton stack index of central string
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER IDX,LBAD
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DOUBLE PRECISION PST,PBM,PTG,PSTH,P1,P2,GABE,EE,
+ & PAR1_def,PAR24_def,PX1,PY1,PX2,PY2,GAM,BET,P1TOT,P2TOT,
+ & SIF,COF,COD,SID,ANORF,PZ
+ DIMENSION PST(5),PBM(5),PTG(5),PSTH(5),P1(4),P2(4),GABE(4)
+ INTEGER LSTH,IPID,IBMST,ITGST,ISTH,IFLB,IFLT,IST,I,IFBAD,JJ,
+ & NOLD,II,K,J
+ SAVE
+
+ LBAD = 2
+ LSTH = 0
+
+c references are:
+c string --> bm-parton --> tg-parton (--> merged string/hadron)
+c read string 4momentum from stack
+ CALL RD_PRTN_4VEC(IDX,PST,IPID,IBMST)
+ CALL RD_PRTN_4VEC(IBMST,PBM,IFLB,ITGST)
+ CALL RD_PRTN_4VEC(ITGST,PTG,IFLT,ISTH)
+
+C kinematic variables
+ EE = PST(5) ! string mass
+
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' FRAG_VLNCE: IDX,EE,IFLB,IFLT',
+ & IDX,EE,IFLB,IFLT
+
+ IF(IDX.ne.ISTH) then
+c read merged string and add hadron to final particle stack..
+ CALL RD_PRTN_4VEC(ISTH,PstH,LSTH,IST)
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' FRAG_VLNCE: found merged string',
+ & LSTH,(PSTH(I),I=1,5)
+ IF(IDX.ne.IST) then
+ write(lun,*) ' FRAG_VLNCE: reference loop broken!' , IDX
+ CALL SIB_REJECT('FRAG_VLNCE ')
+ endif
+ NP = NP + 1
+ DO I=1,4
+ P(NP,I) = PST(I)
+ ENDDO
+ P(NP,5) = AM(IABS(LSTH))
+ LLIST(NP) = LSTH
+ NPORIG(NP) = IPFLAG*2+KINT
+ niorig(NP) = iiflag
+ LBAD = 0
+ RETURN
+ ENDIF
+
+c baryon production setup
+ PAR1_def = PAR(1)
+ if( NSOF+NJET.gt.0) then
+ PAR(1)= PAR(15)
+ else
+ PAR(1)= PAR(14)
+ endif
+
+c charm fractions in different parameterizations
+ PAR24_def = PAR(24)
+ IF(IPAR(15).gt.2.and.IPAR(15).ne.7.and.IPAR(15).lt.12)THEN
+ PAR(24) = PAR(25)*EXP(-PAR(26)/EE)
+ ENDIF
+
+ IF(NDEBUG.gt.1)
+ & WRITE(LUN,*)' FRAG_VLNCE: parameters (CHM,DIQ,STR,VEC,POP)',
+ & PAR(24),PAR(1),PAR(2),PAR(5),PAR(8)
+
+ NOLD=NP
+ IF(IPAR(38).eq.1.or.IPAR(38).eq.2)THEN
+C... rotate strings instead of attaching all pt to string end hadrons
+ PX1 = 0.D0
+ PY1 = 0.D0
+ PX2 = 0.D0
+ PY2 = 0.D0
+ ELSEIF(IPAR(38).eq.0.or.IPAR(38).eq.3)THEN
+c assign pt to hadrons at string end (old model)
+ PX1 = PBM(1)
+ PY1 = PBM(2)
+ PX2 = PTG(1)
+ PY2 = PTG(2)
+ GAM = PST(4)/EE
+ BET = PST(3)/PST(4)
+ ENDIF
+
+C... fragment strings in string restframe
+ CALL STRING_FRAG_4FLV
+ & (EE,IFLB,IFLT,PX1,PY1,PX2,PY2,IFBAD,1)
+
+ PAR(24) = PAR24_def
+ PAR(1) = PAR1_def
+ KINT= 0
+ IF (IFBAD .EQ. 1) then
+ if(Ndebug.gt.1)
+ & WRITE(LUN,*)' STRING_FRAG: rejection (Ncall):',Ncall
+ RETURN
+ ENDIF
+
+C... rotate and boost string
+ IF(IPAR(38).eq.1.or.IPAR(38).eq.2)THEN
+C boost quark momentum to string center-of-mass
+c to calculate rotation angles in string center-of-mass
+ do jj=1,3
+ gabe(jj) = PST(jj)/PST(5)
+ enddo
+ GABE(4) = PST(4)/PST(5)
+ CALL SIB_ALTRA(gabe(4),-gabe(1),-gabe(2),-gabe(3),
+ & PBM(1),pbm(2),pbm(3),pbm(4),
+ & P1TOT,p1(1),p1(2),p1(3),p1(4))
+ CALL SIB_ALTRA(gabe(4),-gabe(1),-gabe(2),-gabe(3),
+ & PTG(1),pTG(2),ptg(3),ptg(4),
+ & P2TOT,p2(1),p2(2),p2(3),p2(4))
+
+c should be back-to-back...
+ IF(ndebug.gt.1)THEN
+ write(lun,*)
+ & ' FRAG_VLNCE: string c.m. momentum, parton 1 (Pabs,P(i)):' ,
+ & P1TOT, (P1(j),j=1,4)
+ write(lun,*)
+ & ' FRAG_VLNCE: string c.m. momentum, parton 2 (Pabs,P(i)):' ,
+ & P2TOT, (P2(j),j=1,4)
+ write(lun,*) ' partons should be back to back...'
+ ENDIF
+c rotation factors
+ COD= P1(3)/P1TOT
+ SID= DSQRT(P1(1)**2+P1(2)**2)/P1TOT
+ COF=1.D0
+ SIF=0.D0
+ IF(P1TOT*SID.GT.EPS5) THEN
+ COF=P1(1)/(SID*P1TOT)
+ SIF=P1(2)/(SID*P1TOT)
+ ANORF=DSQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+c rotate string final state
+ DO K=NOLD+1,NP
+ CALL SIB_TRANI(P(K,1),P(k,2),P(k,3),cod,sid,cof,sif
+ & ,P2(1),P2(2),P2(3))
+ do ii=1,3
+ P(K,ii)=P2(ii)
+ enddo
+ ENDDO
+c boost to hadron - hadron center-of-mass
+ DO K=NOLD+1,NP
+ CALL SIB_ALTRA(gabe(4),gabe(1),gabe(2),
+ & gabe(3),P(k,1),p(k,2),p(k,3),p(k,4),
+ & P1TOT,p2(1),p2(2),p2(3),p2(4))
+ do ii=1,4
+ P(K,ii)=P2(ii)
+ enddo
+ ENDDO
+ ELSEIF(IPAR(38).eq.0.or.IPAR(38).eq.3)THEN
+C... boost string
+ DO K=NOLD+1,NP
+ PZ = P(K,3)
+ P(K,3) = GAM*(PZ+BET*P(K,4))
+ P(K,4) = GAM*(P(K,4)+BET*PZ)
+ ENDDO
+ ENDIF
+ LBAD = 0
+ END
+
+
+C-----------------------------------------------------------------------
+C fragmentation functions in SIBYLL \FR'14
+C=======================================================================
+
+ FUNCTION ZDIS_4FLV (IFL1,IFL2, XMT2)
+
+C-----------------------------------------------------------------------
+C...z distribution
+c includes charmed fragmentation (Peterson/SLAC)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+ DOUBLE PRECISION FAs1, fAs2
+ COMMON /S_CZDISs/ FAs1, fAs2
+ DOUBLE PRECISION ZDMAX, EPSI
+ COMMON /S_CZDISc/ ZDMAX, EPSI
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ IAFL1 = IABS(mod(IFL1,100))
+ IAFL2 = IABS(mod(IFL2,100))
+c SLAC-Peterson fragmentation function for charm
+ IF ((IAFL1/10.eq.4.or.mod(IAFL1,10).eq.4)
+ + .or.(IAFL2/10.eq.4.or.mod(IAFL2,10).eq.4))THEN
+ 90 z = max(S_RNDM(0),1.e-8)
+ tcp = zmefn(z,epsi)/zdmax
+ if (tcp .lt. S_RNDM(1)) goto 90
+ zdis_4flv = z
+ else
+c original lund function, non charm
+ fa=fain ! lund parameter a
+ fb0=fb0in ! lund parameter b
+c parameters for hard scattering (gluon) fragmentation
+ IF(IPAR(6).eq.2)THEN
+ fa= PAR(18)
+ fb0= PAR(19)
+ ENDIF
+c special parameters for strange fragmentation
+c only active for baryon beams (or K0,K0bar)
+C DH correction may 10-1996
+ if (iabs(kb).ge.13) then ! baryons only
+ if (iafl2.eq.3) fa=fain+fas2
+ if (iafl1.eq.3) fa=fain+fas1
+ endif
+c special parameters for baryon fragmentation
+c similar to pythia
+ IF((IAFL1+IAFL2).gt.10.and.
+ & (IPAR(36).eq.1.or.IPAR(20).eq.3))then
+ fa = fain + PAR(45)
+ fb0 = PAR(60)
+ ENDIF
+ FB = FB0*XMT2
+ IF(FA.GT.0.01D0.AND.ABS(FA-1.D0)/FB.LE.0.01D0)
+ + ZMAX=FB/(1.D0+FB)+(1.D0-FA)*FB**2/(1.D0+FB)**3
+ IF(FA.GT.0.01D0.AND.ABS(FA-1.D0)/FB.GT.0.01D0)
+ + ZMAX=0.5D0*(1.D0+FB-DSQRT((1.D0-FB)**2+4.D0*FA*FB))/(1.D0-FA)
+ IF(ZMAX.LT.0.1D0) ZDIV=2.75D0*ZMAX
+ IF(ZMAX.GT.0.85D0)
+ + ZDIV=ZMAX-0.6D0/FB**2+(FA/FB)*dLOG((0.01D0+FA)/FB)
+C... Choice if z, preweighted for peaks at low or high z
+ 100 Z=S_RNDM(0)
+ IDIV=1
+ FPRE=1.D0
+ IF (ZMAX.LT.0.1D0) THEN
+ IF(1.D0.LT.S_RNDM(1)*(1.D0-dLOG(ZDIV))) IDIV=2
+ IF (IDIV.EQ.1) Z=ZDIV*Z
+ IF (IDIV.EQ.2) Z=ZDIV**Z
+ IF (IDIV.EQ.2) FPRE=ZDIV/Z
+ ELSEIF (ZMAX.GT.0.85D0) THEN
+ IF(1.D0.LT.S_RNDM(2)*(FB*(1.D0-ZDIV)+1.D0)) IDIV=2
+ IF (IDIV.EQ.1) Z=ZDIV+dLOG(Z)/FB
+ IF (IDIV.EQ.1) FPRE=dEXP(FB*(Z-ZDIV))
+ IF (IDIV.EQ.2) Z=ZDIV+Z*(1.D0-ZDIV)
+ ENDIF
+C...weighting according to the correct formula
+ IF (Z.LE.FB/(50.D0+FB).OR.Z.GE.1.D0) GOTO 100
+ FVAL=(ZMAX/Z)*dEXP(FB*(1.D0/ZMAX-1.D0/Z))
+ IF(FA.GT.0.01D0) FVAL=((1.D0-Z)/(1.D0-ZMAX))**FA*FVAL
+ IF(FVAL.LT.S_RNDM(3)*FPRE) GOTO 100
+ ZDIS_4FLV=Z
+
+ ENDIF
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE ZNORMAL
+
+C-----------------------------------------------------------------------
+C... normalisation for Peterson/SLAC frag. func
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION ZDMAX, EPSI
+ COMMON /S_CZDISc/ ZDMAX, EPSI
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ SAVE
+
+c get the maximum zmefn value first for normalisation
+ jmax = 1000
+ zdmax = 1.D-10
+
+ DO j = 1, jmax
+ z = dble(j)/dble(jmax+1)
+ zdmax = max(zdmax, zmefn(z,epsi))
+ enddo
+ if (ndebug .gt. 0) WRITE(LUN,*)' ZDMAX,EPS:',zdmax, epsi
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION ZMEFN(z,eps)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+C... Peterson/SLAC frag. func
+cdh zmefn = (z*(1.D0-z**(-1)-eps/(1.D0-z))**2)**(-1)
+ zmefn = 1.D0/(z*(1.D0-z**(-1)-eps/(1.D0-z))**2)
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION ZBLEAD (LB)
+
+C-----------------------------------------------------------------------
+C...fragmentation function for leading baryon
+C. simple form: f(z) = a + x**b
+C INPUT : LB = particle code.
+C..................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION CLEAD, FLEAD
+ COMMON /S_CZLEAD/ CLEAD, FLEAD
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+c ncall = ncall + 1
+c print*,'leading baryon frag. called:',lb,ncall
+
+C... leading z lower bound
+c used for protons only in Sib21 (if ..)
+c used for all baryons alike in Sib22 (else..)
+ ZLMIN = PAR(55)
+ ZSMR = PAR(56)
+
+ IF(IPAR(30).ne.0)THEN
+C Sibyll 2.1 hard fragmentation function
+
+ IC = ICHP(LB)*ISIGN(1,LB)
+
+ if (LB.ge.34.and.LB.le.39) then ! Lambda's and Sigma's
+ IF(IPAR(35).eq.1)then
+ zblead=zdisn(1) ! zblead**2 !soft
+ ELSE
+ 665 ZBLEAD = S_RNDM(LB)
+ if (zblead.le.0.01D0) goto 665
+ ENDIF
+c zblead=zdisn(1) ! blead**2 ! soft
+ elseif (ic.eq.0) then
+ if(IPAR(30).eq.2)then
+ 555 zblead = S_RNDM(1)
+ if (zblead .le. 0.01D0) goto 555
+ else
+ zblead=zdisn(1) ! blead**2 !soft
+ endif
+ elseif (ic.eq.1) then ! fast protons only
+ if (abs(lb).eq.13) then
+ 661 IF (S_RNDM(2) .LT. CLEAD) THEN
+ 666 ZBLEAD = S_RNDM(0)
+ if (zblead.le.0.01D0) goto 666
+ ELSE
+ zblead=1.D0-zdisn(1) ! zblead**2 !hard
+ ENDIF
+c truncated zblead to fix antiprotons
+ if (zblead.le.ZLMIN+ZSMR*(1.D0-2.D0*S_RNDM(LB))) goto 661
+ else
+ zblead=zdisn(1) ! zblead**2 !hard
+ endif
+ else if (ic.eq.2) then ! fast delta++
+ zblead=1.D0- zdisn(1) ! (zblead)**.3333
+ else
+ zblead=S_RNDM(0) ! zdisn(1) !hard
+ endif
+ RETURN
+ ELSE
+C... Sein's flat baryon fragmentation function a.k.a. Sibyll 2.2
+ 999 zblead = S_RNDM(0)
+ if (zblead .le. 0.01D0) goto 999
+c truncated zblead to fix instring pair production (antiprotons)
+ if (zblead.le.ZLMIN+ZSMR*(1.D0-2.D0*S_RNDM(LB))) goto 999
+ RETURN
+ ENDIF
+ END
+
+C=======================================================================
+
+ FUNCTION ZDISN (n)
+
+C-----------------------------------------------------------------------
+C...Generate (1-x)**n
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+666 rmin=1.1D0
+ do i=1,n+1
+ R1=S_RNDM(i)
+ IF (R1.LE.RMIN) RMIN=R1
+ ENDDO
+ ZDISn=RMIN
+ if (zdisn.le.0.01D0) goto 666
+ if (zdisn.ge.0.99D0) goto 666
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_SIG(Jint,SIB_SQS,SIB_PTmin,SIB_SIG_tot,
+ & SIB_SIG_ine,SIB_diff,SIB_diff2,SIB_B_el,SIB_PJET)
+
+C-----------------------------------------------------------------------
+C
+C...SIBYLL 2.1 cross sections
+C
+C input parameter: SIB_SQS c.m.s. energy (GeV)
+C Jint 1 p-p cross sections
+C 2 pi-p cross sections
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+ DOUBLE PRECISION SIB_PJET(0:NS_max,0:NH_max)
+ DOUBLE PRECISION SIB_SQS,SIB_PTmin,
+ & SIB_SIG_ine,SIB_SIG_tot,SIB_diff(3),SIB_diff2(3,2),SIB_B_el
+
+
+ COMMON /SIGMAS/SQS,SIGTOT,SIGEL,SIGINE,
+ & SIGSD1(2),SIGSD2(2),SIGDD(2),
+ & SLOPE,SLOPEc,RHO,PROB(0:NS_max,0:NH_max),SIGSUM
+
+
+ COMMON /PROFILE/XNUS2,XMUS2,XNUSPI2,
+ & XNUH2,XMUH2,XNUHPI2,
+ & ENHPP,ENHPIP,al1,be1,al2,be2
+
+ COMMON /S_CHDCNV/ABR(2,400),ABP(2,400),ABH(2,400),DB,NB
+
+ DIMENSION XI(50)
+
+ DIMENSION SIG_BRN(3)
+ DIMENSION SIG_dif_1(2),SIG_dif_2(2),SIG_dd(2)
+
+ DIMENSION IHAR(2)
+
+ PARAMETER ( NPARFIT = 22 )
+ DOUBLE PRECISION PARS
+ COMMON /XSCTN_FIT/ PARS( 50 , 2 )
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ COMMON /QCD_XSCTN/SIGQCD(61,2),INIT
+ DOUBLE PRECISION SIGQCD
+ SAVE
+ DATA INIT /0/
+ DATA (SIGQCD(K,1),K= 1, 61) /
+ &8.4663D-02,1.8246D-01,3.3880D-01,5.6845D-01,8.8686D-01,1.3116D+00,
+ &1.8626D+00,2.5645D+00,3.4445D+00,4.5343D+00,5.8715D+00,7.4962D+00,
+ &9.4579D+00,1.1811D+01,1.4620D+01,1.7955D+01,2.1890D+01,2.6522D+01,
+ &3.1952D+01,3.8303D+01,4.5704D+01,5.4307D+01,6.4284D+01,7.5818D+01,
+ &8.9121D+01,1.0447D+02,1.2213D+02,1.4240D+02,1.6562D+02,1.9221D+02,
+ &2.2260D+02,2.5733D+02,2.9694D+02,3.4207D+02,3.9348D+02,4.5194D+02,
+ &5.1838D+02,5.9376D+02,6.7921D+02,7.7609D+02,8.8578D+02,1.0099D+03,
+ &1.1504D+03,1.3090D+03,1.4882D+03,1.6903D+03,1.9183D+03,2.1754D+03,
+ &2.4650D+03,2.7912D+03,3.1582D+03,3.5707D+03,4.0341D+03,4.5538D+03,
+ &5.1360D+03,5.7883D+03,6.5193D+03,7.3358D+03,8.2428D+03,9.2498D+03,
+ &1.0369D+04/
+ DATA (SIGQCD(K,2),K= 1, 61) /
+ &1.5665D-01,2.8800D-01,4.7863D-01,7.4235D-01,1.0949D+00,1.5547D+00,
+ &2.1433D+00,2.8859D+00,3.8118D+00,4.9547D+00,6.3534D+00,8.0525D+00,
+ &1.0103D+01,1.2563D+01,1.5498D+01,1.8986D+01,2.3111D+01,2.7971D+01,
+ &3.3678D+01,4.0358D+01,4.8154D+01,5.7228D+01,6.7762D+01,7.9965D+01,
+ &9.4071D+01,1.1034D+02,1.2909D+02,1.5063D+02,1.7536D+02,2.0370D+02,
+ &2.3613D+02,2.7321D+02,3.1553D+02,3.6379D+02,4.1875D+02,4.8129D+02,
+ &5.5238D+02,6.3311D+02,7.2470D+02,8.2854D+02,9.4614D+02,1.0792D+03,
+ &1.2298D+03,1.3999D+03,1.5920D+03,1.8089D+03,2.0534D+03,2.3291D+03,
+ &2.6396D+03,2.9892D+03,3.3825D+03,3.8248D+03,4.3219D+03,4.8803D+03,
+ &5.5072D+03,6.2109D+03,7.0001D+03,7.8849D+03,8.8764D+03,9.9871D+03,
+ &1.1231D+04/
+
+
+ IF(INIT.EQ.0) THEN
+* CALL HAR_INI
+ CALL FACT_INI
+ IHAR(1) = 0
+ IHAR(2) = 0
+ INIT = 1
+ ENDIF
+
+ ECM = SIB_SQS
+
+ IF(JINT.EQ.1) THEN
+c K = 1 , proton
+ DO K=1,NPARFIT
+ XI(K) = PARS(K,1)
+ ENDDO
+
+ ELSE IF(JINT.EQ.2) THEN
+c K = 2 , pion
+ DO K=1,NPARFIT
+ XI(K) = PARS(K,2)
+ ENDDO
+
+ ENDIF
+
+ XNUS2 = XI(12)
+ XMUS2 = XI(13)
+ XNUSPI2 = XI(14)
+
+ XNUH2 = XI(15)
+ XMUH2 = XI(16)
+ XNUHPI2 = XI(17)
+
+ CALL HAD_CONV(IABS(JINT))
+
+ PTCUT = XI(10)+XI(21)*dEXP(XI(22)*DSQRT(2.D0*dLOG(ECM)))
+ INDX = abs(JINT)
+ IHAR(INDX) = IHAR(INDX)+1
+ SIGHAR = SIGQCD(IHAR(INDX),INDX)
+
+ S = ECM**2
+
+ BREG = ABS(XI(18)) + XI(19)*dLOG(S)
+ BPOM = ABS(XI(12)) + XI(13)*dLOG(S)
+ IK = ABS(JINT)
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ ABR(IK,JB) = 2.D0/(8.D0*PI*BREG)*dEXP(-B**2/(4.D0*BREG))
+ ABP(IK,JB) = 2.D0/(8.D0*PI*BPOM)*dEXP(-B**2/(4.D0*BPOM))
+ ENDDO
+
+C reggeon
+ SIGSR = ABS(XI(2))*S**(-ABS(XI(4)))
+ SIG_BRN(1) = SIGSR/CMBARN
+C pomeron (soft part)
+ SIGSP = ABS(XI(1))*S**ABS(XI(3))
+ SIG_BRN(2) = SIGSP/CMBARN
+C pomeron (hard part)
+ SIG_BRN(3) = SIGHAR/CMBARN
+
+C 2x2 channel low-mass model and separate high-mass diffraction
+
+ al1 = XI(5)
+ be1 = XI(6)
+ al2 = al1
+ be2 = be1
+ EnhPP = XI(9)
+ EnhPiP = EnhPP
+
+ CALL SIG_JET_3 (SIG_brn,JINT,SIG_tot,SIG_ela,SIG_ine,SIG_sum,
+ & SIG_dif_1,SIG_dif_2,SIG_dd,B_el,PROB)
+
+ SIGTOT = SIG_tot*CMBARN
+ SIGINE = SIG_ine*CMBARN
+ SIGSUM = SIG_sum*CMBARN
+ SIGELc = SIGTOT-SIGINE
+ SIGEL = SIG_ela*CMBARN
+ SIGSD1(1) = SIG_dif_1(1)*CMBARN
+ SIGSD1(2) = SIG_dif_1(2)*CMBARN
+ SIGSD2(1) = SIG_dif_2(1)*CMBARN
+ SIGSD2(2) = SIG_dif_2(2)*CMBARN
+ SIGDD(1) = SIG_dd(1)*CMBARN
+ SIGDD(2) = SIG_dd(2)*CMBARN
+ SLOPE = B_EL
+ SLOPEc = SIG_tot**2/(16.D0*PI*SIG_ela)
+
+ DE = ABS(SIGEL+SIGINE-SIGTOT)/SIGTOT
+ IF(DE.GT.0.01D0) THEN
+ print *,'SIBSIG: Ecm: ',ECM
+ print *,' SIGTOT: ',SIGTOT
+ print *,' SIGEL1/2: ',SIGEL,SIGELc
+ print *,' SLOPE1/2: ',SLOPE,SLOPEc
+ print *,' SIGDIF 1: ',SIGSD1
+ print *,' SIGDIF 2: ',SIGSD2
+ print *,' SIGDDIF: ',SIGDD
+ print *,' SUM-SIGTOT: ',SIGEL+SIGINE-SIGTOT
+ ENDIF
+
+C SIBYLL interface to single precision
+
+ SIB_PTmin = PTCUT
+ SIB_SIG_tot = SIGTOT
+ SIB_SIG_ine = SIGINE
+ SIB_diff(1) = SIGSD1(1)+SIGSD1(2)
+ SIB_diff(2) = SIGSD2(1)+SIGSD2(2)
+ SIB_diff(3) = SIGDD(1)+SIGDD(2)
+ SIB_B_el = SLOPE
+ DO I=0,NS_max
+ DO K=0,NH_max
+ SIB_PJET(I,K) = PROB(I,K)
+ ENDDO
+ ENDDO
+c full diff. cross section
+c ( ( b.single , t.single , double ) , ( low mass , high mass ) )
+ SIB_diff2(1,1) = SIGSD1(1)
+ SIB_diff2(1,2) = SIGSD1(2)
+ SIB_diff2(2,1) = SIGSD2(1)
+ SIB_diff2(2,2) = SIGSD2(2)
+ SIB_diff2(3,1) = SIGDD(1)
+ SIB_diff2(3,2) = SIGDD(2)
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIG_JET_3 (SIG_brn, JINT, SIG_TOT, SIG_ELA,
+ & SIG_INE, SIG_sum, SIG_DIF1, SIG_DIF2, SIG_DD, B_EL, P_int)
+
+C-----------------------------------------------------------------------
+C
+C...This subroutine receives in INPUT:
+C. SIG_brn (GeV-2) Born graph cross sections
+C. JINT (1 = pp interaction) (2 pi-p interaction)
+C. neg. value: without calculation of interaction probabilities
+C.
+C. and returns as output:
+C. SIG_??? , B_el
+C. and P_int(0:NS_max,0:NH_max) interaction probabilities
+C
+C two x two -channel approximation for diffraction
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DIMENSION SIG_brn(3)
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ COMMON /S_CFACT/ FACT(0:NH_max), CO_BIN(0:NH_max,0:NH_max)
+ COMMON /S_CHDCNV/ABR(2,400),ABP(2,400),ABH(2,400),DB,NB
+
+ COMMON /PROFILE/XNUS2,XMUS2,XNUSPI2,
+ & XNUH2,XMUH2,XNUHPI2,
+ & EnhPP,EnhPiP,al1,be1,al2,be2
+
+ DIMENSION SIG_DIF1(2),SIG_DIF2(2),SIG_DD(2),
+ & P_int(0:NS_max,0:NH_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ DO J=0,NH_max
+ DO I=0,NS_max
+ P_int(I,J) = 0.D0
+ ENDDO
+ ENDDO
+
+ ga1 = dsqrt(al1*al1+be1*be1)
+ ga2 = dsqrt(al2*al2+be2*be2)
+
+ fe_a_1 = (1.D0+al1/ga1)/2.D0
+ fe_a_2 = (1.D0-al1/ga1)/2.D0
+ fd_a_1 = sqrt(1.D0-(al1/ga1)**2)/2.D0
+ fd_a_2 = -fd_a_1
+
+ fe_b_1 = (1.D0+al2/ga2)/2.D0
+ fe_b_2 = (1.D0-al2/ga2)/2.D0
+ fd_b_1 = dsqrt(1.D0-(al2/ga2)**2)/2.D0
+ fd_b_2 = -fd_b_1
+
+ fe_11 = fe_a_1*fe_b_1
+ fe_22 = fe_a_2*fe_b_2
+ fe_12 = fe_a_1*fe_b_2
+ fe_21 = fe_a_2*fe_b_1
+
+ fd_a_11 = fd_a_1*fe_b_1
+ fd_a_22 = fd_a_2*fe_b_2
+ fd_a_12 = fd_a_1*fe_b_2
+ fd_a_21 = fd_a_2*fe_b_1
+
+ fd_b_11 = fe_a_1*fd_b_1
+ fd_b_22 = fe_a_2*fd_b_2
+ fd_b_12 = fe_a_1*fd_b_2
+ fd_b_21 = fe_a_2*fd_b_1
+
+ fdd_11 = fd_a_1*fd_b_1
+ fdd_22 = fd_a_2*fd_b_2
+ fdd_12 = fd_a_1*fd_b_2
+ fdd_21 = fd_a_2*fd_b_1
+
+
+ sum_abs = 0.D0
+ sum_tot = 0.D0
+ sum_ela = 0.D0
+ sum_sd_a = 0.D0
+ sum_sd_b = 0.D0
+ sum_dd = 0.D0
+ sum_B = 0.D0
+
+ IK = ABS(JINT)
+ if(JINT.GT.0) then
+ I0MAX = NS_max
+ J0MAX = NH_max
+ ELSE
+ I0MAX = 1
+ J0MAX = 1
+ ENDIF
+ SIG_REG = SIG_BRN(1)
+ SIG_POM = SIG_BRN(2)
+ SIG_HAR = SIG_BRN(3)
+
+ DO JB=1,NB
+
+ B = DB*DBLE(JB-1)
+
+ ABREG = ABR(IK,JB)
+ ABPOM = ABP(IK,JB)
+ ABHAR = ABH(IK,JB)
+
+ chi2_soft = ABREG*SIG_REG+ABPOM*SIG_POM
+ chi2_soft_11 = (1.D0-al1+ga1)*(1.D0-al2+ga2)*chi2_soft
+ chi2_soft_22 = (1.D0-al1-ga1)*(1.D0-al2-ga2)*chi2_soft
+ chi2_soft_12 = (1.D0-al1+ga1)*(1.D0-al2-ga2)*chi2_soft
+ chi2_soft_21 = (1.D0-al1-ga1)*(1.D0-al2+ga2)*chi2_soft
+
+ chi2_hard = ABHAR*SIG_HAR
+ chi2_hard_11 = (1.D0-al1+ga1)*(1.D0-al2+ga2)*chi2_hard
+ chi2_hard_22 = (1.D0-al1-ga1)*(1.D0-al2-ga2)*chi2_hard
+ chi2_hard_12 = (1.D0-al1+ga1)*(1.D0-al2-ga2)*chi2_hard
+ chi2_hard_21 = (1.D0-al1-ga1)*(1.D0-al2+ga2)*chi2_hard
+
+
+ ef_11 = dexp(-0.5D0*(chi2_soft_11+chi2_hard_11))
+ ef_22 = dexp(-0.5D0*(chi2_soft_22+chi2_hard_22))
+ ef_12 = dexp(-0.5D0*(chi2_soft_12+chi2_hard_12))
+ ef_21 = dexp(-0.5D0*(chi2_soft_21+chi2_hard_21))
+
+ esf_11 = ef_11**2
+ esf_22 = ef_22**2
+ esf_12 = ef_12**2
+ esf_21 = ef_21**2
+
+ F_ine = B*(1.D0 - fe_11*esf_11 - fe_12*esf_12
+ & - fe_21*esf_21 - fe_22*esf_22)
+ F_tot = 1.D0 - fe_11*ef_11 - fe_12*ef_12
+ & - fe_21*ef_21 - fe_22*ef_22
+ F_ela = B*F_tot**2
+ F_tot = B*F_tot
+
+ F_sd_a = B*(fd_a_11*ef_11 + fd_a_12*ef_12
+ & + fd_a_21*ef_21 + fd_a_22*ef_22)**2
+ F_sd_b = B*(fd_b_11*ef_11 + fd_b_12*ef_12
+ & + fd_b_21*ef_21 + fd_b_22*ef_22)**2
+ F_dd = B*(fdd_11*ef_11 + fdd_12*ef_12
+ & + fdd_21*ef_21 + fdd_22*ef_22)**2
+
+ sum_abs = sum_abs+F_ine
+ sum_tot = sum_tot+F_tot
+ sum_ela = sum_ela+F_ela
+
+ sum_sd_a = sum_sd_a+F_sd_a
+ sum_sd_b = sum_sd_b+F_sd_b
+ sum_dd = sum_dd +F_dd
+
+ sum_B = sum_b+B**2*F_tot
+
+ fac_11 = B*esf_11
+ fac_22 = B*esf_22
+ fac_12 = B*esf_12
+ fac_21 = B*esf_21
+ soft_rec_11 = 1.D0/chi2_soft_11
+ soft_rec_22 = 1.D0/chi2_soft_22
+ soft_rec_12 = 1.D0/chi2_soft_12
+ soft_rec_21 = 1.D0/chi2_soft_21
+ chi2_hard_11 = max(chi2_hard_11,EPS10)
+ chi2_hard_22 = max(chi2_hard_22,EPS10)
+ chi2_hard_12 = max(chi2_hard_12,EPS10)
+ chi2_hard_21 = max(chi2_hard_21,EPS10)
+ DO I=0,I0MAX
+ soft_rec_11 = soft_rec_11*chi2_soft_11
+ soft_rec_22 = soft_rec_22*chi2_soft_22
+ soft_rec_12 = soft_rec_12*chi2_soft_12
+ soft_rec_21 = soft_rec_21*chi2_soft_21
+ hard_rec_11 = 1.D0/chi2_hard_11
+ hard_rec_22 = 1.D0/chi2_hard_22
+ hard_rec_12 = 1.D0/chi2_hard_12
+ hard_rec_21 = 1.D0/chi2_hard_21
+ DO J=0,J0MAX
+ hard_rec_11 = hard_rec_11*chi2_hard_11
+ hard_rec_22 = hard_rec_22*chi2_hard_22
+ hard_rec_12 = hard_rec_12*chi2_hard_12
+ hard_rec_21 = hard_rec_21*chi2_hard_21
+ P_int(I,J) = P_int(I,J)
+ & + fe_11*soft_rec_11*hard_rec_11*fac_11
+ & + fe_22*soft_rec_22*hard_rec_22*fac_22
+ & + fe_12*soft_rec_12*hard_rec_12*fac_12
+ & + fe_21*soft_rec_21*hard_rec_21*fac_21
+ ENDDO
+ ENDDO
+
+ ENDDO
+
+ SIG_abs = SUM_abs*TWOPI*DB
+ SIG_tot = SUM_tot*4.D0*PI*DB
+ SIG_ela = SUM_ela*TWOPI*DB
+ SIG_dif1(1) = SUM_sd_a*TWOPI*DB
+ SIG_dif2(1) = SUM_sd_b*TWOPI*DB
+ SIG_dd(1) = SUM_dd*TWOPI*DB
+ SIG_ine = SIG_abs + SIG_dif1(1) + SIG_dif2(1) + SIG_dd(1)
+ B_EL = sum_B/SUM_tot/2.D0
+
+ SA = 0.D0
+ P_int(0,0) = 0.D0
+ DO I=0,I0MAX
+ DO J=0,J0MAX
+ fac = FACT(I)*FACT(J)
+ P_int(I,J) = P_int(I,J)/fac
+ SA = SA + P_int(I,J)
+ ENDDO
+ ENDDO
+
+ SIG_hmsd = EnhPP*(P_int(1,0)+P_int(0,1))*TWOPI*DB
+ SIG_hmdd = be1**2*SIG_hmsd + be2**2*SIG_hmsd
+ & + EnhPP**2*P_int(1,1)*TWOPI*DB
+
+ SIG_dif1(2) = SIG_hmsd
+ SIG_dif2(2) = SIG_hmsd
+ SIG_dd(2) = SIG_hmdd
+
+ SIG_sum = SA*TWOPI*DB
+
+ DO I=0,I0MAX
+ DO J=0,J0MAX
+ P_int(I,J) = P_int(I,J)/SA
+ ENDDO
+ ENDDO
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE HAD_CONV(JINT)
+
+C-----------------------------------------------------------------------
+C
+C...Convolution of hadrons profile
+C. [function A(b) of Durand and Pi]
+C. precalculate and put in COMMON block
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ COMMON /S_CHDCNV/ABR(2,400),ABP(2,400),ABH(2,400),DB,NB
+
+ DOUBLE PRECISION NU2, MU2, NUPI2, NU, MU, NUPI
+ COMMON /S_CH0CNV/ NU2, MU2, NUPI2, NU, MU, NUPI
+
+C
+ COMMON /PROFILE/XNUS2,XMUS2,XNUSPI2,
+ & XNUH2,XMUH2,XNUHPI2,
+ & ENHPP,ENHPIP,al1,be1,al2,be2
+ SAVE
+
+C...integration constants
+ BMAX = 50.D0
+ NB = 400
+ DB = BMAX/DBLE(NB)
+
+C soft reggeon interactions
+
+ NU2 = XNUS2
+ MU2 = XMUS2
+ NUPI2 = XNUSPI2
+
+ NU = SQRT(NU2)
+ MU = SQRT(ABS(MU2))
+ NUPI = SQRT(NUPI2)
+
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ IF(JINT.EQ.1) THEN
+ ABR(JINT,JB) = A_PP(B)
+ ELSE
+ ABR(JINT,JB) = A_PIP(B)
+ ENDIF
+ ENDDO
+
+C soft pomeron interactions
+
+ NU2 = XNUS2
+ MU2 = XMUS2
+ NUPI2 = XNUSPI2
+
+ NU = SQRT(NU2)
+ MU = SQRT(ABS(MU2))
+ NUPI = SQRT(NUPI2)
+
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ IF(JINT.EQ.1) THEN
+ ABP(JINT,JB) = A_PP(B)
+ ELSE
+ ABP(JINT,JB) = A_PIP(B)
+ ENDIF
+ ENDDO
+
+C hard pomeron interactions
+
+ NU2 = XNUH2
+ MU2 = XMUH2
+ NUPI2 = XNUHPI2
+
+ NU = SQRT(NU2)
+ MU = SQRT(ABS(MU2))
+ NUPI = SQRT(NUPI2)
+
+ DB = BMAX/DBLE(NB)
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ IF(JINT.EQ.1) THEN
+ ABH(JINT,JB) = A_PP(B)
+ ELSE
+ ABH(JINT,JB) = A_PIP(B)
+ ENDIF
+ ENDDO
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION A_PP (b)
+
+C-----------------------------------------------------------------------
+C...Convolution of parton distribution for pp interaction
+ IMPLICIT DOUBLE PRECISION (A-Z)
+C
+ DOUBLE PRECISION NU2, MU2, NUPI2, NU, MU, NUPI
+ COMMON /S_CH0CNV/ NU2, MU2, NUPI2, NU, MU, NUPI
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ ETA = NU2/MU2
+
+ IF(ETA.LT.0.D0) THEN
+
+ c = nu**5/(96.D0*PI)
+ if (b .gt. 0.0001D0) then
+ A_pp = c*b**3 * bessk (3, b*nu)
+ else
+ A_pp = nu**2/(12.D0*PI)
+ endif
+
+ ELSE
+
+ X = B*NU
+ Y = B*MU
+ C = NU2/(12.D0*PI)/(1.D0-ETA)**2
+ IF(X.GT.0.0001D0) THEN
+ A_PP = C*(1.D0/8.D0*X**3*BESSK(3,X)
+ & -3.D0/2.D0*ETA/(1.D0-ETA)*X**2*BESSK(2,X)
+ & + 9.D0*ETA**2/(1.D0-ETA)**2*X*BESSK1(X)
+ & -24.D0*ETA**3/(1.D0-ETA)**3*(BESSK0(X)-BESSK0(Y))
+ & + 3.D0*ETA**3/(1.D0-ETA)**2*Y*BESSK1(Y))
+ ELSE
+ A_PP = C*(1.D0 /8.D0*8.D0
+ & -3.D0/2.D0*ETA/(1.D0-ETA)*2.D0
+ & +9.D0*ETA**2/(1.D0-ETA)**2*1.D0
+ & -24.D0*ETA**3/(1.D0-ETA)**3*LOG(MU/NU)
+ & +3.D0*ETA**3/(1.D0-ETA)**2*1.D0)
+ ENDIF
+
+ ENDIF
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION A_PIP (b)
+
+C-----------------------------------------------------------------------
+C...Convolution of parton distribution for pip interaction
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-Z)
+C
+ DOUBLE PRECISION NU2, MU2, NUPI2, NU, MU, NUPI
+ COMMON /S_CH0CNV/ NU2, MU2, NUPI2, NU, MU, NUPI
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ eta = nu2/nupi2
+ c = nu2/(2.D0*PI) * 1.D0/(1.D0-eta)
+
+ if (b .gt. 0.0001D0) then
+ b1 = b*nu
+ b2 = b*nupi
+ f1 = 0.5D0*b1 * bessk1(b1)
+ f2 = eta/(1.D0-eta)*(bessk0(b2)- bessk0(b1))
+ A_pip = c*(f1+f2)
+ else
+ A_pip = c*(0.5D0 + eta/(1.D0-eta)*log(nu/nupi))
+ endif
+ return
+ end
+C
+C
+C-----------------------------------------------------------------------
+C Bessel functions
+C=======================================================================
+
+ FUNCTION BESSK0(X)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ DOUBLE PRECISION P1,P2,P3,P4,P5,P6,P7,
+ * Q1,Q2,Q3,Q4,Q5,Q6,Q7
+ SAVE
+ DATA P1,P2,P3,P4,P5,P6,P7/-0.57721566D0,0.42278420D0,
+ * 0.23069756D0,0.3488590D-1,0.262698D-2,0.10750D-3,0.74D-5/
+ DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414D0,-0.7832358D-1,
+ * 0.2189568D-1,-0.1062446D-1,0.587872D-2,-0.251540D-2,0.53208D-3/
+
+ IF (X.LE.2.0D0) THEN
+ Y=X*X/4.D0
+ BESSK0=(-LOG(X/2.D0)*BESSI0(X))+(P1+Y*(P2+Y*(P3+
+ * Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
+ ELSE
+ Y=(2.D0/X)
+ BESSK0=(EXP(-X)/SQRT(X))*(Q1+Y*(Q2+Y*(Q3+
+ * Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
+ ENDIF
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION BESSK1(X)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ DOUBLE PRECISION P1,P2,P3,P4,P5,P6,P7,
+ * Q1,Q2,Q3,Q4,Q5,Q6,Q7
+ SAVE
+ DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,0.15443144D0,-0.67278579D0,
+ * -0.18156897D0,-0.1919402D-1,-0.110404D-2,-0.4686D-4/
+ DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414D0,0.23498619D0,
+ * -0.3655620D-1,0.1504268D-1,-0.780353D-2,0.325614D-2,
+ * -0.68245D-3/
+
+ IF (X.LE.2.D0) THEN
+ Y=X*X/4.D0
+ BESSK1=(LOG(X/2.D0)*BESSI1(X))+(1.D0/X)*(P1+Y*(P2+
+ * Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
+ ELSE
+ Y=2.D0/X
+ BESSK1=(EXP(-X)/SQRT(X))*(Q1+Y*(Q2+Y*(Q3+
+ * Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
+ ENDIF
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION BESSK(N,X)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+C
+ IF (N.LT.2) stop 'bad argument N in BESSK'
+ TOX=2.D0/X
+ BKM=BESSK0(X)
+ BK=BESSK1(X)
+ DO 11 J=1,N-1
+ BKP=BKM+J*TOX*BK
+ BKM=BK
+ BK=BKP
+11 CONTINUE
+ BESSK=BK
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION BESSI0(X)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ DOUBLE PRECISION P1,P2,P3,P4,P5,P6,P7,
+ * Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9
+ SAVE
+ DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,3.5156229D0,3.0899424D0,
+ * 1.2067492D0, 0.2659732D0,0.360768D-1,0.45813D-2/
+ DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1,
+ * 0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,
+ * 0.2635537D-1,-0.1647633D-1,0.392377D-2/
+
+ IF (ABS(X).LT.3.75D0) THEN
+ Y=(X/3.75D0)**2
+ BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
+ ELSE
+ AX=ABS(X)
+ Y=3.75D0/AX
+ BESSI0=(EXP(AX)/SQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4
+ * +Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9))))))))
+ ENDIF
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION BESSI1(X)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ DOUBLE PRECISION P1,P2,P3,P4,P5,P6,P7,
+ * Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9
+ SAVE
+ DATA P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,
+ * 0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/
+ DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1,
+ * -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1,
+ * -0.2895312D-1,0.1787654D-1,-0.420059D-2/
+
+ IF (ABS(X).LT.3.75D0) THEN
+ Y=(X/3.75D0)**2
+ BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
+ ELSE
+ AX=ABS(X)
+ Y=3.75D0/AX
+ BESSI1=(EXP(AX)/SQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+
+ * Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9))))))))
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE FACT_INI
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+ COMMON /S_CFACT/ FACT(0:NH_max), CO_BIN(0:NH_max,0:NH_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ FACT(0) = 1.D0
+ FACT(NS_max) = 1.D0 ! avoid unused warning and keep parameter block
+ DO J=1,NH_max
+ FACT(J) = FACT(J-1)*DBLE(J)
+ ENDDO
+ DO J=0,NH_max
+ DO K=0,J
+ CO_BIN(J,K) = FACT(J)/(FACT(K)*FACT(J-K))
+ ENDDO
+ ENDDO
+
+ END
+cC=======================================================================
+c
+c SUBROUTINE SAMPLE_SOFT (STR_mass_min, X1,X2,PT)
+c
+C-----------------------------------------------------------------------
+C... Routine for the sampling the kinematical variables of sea quarks
+C. according to (1-x)**b / x**2
+C. INPUT: STR_mass_min : minimal string mass ** 2 = x1 * x2 * s
+C. SLOPE : large x suppression exponent
+C. OUTPUT: gluon 4momenta on parton stack (GeV) /FR'14
+C-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c
+c INTEGER NW_max
+c PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+c
+c EVENT INFO COMMON
+c contains overall interaction properties, like
+c SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+c DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+c INTEGER KB,IAT,KT
+c COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+c
+c INTEGER NCALL, NDEBUG, LUN
+c COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c
+c DOUBLE PRECISION PPT02
+c COMMON /S_CQDIS2/ PPT02(44)
+c INTEGER NIPAR_max,NPAR_max
+c PARAMETER (NPAR_max=200,NIPAR_max=100)
+c DOUBLE PRECISION PAR
+c INTEGER IPAR
+c COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+c
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+c DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+c COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+c
+c DOUBLE PRECISION PI,TWOPI,CMBARN
+c COMMON /SIB_CST/ PI,TWOPI,CMBARN
+c
+c DOUBLE PRECISION FACN
+c DIMENSION FACN(3:10)
+c COMMON /SIB_FAC/ FACN
+c SAVE
+c
+c SLOPE = max(1.D0,PAR(42))
+c ZSOF = 2.D0*dLOG(STR_mass_min/SQS) ! minim. mass ~ x1 * x2
+c 50 XMIN = dEXP(ZSOF)
+c axmin = 1.D0/xmin
+c 100 Z1 = -1.D0*dLOG(axmin-(axmin-1.D0)*S_RNDM(0))
+c x1 = dexp(z1)
+c XR = dlog(1.D0-X1) - dlog(1.D0-xmin)
+c if(SLOPE*XR.le.log(S_RNDM(0))) goto 100
+c
+c 200 Z2 = -1.D0*dLOG(axmin-(axmin-1.D0)*S_RNDM(0))
+c X2 = dEXP(Z2)
+c XR = dlog(1.D0-X2) - dlog(1.D0-dEXP(ZSOF))
+c if(SLOPE*XR.le.dlog(S_RNDM(0))) goto 200
+c
+c IF(Z1+Z2.LE.ZSOF) GOTO 50
+c STR_mass2 = dsqrt(X1*X2*S)/2.D0
+c PPTT = PPT02(10)
+c 150 PT = PPTT*dSQRT(-dLOG(MAX(EPS10,S_RNDM(0))))
+c IF(IPAR(3).eq.6)THEN
+c XM = 0.D0
+c XM2 = XM**2
+c RNDM = MAX(EPS10,S_RNDM(IFL))
+c XMT = PPTT * dLOG(RNDM) - XM
+c XMT2 = XMT**2
+c PT = dSQRT(XMT2-XM2)
+c ENDIF
+c IF(PT.GT.PTmin) GOTO 150
+c IF(PT.GE.STR_mass2) GOTO 150
+c END
+c
+cC=======================================================================
+c
+c SUBROUTINE SAMPLE_SOFT2 (STR_mass_min, X1,X2,PT)
+c
+C-----------------------------------------------------------------------
+C...Routine for sampling the kinematical variables
+C. that characterize a soft cut pomeron (x1,x2, pT)
+C. from the differential cross section:
+C. d3sigma/(dx1 dx2 dpT)
+C. ~ 1/x_i**a .*. exp(-mT)
+C. INPUT: STR_mass_min : minimal string mass defined by kinematic limits
+C. of the string fragmentation
+C. PAR: PAR(42) : exponent a
+C. OUTPUT: X1, X2, PT (GeV)
+C-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c INTEGER NW_max
+c PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+c
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+c DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+c INTEGER KB,IAT,KT
+c COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+c
+c INTEGER NCALL, NDEBUG, LUN
+c COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c
+c DOUBLE PRECISION PPT02
+c COMMON /S_CQDIS2/ PPT02(44)
+c INTEGER NIPAR_max,NPAR_max
+c PARAMETER (NPAR_max=200,NIPAR_max=100)
+c DOUBLE PRECISION PAR
+c INTEGER IPAR
+c COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+c
+cC--------------------------------------------------------------------
+cC SIBYLL utility common blocks containing constants \FR'14
+cC--------------------------------------------------------------------
+c DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+c COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+c
+c DOUBLE PRECISION PI,TWOPI,CMBARN
+c COMMON /SIB_CST/ PI,TWOPI,CMBARN
+c
+c DOUBLE PRECISION FACN
+c DIMENSION FACN(3:10)
+c COMMON /SIB_FAC/ FACN
+c SAVE
+c
+c SLOPE = PAR(42)
+c ZSOF = 2.D0*dLOG(STR_mass_min/SQS) ! zmin
+c zsof = zsof * slope
+c 100 Z1=1.D0/SLOPE*(-zsof*S_RNDM(0)+zsof)
+c Z2=1.D0/SLOPE*(-zsof*S_RNDM(0)+zsof)
+cc print *,'zsof,z1,z2',zsof,z1,z2
+c IF(Z1+Z2.LE.ZSOF) GOTO 100
+c X1=dEXP(Z1)
+c X2=dEXP(Z2)
+c STR_mass2 = sqrt(X1*X2*S)/2.D0
+c if(str_mass2.lt.0.9D0)goto 100
+c PPTT = PPT02(10)
+cc print *,'ptmin,str_mass:',ptmin,str_mass2
+c 150 PT = PPTT*dSQRT(-dLOG(MAX(EPS10,S_RNDM(0))))
+c IF(IPAR(3).eq.6)THEN
+c XM = 0.D0
+c XM2 = XM**2
+c RNDM = MAX(EPS10,S_RNDM(IFL))
+c XMT = PPTT * dLOG(RNDM) - XM
+c XMT2 = XMT**2
+c PT = dSQRT(XMT2-XM2)
+c ENDIF
+c IF(PT.GT.PTmin) GOTO 150
+c IF(PT.GE.STR_mass2) GOTO 150
+c PHI = TWOPI*S_RNDM(L)
+c END
+cC=======================================================================
+cc
+c SUBROUTINE SAMPLE_SOFT3 (STR_mass_min, X1,X2,PT)
+c
+cC-----------------------------------------------------------------------
+cC...Routine for the sampling the kinematical variables
+cC. that characterize a soft cut pomeron (x1,x2, pT)
+cC. from the differential cross section:
+cC. d3sigma/(dx1 dx2 dpT)
+cC. INPUT: L=1 incident proton, L=2 incident pi
+cC. (soft strings identical for pi and p interactions)
+cC. OUTPUT: X1, X2, PT (GeV)
+cC-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c INTEGER NW_max
+c PARAMETER (NW_max = 20)
+cC--------------------------------------------------------------------
+cC SIBYLL common blocks containing event information \FR'14
+cC--------------------------------------------------------------------
+c
+cC EVENT INFO COMMON
+cC contains overall interaction properties, like
+cC SQS : center-of-mass energy
+cC S : " " squared
+cC PTmin : low pt cut of QCD cross section,
+cC i.e. minimal pt of hard minijets
+cC Xmin : low-x bound for PDFs,
+cC i.e. minimal momentum fraction of hard partons
+cC Zmin : logarithm of that
+cC KB : PID of beam hadron
+cC KT() : PID of target
+cC IAT : mass number of target
+c DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+c INTEGER KB,IAT,KT
+c COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+c
+c INTEGER NCALL, NDEBUG, LUN
+c COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c
+c DOUBLE PRECISION PPT02
+c COMMON /S_CQDIS2/ PPT02(44)
+c INTEGER NIPAR_max,NPAR_max
+c PARAMETER (NPAR_max=200,NIPAR_max=100)
+c DOUBLE PRECISION PAR
+c INTEGER IPAR
+c COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+c
+cC--------------------------------------------------------------------
+cC SIBYLL utility common blocks containing constants \FR'14
+cC--------------------------------------------------------------------
+c DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+c COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+c
+c DOUBLE PRECISION PI,TWOPI,CMBARN
+c COMMON /SIB_CST/ PI,TWOPI,CMBARN
+c
+c DOUBLE PRECISION FACN
+c DIMENSION FACN(3:10)
+c COMMON /SIB_FAC/ FACN
+c SAVE
+c
+c SLOPE = max(1.D0,PAR(42))
+c ZSOF = 2.D0*dLOG(STR_mass_min/SQS) ! minim. mass ~ x1 * x2
+c 100 Z1=-ZSOF*S_RNDM(0)+ZSOF ! sample envelope 1/x
+c X1 = dEXP(Z1)
+cc print *,'z1,x1:',z1,x1
+c XR = dlog(1.D0-X1) - dlog(1.D0-dEXP(ZSOF))
+cc print *,'ratio:',(1.-X1)/(1.-EXP(ZSOF)),(1.-X1),1.-EXP(ZSOF)
+cc print *,'log ratio:',xr,log(1.-X1),log(1.-EXP(ZSOF))
+c if(SLOPE*XR.le.dlog(S_RNDM(0))) goto 100
+c
+c 200 Z2=-ZSOF*S_RNDM(0)+ZSOF ! sample envelope 1/x
+c X2 = dEXP(Z2)
+c XR = dlog(1.D0-X2) - dlog(1.D0-dEXP(ZSOF))
+c if(SLOPE*XR.le.dlog(S_RNDM(0))) goto 200
+cc print *,'zsof,z1,z2',zsof,z1,z2
+c IF(Z1+Z2.LE.ZSOF) GOTO 100
+c STR_mass2 = sqrt(X1*X2*S)/2.D0
+c PPTT = PPT02(10)
+c IF(IPAR(3).eq.8) PPTT = PPT02(20)
+c 150 PT = PPTT*dSQRT(-dLOG(MAX(EPS10,S_RNDM(0))))
+c IF(IPAR(3).ge.6)THEN
+c XM = 0.D0
+c XM2 = XM**2
+c RNDM = MAX(EPS10,S_RNDM(IFL))
+c XMT = PPTT * dLOG(RNDM) - XM
+c XMT2 = XMT**2
+c PT = dSQRT(XMT2-XM2)
+c ENDIF
+c IF(PT.GT.PTmin) GOTO 150
+c IF(PT.GE.STR_mass2) GOTO 150
+c PHI = TWOPI*S_RNDM(L)
+c END
+cC=======================================================================
+c
+c SUBROUTINE SAMPLE_SOFT5 (STR_mass_min, X1,X2,PT)
+c
+cC-----------------------------------------------------------------------
+cC...Routine for the sampling the kinematical variables of sea quarks
+cC. according to (1-x)**b / x**2
+cC. INPUT: STR_mass_min : minimal string mass ** 2 = x1 * x2 * s
+cC. SLOPE : large x suppression exponent
+cC. OUTPUT: X1, X2, PT (GeV) /FR'14
+cC-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c INTEGER NW_max
+c PARAMETER (NW_max = 20)
+cc COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, kb ,kt
+cC--------------------------------------------------------------------
+cC SIBYLL common blocks containing event information \FR'14
+cC--------------------------------------------------------------------
+c
+cC EVENT INFO COMMON
+cC contains overall interaction properties, like
+cC SQS : center-of-mass energy
+cC S : " " squared
+cC PTmin : low pt cut of QCD cross section,
+cC i.e. minimal pt of hard minijets
+cC Xmin : low-x bound for PDFs,
+cC i.e. minimal momentum fraction of hard partons
+cC Zmin : logarithm of that
+cC KB : PID of beam hadron
+cC KT() : PID of target
+cC IAT : mass number of target
+c DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+c INTEGER KB,IAT,KT
+c COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+c
+c INTEGER NCALL, NDEBUG, LUN
+c COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c
+c DOUBLE PRECISION PPT02
+c COMMON /S_CQDIS2/ PPT02(44)
+c INTEGER NIPAR_max,NPAR_max
+c PARAMETER (NPAR_max=200,NIPAR_max=100)
+c DOUBLE PRECISION PAR
+c INTEGER IPAR
+c COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+c
+cC--------------------------------------------------------------------
+cC SIBYLL utility common blocks containing constants \FR'14
+cC--------------------------------------------------------------------
+c DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+c COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+c
+c DOUBLE PRECISION PI,TWOPI,CMBARN
+c COMMON /SIB_CST/ PI,TWOPI,CMBARN
+c
+c DOUBLE PRECISION FACN
+c DIMENSION FACN(3:10)
+c COMMON /SIB_FAC/ FACN
+c SAVE
+c
+c SLOPE = max(1.D0,PAR(42))
+c ZSOF = 2.D0*dLOG(STR_mass_min/SQS) ! minim. mass ~ x1 * x2
+c 50 XMIN = dEXP(ZSOF)
+c axmin = 1.D0/xmin
+c 100 Z1 = -1.D0*dLOG(axmin-(axmin-1.D0)*S_RNDM(0))
+c x1 = dexp(z1)
+c XR = dlog(1.D0-X1) - dlog(1.D0-xmin)
+c if(SLOPE*XR.le.log(S_RNDM(0))) goto 100
+c
+c 200 Z2 = -1.D0*dLOG(axmin-(axmin-1.D0)*S_RNDM(0))
+c X2 = dEXP(Z2)
+c XR = dlog(1.D0-X2) - dlog(1.D0-dEXP(ZSOF))
+c if(SLOPE*XR.le.dlog(S_RNDM(0))) goto 200
+c
+c IF(Z1+Z2.LE.ZSOF) GOTO 50
+c STR_mass2 = dsqrt(X1*X2*S)/2.D0
+c PPTT = PPT02(10)
+c IF(IPAR(3).eq.8) PPTT = PPT02(20)
+c 150 PT = PPTT*dSQRT(-dLOG(MAX(EPS10,S_RNDM(0))))
+c IF(IPAR(3).ge.6)THEN
+c XM = 0.D0
+c XM2 = XM**2
+c RNDM = MAX(EPS10,S_RNDM(IFL))
+c XMT = PPTT * dLOG(RNDM) - XM
+c XMT2 = XMT**2
+c PT = dSQRT(XMT2-XM2)
+c ENDIF
+c IF(PT.GT.PTmin) GOTO 150
+c IF(PT.GE.STR_mass2) GOTO 150
+c END
+c
+C=======================================================================
+
+ SUBROUTINE SAMPLE_SOFT6 (STR_mass_min, X1,X2,PT)
+
+C-----------------------------------------------------------------------
+C...Routine for the sampling the kinematical variables of sea quarks
+C. according to (1-x)**b / x
+C. INPUT: STR_mass_min : minimal string mass ** 2 = x1 * x2 * s
+C. SLOPE : large x suppression exponent
+C. OUTPUT: X1, X2, PT (GeV) /FR'14
+C-----------------------------------------------------------------------
+Cf2py double precision, intent(in) :: STR_mass_min
+Cf2py double precision, intent(out) :: X1
+Cf2py double precision, intent(out) :: X2
+Cf2py double precision, intent(out) :: PT
+
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION PPT02
+ COMMON /S_CQDIS2/ PPT02(44)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ NOSLOPE = 0
+ SLOPE = PAR(42)
+ IF(SLOPE.lt.0.5D0) NOSLOPE = 1
+ XMAX = 0.8D0
+ ZSOF = 2.D0*LOG(STR_mass_min/SQS) ! minim. mass ~ x1 * x2
+ XMINA = MAX(EXP(ZSOF),EPS10)
+ AXMINA = 1.D0/XMINA
+ IF(ndebug.gt.2)
+ & write(lun,*) ' SAMPLE_SOFT6: Mmin,ZSOF,XMINA,XMAX,SLOPE:',
+ & STR_mass_min,ZSOF,XMINA,XMAX,SLOPE
+
+ 100 X1 = XM2DIS(XMINA,XMAX,1.D0) ! ~(1/x)**alpha
+ IF(NOSLOPE.eq.1) goto 200
+ XRNDM = S_RNDM(0)
+ XR = LOG(1.D0-X1)-LOG(1.D0-XMINA)
+ IF(ndebug.gt.5)
+ & write(lun,*) ' X1,XR,SLOPE*XR:',X1,XR,SLOPE*XR
+ if(SLOPE*XR.le.LOG(max(xrndm,eps10))) goto 100
+
+ 200 X2 = XM2DIS(XMINA,XMAX,1.D0) ! ~(1/x)**alpha
+ IF(NOSLOPE.eq.1) goto 300
+ XRNDM = S_RNDM(1)
+ XR = log(1.D0-X2) - log(1.D0-XMINA)
+ IF(ndebug.gt.5)
+ & write(lun,*) ' X2,XR,SLOPE*XR:',X2,XR,SLOPE*XR
+ if(SLOPE*XR.le.log(max(xrndm,eps10))) goto 200
+
+ 300 Z1 = log(X1)
+ Z2 = log(X2)
+ IF(Z1+Z2.LE.ZSOF) GOTO 100
+ STR_mass2 = sqrt(X1*X2*S)/2.D0
+ PPTT = PPT02(10)
+ IF(IPAR(3).eq.8) PPTT = PPT02(20)
+ IF(ndebug.gt.2)
+ & write(lun,*) ' SAMPLE_SOFT6: PPTT,Mmin2,PTmin:',
+ &PPTT,STR_mass2,PTmin
+ 150 PT = PPTT*SQRT(-LOG(MAX(EPS10,S_RNDM(0))))
+ IF(IPAR(3).ge.6)THEN
+ XM = 0.D0
+ XM2 = XM**2
+ RNDM = MAX(EPS10,S_RNDM(1))
+ XMT = PPTT * LOG(RNDM) - XM
+ XMT2 = XMT**2
+ PT = SQRT(XMT2-XM2)
+ ENDIF
+ IF(ndebug.gt.2)
+ & write(lun,*) ' XM,XMT2,PT:',XM,XMT2,PT
+ IF(PT.GT.PTmin) GOTO 150
+ IF(PT.GE.STR_mass2) GOTO 150
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_START_EV (SQS, L, IA, IAFLG, NW, JDIF)
+
+C-----------------------------------------------------------------------
+C...Beginning of a SIBYLL interaction
+C.
+C. add l.m. Glauber SD cross section for pAir 13/FR
+C.
+C. INPUT : SQS = c.m.s. energy (GeV)
+C. L = 1:proton, 2:charged pion
+C. IA = mass of target nucleon
+C. IAFLG = target is air
+C.
+C. OUTPUT: NW = number of wounded nucleons
+C. JDIF(JW) = diffraction code !!!! changed to field !!!!
+C. (0 : non-diffractive interaction)
+C. (1 : forward diffraction)
+C. (2 : backward diffraction)
+C. (3 : double diffraction)
+C.
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c external type declarations
+ INTEGER NW_max,JDIF,IA,L,IAFLG,NW
+ DOUBLE PRECISION SQS
+ PARAMETER (NW_max = 20)
+ DIMENSION JDIF(NW_max)
+
+ DOUBLE PRECISION B, BMAX
+ INTEGER NTRY, NA
+ COMMON /S_CNCM0/ B, BMAX, NTRY, NA
+ DOUBLE PRECISION XM2MIN,ALXMIN,SLOP0,ASLOP,BSLOP,XMASS
+ COMMON /S_DIFMAss/ XM2MIN(6),ALXMIN(6),SLOP0,ASLOP,BSLOP,XMASS(2)
+ DOUBLE PRECISION XI_MAX, ALAM
+ COMMON /GLAUB_SCR/ XI_MAX, ALAM(61)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+c local type declarations
+ DOUBLE PRECISION SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO,
+ & SIGPROD,SIGBDIF,S_RNDM,S,PF,PB,PD,P0,P1,P2,R
+ DIMENSION SIGDIF(3)
+ INTEGER K
+ SAVE
+
+ IF(NDEBUG.gt.0)
+ &WRITE(LUN,*)'SIB_START_EV:', SQS, L, IA, IAFLG, NW, JDIF
+
+C...sample number of wounded nucleons
+c read hadron-nucleon cross section from table
+ CALL SIB_SIGMA_HP(L,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+ IF (IA .GT. 1) THEN
+ IF(IPAR(12).NE.0)THEN
+ IF(IPAR(12).eq.3)THEN
+c distinguish between nuclear cross sections..
+ IF(IAFLG.eq.0)THEN
+c if target is nucleus calc. hadron-nucleus cross section (slow)
+ CALL SIB_SIGMA_HNUC(L,IA,SQS,SIGprod,SIGbdif)
+ ELSE
+c if target is air read hadron-air cross section from table
+ CALL SIB_SIGMA_HAIR(L,SQS,SIGprod,SIGbdif)
+ ENDIF
+ ELSE
+c always use air cross section...
+ CALL SIB_SIGMA_HAIR(L,SQS,SIGprod,SIGbdif)
+ ENDIF
+C 2channel low-mass (coherent) diffraction?
+ IF(S_RNDM(L).LT.SIGbdif/SIGprod)THEN
+ NW = 1
+ JDIF(1) = 1
+ RETURN
+ ENDIF
+ ENDIF
+c sample number of wounded nucleons
+ CALL INT_H_NUC (IA, SIGT, SLOPE, RHO)
+ ELSE
+ NA = 1
+ ENDIF
+ NW = NA
+
+ IF(NDEBUG.gt.0)
+ & WRITE(LUN,'(A50,2I3,1P,3E10.3)')
+ & ' START_EVT: IA, NW, SIGT, SLOPE, RHO:',IA,NW,SIGT,SLOPE,RHO
+C...new treatment of diffraction
+ IF(IA.GT.1) THEN
+c hadron-nucleus case
+ IF(NW.eq.1)THEN
+ IF(IPAR(12).NE.0)THEN
+c high mass (incoherent) diffraction?
+ S = SQS ** 2
+ PF =(1.D0-dLOG(S*XI_MAX/XM2MIN(L))/
+ & dLOG(S*PAR(13)/XM2MIN(L)))*SIGDIF(1)/SIGINEL
+ PB = SIGDIF(2)/SIGINEL
+ PD = SIGDIF(3)/SIGINEL
+ ELSE
+ PF = SIGDIF(1)/SIGINEL
+ PB = SIGDIF(2)/SIGINEL
+ PD = SIGDIF(3)/SIGINEL
+ ENDIF
+ ELSE
+c Nw>1:
+ IF(IPAR(12).EQ.1)THEN
+c all interactions with Nw>1 are non-diff.
+ DO K=1, NW
+ JDIF(K) = 0
+ ENDDO
+ RETURN
+ ELSE
+c some Nw>1 are attached by diff.
+ PF = PAR(124)*SIGDIF(1)/SIGINEL
+ PB = PAR(124)*SIGDIF(2)/SIGINEL
+ PD = PAR(124)*SIGDIF(3)/SIGINEL
+ ENDIF
+ ENDIF
+ ELSE
+c hadron-nucleon case
+ PF = SIGDIF(1)/SIGINEL
+ PB = SIGDIF(2)/SIGINEL
+ PD = SIGDIF(3)/SIGINEL
+ ENDIF
+ P0 = 1.D0-PF-PB-PD
+ P1 = P0 + PF
+ P2 = P1 + PB
+ DO K=1, NW
+ R = S_RNDM(0)
+ IF (R .LT. P0) THEN
+ JDIF(K) = 0
+ ELSE IF (R .LT. P1) THEN
+ JDIF(K) = 1
+ ELSE IF (R .LT. P2) THEN
+ JDIF(K) = 2
+ ELSE
+ JDIF(K) = 3
+ ENDIF
+ ENDDO
+
+ END
+C=======================================================================
+
+ SUBROUTINE INI_EVENT(ECM,KBEAM,IATARG,IMOD)
+
+C-----------------------------------------------------------------------
+C initializes the stacks and event info common
+c if Imod : 0 - initiate subevent in recursive call
+c ( keeps the final hadron stack intact )
+C : 1 - initiate entire new event
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+c external type declarations
+ DOUBLE PRECISION ECM
+ INTEGER KBEAM,IATARG,IMOD
+
+c COMMONs
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER II2,JJ2
+ DOUBLE PRECISION U2,C2,CD2,CM2
+ COMMON /SIB_RAND/ U2(97),C2,CD2,CM2,II2,JJ2
+
+c local types
+ DOUBLE PRECISION PZ,E1,PAWT,S_RNDM,R,FOX
+ INTEGER KK,JJ,II,KBA,IREFout,JN
+ SAVE
+ DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air
+
+
+ IF(NDEBUG.gt.0.and.IMOD.eq.1)
+ & WRITE(LUN,'(A50,F10.2,I4,I3,I3)')
+ & ' INI_EVENT: called with (ECM,KBEAM,IATARG,NCALL):',
+ & ECM,KBEAM,IATARG,NCALL
+
+c set final particle stack to zero
+ IF(IMOD.eq.1)then
+ NP = 0
+ NWD = 0
+ NJET = 0
+ NSOF = 0
+ endif
+
+ CALL INI_PRTN_STCK(0,0)
+
+c clear index cache
+ do kk=1,3
+ IBMRDX(kk) = 0
+ ENDDO
+ do jj=1,NW_max
+ do kk=1,3
+ ICSTDX(jj,kk) = 0
+ ICSTDX(jj+1,kk) = 0
+ ITGRDX(jj,kk) = 0
+ IINTDX(jj) = 0
+ ENDDO
+ do ii=1,NH_max
+ IHMJDX(NH_max*(JJ-1)+II) = 0
+ enddo
+ do ii=1,NS_max
+ ISMJDX(NS_max*(JJ-1)+II) = 0
+ enddo
+ ENDDO
+
+ SQS = Ecm
+ S = SQS*SQS
+
+ KB = KBEAM
+ KBA = IABS(KBEAM)
+c add beam particles to parton stack, lvl -2
+ PZ = PAWT(SQS,AM(KBA),AM(13))
+ E1 = SQRT(PZ**2+AM2(KBA))
+ CALL ADD_PRTN(0.D0,0.D0,PZ,E1,AM(KBA),KB,-2,0,IREFout)
+ IF(IMOD.eq.1)THEN
+ IAT = IATARG
+ IF(IATARG.EQ.1)THEN
+ KT(1) = 13
+ ELSE
+ IF(IATARG.eq.0)THEN
+C... Generate an 'air' interaction by choosing Nitrogen or Oxygen
+ R = S_RNDM(0)
+ IATARG = 14
+ IF (R .LT. FOX) IATARG = 16
+ if (NDEBUG.gt.0)
+ * WRITE(lun,*)'fox,rndm,iatarg,eps:',fox,r,iatarg,eps8
+ ENDIF
+ DO JN=1,IATARG
+c for nuclear target: proton (13) or neutron (14)
+ KT(JN) = 13 + INT((2.D0-EPS8)*S_RNDM(JN))
+ ENDDO
+ ENDIF
+ ELSE
+ KT(1) = IATARG
+ ENDIF
+
+C...energy-dependent transverse momentum cutoff
+c...EJA correction 2007.03.27
+ IF(IPAR(27).eq.1)THEN
+ PTmin = PAR(10)+PAR(11)*EXP(PAR(12)*SQRT(LOG(SQS)))
+ else
+ PTmin = PAR(10)+PAR(11)*EXP(PAR(12)*SQRT(LOG(S)))
+ endif
+ XMIN = 4.D0*PTmin**2/S
+ ZMIN = LOG(XMIN)
+ IF(ndebug.gt.0)then
+ write(lun,*) ' INI_EVENT: ncall:', ncall
+ write(lun,'(2X,A33,F10.2,1X,F16.2,F8.5,E10.3,F10.5)')
+ & 'INI_EVENT: (SQS,S,PTmin,Xmin,Zmin)',
+ & SQS,S,PTmin,Xmin,Zmin
+ write(lun,*) ' INI_EVENT: KB,IAT,IATARG,KT',KB,IAT,IATARG
+ write(lun,*) ' ',(KT(jj),jj=1,IATARG)
+ endif
+
+ CALL PTSETUP_4FLV(ECM)
+
+ return
+ END
+C-----------------------------------------------------------------------
+C parton level administration tools for SIBYLL \FR'14
+C-----------------------------------------------------------------------
+
+C... COMMON /S_PRTNS/ : parton stack
+c PP: 4momentum of parton, px,py,pz,energy,mass
+c LPID(1): parton id, i.e. flavor (u:1,d:2,s:3,c:4) for quarks
+c LPID(2): level of parton
+c fragmenting systems (strings,remnants) are marked as level0
+c partons that make up these systems are marked as level1
+c LPID(3): 'downward' reference
+c pointer from level1 partons to their level0 parent
+c LPID(4): 'upward' reference
+c pointer from level0 partons to their level-1 parent
+c LVL0IDX: index cache for level0 partons
+c NPP: total number of partons on stack
+c NPP0: number of level0 partons on stack
+
+C=======================================================================
+
+ SUBROUTINE ADD_PRTN(PX,PY,PZ,E,XMS,IPID,LVL,IREFin,IREFout)
+
+C-----------------------------------------------------------------------
+C routine to add a parton to the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ PP(NPP+1,1) = PX
+ PP(NPP+1,2) = PY
+ PP(NPP+1,3) = PZ
+ PP(NPP+1,4) = E
+ PP(NPP+1,5) = XMS
+ LPID(NPP+1,1) = IPID
+ LPID(NPP+1,2) = LVL
+ LPID(NPP+1,3) = IREFin
+ NPP = NPP + 1
+c level0 index
+ IF(LVL.eq.0)THEN
+ LVL0IDX(NPP0+1) = NPP
+ NPP0 = NPP0 + 1
+ ENDIF
+ IREFout = NPP
+ IF(NDEBUG.gt.6)THEN
+ WRITE(LUN,*) ' ADD_PRTN: (#,PID,LEVEL,REF)',
+ & NPP,LPID(NPP,1),LPID(NPP,2),LPID(NPP,3)
+ WRITE(LUN,*) ' 4momentum: ',(PP(NPP,JJ),JJ=1,5)
+ ENDIF
+ END
+
+C=======================================================================
+
+ SUBROUTINE ADD_PRTN_4VEC(PIN,IPID,LVL,IREFin,IREFout)
+
+C-----------------------------------------------------------------------
+C wrapper for ADD_PRTN to add 4momentum directly \FR'14
+C----------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DIMENSION PIN(5)
+ SAVE
+
+ CALL ADD_PRTN
+ & (PIN(1),PIN(2),PIN(3),PIN(4),PIN(5),IPID,LVL,IREFin,IRF)
+ IREFout = IRF
+ END
+
+C=======================================================================
+
+ SUBROUTINE ADD_REF(IDX,Irefin)
+
+C-----------------------------------------------------------------------
+C routine to add a reference label to a particle
+C after it has been added to the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+c IF(LPID(IDX,3).ne.0) WRITE(LUN,*)
+c & ' ADD_REF: warning particle already has defined reference,',
+c & IDX,' overwritting..'
+ IF(NDEBUG.gt.6)
+ &WRITE(LUN,*) ' ADD_REF: (IDX,REFin)',IDX,Irefin
+ LPID(IDX,3) = Irefin
+ END
+
+C=======================================================================
+
+ SUBROUTINE RD_REF(IDX,Irefout)
+
+C-----------------------------------------------------------------------
+C routine to add a reference label to a particle
+C after it has been added to the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ Irefout = LPID(IDX,3)
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*) ' RD_ref: (IDX,REFout)',IDX,Irefout
+ END
+
+C=======================================================================
+
+ SUBROUTINE ADD_INT_REF(IDX,Irefin)
+
+C-----------------------------------------------------------------------
+C routine to add a reference label to an interaction
+C after it has been added to the stack \FR'15
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*) ' ADD_INT_REF: (IDX,REFin)',IDX,Irefin
+ LPID(IDX,4) = Irefin
+ END
+
+C=======================================================================
+
+ SUBROUTINE RD_INT(IDX,Irefout,Iout)
+
+C-----------------------------------------------------------------------
+C routine to add a reference label to an interaction
+C after it has been added to the stack \FR'15
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ Irefout = LPID(IDX,4)
+ IF(Irefout.ne.0) Iout = LPID(Irefout,1)
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*) ' RD_INT: (IDX,REFout,Iint)',IDX,Irefout,Iout
+ END
+
+C=======================================================================
+
+ SUBROUTINE EDT_PRTN(IDX,PX,PY,PZ,EN,XMS,IREFout)
+
+C-----------------------------------------------------------------------
+C routine to edit a parton already on stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ IF(NDEBUG.gt.6)THEN
+ WRITE(LUN,*) ' EDT_PRTN: (#,PID,LEVEL,REF)',
+ & IDX,LPID(IDX,1),LPID(IDX,2),LPID(IDX,3)
+ WRITE(LUN,*) ' initial 4momentum:',(PP(IDX,JJ),JJ=1,5)
+ ENDIF
+ PP(IDX,1) = PX
+ PP(IDX,2) = PY
+ PP(IDX,3) = PZ
+ PP(IDX,4) = EN
+ PP(IDX,5) = XMS
+c return reference to other partons
+ IREFout = LPID(IDX,3)
+ IF(NDEBUG.gt.6)
+ & WRITE(LUN,*) ' final 4momentum: ',(PP(IDX,JJ),JJ=1,5)
+ END
+
+C=======================================================================
+
+ SUBROUTINE RD_PRTN(IDX,PX,PY,PZ,EN,XMS,IFL,IREFout)
+
+C-----------------------------------------------------------------------
+C routine to read a parton from the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ IF(NDEBUG.gt.6)THEN
+ WRITE(LUN,*) ' RD_PRTN: (#,PID,LEVEL,REF)',
+ & IDX,LPID(IDX,1),LPID(IDX,2),LPID(IDX,3)
+ WRITE(LUN,*) ' 4momentum: ',(PP(IDX,JJ),JJ=1,5)
+ ENDIF
+ PX = PP(IDX,1)
+ PY = PP(IDX,2)
+ PZ = PP(IDX,3)
+ EN = PP(IDX,4)
+ XMS = PP(IDX,5)
+ IFL = LPID(IDX,1)
+c return reference to other partons
+ IREFout = LPID(IDX,3)
+ END
+
+C=======================================================================
+
+ SUBROUTINE RD_PRTN_4VEC(IDX,Pin,IFL,IREFout)
+
+C-----------------------------------------------------------------------
+C routine to read a parton from the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ DIMENSION Pin(5)
+ SAVE
+
+ IF(IDX.EQ.0) THEN
+ WRITE(LUN,*) ' RD_PRTN_4VEC: invalid index!',IDX
+ xa = -1.D0
+ xa = log(xa)
+ RETURN
+ ELSE
+ do ii = 1,5
+ PIN(ii) = PP(IDX,ii)
+ enddo
+ IFL = LPID(IDX,1)
+c return reference to other partons
+ IREFout = LPID(IDX,3)
+ IF(NDEBUG.gt.6)THEN
+ WRITE(LUN,*) ' RD_PRTN: (#,PID,LEVEL,REF)',
+ & IDX,IFL,LPID(IDX,2),IREFout
+ WRITE(LUN,*) ' 4momentum: ',(PIN(JJ),JJ=1,5)
+ ENDIF
+
+ ENDIF
+ END
+
+C=======================================================================
+
+ SUBROUTINE ITR_LVL0_PRTN(JJ,IDX,LID)
+
+C-----------------------------------------------------------------------
+C routine that serves as iterator over the level0
+C partons on the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ IDX = LVL0IDX(JJ)
+ IF(ndebug.gt.6)
+ & WRITE(LUN,*) ' ITR_LVL0_PRTN: JJ,IDX',JJ,IDX
+ LID = LPID(IDX,1)
+ IF(JJ+1.gt.NPP0) THEN
+ JJ = -1
+ RETURN
+ ELSE
+ JJ = JJ + 1
+ ENDIF
+ END
+
+C=======================================================================
+
+ SUBROUTINE INI_PRTN_STCK(NOLD,N0OLD)
+
+C-----------------------------------------------------------------------
+C reset parton stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ IF(NDEBUG.gt.6) WRITE(LUN,*) ' PRTN_STCK: reset .. '
+ IF(NDEBUG.gt.6) WRITE(LUN,*) ' old state: NPP,NPP0',NPP,NPP0
+
+ NPP = NOLD
+ NPP0 = N0OLD
+
+ IF(NDEBUG.gt.6) WRITE(LUN,*) ' new state: NPP,NPP0',NPP,NPP0
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE GET_NPP(NPPLD,NPP0LD)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ NPPLD = NPP
+ NPP0LD = NPP0
+ END
+
+C=======================================================================
+
+ SUBROUTINE GET_LVL0(NPP0LD,IDXLIST)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ DIMENSION IDXLIST(NPP0_max)
+ INTEGER N
+ SAVE
+
+ NPP0LD = NPP0
+ DO N = 1, NPP0_max
+ IDXLIST(N) = LVL0IDX(N)
+ ENDDO
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE PRNT_PRTN_STCK
+
+C-----------------------------------------------------------------------
+C as the name suggests, prints the current state
+C of the parton stack
+C print unit is defined in S_DEBUG:LUN \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ CHARACTER*5 CDE
+ CHARACTER*9 CODE
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ SAVE
+
+ WRITE (LUN,50)
+ 50 FORMAT(3X,88('-'),/,21X,'SIBYLL PARTON LEVEL EVENT SUMMARY',21X,
+ & /,3X,75('-'),13('-'))
+
+c beam particles
+ WRITE(LUN,*) ' BEAM PARTICLES'
+ 52 FORMAT(4X,'#',3X,'PID',2x,'LVL',2x,'REF',20x,'PX',9x,'PY',7x,
+ + 'PZ',9x,'E',11X,'Mass', /, 3X,75('-'),13('-'))
+ WRITE (LUN,52)
+ DO J=1,NPP
+ IF(LPID(J,2).eq.-2)then
+ WRITE (LUN,60) J, (LPID(J,KK),KK=1,3), (PP(J,K),K=1,5)
+ ENDIF
+ ENDDO
+c level -2 format
+ 60 FORMAT(4I5,14X,2F11.3,1p,2E11.3,0p,F9.3)
+ WRITE(LUN,61)
+ 61 FORMAT(3X,75('-'),13('-'))
+
+c interactions
+ WRITE(LUN,*) ' INTERACTIONS'
+ 62 FORMAT(4X,'#',3X,'PID',2x,'LVL',2x,'REF',20x,'NSOF',8x,'NJET',7x,
+ + 'JDIF',7x,'E',11X,'Mass', /, 3X,75('-'),13('-'))
+ WRITE (LUN,62)
+ DO J=1,NPP
+ IF(LPID(J,2).eq.-1)then
+ WRITE (LUN,63) J, (LPID(J,KK),KK=1,3), (PP(J,K),K=1,5)
+ ENDIF
+ ENDDO
+c level -1 format
+ 63 FORMAT(4I5,12X,4F12.0,F11.3)
+ 64 FORMAT(3X,75('-'),13('-'))
+ WRITE(LUN,64)
+
+c partons
+ WRITE (LUN,100)
+ DO J=1,NPP
+ IF(LPID(J,2).eq.0)then
+ WRITE (LUN,120) J, (LPID(J,KK),KK=1,3), (PP(J,K),K=1,5)
+ elseif(LPID(J,2).eq.1)then
+ CALL KCODE(LPID(J,1),cde,nc)
+ WRITE (LUN,121) J, CDE(1:nc),(LPID(J,KK),KK=2,3),
+ & (PP(J,K),K=1,5)
+ elseif(LPID(J,2).eq.2)then
+ CODE = ' '
+ L = LPID(J,1)
+ CODE(1:6) = NAMP(IABS(L))
+ IF (L .LT. 0) CODE(7:9) = 'bar'
+ WRITE (LUN,122) J,CODE,(LPID(J,KK),KK=2,3), (PP(J,K),K=1,5)
+ endif
+ ENDDO
+ CALL PPSUM(1,NPP,Esum,PXsum,PYsum,PZsum,NF)
+ WRITE(LUN,140) PXsum,PYsum,PZsum,Esum
+
+ 100 FORMAT(4X,'#',3X,'PID',2x,'LVL',2x,'REF',20x,'PX',9x,'PY',7x,
+ + 'PZ',9x,'E',11X,'Mass', /, 3X,75('-'),13('-'))
+c level 0 format
+ 120 FORMAT(4I5,14X,2F11.3,1p,2E11.3,0p,F11.3)
+c level 1 format cjoe
+ 121 FORMAT(I7,1X,A5,2I5,14X,2F11.3,1p,2E11.3,0p,F11.3)
+c level 2 format
+ 122 FORMAT(I10,1X,A9,2I5,10X,2F11.3,1p,2E11.3,0p,F11.3)
+ 140 FORMAT(3X,75('-'),13('-'),/,' Tot = ',26X,2F11.3,1p,2e11.3)
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE PPSUM(N1,N2,ETOT,PXT,PYT,PZT,NF)
+
+C-----------------------------------------------------------------------
+C Return the energy,px,py,pz of level0 partons
+C in the list between N1 and N2
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ NF=0
+ ETOT=0.D0
+ PXT=0.D0
+ PYT=0.D0
+ PZT=0.D0
+ DO J=N1,N2
+ IF (LPID(J,2) .EQ. 0) THEN
+ NF = NF+1
+ ETOT = ETOT + ABS( PP(J,4) )
+ PXT = PXT + PP(J,1)
+ PYT = PYT + PP(J,2)
+ PZT = PZT + PP(J,3)
+ ENDIF
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE FOUR_LENGTH(XP,XM2)
+
+C-----------------------------------------------------------------------
+C Calculate the length of a 4vector (+---) \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION XP(5)
+ SAVE
+
+ XM2 = XP(4)**2 - XP(1)**2 - XP(2)**2 - XP(3)**2
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CALC_INVM(XP1,XP2)
+
+C-----------------------------------------------------------------------
+C Calculate the invariant mass of two 4vectors FR'15
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION XP1(5),XP2(5)
+ SAVE
+
+ CALC_INVM = (XP1(4)+ XP2(4))**2
+ DO I=1,3
+ CALC_INVM = CALC_INVM-(XP1(I)+XP2(I))**2
+ ENDDO
+ CALC_INVM = SQRT(CALC_INVM)
+ END
+
+C=======================================================================
+
+ SUBROUTINE GET_XMT2(IDX,XM2)
+
+C-----------------------------------------------------------------------
+C Calculate the transverse mass of a parton
+C on the stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ XM2 = PP(IDX,1)**2 + PP(IDX,2)**2 + PP(IDX,5)**2
+ END
+C=======================================================================
+
+ SUBROUTINE GET_IMASS2(IDX,XM2)
+
+C-----------------------------------------------------------------------
+C Calculate the invariant mass squared of a parton
+C on the stack (+---) \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ SAVE
+
+ XM2 = PP(IDX,1)**2 + PP(IDX,2)**2 + PP(IDX,3)**2
+ XM2 = PP(IDX,4)**2 - XM2
+ END
+
+C=======================================================================
+
+ SUBROUTINE GET_MASS(IDX,XM)
+
+C-----------------------------------------------------------------------
+C read mass of parton on stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ IF(IDX.EQ.0) THEN
+ XM2 = 0.D0
+ else
+ XM = PP(IDX,5)
+ ENDIF
+ END
+C=======================================================================
+
+ SUBROUTINE GET_MASS2(IDX,XM2)
+
+C-----------------------------------------------------------------------
+C read mass of parton on stack \FR'14
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ IF(IDX.EQ.0) THEN
+ XM2 = 0.D0
+ else
+ XM2 = PP(IDX,5)**2
+ ENDIF
+ END
+
+C=======================================================================
+
+ SUBROUTINE GET_VRTLTY(IDX,XX)
+
+C-----------------------------------------------------------------------
+C calculate virtuality of parton on stack \FR'14
+C = on-shell mass - inv. mass
+C-------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NPP_max = 1000, NPP0_max = 500)
+ COMMON /S_PRTNS/ PP(NPP_max,5), LPID(NPP_max,4), LVL0IDX(NPP0_max)
+ & ,NPP,NPP0
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ SAVE
+
+ IF(IDX.EQ.0) XM2 = 0.D0
+ CALL GET_IMASS2(IDX,xm2)
+ XX = PP(IDX,5)**2-xm2
+ END
+
+C=======================================================================
+
+ SUBROUTINE ADD_4VECS(P1,P2,POUT)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DIMENSION P1(5),P2(5),POUT(5)
+ SAVE
+
+ DO II=1,4
+ POUT(II) = P1(II) + P2(II)
+ ENDDO
+ CALL FOUR_LENGTH(POUT,XM2)
+ IF(XM2.LT.0)THEN
+c virtual particle
+ POUT(5) = -1.D0
+ IF(NDEBUG.gt.6)then
+ WRITE(LUN,*)
+ & ' ADD_4VECS: resulting particle virtual!! (m**2):',XM2
+ WRITE(LUN,*) ' p**2' , POUT(1)**2+POUT(2)**2+POUT(3)**2
+ WRITE(LUN,*) ' E**2: ', POUT(4)**2
+ ENDIF
+ ELSE
+ POUT(5) = sqrt(xm2)
+ ENDIF
+ END
+C=======================================================================
+
+ SUBROUTINE DECPAR (LA,P0,ND,LL,P)
+
+C-----------------------------------------------------------------------
+C...This subroutine generates the decay of a particle
+C. with ID = LA, and 5-momentum P0(1:5)
+C. into ND particles of 5-momenta P(j,1:5) (j=1:ND)
+C.
+C. If the initial particle code is LA=0
+C. then ND and LL(1:ND) are considered as input and
+C. the routine generates a phase space decay into ND
+C. particles of codes LL(1:nd)
+C.
+C. june 1992
+C. This version contains the decay of polarized muons
+C. The muon codes are L = 4 : mu+ R
+C. -4 : mu+ L
+C. 5 : mu- L
+C. -5 : mu- R
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ DIMENSION P0(5), LL(10), P(10,5)
+ DIMENSION PV(10,5), RORD(10), UE(3),BE(3)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+C...Phase space decay into the particles in the list
+ IF (LA .EQ. 0) THEN
+ MAT = 0
+ MBST = 0
+ PS = 0.D0
+ DO J=1,ND
+CDH following statements corrected by D.H. dec 20.,1995
+ P (J,5) = AM(IABS(LL(J)))
+ PV(J,5) = AM(IABS(LL(J)))
+ PS = PS+P(J,5)
+ ENDDO
+ DO J=1,4
+ PV(1,J) = P0(J)
+ ENDDO
+ PV(1,5) = P0(5)
+ GOTO 140
+ ENDIF
+
+C...Choose decay channel
+ L = IABS(LA)
+ ND=0
+ IDC = IDB(L)-1
+ IF (IDC+1 .LE.0) RETURN
+ RBR = S_RNDM(0)
+110 IDC=IDC+1
+ IF(RBR.GT.CBR(IDC)) GOTO 110
+
+ KD =6*(IDC-1)+1
+ ND = KDEC(KD)
+ MAT= KDEC(KD+1)
+ MBST=0
+ IF (MAT .GT.0 .AND. P0(4) .GT. 20.D0*P0(5)) MBST=1
+ IF (MAT .GT.0 .AND. MBST .EQ. 0)
+ + BETA = DSQRT(P0(1)**2+P0(2)**2+P0(3)**2)/P0(4)
+ PS = 0.D0
+c reduce omega mass by 50MeV to allow on-shell N(1710) decay
+ Xmomega = am(32)
+ IF(L.eq.53.or.L.eq.54) AM(32) = AM(32)-0.05D0
+ DO J=1,ND
+ LL(J) = KDEC(KD+1+J)
+ P(J,5) = AM(LL(J))
+ PV(J,5) = AM(LL(J))
+ PS = PS + P(J,5)
+ ENDDO
+ AM(32) = Xmomega
+ DO J=1,4
+ PV(1,J) = 0.D0
+ IF (MBST .EQ. 0) PV(1,J) = P0(J)
+ ENDDO
+ IF (MBST .EQ. 1) PV(1,4) = P0(5)
+ PV(1,5) = P0(5)
+
+140 IF (ND .EQ. 2) GOTO 280
+
+ IF (ND .EQ. 1) THEN
+ DO J=1,4
+ P(1,J) = P0(J)
+ ENDDO
+ RETURN
+ ENDIF
+
+C...Calculate maximum weight for ND-particle decay
+ WWTMAX = 1.D0/FACN(ND)
+ PMAX=PV(1,5)-PS+P(ND,5)
+ PMIN=0.D0
+ DO IL=ND-1,1,-1
+ PMAX = PMAX+P(IL,5)
+ PMIN = PMIN+P(IL+1,5)
+ WWTMAX = WWTMAX*PAWT(PMAX,PMIN,P(IL,5))
+ ENDDO
+
+C...generation of the masses, compute weight, if rejected try again
+240 RORD(1) = 1.D0
+ DO 260 IL1=2,ND-1
+ RSAV = S_RNDM(0)
+ DO 250 IL2=IL1-1,1,-1
+ IF(RSAV.LE.RORD(IL2)) GOTO 260
+250 RORD(IL2+1)=RORD(IL2)
+260 RORD(IL2+1)=RSAV
+ RORD(ND) = 0.D0
+ WT = 1.D0
+ DO 270 IL=ND-1,1,-1
+ PV(IL,5)=PV(IL+1,5)+P(IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
+270 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(IL,5))
+ IF (WT.LT.S_RNDM(1)*WWTMAX) GOTO 240
+
+C...Perform two particle decays in respective cm frame
+280 DO 300 IL=1,ND-1
+ PA=PAWT(PV(IL,5),PV(IL+1,5),P(IL,5))
+ UE(3)=2.D0*S_RNDM(IL)-1.D0
+ PHI=TWOPI*S_RNDM(3)
+ UT = DSQRT(1.D0-UE(3)**2)
+ UE(1) = UT*dCOS(PHI)
+ UE(2) = UT*dSIN(PHI)
+ DO 290 J=1,3
+ P(IL,J)=PA*UE(J)
+290 PV(IL+1,J)=-PA*UE(J)
+ P(IL,4)=DSQRT(PA**2+P(IL,5)**2)
+300 PV(IL+1,4)=DSQRT(PA**2+PV(IL+1,5)**2)
+
+C...Lorentz transform decay products to lab frame
+ DO 310 J=1,4
+310 P(ND,J)=PV(ND,J)
+ DO 340 IL=ND-1,1,-1
+ DO 320 J=1,3
+320 BE(J)=PV(IL,J)/PV(IL,4)
+ GA=PV(IL,4)/PV(IL,5)
+ DO 340 I=IL,ND
+ BEP = BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO 330 J=1,3
+330 P(I,J)=P(I,J)+GA*(GA*BEP/(1.D0+GA)+P(I,4))*BE(J)
+340 P(I,4)=GA*(P(I,4)+BEP)
+
+C...Weak decays
+ IF (MAT .EQ. 1) THEN
+ F1=P(2,4)*P(3,4)-P(2,1)*P(3,1)-P(2,2)*P(3,2)-P(2,3)*P(3,3)
+ IF (MBST.EQ.1) THEN
+C WT = P0(5)*P(1,4)*F1
+ WT = P0(5)*(P(1,4)+DBLE(LA/L)*P(1,3))*F1
+ ENDIF
+ IF (MBST.EQ.0) THEN
+ WT=F1*(P(1,4)*P0(4)-P(1,1)*P0(1)-P(1,2)*P0(2)-P(1,3)*P0(3))
+ IF(L.lt.50)
+ + WT= WT-DBLE(LA/L)*(P0(4)*BETA*P(1,4)-P0(4)*P(1,3))*F1
+ ENDIF
+ WTMAX = P0(5)**4/8.D0
+ IF(WT.LT.S_RNDM(0)*WTMAX) GOTO 240
+ ENDIF
+
+C...Boost back for rapidly moving particle
+ IF (MBST .EQ. 1) THEN
+ DO 440 J=1,3
+440 BE(J)=P0(J)/P0(4)
+ GA= P0(4)/P0(5)
+ DO 460 I=1,ND
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO 450 J=1,3
+450 P(I,J)=P(I,J)+GA*(GA*BEP/(1.D0+GA)+P(I,4))*BE(J)
+460 P(I,4)=GA*(P(I,4)+BEP)
+ ENDIF
+
+C...labels for antiparticle decay
+ IF (LA .LT. 0 .AND. L .GT. 18) THEN
+ DO J=1,ND
+ LL(J) = LBARP(LL(J))
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C=======================================================================
+
+ BLOCK DATA DATDEC
+
+C-----------------------------------------------------------------------
+C...initialization of SIBYLL particle data
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ DOUBLE PRECISION AW,AW2
+ COMMON /S_WIDTH1/ AW(99), AW2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ SAVE
+c CBR contains the normed sum of the branching ratios of the decay channels
+c indexed by IDB, i.e. a particle with 4 decay channels will have the entries
+c [B1/Btot, (B1+B2)/Btot, (B1+B2+B3)/Btot, 1.]
+ DATA CBR /3*1.D0,0.D0,1.D0,1.D0,0.6354D0,0.8422D0,0.8981D0,
+ + 0.9157D0,0.9492D0,1.D0,0.6354D0,0.8422D0,0.8981D0,0.9157D0,
+ + 0.9492D0,1.D0,0.1965D0,0.3224D0,0.4579D0,0.5934D0,0.7967D0,1.D0,
+ + 0.6925D0,1.D0,3*0.D0,0.5D0,1.D0,0.5D0,1.D0,
+ + 0.3941D0,0.7197D0,0.9470D0,0.9930D0,1.D0, ! eta
+ + 0.4285D0,0.7193D0,0.9487D0,0.9750D0,0.9973D0,0.9999D0,1.D0, ! eta'
+ + 3*1.D0, ! rho-mesons
+ + 0.6670D0,1.D0, ! K*+
+ + 0.4894D0,0.8317D0,0.9850D0,0.9981D0,0.9994D0,0.9997D0,1.D0, ! phi(1020)
+ + 2*0.D0, ! (empty)
+ + 0.6670D0,1.D0, ! K*-
+ + 0.6670D0,1.D0, ! K*0
+ + 0.6670D0,1.D0, ! K*0 bar
+ + 0.8940D0,0.9830D0,1.D0, ! omega
+ + 4*0.D0, ! (empty)
+ + 0.5160D0,5*1.D0,0.6410D0,2*1.D0,0.67D0,1.D0,0.33D0,2*1.D0,
+ + 0.88D0,0.94D0,1.D0,0.88D0,0.94D0,1.D0,0.88D0,0.94D0,1.D0,0.33D0,
+ + 1.D0,0.67D0,1.D0,0.678D0,0.914D0,1.D0,0.217D0,0.398D0,0.506D0,
+ + 0.595D0,0.684D0,0.768D0,0.852D0,0.923D0,0.976D0,1.D0,0.217D0,
+ + 0.398D0,0.506D0,0.595D0,0.684D0,0.768D0,0.852D0,0.923D0,0.976D0,
+ + 1.D0,0.2490D0,0.4604D0,0.5338D0,0.5703D0,0.7440D0,0.7840D0,
+ + 0.8460D0,0.8880D0,0.9230D0,0.9650D0,1.D0,0.2490D0,0.4604D0,
+ + 0.5338D0,0.5703D0,0.7440D0,0.7840D0,0.8460D0,0.8880D0,0.9230D0,
+ + 0.9650D0,1.D0,0.1666D0,0.3332D0,0.4998D0,0.6664D0,0.8330D0,1.D0,
+ + 0.6770D0,0.9840D0,1.D0,
+ + 0.6770D0,0.9840D0,1.D0,0.6190D0,1.D0,0.6190D0,1.D0,0.0602D0,
+ + 0.1203D0,1.D0,3*1.D0,0.06D0,0.08D0,0.14D0,0.16D0,0.73D0,0.855D0,
+ + 0.98D0,1.D0,0.08D0,0.16D0,0.92D0,1.D0,0.2335D0,0.4283D0,0.6446D0,
+ + 0.7099D0,0.8080D0,0.9080D0,0.9380D0,0.9540D0,0.9840D0,1.D0,
+ + 3*1.D0,0.5D0,1.D0,0.5D0,1.D0,0.08D0,0.16D0,0.92D0,1.D0,0.942D0,
+ + 1.D0,0.942D0,1.D0,0.2493D0,0.4061D0,0.5602D0,0.6860D0,0.7608D0,
+ + 0.8305D0,0.8818D0,0.9277D0,0.9691D0,1.D0,0.2493D0,0.4061D0,
+ + 0.5602D0,0.6860D0,0.7608D0,0.8305D0,0.8818D0,0.9277D0,0.9691D0,
+ + 1.D0,
+ & 0.466D0,0.7D0,0.899D0,1.D0,0.466D0,0.7D0,0.899D0,1.D0, ! N1440+-
+ & 0.3334D0,0.5D0,0.6334D0,0.7634D0,0.8734D0,0.9394D0,1.D0, ! N1710+
+ & 0.3334D0,0.5D0,0.6334D0,0.7634D0,0.8734D0,0.9394D0,1.D0, ! N1710-
+ & 0.5D0, 1.D0, 0.5D0, 1.D0, 0.5D0, 1.0D0, ! pi1+-0
+ & 0.6666D0,1.D0, 0.6666D0,1.D0,0.6666D0,1.D0,0.6666D0,1.D0/ ! K0*
+ DATA AM / 0.0,2*0.511D-3, 2*0.10566, 0.13497, 2*0.13957,
+ + 2*0.49368, 2*0.49761, 0.93827, 0.93957, 4*0.0,0.93827,
+ + 0.93957, 2*0.49761, 0.54785,0.95766,2*0.76690,0.76850,
+ + 2*0.89166D0,2*0.89600,0.78265,1.01946D0,1.18937D0,1.19264D0,
+ + 1.19745,1.31486,1.32171,1.11568,1.23100,1.23500,
+ + 1.23400,1.23300,1.38280,1.38370,1.38720,
+ + 1.53180,1.53500,1.67245,0.,1.44,1.44,1.71,1.71,4*0.0,
+ + 2*1.86926,1.30,1.30,1.30,4*1.430, 3*0.0,
+ + 2*1.86484,2.9803,2*1.9685,2*2.1123,2*2.01027,2*2.00697,
+ + 0.0,3.09692,2.45402,2.4529,2.45376,2.4679,2.4710,
+ + 2.28646, 2*1.777, 2*0.0, 2.5184,2.5175, 2.5180, 2.6466,
+ + 2.6461, 2.6975 /
+ DATA AM2 /0.0,2*2.61121D-07,2*0.011164,0.018217,0.019480,
+ + 0.019480,0.243720,0.243720,0.247616,0.247616,0.880351,
+ + 0.882792,0.000000,0.000000,0.000000,0.000000,0.880351,
+ + 0.882792,0.247616,0.247616,0.300140,0.917113,0.588136,
+ + 0.588136,0.590592,0.795058,0.795058,0.802816,0.802816,
+ + 0.612541,1.039299,1.414601,1.422390,1.433887,1.728857,
+ + 1.746917,1.244742,1.515361,1.525225,1.522765,1.520289,
+ + 1.912136,1.914626,1.924324,2.346411,2.356225,2.797022,
+ + 0.,2.0736,2.0736,2.9241,2.9241,4*0.0, 2*3.49414,
+ + 1.690, 1.690, 1.690, 4*2.0449, 3*0.0, 2*3.477628, 8.882188,
+ + 2*3.8750,2*4.4618,2*4.041186,2*4.027928, 0.0, 9.590914, 6.022214,
+ + 6.016718, 6.020938,6.09053, 6.105841, 5.227899, 2*3.158, 2*0.0,
+ + 6.342339, 6.337806, 6.340323,7.004492, 7.001845, 7.276506/
+ DATA AW /24*0.D0,0.022231D0,0.022231D0,0.022231D0,0.002581D0,
+ & 0.002581D0,0.D0,0.D0,7.20801D-05,1.81476D-05,6*0.D0,
+ & 0.013689D0,0.013689D0,0.013689D0,0.013689D0,0.001296D0,
+ & 0.001295D0,0.00155D0,8.281D-05,9.801D-05,0.D0,0.D0,0.09D0,
+ & 0.01D0,0.09D0,0.01D0,6*0.D0,0.1D0,0.1D0,0.1D0,4*0.27D0,
+ & 32*0.D0/
+ DATA AW2 /24*0.D0,0.022231D0,0.022231D0,0.022231D0,0.002581D0,
+ & 0.002581D0,0.D0,0.D0,7.20801D-05,1.81476D-05,6*0.D0,
+ & 0.013689D0,0.013689D0,0.013689D0,0.013689D0,0.001296D0,
+ & 0.001295D0,0.00155D0,8.281D-05,9.801D-05,0.D0,0.D0,0.09D0,
+ & 0.01D0,0.09D0,0.01D0,6*0.D0,0.01D0,0.01D0,0.01D0,4*0.0729D0,
+ & 32*0.D0/
+c IDB is the index to the branching ratios (CBR) and decay channels (KDEC).
+c always indicates the first decay channel
+ DATA IDB /
+ + 0,0,0,1,2, ! leptons
+ + 3,5,6,7,13,19,25, ! pions and kaons
+ + 8*0,30,32,34,39,46,47,48,49,60,62,64,66,51, !69, ! meson resonances
+ + 73,75,76,77,78,79,81,82,84,86,87,90,93,96,98,100, ! baryons : Sibyll 2.1
+ + 0,224,228,232,239,4*0, ! Nucleon resonaces
+ + 103,113,246,248,250, 252,254,256,258,3*0,
+ + 123,134,145,204,214,200,202,151,154,157,159,0,
+ + 161,164,165,166,167,175,179,4*0,189,190,191,192,194,196 /
+c KDEC contains decay channels, format is [ND, MAT, LL(1:4)]
+c where ND is the number of particles in the final state (max 4)
+C MAT is 0, 1 for semi-leptonic (weak decay) or not
+c (adds primitive matrix element)
+c LL(1:4) are the particle ids of the final state particles
+ DATA KDEC /
+ + 3,1,15,2,18,0,3,1,16,3,17,0,2,0,1,1,8*0,2,0,4,17,0,0,2,0,5,18,0,
+ + 0,2,0,4,17,0,0,2,0,7,6,0,0,3,0,7,7,8,0,3,0,7,6,6,0,3,1,17,4,6,0,
+ + 3,1,15,2,6,0,2,0,5,18,0,0,2,0,8,6,0,0,3,0,8,8,7,0,3,0,8,6,6,0,3,
+ + 1,18,5,6,0,3,1,16,3,6,0,3,0,6,6,6,0,3,0,7,8,6,0,3,1,18,5,7,0,3,
+ + 1,17,4,8,0,3,1,16,3,7,0,3,1,15,2,8,0,2,0,7,8,0,0,2,0,6,6,20*0,1,
+ + 0,11,3*0,1,0,12,0,0,0,1,0,11,0,0,0,1,0,12,0,0,0,2,0,1,1,0,0,3,0,
+ + 6,6,6,0,3,0,7,8,6,0,3,0,1,7,8,0,3,0,1,3,2,0,
+ + 3,0,7,8,23,0, 3,0,6,6,23,0, 2,0,1,27,0,0, 2,0,1,32,0,0, ! eta'
+ + 2,0,1,1,0,0, 3,0,6,6,6,0, 3,0,1,4,5,0, ! eta'
+ + 2,0,7,6,0,0, ! rho+
+ + 2,0,8,6,0,0, ! rho-
+ + 2,0,7,8,0,0, ! rho0
+ + 2,0,21,7,0,0, 2,0,9,6,0,0, ! K*+
+ + 2,0,9,10,0,0, 2,0,11,12,0,0, 3,0,7,8,6,0, 2,0,1,23,0,0, ! phi(1020)
+ + 2,0,1,6,0,0, 2,0,2,3,0,0, 2,0,4,5,0,0, ! phi(1020)
+ + 12*0,
+ + 2,0,22,8,0,0, 2,0,10,6,0,0, ! K*-
+ + 2,0,9,8,0,0, 2,0,21,6,0,0, ! K*0
+ + 2,0,10,7,0,0, 2,0,22,6,0,0, ! K*0 bar
+ + 3,0,7,8,6,0, 2,0,1,6,0,0, 2,0,7,8,0,0, ! omega
+ + 24*0,
+ + 2,0,13,6,0,0,2,0,14,7,0,0,2,0,39,1,0,0,2, ! baryons
+ + 0,14,8,0,0,2,0,39,6,0,0,2,0,39,8,0,0,2,0,13,8,0,0,2,0,
+ + 14,6,0,0,2,0,13,7,0,0,2,0,13,6,
+ + 0,0,2,0,14,7,0,0,2,0,13,8,0,0,2,0,14,6,0,0,2,0,14,8,0,0,2,0,
+ + 39,7,0,0,2,0,34,6,0,0,2,0,35,7,0,0,2,0,39,6,0,0,2,0,34,8,0,0,
+ + 2,0,36,7,0,0,2,0,39,8,0,0,2,
+ + 0,35,8,0,0,2,0,36,6,0,0,2,0,37,6,0,0,2,0,38,7,0,0,2,0,
+ + 37,8,0,0,2,0,38,6,0,0,2,0,39,10,0,0,2,0,37,8,0,0,2,0,38,6,0,0,
+ + 3,0,22,7,6,0,3,0,22,9,22,0,2,0,22,7,0,0,3,1,2,15,22,0,3,1,4,17,
+ + 22,0,3,1,2,15,31,0,3,1,4,17,31,0,2,0,31,25,0,0,3,0,33,7,6,0,
+ + 3,0,10,7,7,0,
+ + 3,0,21,8,6,0,3,0,21,10,21,0,2,0,21,8,0,0,3,1,3,16,21,0,3,1,5,18,
+ + 21,0,3,1,3,16,30,0,3,1,5,18,30,0,2,0,30,26,0,0,3,0,33,8,6,0,
+ + 3,0,9,8,8,0,
+ + 2,0,29,7,0,0,2,0,31,6,0,0,2,0,22,6,0,0,2,0,10,7,0,0,2,0,31,27,0,
+ + 0,2,0,30,27,0,0,2,0,29,25,0,0,3,1,2,15,10,0,3,1,2,15,29,0,
+ + 3,1,4,17,10,0,3,1,4,17,29,0,
+ + 2,0,28,8,0,0,2,0,30,6,0,0,2,0,21,6,0,0,2,0,9,8,0,0,2,0,30,27,0,
+ + 0,2,0,31,27,0,0,2,0,28,26,0,0,3,1,3,16,9,0,3,1,3,16,28,0,
+ + 3,1,5,18,9,0,3,1,5,18,28,0,
+ + 3,0,6,21,22,0,3,0,6,9,10,0,3,0,23,6,6,0,3,0,23,7,8,0,3,0,24,6,6,
+ + 0,3,0,24,7,8,0,
+ + 2,0,71,7,0,0,2,0,59,6,0,0,2,0,59,1,0,0,
+ + 2,0,72,8,0,0,2,0,60,6,0,0,2,0,60,1,0,0,
+ + 2,0,71,6,0,0,2,0,71,1,0,0,2,0,72,6,0,0,2,0,72,1,0,0,
+ + 2,0,2,3,0,0,2,0,4,5,0,0,3,0,6,7,8,0,
+ + 2,0,89,7,0,0,2,0,89,6,0,0,2,0,89,8,0,0,
+ + 3,1,2,15,22,0,3,1,2,15,33,0,3,1,4,17,22,0,3,1,4,17,33,0,2,0,7,22,
+ + 0,0,2,0,9,22,0,0,2,0,7,33,0,0,2,0,9,33,0,0,
+ + 3,1,2,15,10,0,3,1,4,17,10,0,2,0,7,10,0,0,2,0,9,10,0,0,
+ + 3,0,7,10,13,0,3,0,7,22,14,0,3,0,7,8,13,0,3,0,9,10,13,0,3,0,9,22,
+ + 14,0,3,0,22,8,40,0,3,1,2,15,39,0,3,1,2,15,14,0,3,1,4,17,39,0,3,
+ + 1,4,17,14,0,
+ + 2,0,89,7,0,0,2,0,89,6,0,0,2,0,89,8,0,0,
+ + 2,0,87,6,0,0,2,0,87,1,0,0,2,0,88,6,0,0,2,0,88,1,0,0,
+ + 3,1,2,15,10,0,3,1,4,17,10,0,2,0,7,10,0,0,2,0,9,10,0,0 ,
+ + 2,0,74,1,0,0 ,2,0,74,6,0,0 , 2,0,75,1,0,0 ,2,0,75,6,0,0, !C=1,S=1 mesons
+ + 2,0,23,25,0,0, 4,0,9,10,7,6, 3,0,9,10,7,0, 2,0,33,7,0,0,
+ + 3,1,23,2,15,0, 3,1,33,2,15,0, 2,0,23,7,0,0, 4,0,12,10,7,7,
+ + 2,0,9,12,0,0, 4,0,7,8,7,8, 2,0,23,26,0,0, 4,0,10,9,8,6, ! | D*(_s)
+ + 3,0,10,9,8,0, 2,0,33,8,0,0, 3,1,23,3,16,0, 3,1,33,3,16,0,! v
+ + 2,0,23,8,0,0, 4,0,12,9,8,8, 2,0,10,12,0,0, 4,0,7,8,7,8, ! ----
+ & 2,0,14,7,0,0, 2,0,13,6,0,0, 3,0,14,7,6,0, 3,0,13,7,8,0, ! N-res
+ & 2,0,13,8,0,0, 2,0,14,6,0,0, 3,0,13,6,8,0, 3,0,14,7,8,0,
+ & 3,0,14,7,6,0, 3,0,13,7,8,0, 2,0,14,7,0,0, 2,0,13,32,0,0,
+ & 2,0,39,9,0,0, 2,0,13,6,0,0, 2,0,13,23,0,0,
+ & 3,0,13,8,6,0, 3,0,14,7,8,0, 2,0,13,8,0,0, 2,0,14,32,0,0,
+ & 2,0,39,21,0,0, 2,0,14,6,0,0, 2,0,14,23,0,0, ! ---
+ & 2,0,25,8,0,0, 2,0,26,7,0,0, ! pi10 |
+ & 2,0,25,6,0,0, 2,0,27,7,0,0, ! + v
+ & 2,0,27,8,0,0, 2,0,26,6,0,0, ! - ---
+ & 2,0,21,7,0,0, 2,0,9,6,0,0, 2,0,22,8,0,0, 2,0,10,6,0,0, ! k0* |
+ & 2,0,9,8,0,0, 2,0,21,6,0,0, 2,0,10,7,0,0, 2,0,22,6,0,0/ ! v
+ DATA LBARP/1,3,2,5,4,6,8,7,10,9,11,12,-13,-14,16,15,18,17,13,14,
+ + 22,21,23,24,26,25,27,29,28,31,30,32,33,-34,-35,-36,-37,-38,-39,
+ + -40,-41,-42,-43,-44,-45,-46,-47,-48,-49,0,-51,-52,-53,-54,4*0,
+ + 60,59,61,63,62,65,64,67,66,3*0,72,71,
+ + 73,75,74,77,76,79,78,81,80,0,83,-84,-85,-86,-87,-88,-89,
+ + 91,90,93,92,-94,-95,-96,-97,-98,-99 /
+ DATA ICHP /0,1,-1,1,-1,0,1,-1,1,-1,0,0,1,0,4*0,-1,0,4*0, !24
+ + 1,-1,0,1,-1,4*0,1,0,-1,0,-1,0,2,1,0,-1,1,0,-1,0,-1,-1, !49
+ + 0,1,0,1,0,4*0,1,-1,0,1,-1,1,-1,0,0,3*0, !70
+ + 0,0,0,1,-1,1,-1,1,-1,0,0,0, !82
+ + 0,2,1,0,1,0,1,1,-1,2*0,2,1,0,1,0,0 / ! charmed baryons + tau
+
+ DATA ISTR /8*0,-1,+1,-1,-1,8*0,-1,+1,5*0,-1,+1,-1,+1,2*0, ! mesons
+ + 3*1,2*2,1,4*0,3*1,2*2,3,0,4*0, ! 54
+ + 4*0,2*0,3*0,-1,1,-1,1,3*0,2*0,0,-1,1,-1,1,2*0,2*0,0,0, ! 83
+ + 3*0,2*1,0,4*0,3*0,2*1,2 / ! charmed baryons
+ DATA IBAR /12*0,2*1,4*0,2*-1,13*0,16*1,0,4*1,4*0,
+ + 2*0,10*0,2*0,0,4*0,2*0,2*0,0,0,6*1,4*0,6*1 /
+ DATA ICHM /58*0,1,-1,10*0,1,-1,0,1,-1,+1,-1,1,-1,1,-1,0,0,
+ + 6*1,4*0,6*1/
+ DATA NAMP /
+ + ' ','gam ','e+','e-','mu+','mu-','pi0',
+ + 'pi+','pi-','k+', 'k-', 'k0l','k0s',
+ + 'p', 'n', 'nue', 'nueb', 'num', 'numb', 'pbar', 'nbar',
+ + 'k0', 'k0b', 'eta', 'etap', 'rho+', 'rho-','rho0',
+ + 'k*+','k*-','k*0','k*0b','omeg', 'phi', 'SIG+', 'SIG0',
+ + 'SIG-','XI0','XI-','LAM','DELT++','DELT+','DELT0','DELT-',
+ + 'SIG*+','SIG*0','SIG*-', 'XI*0', 'XI*-', 'OME-',
+ + ' ','N144_+','N144_0','N171_+','N171_0',
+ + 4*' ', 'D+', 'D-','pi1_0 ','pi1_+ ','pi1_- ',
+ + 'k0*_+','k0*_-','k0*_0','k0*_0b',
+ + 3*' ', 'D0', 'D0b', 'eta_c',
+ + 'D_s+','D_s-','D*_s+','D*_s-','D*+', 'D*-', 'D*0', 'D*0b',
+ + ' ', 'J/psi',
+ + 'SIGc++', 'SIGc+', 'SIGc0','XI_c+','XI_c0','LAM_c+',
+ + 'tau+ ','tau- ','nut ','nutb ',
+ + 'SIc*++','SIGc*+','SIGc*0', 'XI_c*+', 'XI_c*0',
+ + 'OME_c0' /
+ END
+C->
+C=======================================================================
+
+ SUBROUTINE DECPR (LUN)
+
+C-----------------------------------------------------------------------
+C...Print on unit LUN the list of particles and decay channels
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ DOUBLE PRECISION AW,AW2
+ COMMON /S_WIDTH1/ AW(99), AW2(99)
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ DIMENSION LL(4)
+ SAVE
+
+ 100 FORMAT(/,1X,75('-'),/,28X,'SIBYLL DECAY TABLE')
+ WRITE(LUN,100)
+ 101 FORMAT(1X,75('-'),/,2X,'PID',1X,'Particle',6X,'Mass',9X,'Width',/,
+ + 4X,'Channel',1X,'Br.frac.',1X,'Nf',2X,'MAT',1X,
+ + 'Final Particles',/,1X,75('-'))
+ WRITE(LUN,101)
+ DO L=1,99
+ IF(MOD(L,10).EQ.0)WRITE(LUN,101)
+ IDC = IDB(L)-1
+ NC = 0
+ WRITE (LUN,10) L,NAMP(L), AM(L), AW(L)
+ IF(IDC+1 .GT. 0) THEN
+ CB = 0.D0
+110 IDC=IDC+1
+ NC = NC+1
+ CBOLD = CB
+ CB = CBR(IDC)
+ BR = CB-CBOLD
+ KD = 6*(IDC-1)+1
+ ND = KDEC(KD)
+ MAT= KDEC(KD+1)
+ DO J=1,ND
+ LL(J) = KDEC(KD+1+J)
+ ENDDO
+ WRITE (LUN,15) NC,BR,ND,MAT, (NAMP(LL(J)),J=1,ND)
+ IF (CB .LT. 1.D0) GOTO 110
+ ENDIF
+ ENDDO
+ RETURN
+10 FORMAT(2X,I3,2X,A6,3X,F10.4,3X,F10.4)
+15 FORMAT(5X,I2,2X,F9.4,I4,I4,2X,3(A6,2X))
+ END
+
+C=======================================================================
+
+ SUBROUTINE DEC_DEBUG (L,P0, ND, LL, PD)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ DIMENSION P0(5), LL(10), PD(10,5)
+ SAVE
+
+ ETOT = 0.D0
+ DO J=1,ND
+ ETOT = ETOT + PD(J,4)
+ ENDDO
+ WRITE(*,*) NAMP(IABS(L)),' -> ', (NAMP(IABS(LL(J))),J=1,ND)
+ WRITE(*,*) ' Ei, Ef = ', P0(4), ETOT, ' L = ', L
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE DEC_INI
+
+C-----------------------------------------------------------------------
+C decay initialization routine
+C sets which particles should decay and wich should be stable
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ SAVE
+
+ if ( ndebug .gt. 0 ) then
+ write(lun,*)' -----------------------------------------'
+ write(lun,*)' SIBYLL DEC_INI: setting particle decays!'
+ write(lun,*)' to be used in stand-alone SIBYLL only ! '
+ write(lun,*)' -----------------------------------------'
+ endif
+
+C... Definition of stable particles
+ DO J=4,12
+ IDB(J) = -abs(IDB(J))
+ ENDDO
+c----------------------------------------------------------
+c if the folowing is commented out then all particles
+c except leptons, protons and neutrons are UNSTABLE
+c----------------------------------------------------------
+c all particles with t<0.3e-10s are considered unstable
+c i.e. all the mesons from K0s onwards(K0l is stable)
+c----------------------------------------------------------
+C K0s stable
+ if (ndebug .gt. 0 ) write(lun,*)' making K0s stable..'
+ IDB(12) = -abs(IDB(12))
+
+C Lambda/Anti-lambda stable
+ if (ndebug .gt. 0 ) write(lun,*)' making LAMBDA stable..'
+ IDB(39) = -abs(IDB(39))
+
+c Sigmas stable
+ if (ndebug .gt. 0 ) write(lun,*)' making SIGMAs stable..'
+ do i=34,36
+ IDB(i) = -abs(IDB(i))
+ enddo
+ IDB(35) = -abs(IDB(35))
+C Eta stable
+cfr in reasonable contex eta is never stable !
+
+cdh initializing the pythia routines is done in corsika/SIBINI
+c IF(IPAR(44).eq.1)THEN
+c use pythia decay routine
+c if (ndebug .gt. 0 ) write(LUN,*) ' using PYTHIA decay routine...'
+c CALL PYDEC_INI
+c endif
+
+ if (ndebug .gt. 0 )
+ * write(lun,*)' ------------------------------------------'
+ end
+C=======================================================================
+
+ SUBROUTINE STRING_FRAG_4FLV
+ + (E0,IFL1,IFL2,PX1,PY1,PX2,PY2,IFBAD,IFQRK)
+
+C-----------------------------------------------------------------------
+C. This routine fragments a string of energy E0
+C. the ends of the strings have flavors IFL1 and IFL2
+C. the particles produced are in the jet-jet frame
+C. with IFL1 going in the +z direction
+C. E0 = total energy in jet-jet system
+C. This version consider also a primordial pT attached
+C. to the ends of the string PX1,PY1, PX2,PY2
+C. OUTPUT: IFBAD =1 kinematically impossible decay
+c 2010.03.11 ifqrk - leading quark flag
+c 1 in valence quark, 0 in others
+c
+c Modified Nov. 91. RSF and TSS to fragment symmetrically
+c ie forward and backward are fragmented as leading.
+c Change- Dec. 92 RSF. call to ptdis moved- to use flavor
+c of NEW quark in fragmentation.
+c
+c includes 4 FLAVORS \FR'13
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ DOUBLE PRECISION ZLIST
+ COMMON /S_ZLIST/ ZLIST(8000)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+ DOUBLE PRECISION FAin, FB0in
+ COMMON /S_CZDIS/ FAin, FB0in
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ INTEGER LRNK
+ COMMON /SIB_RNK/ LRNK(8000)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+ DIMENSION WW(2,2), PTOT(4), PX(3),PY(3),IFL(3),ILEAD(2)
+ DIMENSION LPOINT(8000), PMQ(3), IRNK(2), LRES(6:99)
+ LOGICAL LRANK
+ SAVE
+ DATA LRANK/.true./
+
+ DATA (LRES(I),I=6, 39)
+ & /27,25,26,28,29,9,9,41,42,19*0,44,45,46,47,48,39/
+ DATA (LRES(I),I=40, 49) /40,41,42,43,44,45,46,47,48,49/
+ DATA (LRES(I),I=50, 83)
+ & /0,51,52,53,54,4*0,78,79,10*0,71,72,73,76,77,76,
+ & 77,78,79,80,81,0,83/
+ DATA (LRES(I),I=84, 99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+
+ IF(Ndebug.gt.3) THEN
+ WRITE(LUN,*)
+ & ' STRING_FRAG_4FLV: called with ',
+ & '(E0,IFL1,IFL2,PX1,PY1,PX2,PY2,IVAL)',
+ & E0,IFL1,IFL2,PX1,PY1,PX2,PY2,IFQRK
+ WRITE(LUN,*)' STRING_FRAG_4FLV: NP before fragmentation:',NP
+ ENDIF
+
+c... remember initial values
+c strange fraction
+ par2_def = PAR(2)
+c vector model
+ IPAR11_def = IPAR(11)
+c vector fraction
+ PAR5_def = PAR(5)
+c charm fraction
+ PAR24_def = PAR(24)
+c popcorn fraction
+ PAR8_def = PAR(8)
+
+C...initialise
+ NTRY = 0
+ IFBAD = 0
+ 200 NTRY = NTRY + 1
+
+c reset parameters after rejection
+ PAR(2) = PAR2_def
+ PAR(5) = PAR5_def
+ PAR(24) = PAR24_def
+ IPAR(11) = IPAR11_def
+ PAR(8) = PAR8_def
+
+ IF (NTRY .GT. 50) THEN
+ IFBAD = 1
+ RETURN
+ ENDIF
+ I = NP
+ DO K=1,2
+ WW(K,1) = 1.D0
+ WW(K,2) = 0.D0
+ IRNK(K) = 0
+ ENDDO
+ PX(1) = PX1
+ PY(1) = PY1
+ PX(2) = PX2
+ PY(2) = PY2
+ PX(3) = 0.D0
+ PY(3) = 0.D0
+ PTOT (1) = PX1+PX2
+ PTOT (2) = PY1+PY2
+ PTOT (3) = 0.D0
+ PTOT (4) = E0
+c turn on/off splitting of leading diquark
+c (1: no splitting, 0: diq may be split, producing leading meson)
+ IFL(1) = IFL1+ISIGN(100,IFL1)*MIN(1,IABS(IFL1)/10)*IPAR(90)
+ IFL(2) = IFL2+ISIGN(100,IFL2)*MIN(1,IABS(IFL2)/10)*IPAR(90)
+ PMQ(1) = QMASS(IFL(1))
+ PMQ(2) = QMASS(IFL(2))
+
+ ILEAD(1) = 0
+ ILEAD(2) = 0
+ IBLEAD = 0
+ IF(IABS(IFQRK).eq.1) THEN
+ ILEAD(1) = 1
+ ILEAD(2) = 1
+ ENDIF
+c switch leading baryon fragmentation function on/off
+ IF(IPAR(20).eq.0) GOTO 300
+c set flags for leading baryon
+C
+C SET FLAG FOR GENERATION OF LEADING PARTICLES.
+C "AND" IS FOR PPBAR ( DIQUARK AT BOTH ENDS)
+C "OR" IS FOR PP, PPI, ( DIQUARK AT ONE END.)
+C
+ IF (IABS(IFL1) .GT. 10 .AND. IABS(IFL2) .GT. 10) THEN
+ IBLEAD = 2
+ I = I+1
+ JT = INT(1.5D0+S_RNDM(0))
+ GOTO 350
+ ENDIF
+ IF (IABS(IFL1) .GT. 10 .OR. IABS(IFL2) .GT. 10) THEN
+ IBLEAD = 1
+ I = I+1
+ JT = 2
+ IF (IABS(IFL2) .GT. 10) JT = 1
+ GOTO 350
+ ENDIF
+
+C...produce new particle: side, pT
+ 300 continue
+ I=I+1
+ if(i.gt.8000) then
+ write(LUN,'(1x,a,i8)')
+ & ' STRING_FRAG_4FLV: no space left in S_PLIST:',I
+ CALL SIB_REJECT('STRING_FRAG_4FLV')
+ endif
+ IF (IBLEAD .GT. 0) THEN
+ JT = 3 - JT
+ GO TO 350
+ ENDIF
+c
+c 349 continue
+c choose side (1 or 2)
+ JT=INT(1.5D0+S_RNDM(0))
+c set 'other' side
+ 350 JR=3-JT
+c remember side particle was produced
+ LPOINT(I) = JT
+c increase rank counter
+ IRNK(JT) = ISIGN(ABS(IRNK(JT))+1,1-JT)
+c set particle rank
+ LRNK(I) = IRNK(JT)
+
+ nporig(I)= Ipflag*2 + KINT
+ niorig(I)= iiflag
+ IF(ILEAD(JT).eq.1) nporig(I)= -1 * nporig(I)
+ nforig(I) = 0
+
+ 555 CONTINUE
+c
+c.... CHARM config
+c
+ charmPARdef=PAR(24)
+ IF(IPAR(15).lt.9)THEN
+c no s->c
+ PAR(24) = 0.D0
+ IF (IFQRK.EQ.1) THEN
+c ifqrk = 1 (valence quark attatched)
+ IF(IPAR(15).ge.1) THEN
+c enforce s->c at string end
+ IF(ILEAD(JT).eq.1) PAR(24)=charmPARdef
+c produce charm in all strings
+ IF(IPAR(15).eq.8) PAR(24)=charmPARdef
+ ELSE
+c compatibility to broken version
+ PAR(24)=charmPARdef
+ ENDIF
+ ELSE
+c no val. quark at string end or diff
+ PAR(24)=charmPARdef
+ ENDIF
+ ENDIF
+c
+C.... Vector meson config
+c
+c increase vec.meson ratio for leading particle in str. diff.
+ IF(IFQRK.eq.-1)THEN
+ IF(IPAR(66).eq.1)THEN
+ IF(ILEAD(JT).EQ.1)THEN
+ IF(IBAR(IABS(kb)).eq.0.or.IPAR(70).eq.1) PAR(5) = PAR(113)
+ ENDIF
+ ELSEIF(IPAR(66).eq.2)THEN
+ IF(IBAR(IABS(kb)).eq.0.or.IPAR(70).eq.1) PAR(5) = PAR(113)
+
+ ELSEIF(IPAR(66).eq.3)THEN
+c increase vector meson rate for meson beam
+c on beam side (rank+) only!
+ IF(ILEAD(JT).EQ.1)THEN
+ IF(IBAR(IABS(kb)).eq.0.and.IRNK(JT).gt.0)
+ & PAR(5) = PAR(113)
+c always incr. vector rate for diff. strings independent of beam type
+ IF(IPAR(70).eq.1) PAR(5) = PAR(113)
+ ENDIF
+
+ ENDIF
+ endif
+
+c... switch off for proton beam
+ IF(IPAR(31).eq.1)then
+c print*,'ipar11,ipar11def,1-kb/13,kb',IPAR(11),ipar11_def,
+c + max((1-iabs(kb)/13),0),kb
+ IPAR(11) = IPAR(11)*max((1-iabs(kb)/13),0) ! meson beam only
+ endif
+c increase vec.meson ratio for leading quarks
+ IF(IABS(IFQRK).eq.1)THEN
+ IF(IPAR(11).le.-5.and.IPAR(11).ge.-7
+ & .and.ilead(jt).eq.1)
+ & PAR(5) = 9.D0
+
+c increase vec.meson ratio for diff.
+ IF(IFQRK.eq.-1.and.IPAR(11).le.-4.and.IPAR(11).ge.-7)
+ & PAR(5) = 9.D0
+
+c increase vec.meson ratio for leading particle in str. diff. (lvec16)
+ IF(IFQRK.eq.-1.and.IPAR(11).le.-11.and.ILEAD(JT).EQ.1)
+ & PAR(5) = 99.D0
+ ENDIF
+
+c... suppress leading charm for pion and kaon beams
+ IF(IPAR(15).eq.11)then
+ IF((1-IABS(KB)/13)*ILEAD(JT).gt.0) PAR(24)=0.D0
+ ENDIF
+
+C... suppress rank-1 baryon through popcorn
+ IF(IBLEAD .GT. 0.and.abs(ifl(jt)).gt.10
+ & .and.abs(ifl(3)).lt.10) PAR(8)=PAR(63)*PAR(8)
+
+C... leading strange/charm
+ IF(ILEAD(JT).eq.1.and.IPAR(39).gt.0) PAR(2) = PAR(65)
+
+c scale valence string end charm for assoc. prod.
+ IF(IPAR(41).eq.1)THEN
+ IF(ILEAD(JT).eq.1.and.IFQRK.eq.1) PAR(24) = PAR(71)*PAR(24)
+ ENDIF
+
+c suppress direct pi0 for meson projectiles
+c rate set by par( 137 )
+ ipar82_def = IPAR(82)
+c skip if baryon projectile or minijet (i.e no flavor attached)
+ if(ibar(iabs(kb)).ne.0.or.ifqrk.eq.0) IPAR(82) = 0
+
+c suppress direct omega for meson projectiles
+c rate set by par( 138 )
+ ipar83_def = IPAR(83)
+c skip if baryon projectile or central string
+ if(ibar(iabs(kb)).ne.0.or.(ifqrk.gt.0.and.IPAR(83).eq.2))
+ & IPAR(83) = 0
+
+c change rho0 / omega ratio
+ PAR143_def = PAR(143)
+ IF(IPAR(81).eq.1)THEN
+c change if beam is meson
+ if(ibar(iabs(kb)).eq.0) PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.2)THEN
+c change if beam is meson, on meson side only
+ if(ibar(iabs(kb)).eq.0.and.IRNK(JT).gt.0) PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.3)THEN
+c change if beam is meson, on meson side only, for leading only
+ if(ibar(iabs(kb)).eq.0.and.ISIGN(ILEAD(JT),IRNK(JT)).eq.1)
+ & PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.4)THEN
+c change if beam is meson, on meson side only, for diff. strings only
+ if(ibar(iabs(kb)).eq.0.and.IFQRK.eq.-1)
+ & PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.5)THEN
+c change if beam is meson, for leading on meson side only and
+c for diff. strings only
+ if(ibar(iabs(kb)).eq.0.and.IFQRK.eq.-1.and.
+ & ISIGN(ILEAD(JT),IRNK(JT)).eq.1) PAR(143) = PAR(144)
+ ENDIF
+
+C...particle ID and pt.
+
+ CALL SIB_I4FLAV (IFL(JT), 0, IRNK(JT), IFL(3), LLIST(I))
+
+c reset strange fraction
+ PAR(2) = PAR2_def
+c reset vec.meson production
+ PAR(5) = PAR5_def
+c reset charm fraction
+ PAR(24) = PAR24_def
+c reset popcorn
+ PAR(8) = par8_def
+
+c reset pi0 suppr.
+ IPAR(82) = ipar82_def
+
+c reset omega suppr.
+ IPAR(83) = ipar83_def
+
+c reset rho0 / omega ratio
+ PAR(143) = PAR143_def
+
+c reject iso 0 spin 1 for meson projectiles
+ IF(IBAR(IABS(KB)).eq.0)THEN
+c reject leading spin1,isospin singlett
+ IF(ILEAD(JT).EQ.1.and.LLIST(I).eq.32.and.
+ + PAR(136).gt.S_RNDM(I)) LLIST(I) = 27
+ endif
+
+c replace leading or all pi0 with rho0
+ IF(IFQRK.eq.-1) THEN
+ IF(IPAR(67).eq.1)THEN
+ IF(ILEAD(JT).EQ.1) THEN
+c replace leading pi0 with rho0
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+ ELSEIF(IPAR(67).eq.2)THEN
+c replace all pi0 with rho0 for all beams
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+ ELSEIF(IPAR(67).eq.3)THEN
+c replace all pi0 with rho0 for meson beam only
+ IF(IBAR(IABS(KB)).eq.0)THEN
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+ ELSEIF(IPAR(67).eq.4)THEN
+c replace all pi0 with rho0 for meson beam only
+c replace some beam mesons with their vector partner
+ IF(IBAR(IABS(KB)).eq.0)THEN
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+c reject leading spin1,isospin singlett
+ IF(ILEAD(JT).EQ.1.and.LLIST(I).eq.32.and.
+ + PAR(136).gt.S_RNDM(I)) LLIST(I) = 27
+ IF(S_RNDM(0).lt.PAR(120).and.LLIST(I).eq.KB)
+ & LLIST(I) = LRES(LLIST(I))
+ ENDIF
+ ENDIF
+ ENDIF
+
+c replace leading pi0 by rho0's
+ IF(IABS(IFQRK).eq.1)THEN
+ IF(ABS(IPAR(11)).ge.2.and.IPAR(11).ge.-3)THEN
+ IF(ilead(jt).EQ.1) then
+ IF(ABS(LLIST(I)).EQ.6) THEN
+ LLIST(I) = 27*isign(1,LLIST(I))
+ endif
+ endif
+
+c replace leading pi0 in string diff by rho0's (lvec15)
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-10)THEN
+ IF(ILEAD(JT).EQ.1) THEN
+ IF(ABS(LLIST(I)).EQ.6) THEN
+ LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+ ENDIF
+c replace leading pi0 in string diff by rho0's
+c in addition to increased leading vec.meson ratio (lvec20)
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-15)THEN
+ IF(ILEAD(JT).EQ.1) THEN
+ IF(ABS(LLIST(I)).EQ.6) THEN
+ LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+ ENDIF
+c replace leading omega in string diff by rho0's
+c in addition to increased leading vec.meson ratio (lvec21)
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-16)THEN
+ IF(ILEAD(JT).EQ.1) THEN
+ IF(ABS(LLIST(I)).EQ.32)
+ & LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+c replace leading omega in string diff by rho0's
+c suppress pi0 in diff. strings
+c in addition to increased leading vec.meson ratio (lvec22)
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-17)THEN
+ IF(ILEAD(JT).EQ.1) THEN
+c print*,'replacing leading omega with rho0'
+ IF(ABS(LLIST(I)).EQ.32)
+ & LLIST(I) = 27*isign(1,LLIST(I))
+ ENDIF
+ IF(LLIST(I).EQ.6) then
+c print*,'pi0 found! start again.. '
+ GOTO 555
+ endif
+
+c replace all for diff.
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).lt.0.and.
+ & IPAR(11).ge.-3) then
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+
+c increased vec.meson ratio and replace pi0 with rho0 in str.diff
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-7) then
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+
+c replace leading pi's by vec.mesons, iso-spin conserving
+ ELSEIF(IPAR(11).eq.-8.and.IPAR(11).lt.0)THEN
+ PAR(5) = 9.D0
+ IF(ilead(jt).EQ.1.and.
+ $ INT((PAR(5)+1.D0)*S_RNDM(0)).gt.1) then
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+ IF(ABS(LLIST(I)).EQ.7) LLIST(I) = 25*isign(1,LLIST(I))
+c IF(ABS(LLIST(I)).EQ.8) LLIST(I) = 26*isign(1,LLIST(I))
+ endif
+
+c replace almost all for diff.
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-8.and.IPAR(11).lt.0) then
+ PAR(5) = 9.D0
+ if( INT((PAR(5)+1.D0)*S_RNDM(0)).gt.1 ) then
+ IF(ABS(LLIST(I)).EQ.6) LLIST(I) = 27*isign(1,LLIST(I))
+ IF(ABS(LLIST(I)).EQ.7) LLIST(I) = 25*isign(1,LLIST(I))
+ endif
+
+c replace leading pi0's by vec.mesons
+ ELSEIF(IPAR(11).eq.-9.and.IPAR(11).lt.0)THEN
+ PCHF = 0.1D0
+ IF(ilead(jt).EQ.1.and.ABS(LLIST(I)).EQ.6)
+ & LLIST(I) = 27*isign(1,LLIST(I))
+ if(ilead(jt).EQ.1.and.ABS(LLIST(I)).EQ.7)then
+ if(S_RNDM(0).lt.PCHF) LLIST(I) = 25*isign(1,LLIST(I))
+ endif
+
+c replace for string diff.
+ ELSEIF(IFQRK.eq.-1.and.IPAR(11).eq.-9) then
+ IF(ABS(LLIST(I)).EQ.6)
+ & LLIST(I) = 27*isign(1,LLIST(I))
+ if(ABS(LLIST(I)).EQ.7)then
+ if(S_RNDM(0).lt.PCHF)
+ & LLIST(I) = 25*isign(1,LLIST(I))
+ endif
+ ELSE
+ CONTINUE
+ ENDIF
+ ENDIF
+
+c reset vec.meson ratio
+ PAR(5) = 0.3D0
+ IF(IABS(IFQRK).eq.1) ILEAD(JT) = 0
+
+ PMQ(3) = QMASS(IFL(3))
+ P(I,5) = AM(IABS(LLIST(I)))
+ CALL PTDIS_4FLV (IFL(3), PX(3),PY(3))
+
+C...fill transverse momentum
+ P(I,1) = PX(JT) + PX(3)
+ P(I,2) = PY(JT) + PY(3)
+ XMT2 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+
+C...test end of fragmentation
+
+ WREM2 = PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2
+c IF (WREM2 .LT. 0.1) GOTO 200
+ IF (WREM2 .LT. 0.1D0) GOTO 200
+c WMIN = PMQ(1)+PMQ(2)+2.*PMQ(3)+ 1.1 + (2.*S_RNDM(0)-1.)*0.2
+ WMIN=PMQ(1)+PMQ(2)+2.D0*PMQ(3)+PAR(59)+(2.D0*S_RNDM(0)-1.D0)*0.2D0
+ IF (WREM2 .LT. WMIN**2) Then
+ if (IABS(ifl(3)).ne.3.and.IABS(IFL(3)).ne.4) GOTO 400
+ goto 200
+ endif
+
+C...Choose z
+ IF(IABS(IFQRK).eq.1) THEN
+c valence strings: ( str.diff and non diff. )
+ IF(IPAR(11).EQ.1) THEN
+c use hard distribution for leading quarks ( no exchange )
+ IF(ILEAD(JT).eq.1) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSE
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10
+ & .and.iabs(ifl(3)).lt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ IBLEAD = IBLEAD - 1
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+ ENDIF
+c use hard frag. for leading particles
+ ELSEIF(IPAR(11).ge.3.or.IPAR(11).eq.-3.or.IPAR(11).eq.-6
+ & .or.IPAR(11).eq.-7) THEN
+ IF(ILEAD(jt).eq.1) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSE
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10
+ & .and.iabs(ifl(3)).lt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ IBLEAD = IBLEAD - 1
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+ ENDIF
+ ELSEIF(IPAR(11).EQ.-11) THEN
+c very hard leading frag. for diff and non. diff val. strings (lvec16)
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSEIF(ILEAD(jt).eq.1)THEN
+ Z = 1.D0 - ZDISN(1)
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+
+ ELSEIF(IPAR(11).EQ.-12.OR.IPAR(11).LE.-15.or.IPAR(68).eq.1)THEN
+c very hard leading frag. for diff. val. strings only (lvec17)
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSEIF(ILEAD(jt).eq.1.and.IFQRK.eq.-1)THEN
+ Z = 1.D0 - ZDISN(1)
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+
+ ELSEIF(IPAR(11).EQ.-13.AND.IFQRK.eq.-1) THEN
+c hard leading frag. for diff. val. strings only (lvec18)
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSEIF(ILEAD(jt).eq.1)THEN
+ Z = S_RNDM(JT)
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+ ELSEIF(IPAR(11).EQ.-14.AND.IFQRK.eq.-1) THEN
+c hard leading frag. for diff. AND ndiff. val. strings (lvec19)
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10) THEN
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ELSEIF(ILEAD(jt).eq.1)THEN
+ Z = S_RNDM(JT)
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+
+ ELSE
+
+c hard leading baryons only ( standard )
+ IF(IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10
+ & .and.abs(ifl(3)).lt.10) THEN
+c print*,'calling zblead: i,id,jt,ncall', i,llist(i),jt,ncall
+ IF(IPAR(20).eq.3)THEN
+c use lund function with different parameters for leading baryon
+ fa_def = FAin
+ fb_def = FB0in
+ FAin = PAR(57)
+ FB0in = PAR(58)
+ z = zdis_4flv(IFL(3),ifl(jt),xmt2)
+c set parameters to initial values again
+ FAin = fa_def
+ FB0in = fb_def
+ ELSE
+ Z = ZBLEAD (IABS(LLIST(I)))
+ ENDIF
+ IBLEAD = IBLEAD - 1
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+ ENDIF
+ ELSE
+c non valence string
+ IF (IBLEAD .GT. 0.and.iabs(ifl(jt)).gt.10
+ & .and.iabs(ifl(3)).lt.10) THEN
+C Special frag. for leading Baryon only
+c print*,'calling zblead: i,id,jt,ncall', i,llist(i),jt,ncall
+ Z = ZBLEAD (IABS(LLIST(I)))
+ IBLEAD = IBLEAD - 1
+ ELSE
+ Z = ZDIS_4FLV (IFL(3),ifl(jt),XMT2)
+ ENDIF
+ ENDIF
+ IF(IPAR(20).eq.2)IBLEAD = 2
+ IF(IFQRK.eq.1) ILEAD(JT) = 0
+
+ ZLIST(I) = Z
+ WW(JT,2) = Z*WW(JT,1)
+ WW(JR,2) = XMT2/(WW(JT,2)*E0**2)
+
+ P(I,3) = WW(1,2)*0.5D0*E0 - WW(2,2)*0.5D0*E0
+ P(I,4) = WW(1,2)*0.5D0*E0 + WW(2,2)*0.5D0*E0
+
+ DO J=1,4
+ PTOT (J) = PTOT(J) - P(I,J)
+ ENDDO
+ DO K=1,2
+ WW(K,1) = WW(K,1) - WW(K,2)
+ ENDDO
+
+C...Reset pT and flavor at ends of the string
+ PX(JT) = -PX(3)
+ PY(JT) = -PY(3)
+ IFL(JT) =-IFL(3)
+ PMQ(JT) = PMQ(3)
+
+ GOTO 300
+
+C...Final two hadrons
+ 400 IAFL1 = IABS(mod(IFL(JR),100))
+ IAFL2 = IABS(mod(IFL(3),100))
+ IF(NDEBUG.gt.5)
+ & write(lun,*)'STRING_FRAG: final flavors:', IFL(JR), -IFL(3)
+
+C.. check if flavor combination is allowed..
+
+c reject anti-baryon next to leading baryon
+c remaining anti-quark from leading baryon is marked by id+100
+ IF((IABS(IFL(JR)).gt.100.and.IAFL2.gt.10).or.
+ & (IABS(IFL(3)).gt.100.and.IAFL1.gt.10)) GOTO 200
+
+ IF(IPAR(40).eq.0)THEN
+c reject two diquarks, two anti-diquarks AND diquark anti-diquark pairs
+ IF (IAFL1*IAFL2 .GT. 100) GOTO 200
+ ELSE
+c ONLY reject two diquarks or two anti-diquarks (unphysical)
+c AND KEEP diquark anti-diquark pairs
+ IF (mod(IFL(JR),100)*mod(IFL(3),100).GT.100) GOTO 200
+ ENDIF
+
+ IF ((IAFL1/10.eq.4.or.mod(IAFL1,10).eq.4)
+ + .and.(IAFL2/10.eq.4.or.mod(IAFL2,10).eq.4))
+ + GOTO 200 ! reject two charm quarks
+
+C.... Vector meson config
+c increase vec.meson ration for diff.
+ IF(IFQRK.eq.-1.and.IPAR(11).le.-4.and.IPAR(11).gt.-8) PAR(5) =9.D0
+c increase vec.meson ration for leading quarks in valence interactions
+ IF(IABS(IFQRK).eq.1.and.IPAR(11).le.-5.and.ilead(jr).eq.1
+ & .and.IPAR(11).gt.-8) PAR(5) = 9.D0
+
+c suppress direct pi0 for meson projectiles
+c rate set by par( 137 )
+ 666 ipar82_def = IPAR(82)
+c skip if baryon projectile
+ if(ibar(iabs(kb)).ne.0.or.ifqrk.eq.0) IPAR(82) = 0
+
+c suppress direct omega for meson projectiles
+c rate set by par( 138 )
+ ipar83_def = IPAR(83)
+c skip if baryon projectile or central string
+ if(ibar(iabs(kb)).ne.0.or.(ifqrk.gt.0.and.IPAR(83).eq.2))
+ & IPAR(83) = 0
+
+c set current rank
+ IRNK(JR)=ISIGN(IABS(IRNK(JR))+1,1-JR)
+
+c change rho0 / omega ratio
+ IF(IPAR(81).eq.1)THEN
+c change if beam is meson
+ if(ibar(iabs(kb)).eq.0) PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.2)THEN
+c change if beam is meson, on meson side only
+ if(ibar(iabs(kb)).eq.0.and.IRNK(JR).gt.0) PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.3)THEN
+c change if beam is meson, on meson side only, for leading only
+ if(ibar(iabs(kb)).eq.0.and.ISIGN(ILEAD(JR),IRNK(JR)).eq.1)
+ & PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.4)THEN
+c change if beam is meson, on meson side only, for diff. strings only
+ if(ibar(iabs(kb)).eq.0.and.IFQRK.eq.-1)
+ & PAR(143) = PAR(144)
+ ELSEIF(IPAR(81).eq.5)THEN
+c change if beam is meson, for leading on meson side only and
+c for diff. strings only
+ if(ibar(iabs(kb)).eq.0.and.IFQRK.eq.-1.and.
+ & ISIGN(ILEAD(JR),IRNK(JR)).eq.1) PAR(143) = PAR(144)
+ ENDIF
+
+c increase vec.meson ratio for leading particle in str. diff.
+ IF(IPAR(66).eq.1)THEN
+ IF(ILEAD(JT).EQ.1.and.IFQRK.eq.-1)THEN
+ IF(IBAR(IABS(kb)).eq.0.or.IPAR(70).eq.1) PAR(5) = PAR(113)
+ ENDIF
+
+ ELSEIF(IPAR(66).eq.2)THEN
+ IF(IFQRK.eq.-1)THEN
+ IF(IBAR(IABS(kb)).eq.0.or.IPAR(70).eq.1) PAR(5) = PAR(113)
+ ENDIF
+
+ ELSEIF(IPAR(66).eq.3)THEN
+c increase vector meson rate for meson beam
+c on beam side (rank+) only!
+ IF(IFQRK.eq.-1)THEN
+ IF(ILEAD(JR).EQ.1)THEN
+ IF(IBAR(IABS(kb)).eq.0.and.IRNK(JR).gt.0)
+ & PAR(5) = PAR(113)
+c always incr. vector rate for diff. strings independent of beam type
+ IF(IPAR(70).eq.1) PAR(5) = PAR(113)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL SIB_I4FLAV (IFL(JR), -IFL(3), IRNK(JR), IFLA, LLIST(I+1))
+
+ IPAR(82) = ipar82_def
+ IPAR(83) = ipar83_def
+ PAR(143) = PAR143_def
+
+ nporig(I+1)= Ipflag*2 + KINT
+ niorig(I+1)= iiflag
+ IF(ILEAD(1).eq.1.or.ILEAD(2).eq.1) nporig(I+1)= -1 * nporig(I+1)
+
+c replace leading or all pi0 with rho0
+ IF(IFQRK.eq.-1) THEN
+ IF(IPAR(67).eq.1)THEN
+ IF(ILEAD(JR).EQ.1) THEN
+ IF(IABS(LLIST(I+1)).EQ.6)
+ & LLIST(I+1) = 27*isign(1,LLIST(I+1))
+ ENDIF
+ ELSEIF(IPAR(67).eq.2)THEN
+ IF(IABS(LLIST(I+1)).EQ.6) LLIST(I+1) =27*isign(1,LLIST(I+1))
+ ELSEIF(IPAR(67).eq.3)THEN
+ IF(IBAR(IABS(KB)).eq.0)THEN
+ IF(ABS(LLIST(I+1)).EQ.6)LLIST(I+1)=27*isign(1,LLIST(I+1))
+ ENDIF
+ ENDIF
+ ENDIF
+
+c replace all for diff.
+ IF(IABS(IFQRK).EQ.1)THEN
+ IF(IFQRK.eq.-1.and.IPAR(11).lt.0
+ & .and.IPAR(11).ge.-3) then
+ IF(ABS(LLIST(I+1)).EQ.6) LLIST(I+1) = 27*isign(1,LLIST(I+1))
+ endif
+c replace all for leading val.
+ IF(IPAR(11).le.-2.and.IPAR(11).ge.-3) then
+ if( ilead(jr).eq.1 ) then
+ IF(IABS(LLIST(I+1)).EQ.6)
+ & LLIST(I+1) = 27*isign(1,LLIST(I+1))
+ endif
+ endif
+
+c increased vec.meson ratio and replace pi0 with rho0
+ IF(IFQRK.eq.-1.and.IPAR(11).eq.-7) then
+ IF(IABS(LLIST(I+1)).EQ.6) LLIST(I+1) = 27*isign(1,LLIST(I+1))
+c IF(ABS(LLIST(I+1)).EQ.7) LLIST(I+1) = 25*isign(1,LLIST(I+1))
+ endif
+
+c replace all for diff. ( same as lvec6 but for rhop as well )
+c reset vec.meson ratio
+ IF(IFQRK.eq.-1.and.IPAR(11).eq.-8) then
+ PAR(5) = 9.D0
+ if( INT((PAR(5)+1.D0)*S_RNDM(0)).gt.1 ) then
+ IF(IABS(LLIST(I+1)).EQ.6)
+ & LLIST(I+1) = 27*isign(1,LLIST(I+1))
+ IF(IABS(LLIST(I+1)).EQ.7)
+ & LLIST(I+1) = 25*isign(1,LLIST(I+1))
+ endif
+ endif
+c replace leading pseudoscalar by vector
+ IF(IPAR(11).eq.-8.and.ilead(jr).eq.1) then
+ PAR(5) = 9.D0
+ if( INT((PAR(5)+1.D0)*S_RNDM(0)).gt.1 ) then
+ IF(IABS(LLIST(I+1)).EQ.6)
+ & LLIST(I+1) = 27*isign(1,LLIST(I+1))
+ IF(IABS(LLIST(I+1)).EQ.7)
+ & LLIST(I+1) = 25*isign(1,LLIST(I+1))
+ endif
+ endif
+
+c replace all pi0 for string diff.( same as lvec7 but for rhop as well )
+ IF(IFQRK.eq.-1.and.IPAR(11).eq.-9) then
+ if(IABS(LLIST(I+1)).EQ.6) LLIST(I+1) =27*isign(1,LLIST(I+1))
+ endif
+c replace leading pi0 by vector
+ IF(IPAR(11).eq.-9.and.ILEAD(JR).eq.1) then
+ if(IABS(LLIST(I+1)).EQ.6) LLIST(I+1) =27*isign(1,LLIST(I+1))
+ endif
+
+c replace leading omega in string diff by rho0's
+c suppress pi0 in diff. strings
+c in addition to increased leading vec.meson ratio (lvec22)
+ IF(IFQRK.eq.-1.and.IPAR(11).eq.-17)THEN
+ IF(IABS(LLIST(I+1)).EQ.6)THEN
+c print*,'found pi0, restarting..'
+ GOTO 666
+ ENDIF
+ ENDIF
+ ILEAD(JR)= 0
+ ENDIF
+
+c reject iso 0 spin 1 (omega) for meson projectiles
+ IF(IBAR(IABS(KB)).eq.0)THEN
+c reject leading spin1,isospin singlett
+ IF(ILEAD(JR).EQ.1.and.LLIST(I+1).eq.32.and.
+ + PAR(136).gt.S_RNDM(I)) LLIST(I+1) = 27
+ endif
+
+c reset vec.mes. ratio
+ PAR(5) = PAR5_def
+ PAR(24) = charmPARdef
+ IPAR(11) = IPAR11_def
+
+ P(I,1) = PX(JT)+PX(3)
+ P(I,2) = PY(JT)+PY(3)
+ LPOINT(I) = JT
+ I1 = I+1
+ nforig(I1) = 0
+ P(I1,5) = AM(IABS(LLIST(I1)))
+ P(I1,1) = PX(JR)-PX(3)
+ P(I1,2) = PY(JR)-PY(3)
+ LPOINT(I1) = JR
+ LRNK(I1) = IRNK(JR)
+ XM1 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+ XM2 = P(I1,5)**2+P(I1,1)**2+P(I1,2)**2
+ IF (DSQRT(XM1)+dSQRT(XM2) .GT. dSQRT(WREM2)) GOTO 200
+
+c...RE & EJA fix
+ PT2 = (P(I,1)+P(I1,1))**2+(P(I,2)+P(I1,2))**2
+ WREMPT = dsqrt(WREM2+PT2)
+ EA1 = (WREM2+XM1-XM2+PT2)/(2.D0*WREMPT)
+
+ PA2 = (EA1**2-XM1)
+ if (pa2.gt.0.D0) then
+ PA = dSQRT(PA2)
+ else
+ goto 200
+ endif
+ BA = PTOT(3)/PTOT(4)
+ GA = PTOT(4)/WREMPT
+ SGN = DBLE(3-2*JT)
+ P(I,3) = GA*(BA*EA1+SGN*PA)
+ P(I,4) = GA*(EA1+BA*SGN*PA)
+ P(I+1,3) = PTOT(3)-P(I,3)
+ P(I+1,4) = PTOT(4)-P(I,4)
+
+c mark as final hadrons
+ ZLIST(I) = 0.D0
+ ZLIST(I+1) = 0.D0
+
+ NA= NP+1
+ NP=I+1
+
+C...reorder particles along chain (in rank)
+ IF (LRANK) THEN
+ N1 = NA-1
+ N2 = 0
+ DO J=NA,NP
+ IF(P(J,4).lt.0) THEN
+ NP=NA-1
+ GOTO 200 ! negative energy bug 'fix'
+ ENDIF
+ IF(LPOINT(J) .EQ. 2) THEN
+ N2=N2+1
+ LLIST (NP+N2) = LLIST(J)
+ LRNK(NP+N2) = LRNK(J)
+ ZLIST (NP+N2) = ZLIST(J)
+ nporig(NP+N2) = nporig(J)
+ niorig(NP+N2) = niorig(J)
+ nforig(NP+N2) = 0
+ DO K=1,5
+ P(NP+N2,K)=P(J,K)
+ ENDDO
+ ELSE
+ N1= N1+1
+ IF (N1.LT.J) THEN
+ LLIST(N1) = LLIST(J)
+ LRNK(N1) = LRNK(J)
+ ZLIST(N1) = ZLIST(J)
+ nporig(N1) = nporig(J)
+ niorig(N1) = niorig(J)
+ nforig(N1) = nforig(J)
+ DO K=1,5
+ P(N1,K) = P(J,K)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDDO
+ JJ=N1
+ DO J=NP+N2,NP+1,-1
+ JJ= JJ+1
+ LLIST(JJ) = LLIST(J)
+ LRNK(JJ) = LRNK(J)
+ ZLIST(JJ) = ZLIST(J)
+ nporig(JJ) = nporig(J)
+ niorig(JJ) = niorig(J)
+ nforig(JJ) = nforig(J)
+ DO K=1,5
+ P(JJ,K) = P(J,K)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ if(Ndebug.gt.3)
+ & WRITE(LUN,*)' STRING_FRAG_4FLV: NP after fragmentation:',NP
+
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE GG_FRAG_4FLV (E0)
+
+C-----------------------------------------------------------------------
+C...This routine fragments a gluon-gluon system
+C. of mass E0 (GeV)
+C. the particles produced are in the jet-jet frame
+C. oriented along the z axis
+C...........................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ DOUBLE PRECISION ZLIST
+ COMMON /S_ZLIST/ ZLIST(8000)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DIMENSION WW(2,2),PTOT(4),PX(3),PY(3),IFL(3),PMQ(3)
+ SAVE
+
+ if(Ndebug.gt.3) then
+ WRITE(LUN,*)
+ & ' GG_FRAG_4FLV: called with (E0)',
+ & E0
+ WRITE(LUN,*)' GG_FRAG_4FLV: NP before fragmentation:',NP
+ endif
+
+C... 'leading' strange fraction
+ PAR2_def = PAR(2)
+ IF(IPAR(39).eq.2) PAR(2) = PAR(66)
+
+ PAR24_def = PAR(24)
+C leading charm fraction
+ IF(IPAR(87).eq.1) PAR(24) = PAR(150)
+ IF(IPAR(87).eq.2) PAR(24) = PAR(150)*PAR(24)
+
+ E0S = E0**2
+
+C...Generate the 'forward' leading particle.
+100 I = NP+1
+c dummy rank argument
+ IDM = 5
+c sample new flavor, i.e. split gluon into quark-antiquark, quark or antiquark
+ if( IPAR(87).eq.3 )THEN
+C flavor threshold model
+c u,d -> u,d,s -> u,d,s,c
+ CALL SIB_ICFLAV(E0S,0,I0,IFL1)
+ ELSE
+c default u,d,s model, same rates as in hadronization (string frag.)
+ I0 = INT(-1 + 2.D0*INT((2.D0-EPS8)*S_RNDM(I)))
+ CALL SIB_I4FLAV(I0,0,IDM,IFL1, LDUM)
+ ENDIF
+c form first hadron from new flavor
+ CALL SIB_I4FLAV(IFL1,0,IDM,IFL2, LLIST(I))
+ CALL PTDIS_4FLV(IFL1,PX1,PY1)
+ CALL PTDIS_4FLV(IFL2,PX2,PY2)
+ P(I,1) = PX1+PX2
+ P(I,2) = PY1+PY2
+ P(I,5) = AM(IABS(LLIST(I)))
+ XM1 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+ Z1 = ZDIS_4FLV (IFL1,1,0.25D0*XM1)
+ Z2 = ZDIS_4FLV (IFL2,1,0.25D0*XM1)
+ T1 = 4.D0*XM1/(E0S*(Z1+Z2))
+ P(I,4) = 0.25D0*E0*(Z1+Z2 + T1)
+ P(I,3) = 0.25D0*E0*(Z1+Z2 - T1)
+
+ nforig(I)= 0
+ nporig(I)= Ipflag*3 + KINT
+ niorig(I)= iiflag
+ ZLIST(I) = Z1 + Z2
+
+C...Generate the 'backward' leading particle.
+ I = I+1
+ IF( IPAR(87).eq.3 )THEN
+ CALL SIB_ICFLAV(E0S,-I0,IDM,IFL3)
+ ELSE
+ CALL SIB_I4FLAV(-I0,0,IDM,IFL3, LDUM)
+ ENDIF
+ CALL SIB_I4FLAV(IFL3,0,IDM,IFL4, LLIST(I))
+ CALL PTDIS_4FLV(IFL3,PX3,PY3)
+ CALL PTDIS_4FLV(IFL4,PX4,PY4)
+ P(I,1) = PX3+PX4
+ P(I,2) = PY3+PY4
+ P(I,5) = AM(IABS(LLIST(I)))
+ XM2 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+ Z3 = ZDIS_4FLV (IFL3,1,0.25D0*XM2)
+ Z4 = ZDIS_4FLV (IFL4,1,0.25D0*XM2)
+ T2 = 4.D0*XM2/(E0S*(Z3+Z4))
+ P(I,4) = 0.25D0*E0*( Z3+Z4 + T2)
+ P(I,3) = 0.25D0*E0*(-Z3-Z4 + T2)
+
+ nforig(I)= 0
+ nporig(I)= Ipflag*3 + KINT
+ niorig(I)= iiflag
+ ZLIST(I) = Z3 + Z4
+c PAR24def = PAR(24)
+c charm QCD fusion
+c IF(IPAR(17).eq.2) PAR(24) = 0.
+
+c reset strange fraction
+ PAR(2) = PAR2_def
+
+c reset charm fraction
+ PAR(24) = PAR24_def
+
+C...Fragment the two remaning strings
+ N0 = 0
+ DO KS=1,2
+
+ NTRY = 0
+200 NTRY = NTRY+1
+ I = NP+2+N0
+ IF (NTRY .GT. 30) GOTO 100
+
+ IF (KS .EQ. 1) THEN
+ WW(1,1) = 0.5D0 * (1.D0 - Z1 - 0.5D0*T2)
+ WW(2,1) = 0.5D0 * (1.D0 - Z3 - 0.5D0*T1)
+ PX(1) = -PX1
+ PY(1) = -PY1
+ PX(2) = -PX3
+ PY(2) = -PY3
+ IFL(1) = -IFL1
+ IFL(2) = -IFL3
+ ELSE
+ WW(1,1) = 0.5D0 * (1.D0 - Z2 - 0.5D0*T2)
+ WW(2,1) = 0.5D0 * (1.D0 - Z4 - 0.5D0*T1)
+ PX(1) = -PX2
+ PY(1) = -PY2
+ PX(2) = -PX4
+ PY(2) = -PY4
+ IFL(1) = -IFL2
+ IFL(2) = -IFL4
+ ENDIF
+ PX(3) = 0.D0
+ PY(3) = 0.D0
+ PTOT (1) = PX(1)+PX(2)
+ PTOT (2) = PY(1)+PY(2)
+ PTOT (3) = 0.5D0*E0*(WW(1,1)-WW(2,1))
+ PTOT (4) = 0.5D0*E0*(WW(1,1)+WW(2,1))
+
+ PMQ(1) = QMASS(IFL(1))
+ PMQ(2) = QMASS(IFL(2))
+
+C...produce new particle: side, pT
+300 I=I+1
+ if(i.gt.8000) then
+ write(LUN,'(1x,a,i8)')
+ & ' GG_FRAG: no space left in S_PLIST:',I
+ CALL SIB_REJECT ('GG_FRAG ')
+ endif
+ nforig(I)= 0
+ nporig(I)= Ipflag*2 + KINT
+ niorig(I)= iiflag
+
+ JT=INT(1.5D0+S_RNDM(0))
+ JR=3-JT
+c CALL PTDIS (IFL(JT), PX(3),PY(3))
+
+C...particle ID
+ CALL SIB_I4FLAV (IFL(JT), 0, IDM, IFL(3), LLIST(I))
+ PMQ(3) = QMASS(IFL(3))
+ P(I,5) = AM(IABS(LLIST(I)))
+
+ CALL PTDIS_4FLV (IFL(3), PX(3),PY(3))
+
+C...test end of fragmentation
+ WREM2 = PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2
+ IF (WREM2 .LT. 0.1D0) GOTO 200
+ WMIN = PMQ(1)+PMQ(2)+2.D0*PMQ(3)+1.1D0+(2.D0*S_RNDM(0)-1.D0)*0.2D0
+ IF (WREM2 .LT. WMIN**2)THEN
+ GOTO 400
+ ENDIF
+
+C...fill transverse momentum
+ P(I,1) = PX(JT) + PX(3)
+ P(I,2) = PY(JT) + PY(3)
+
+C...Choose z
+ XMT2 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+ Z = ZDIS_4FLV (ifl(3),IFL(JT), XMT2)
+
+ ZLIST(I) = Z
+ WW(JT,2) = Z*WW(JT,1)
+ WW(JR,2) = XMT2/(WW(JT,2)*E0S)
+
+ P(I,3) = WW(1,2)*0.5D0*E0 - WW(2,2)*0.5D0*E0
+ P(I,4) = WW(1,2)*0.5D0*E0 + WW(2,2)*0.5D0*E0
+
+ DO J=1,4
+ PTOT (J) = PTOT(J) - P(I,J)
+ ENDDO
+ DO K=1,2
+ WW(K,1) = WW(K,1) - WW(K,2)
+ ENDDO
+
+C...Reset pT and flavor at ends of the string
+ PX(JT) = -PX(3)
+ PY(JT) = -PY(3)
+ IFL(JT) =-IFL(3)
+ PMQ(JT) = PMQ(3)
+ GOTO 300
+
+C...Final two hadrons
+ 400 IAFL1 = mod(IABS(IFL(JR)),100)
+ IAFL2 = mod(IABS(IFL(3)),100)
+ IF (IAFL1*IAFL2 .GT. 100) GOTO 200 ! reject two diquarks
+ IF ((IAFL1/10.eq.4.or.mod(IAFL1,10).eq.4)
+ + .and.(IAFL2/10.eq.4.or.mod(IAFL2,10).eq.4))
+ + GOTO 200 ! reject two charm quarks
+
+ CALL SIB_I4FLAV (IFL(JR), -IFL(3), IDM, IFLA, LLIST(I+1))
+ P(I+1,5) = AM(IABS(LLIST(I+1)))
+ P(I,1) = PX(JT)+PX(3)
+ P(I,2) = PY(JT)+PY(3)
+ nporig(I)= Ipflag*2 + KINT
+ niorig(I)= iiflag
+ I1 = I+1
+ nporig(I1)= Ipflag*2 + KINT
+ niorig(I1)= iiflag
+ P(I1,1) = PX(JR)-PX(3)
+ P(I1,2) = PY(JR)-PY(3)
+ XM1 = P(I,5)**2+P(I,1)**2+P(I,2)**2
+ XM2 = P(I1,5)**2+P(I1,1)**2+P(I1,2)**2
+ IF (dSQRT(XM1)+dSQRT(XM2) .GT. dSQRT(WREM2)) GOTO 200
+ if (ptot(4).le.0.D0) goto 200
+ PT2 = (P(I,1)+P(I1,1))**2+(P(I,2)+P(I1,2))**2
+ WREMPT = dsqrt(WREM2+PT2)
+ EA1 = (WREM2+XM1-XM2+PT2)/(2.D0*WREMPT)
+ PA2 = (EA1**2-XM1)
+ if (PA2.ge.0.D0) then
+ PA = dSQRT(PA2)
+ else
+ goto 200
+ endif
+ BA = PTOT(3)/PTOT(4)
+ GA = PTOT(4)/WREMPT
+ SGN = DBLE(3-2*JT)
+ P(I,3) = GA*(BA*EA1+SGN*PA)
+ P(I,4) = GA*(EA1+BA*SGN*PA)
+ P(I+1,3) = PTOT(3)-P(I,3)
+ P(I+1,4) = PTOT(4)-P(I,4)
+ ZLIST(I) = 0.D0
+ ZLIST(I+1) = 0.D0
+ N0 = I-NP-1
+ ENDDO ! loop on two `remaining strings'
+
+ NP = I+1
+c PAR(24) = PAR24def
+ IF(Ndebug.gt.3) then
+ WRITE(LUN,*)' GG_FRAG_4FLV: NP after fragmentation:',NP
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE DIFDEC (L0, Irec, IBAD, P0)
+
+C-----------------------------------------------------------------------
+C..."decay" of an excited state with the quantum numbers
+C. of particle L0 and the 5-momentum P0
+C. - low energy: phase space decay (fire ball model)
+C. - intermediate energy: one-string decay (longitudinal phase space)
+C. - high energy: pomeron-hadron scattering (multi-string model)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ INTEGER L0, Irec, IBAD
+ DOUBLE PRECISION P0
+ DIMENSION P0(5)
+
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+ INTEGER LRNK
+ COMMON /SIB_RNK/ LRNK(8000)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c internal types
+ INTEGER LL,LCON,LRES,LRES1,NTRYS,NRJECT,LA,N1,IREJ,I,J,IFLA,
+ & IFL1,IFL2,IFBAD,NPI,IRES,LA1,JQQ,JQTOT,K,JQR,
+ & KB_0,IAT_0
+ DOUBLE PRECISION PD,BE,EMIN,EMIN2,PCHEX,PRES,DELTAE,
+ & SQS_0,S_0,PTmin_0,XMIN_0,ZMIN_0,
+ & PAR1_def,PAR24_def,PAR53_def,GA,BEP,S_RNDM,AV,GASDEV,PCXG,
+ & XI1,XI2,XSMR !,FERMI
+ DIMENSION LL(10), PD(10,5), BE(3), LCON(6:99),LRES1(6:99)
+ DIMENSION LRES(6:99)
+ SAVE
+ EXTERNAL GASDEV
+ DATA (LRES(k),k=6,22) /27,25,26,28,29,0,0,51,52,6*0,30,31/
+ DATA (LRES(k),k=23,33) /23,24,25,26,27,28,29,30,31,27,27/
+ DATA (LRES(k),k=34,49) /34,35,36,37,38,39,40,41,42,43,34,35,36,
+ & 37,38,49/
+ DATA (LRES(k),k=50,83) /0,51,52,53,54,4*0,78,79,10*0,80,81,73,
+ & 74,75,76,77,78,79,80,81,0,83/
+ DATA (LRES(k),k=84,99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+
+ DATA EMIN /0.7D0/
+ DATA EMIN2 /10.D0/
+ DATA LCON /7,6,6,11,11,9,9,14,13,19*0,35,34,35,38,37,39,
+ & 19*0,71,72,10*0,59,60,73,10*0,85,86,85,88,87,89,10*0/
+ DATA LRES1 /27,25,26,11,11,9,9,14,13,19*0,35,34,35,38,37,39,
+ & 19*0,78,79,10*0,80,81,83,10*0,94,95,96,97,98,89,10*0/
+ DATA PCHEX /0.33D0/ ! probability of charge exchange
+ DATA PRES /0.7D0/ ! probability of forming a resonance
+ DATA NRJECT /0/
+
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,'(2X,A,1x,I2,1x,I2,/,5(2x,F10.3))')
+ & 'DIFDEC: (L0,Irec,P0):',L0,Irec,(P0(i),i=1,5)
+
+
+ NTRYS = 0
+
+ LA = IABS(L0)
+ DELTAE = P0(5) - AM(LA)
+ IF(IBAR(LA).ne.0.or.IPAR(65).eq.0)THEN
+c baryons
+ EMIN = PAR(30)
+ ELSE
+c mesons
+ EMIN = PAR(112)
+ ENDIF
+c IBAD = 0
+ PAR1_def= PAR(1)
+ if(Irec.gt.0) PAR(1)= PAR(16)
+c XSMR = 0.5D0
+c XI2=FERMI(DELTAE,EMIN2,XSMR)
+c XI1=FERMI(DELTAE,EMIN,XSMR)
+ XSMR=PAR(131)*EMIN
+ XI1=MAX((EMIN-DELTAE)/XSMR,0.D0)
+ XSMR=PAR(131)*EMIN2
+ XI2=MAX((EMIN2-DELTAE)/XSMR,0.D0)
+ if(Ndebug.gt.2)
+ & WRITE(LUN,'(1x,A29,2(2x,F5.2),2(2x,F8.3))')
+ & ' DIFDEC: EMIN1,EMIN2,XI1,XI2',
+ & EMIN,EMIN2,Xi1,Xi2
+
+C... pomeron-hadron scattering (pi0 is used instead of pomeron)
+ IF ((IPAR(10).gt.0).and.(Irec.gt.0).and.
+ & (DELTAE.gt.EMIN2.or.S_RNDM(LA).gt.XI2)) THEN
+ if(Ndebug.gt.2)
+ & WRITE(LUN,*)' DIFDEC: central (L0,DELTAE,NP,XI):',
+ & L0,DELTAE,NP,XI2
+ N1 = NP+1
+ if(irec.gt.0.and.IPAR(5).eq.1) par(1)= par(15)
+ 50 CONTINUE
+ IPFLAG= IPFLAG*100
+c create subevent
+ SQS_0 = SQS
+ S_0 = S
+ PTmin_0 = PTmin
+ XMIN_0 = XMIN
+ ZMIN_0 = ZMIN
+ KB_0 = KB
+ IAT_0 = IAT
+ CALL INI_EVENT(P0(5),L0,6,0)
+c create L0 - pi0 interaction, pi0(pid=6) target
+ CALL SIB_NDIFF(L0, 1, P0(5), 0, IREJ) ! ori
+c restore main event
+ SQS = SQS_0
+ S = S_0
+ PTmin = PTmin_0
+ XMIN = XMIN_0
+ ZMIN = ZMIN_0
+ KB = KB_0
+ IAT = IAT_0
+ IF(IREJ.NE.0) THEN
+ NP = N1-1
+ GOTO 50
+ ENDIF
+ PAR(1) = PAR1_def
+ DO J=1,3
+ BE(J)=P0(J)/P0(4)
+ ENDDO
+ GA=P0(4)/P0(5)
+ if(P0(3).lt.0.D0) then
+ do i=N1,NP
+ P(I,3) = -P(I,3)
+ enddo
+ endif
+ DO I=N1,NP
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO J=1,3
+ P(I,J)=P(I,J)+GA*(GA*BEP/(1.D0+GA)+P(I,4))*BE(J)
+ ENDDO
+ P(I,4)=GA*(P(I,4)+BEP)
+ ENDDO
+
+C..."string-like" decay
+ ELSE IF (DELTAE .GT. EMIN .or. S_RNDM(LA).gt.XI1) THEN
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,'(2X,A,3(2x,F8.3))')
+ & 'DIFDEC: string-like, (DELTAE,E0,central prob.):',
+ & DELTAE,P0(5),1.D0-XI2
+c set charge exchange probability, i.e. prob for p* -> n + pip
+ PAR53_def = PAR(53)
+ PAR(53) = PAR(130)
+ N1 = NP+1
+ CALL HSPLI(L0,IFL1,IFL2)
+ PAR(53) = PAR53_def
+ IF (P0(3) .GT. 0.D0.and.L0.gt.0) THEN
+ IFLA = IFL2
+ IFL2 = IFL1
+ IFL1 = IFLA
+ ENDIF
+c randomize flavor orientation in string
+ IF(IPAR(25).eq.1.and.S_RNDM(L0).gt.PAR(39))THEN
+ IFLA = IFL2
+ IFL2 = IFL1
+ IFL1 = IFLA
+ ENDIF
+ PAR24_def = PAR(24)
+ IF(IPAR(15).eq.2.and.IPAR(15).eq.3.and.IPAR(15).ne.7.and.
+ & IPAR(15).lt.12)THEN
+ PAR(24) = PAR(25)*dEXP(-PAR(26)/P0(5))
+ ELSEIF(IPAR(15).eq.7)THEN
+ PAR(24) = PAR(25)
+ ENDIF
+ 10 CONTINUE
+ IPFLAG = IPFLAG*10
+ CALL STRING_FRAG_4FLV
+ + (P0(5), IFL1, IFL2, 0.D0,0.D0,0.D0,0.D0,IFBAD,-1)
+ IF (IFBAD .EQ. 1)then
+ if(ndebug.gt.1)
+ & WRITE(lun,*)' SIB_DIFF: string-frag rejection! ',
+ & '(M,NCALL)',P0(5),NCALL
+ NTRYS = NTRYS + 1
+ NP = N1-1
+ IFBAD = 0
+ IF(NTRYS.gt.5)then ! resample diff. mass
+ NP = 0
+ IBAD = 1
+ PAR(24) = PAR24_def
+ RETURN
+ endif
+ GOTO 10
+ ENDIF
+ DO J=1,3
+ BE(J)=P0(J)/P0(4)
+ ENDDO
+ GA=P0(4)/P0(5)
+ DO I=N1,NP
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO J=1,3
+ P(I,J)=P(I,J)+GA*(GA*BEP/(1.D0+GA)+P(I,4))*BE(J)
+ ENDDO
+ P(I,4)=GA*(P(I,4)+BEP)
+ ENDDO
+ PAR(24) = PAR24_def
+
+C...Phase space decay of the excited state
+ ELSEIF(DELTAE.GT.AM(7)+0.02D0)THEN
+ if(Ndebug.gt.2)
+ & WRITE(LUN,*)' DIFDEC: fireball, (DELTAE,string prob.):',
+ & DELTAE,1.D0-XI1
+ IF(IPAR(14).GT.0.and.IPAR(14).NE.7)THEN
+ IF(IPAR(14).eq.5) PCHEX = 0.D0
+ NPI=0
+ IRES = 0
+ IF (S_RNDM(0).LT.PRES) THEN
+ IF (LA.LT.9) THEN
+c if kinematically possible produce rho0 in charge exchange
+ LL(1) = LRES(LA)
+ DELTAE = P0(5) - AM(LRES(LA))
+ IF (DELTAE.GT.AM(7)+0.02D0) GOTO 100
+ ENDIF
+ ENDIF
+c switch charge exchange on/off
+ IF( S_RNDM(1).LT.PCHEX)THEN
+ LL(1) = LCON(LA)*ISIGN(1,L0)
+ IF( (L0 .EQ. 6) .OR. (L0 .EQ. 11) )
+ . LL(1) = LL(1)+INT((2.D0-EPS8)*S_RNDM(2))
+ ELSE
+ LL(1) = L0
+ ENDIF
+
+ DELTAE = P0(5) - AM(LA)
+ 100 AV = 2.D0*dSQRT(DELTAE)
+ LA1 = IABS(LL(1))
+ NPI = INT(AV*(2.D0+0.5D0*GASDEV(LA)))
+ IF (IPAR(14).EQ.6)THEN
+ IF(NPI.LT.1.OR.NPI.GT.9.OR.AM(LA1)+NPI*AM(7)+0.02D0
+ . .GT.P0(5)) GOTO 100
+ ELSE
+ IF(NPI.LT.0.OR.NPI.GT.9.OR.AM(LA1)+NPI*AM(7)+0.02D0
+ . .GT.P0(5)) GOTO 100
+ ENDIF
+c create resonances inside fireball..
+ IF(IPAR(14).ge.2
+ + .and.DELTAE.GE.AM(LA1)+AM(27)+(NPI-1)*AM(7)+0.02D0)
+ + IRES = 1
+ IF(IPAR(14).ge.3.and.DELTAE.GE.AM(LA1)+NPI*AM(27)+0.02D0)
+ + IRES=3
+ JQQ = ICHP(LA)*ISIGN(1,L0)-
+ . ICHP(IABS(LL(1)))*ISIGN(1,LL(1))
+ 120 JQTOT = 0
+ DO K=2,NPI
+ LL(K) = 6+INT(S_RNDM(K)*(3.D0-EPS8))
+c suppress pi0 in fireball
+ IF(IPAR(14).ge.4)
+ + LL(K) = 7+INT(S_RNDM(0)*(2.D0-EPS8))
+c IF(IRES.EQ.1.and.S_RNDM(LA).LT.0.5D0)
+ IF(IRES.EQ.1) THEN
+ LL(K) = 27-INT(S_RNDM(1)*(3.D0-EPS8))
+ IRES = 2
+ ENDIF
+ IF(IRES.EQ.3)
+ + LL(K) = 27-INT(S_RNDM(2)*(3.D0-EPS8))
+ JQTOT = JQTOT + ICHP(LL(K))
+ ENDDO
+ JQR = JQQ-JQTOT
+ IF (JQR.LT.-1.OR.JQR.GT.1) GOTO 120
+ LL(NPI+1) = 6+JQR
+ IF (LL(NPI+1) .EQ. 5) LL(NPI+1)=8
+ CALL DECPAR (0,P0,NPI+1,LL, PD)
+ DO J=1,NPI+1
+ NP = NP+1
+ LLIST(NP) = LL(J)
+ nporig(NP)= Ipflag*2
+ lrnk(Np) = 0
+ niorig(NP)= iiflag
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ ENDDO
+
+ ELSEIF (IPAR(14).EQ.7.AND.LA.LT.9) THEN
+c all diff states go to resonances for pi beam ..
+ NPI=0
+ IRES = 0
+ LL(1) = LRES1(LA)
+ DELTAE = P0(5) - AM(LL(1))
+cdh IF( DELTAE.LT.AM(7)+0.02D0) GOTO 222
+ IF( DELTAE.LT.AM(7)+0.02D0) THEN
+ IF(IPAR(14).EQ.7) DELTAE = P0(5) - AM(LA)
+ AV = 2.D0*DSQRT(DELTAE)
+ 201 NPI = INT(AV*(1.D0+0.5D0*GASDEV(LA)))
+c print *,'npi:',npi,'av',av,'p05',p0(5),am(la),deltae
+ IF(NPI.LE.0.OR.NPI.GT.9.OR.AM(LA)+NPI*AM(7)+0.02D0
+ . .GT.P0(5)) GOTO 201
+ IF (S_RNDM(0).LT.PCHEX) THEN
+ LL(NPI+1) = LCON(LA)*ISIGN(1,L0)
+ IF( (L0 .EQ. 6) .OR. (L0 .EQ. 11) )
+ . LL(NPI+1) = LL(NPI+1)+INT((2.D0-EPS8)*S_RNDM(1))
+ ELSE
+ LL(NPI+1) = L0
+ ENDIF
+ JQQ = ICHP(LA)*ISIGN(1,L0)-
+ . ICHP(IABS(LL(NPI+1)))*ISIGN(1,LL(NPI+1))
+ 221 JQTOT = 0
+ DO K=1,NPI-1
+ LL(K) = 6+INT(S_RNDM(K)*(3.D0-EPS8))
+ JQTOT = JQTOT + ICHP(LL(K))
+ ENDDO
+ JQR = JQQ-JQTOT
+ IF (JQR.LT.-1.OR.JQR.GT.1) GOTO 221
+ LL(NPI) = 6+JQR
+ IF (LL(NPI) .EQ. 5) LL(NPI)=8
+ CALL DECPAR (0,P0,NPI+1,LL, PD)
+ DO J=1,NPI+1
+ NP = NP+1
+ LLIST(NP) = LL(J)
+ NPORIG(NP) = IPFLAG*2
+ lrnk(Np) = 0
+ niorig(NP)= iiflag
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ ENDDO
+
+ ELSE
+ IF( S_RNDM(0).LT.PAR(31))THEN
+ LL(1) = LRES1(LCON(LA))
+ IF( (L0 .EQ. 6) .OR. (L0 .EQ. 11) )
+ . LL(1) = LRES1(IABS(L0)+INT((2.D0-EPS8)*S_RNDM(1)))
+ ENDIF
+ 300 AV = 2.D0*dSQRT(DELTAE)
+ LA1 = IABS(LL(1))
+ NPI = INT(AV*(2.D0+0.5D0*GASDEV(LA)))
+ IF(ABS(PAR(32)).gt.0.D0)
+ & NPI = INT(AV*(PAR(32)+0.5D0*GASDEV(LA)))
+ IF(NPI.LT.0.OR.NPI.GT.9.OR.AM(LA1)+NPI*AM(7)+0.02D0
+ . .GT.P0(5)) GOTO 300
+c create resonances inside fireball..
+c IRES=3
+ JQQ = ICHP(LA)*ISIGN(1,L0)-
+ . ICHP(IABS(LL(1)))*ISIGN(1,LL(1))
+ 320 JQTOT = 0
+ DO K=2,NPI
+ LL(K) = 6+INT(S_RNDM(K)*(3.D0-EPS8))
+c suppress pi0 in fireball
+c IF(IPAR(14).ge.4)
+c + LL(K) = 7+INT(S_RNDM(0)*1.99999D0)
+c IF(IRES.EQ.1.and.S_RNDM(LA).LT.0.5D0)
+c LL(K) = 27-INT(S_RNDM(0)*2.99999D0)
+ JQTOT = JQTOT + ICHP(LL(K))
+ ENDDO
+ JQR = JQQ-JQTOT
+ IF (JQR.LT.-1.OR.JQR.GT.1) GOTO 320
+ LL(NPI+1) = 6+JQR
+ IF (LL(NPI+1) .EQ. 5) LL(NPI+1)=8
+ CALL DECPAR (0,P0,NPI+1,LL, PD)
+ DO J=1,NPI+1
+ NP = NP+1
+ LLIST(NP) = LL(J)
+ nporig(NP)= Ipflag*2
+ lrnk(Np) = 0
+ niorig(NP)= iiflag
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ELSEIF (IPAR(14).LE.-1) THEN
+C... generalized fireball model
+ IF(Ndebug.gt.2)
+ & WRITE(LUN,*)' DIFDEC: using generalized fireball!'
+c set charge exchange probability,
+c i.e. prob for p* -> n + pip
+ PCXG = PAR(61)
+ CALL FIREBALL_4FLV(L0,P0,PCXG,IFBAD)
+ IF(IFBAD.eq.1)THEN
+ IF(ndebug.gt.0)THEN
+ IF(NRJECT.le.10)THEN
+ WRITE(LUN,*)
+ & ' DIFDEC: warning: fireball rejection! ',
+ & 'diff. mass to low to dissociate beam!'
+ WRITE(LUN,*)
+ & ' DIFDEC: m_Beam, DELTAE ,AM(7)+0.02, NCALL: ',
+ & AM(LA),DELTAE,'>',AM(7)+0.02D0,NCALL
+ ENDIF
+ IF(NRJECT.eq.10)
+ & write(lun,*)' this was the last warning.. good luck!'
+ ENDIF
+ NRJECT = NRJECT + 1
+ NP = 0
+ IBAD = 1
+ RETURN
+ ENDIF
+
+ ELSE
+cdh 222 IF(IPAR(14).EQ.7) DELTAE = P0(5) - AM(LA)
+ IF(IPAR(14).EQ.7) DELTAE = P0(5) - AM(LA)
+ AV = 2.D0*dSQRT(DELTAE)
+ 200 NPI = INT(AV*(1.D0+0.5D0*GASDEV(0)))
+c print *,'npi:',npi,'av',av,'p05',p0(5),am(la),deltae
+ IF(NPI.LE.0.OR.NPI.GT.9.OR.AM(LA)+NPI*AM(7)+0.02D0
+ . .GT.P0(5)) GOTO 200
+ IF (S_RNDM(0).LT.PCHEX) THEN
+ LL(NPI+1) = LCON(LA)*ISIGN(1,L0)
+ IF( (L0 .EQ. 6) .OR. (L0 .EQ. 11) )
+ . LL(NPI+1) = LL(NPI+1)+INT((2.D0-EPS8)*S_RNDM(1))
+ ELSE
+ LL(NPI+1) = L0
+ ENDIF
+ JQQ = ICHP(LA)*ISIGN(1,L0)-
+ . ICHP(IABS(LL(NPI+1)))*ISIGN(1,LL(NPI+1))
+ 220 JQTOT = 0
+ DO K=1,NPI-1
+ LL(K) = 6+INT(S_RNDM(K)*(3.D0-EPS8))
+ JQTOT = JQTOT + ICHP(LL(K))
+ ENDDO
+ JQR = JQQ-JQTOT
+ IF (JQR.LT.-1.OR.JQR.GT.1) GOTO 220
+ LL(NPI) = 6+JQR
+ IF (LL(NPI) .EQ. 5) LL(NPI)=8
+ CALL DECPAR (0,P0,NPI+1,LL, PD)
+ DO J=1,NPI+1
+ NP = NP+1
+ LLIST(NP) = LL(J)
+ NPORIG(NP) = IPFLAG*2
+ lrnk(Np) = 0
+ niorig(NP)= iiflag
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ ENDDO
+ ENDIF
+ ELSE
+ if (ndebug .gt. 0) then
+ IF(NRJECT.le.10)THEN
+ WRITE(LUN,*) ' DIFDEC rejection! ',
+ & 'diff. mass to low to dissociate beam!'
+ WRITE(LUN,*) ' DIFDEC: LA, m_Beam, DELTAE, NCALL : ',
+ & LA, AM(LA),DELTAE,'>',AM(7)+0.02D0,NCALL
+ IF(Irec.ne.1)
+ & WRITE(LUN,*) ' was recursive call! (ECM):',P0(5)
+ ENDIF
+ IF(NRJECT.eq.10)
+ & write(lun,*)' this was the last warning.. good luck!'
+ endif
+ NRJECT = NRJECT + 1
+ NP = 0
+ IBAD = 1
+ RETURN
+ ENDIF
+ PAR(1) = PAR1_def
+ END
+C=======================================================================
+
+ SUBROUTINE EXCT_RMNT(JW,KRMNT,IREJ)
+
+C-----------------------------------------------------------------------
+C routine to produce massive excitations of beam and/or target \FR'14
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTMIN,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+
+ INTEGER IRMNT,KRB,KRT
+ DOUBLE PRECISION XRMASS,XRMEX
+ COMMON /S_RMNT/ XRMASS(2),XRMEX(2),IRMNT(NW_max),KRB,KRT(NW_max)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+ DOUBLE PRECISION XM2MIN,ALXMIN,SLOP0,ASLOP,BSLOP,XMASS
+ COMMON /S_DIFMAss/ XM2MIN(6),ALXMIN(6),SLOP0,ASLOP,BSLOP,XMASS(2)
+
+ DOUBLE PRECISION P1(5),P2(5),P1N(5),P2N(5),PBM1(5),PBM2(5),PBM(5),
+ & PTG1(5),PTG2(5),PTG(5),PTT(5),GABE(4)
+ DOUBLE PRECISION XMB,XMB2,ALPHA,XMSQMIN,XM2MAX,XM2,SHAT,ECM,EE,EE2
+ DOUBLE PRECISION XMFRAC,XSFRAC,XMT,XMT2,XMT12,XMT22,P1TOT,P2TOT
+ DOUBLE PRECISION DELTAE,XMMIN,COD,COF,SID,SIF,ANORF,PX,PY,PZ
+ DOUBLE PRECISION XM1,ETOT,XI,XM2DIS,S_RNDM
+c DOUBLE PRECISION XDUMMY
+
+ INTEGER IMRG2HAD,LL(99)
+ INTEGER IBM1,IBM2,IBMST1,IBMST2,ITG1,ITG2,ITGST1,ITGST2,ITGH
+ INTEGER IDM,IFL,IBMH, IREF,I, II,K,J,JJ,L01,L02,NP0LD,NPLD
+ INTEGER JW,IREJ,KRMNT,LREJ,IBD,ICST11,ICST21
+ INTEGER IFLB1,IFLB2,IFLT1,IFLT2,L0,IDHAD,ISTH,IBMST,ITGST
+ INTEGER IFL1,IFL2,IMRG,IMST,IMST1,IMRGBAR,ICST2,LBD
+ INTEGER IMST11,IMST2,IMST21,ISTH1,ISTH2,IAFL1,IAFL2!,IMST22
+
+ SAVE
+ DATA LL /5*0,7*2,2*1,12*0,2,6*0,6*1,19*0,2,2,10*0,
+ & 2,2,0,2,2,11*0,1,1,1,9*0,1/
+
+
+c default return point, beam and target sampling
+c IREJ = 1
+
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*) ' EXCT_RMNT: input (JW,KRMNT,IREJ)',
+ & JW,KRMNT,IREJ
+
+ IF(NDEBUG.gt.3)THEN
+ write(LUN,*)' beam remnant index: (lvl0,flv1,flv2) ',IBMRDX
+ write(LUN,*)' 1st central string index: (lvl0,bm,tg)',
+ & (ICSTDX(2*(JW-1)+1,ii),ii=1,3)
+ write(LUN,*)' 2nd central string index: (lvl0,bm,tg)',
+ & (ICSTDX(2*(JW-1)+2,ii),ii=1,3)
+ write(LUN,*)' target remnant index: (lvl0,flv1,flv2)',
+ & (ITGRDX(JW,ii),ii=1,3)
+ ENDIF
+
+ ITRY(5) = 0
+
+C... select indices depending on configuration
+C krmnt = 0 : no excitation on either side
+c = 1 : beam side excited remnant
+c = 2 : target side
+c = 3 : both sides
+
+c write remnant configuration to remnant common
+ IRMNT(JW) = KRMNT
+ IF(KRMNT.eq.1)THEN
+c beam side remnant only
+c proto-remnant position: IBMRDX(1)
+c partons in : IBMRDX(2:3)
+ IBM1 = IBMRDX(2)
+ IBM2 = IBMRDX(3)
+c target side to transfer energy from:
+c (sofar always choose valence pair)
+ ITG1 = ICSTDX(2*(JW-1)+1,3)
+ ITG2 = ICSTDX(2*(JW-1)+2,3)
+c beam-side partons to go into central strings
+ IBMST1 = ICSTDX(2*(JW-1)+1,2)
+ IBMST2 = ICSTDX(2*(JW-1)+2,2)
+c target-side partons to go into central strings
+ ITGST1 = ITG1
+ ITGST2 = ITG2
+
+ ELSEIF(KRMNT.eq.2)THEN
+c target side remnant only
+c proto-remnant in ITGRDX(JW,1)
+ ITG1 = ITGRDX(JW,2)
+ ITG2 = ITGRDX(JW,3)
+c transfer energy from beam remnant or
+c central strings with valence quarks
+c in ICSTDX(JW+0:1,2)
+c means no beam remnant --> get from valence strings
+ IBM1 = ICSTDX(2*(JW-1)+1,2)
+ IBM2 = ICSTDX(2*(JW-1)+2,2)
+c beam-side partons to go into central strings
+ IBMST1 = IBM1
+ IBMST2 = IBM2
+c target-side partons to go into central strings
+ ITGST1 = ICSTDX(2*(JW-1)+1,3)
+ ITGST2 = ICSTDX(2*(JW-1)+2,3)
+
+ ELSEIF(KRMNT.eq.3)THEN
+c beam and target side remnant
+c transfer energy from pairs in rmnt or central strings
+c listed in I?RDX and ICSTDX()
+ IBM1 = IBMRDX(2)
+ IBM2 = IBMRDX(3)
+ ITG1 = ITGRDX(JW,2)
+ ITG2 = ITGRDX(JW,3)
+
+ ELSEIF(KRMNT.eq.0)THEN
+c no excited remnant case, jump straight to central strings..
+ GOTO 100
+
+ ENDIF
+
+ IF(NDEBUG.gt.3)then
+ write(lun,*) ' beam parton1: ',IBM1
+ write(lun,*) ' beam parton2: ',IBM2
+ write(lun,*) ' target parton1:',ITG1
+ write(lun,*) ' target parton2:',ITG2
+ endif
+
+c save status of parton stack
+ CALL GET_NPP(NPLD,NP0LD)
+
+ 10 ITRY(5) = ITRY(5) + 1
+ IF(ITRY(5).GT.NREJ(5))THEN
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*) ' EXCT_RMNT: no. of trials exceeded, ',
+ & NREJ(5), 'resample minijets ...' , IREJ
+ RETURN
+ ENDIF
+c reset parton stack after rmnt mass rejection
+ CALL INI_PRTN_STCK(NPLD,NP0LD)
+
+C.. construct 4momenta of proto-remnants
+c index of beam remnant on stack: IBMRDX(1)
+
+C.. center-of-mass energy of parton system (s hat)
+c calculated in hadron-hadron frame
+c for first interaction (jw=1) partons are massless and collinear (sum pt=0)
+c in this case ecm = SQS*SQRT(XB*XT), xb,t=x1+x2
+c for jw>1 beam partons may have already acquired mass and additional pt
+c therefore ecm = sqs*sqrt(xb*xt) + corr.
+c IRDX: index of remnant on parton stack
+c SHAT = S*XB*XT+XM2+(XT/XB)*XMT2
+
+c with 4momenta of partons on stack, momentum fractions are obsolete
+c center-of-mass energy is simply: shat = (pbm+ptg)**2
+
+c construct total 4momentum
+c add beam-side parton momenta, in had.-had. frame
+ CALL RD_PRTN_4VEC(IBM1,PBM1,IFL,IDM)
+ CALL RD_PRTN_4VEC(IBM2,PBM2,IFL,IBMH)
+ CALL ADD_4VECS(PBM1,PBM2,PBM)
+
+c target-side parton momenta, in had.-had. frame
+ CALL RD_PRTN_4VEC(ITG1,PTG1,IFL,IDM)
+ CALL RD_PRTN_4VEC(ITG2,PTG2,IFL,IDM)
+ CALL ADD_4VECS(PTG1,PTG2,PTG)
+
+c add beam and target side to get total 4momentum
+ CALL ADD_4VECS(PBM,PTG,PTT)
+ SHAT = PTT(5)**2
+ ECM = PTT(5)
+c catch virtual remnants
+ IF(PTT(5).LT.0.D0) THEN
+ IF(NDEBUG.GT.2)THEN
+ WRITE(LUN,*) ' EXCT_RMNT: too little mass left (Shat):',
+ & SHAT
+ WRITE(LUN,*) ' resample minijets...'
+ ENDIF
+ LREJ = 2
+ RETURN ! resample minijets
+ ENDIF
+
+
+ IF(NDEBUG.GT.2) WRITE(LUN,*) ' EXCT_RMNT: try no.',ITRY(5)
+ IF(NDEBUG.GT.3)THEN
+ write(LUN,*) ' 4momenta before scattering:'
+ write(LUN,*) ' PBM1:' , (PBM1(jj),jj=1,5)
+ write(LUN,*) ' PBM2:' , (PBM2(jj),jj=1,5)
+ write(LUN,*) ' PBM:' , (PBM(jj),jj=1,5)
+
+ write(LUN,*) ' PTG1:' , (PTG1(jj),jj=1,5)
+ write(LUN,*) ' PTG2:' , (PTG2(jj),jj=1,5)
+ write(LUN,*) ' PTG:' , (PTG(jj),jj=1,5)
+
+ write(LUN,*) ' PTT:' , (PTT(jj),jj=1,5)
+ ENDIF
+
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: SHAT:',SHAT
+
+ XMFRAC = PAR(81)
+ XSFRAC = PAR(82)
+
+c exponent of remnant mass distribution (1/Mx**2)**alpha
+c by default: alpha = 1
+c different for baryons and mesons
+c ALPHA = PAR(98)
+
+C.. Sample masses
+ IF(KRMNT.eq.1)THEN
+ XM2MAX = MIN(XSFRAC*S,XMFRAC*AM2(IABS(KB)))
+ XM2MAX = MAX(XM2MAX,1.D0)
+
+c mass of target-side: 0
+ XMT = 0.D0
+ XMT2 = 0.D0
+c get remnant mass
+c (might have received mass from prior interaction)
+ CALL GET_MASS2(IBMRDX(1),XM2)
+c allowing excitation to fallback to beam means min.
+c mass is beam mass, or more exact smallest mass of hadrons
+c with flavors in remnant
+ IF(IPAR(64).eq.1)THEN
+c remnant mass can also decrease through interactions
+ XMSQMIN = AM2(IABS(KB))
+ ELSE
+c remnant mass only increased by multiple interactions..
+ XMSQMIN = MAX(AM2(IABS(KB)),XM2)
+ ENDIF
+C select exponent from COMMON
+ ALPHA = XRMEX(LL(IABS(KB)))
+c sample beam mass
+ XMB2 = XM2DIS(XMSQMIN,XM2MAX,ALPHA)
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: XM2min,XM2max,ALPHA,XM2:',
+ & XMSQMIN,XM2MAX,ALPHA,XMB2
+c check if resonance or massive hadron has to be formed
+ CALL SEL_RES(XMB2,KRB,IBMRDX(1),IBMH)
+ XMB = dsqrt(XMB2)
+
+ ELSEIF(KRMNT.eq.2)THEN
+c target side mass
+ XM2MAX = MIN(XSFRAC*S,XMFRAC*AM2(IABS(KT(JW))))
+ XM2MAX = MAX(XM2MAX,1.D0)
+
+ XMB = 0.D0
+ XMB2 = 0.D0
+ XMSQMIN = AM2(KT(JW))
+C select exponent from COMMON
+ ALPHA = XRMEX(LL(IABS(KT(JW))))
+ XMT2 = XM2DIS(XMSQMIN,XM2MAX,ALPHA)
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: XM2min,XM2max,ALPHA,XM2:',
+ & XMSQMIN,XM2MAX,ALPHA,XMT2
+
+c check if resonance or massive hadron has to be formed
+ CALL SEL_RES(XMT2,KRT(JW),ITGRDX(JW,1),ITGH)
+ XMT = dsqrt(XMT2)
+
+ ELSEIF(KRMNT.eq.3)THEN
+ XM2MAX = MIN(XSFRAC*S,XMFRAC*AM2(IABS(KB)))
+ XM2MAX = MAX(XM2MAX,1.D0)
+
+ CALL GET_MASS2(IBMRDX(1),XM2)
+ IF(IPAR(64).eq.1)THEN
+c remnant mass can also decrease through interactions
+ XMSQMIN = AM2(IABS(KB))
+ ELSE
+c remnant mass only increased by multiple interactions..
+ XMSQMIN = MAX(AM2(IABS(KB)),XM2)
+ ENDIF
+C select exponent from COMMON
+ ALPHA = XRMEX(LL(IABS(KB)))
+ XMB2 = XM2DIS(XMSQMIN,XM2MAX,ALPHA)
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: XM2min,XM2max,ALPHA,xm2:',
+ & XMSQMIN,XM2MAX,ALPHA,XMB2
+
+c check if resonance or massive hadron has to be formed
+ CALL SEL_RES(XMB2,KRB,IBMRDX(1),IBMH)
+ XMB = SQRT(XMB2)
+
+c target always nucleon
+ XM2MAX = MIN(XSFRAC*S,XMFRAC*AM2(IABS(KT(JW))))
+ XM2MAX = MAX(XM2MAX,1.D0)
+
+ XMSQMIN = AM2(IABS(KT(JW)))
+C select exponent from COMMON
+ ALPHA = XRMEX(LL(IABS(KT(JW))))
+ XMT2 = XM2DIS(XMSQMIN,XM2MAX,ALPHA)
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: XM2min,XM2max,alpha,XM2:',
+ & XMSQMIN,XM2MAX,ALPHA,XMT2
+
+c check if resonance or massive hadron has to be formed
+ CALL SEL_RES(XMT2,KRT(JW),ITGRDX(JW,1),ITGH)
+ XMT = SQRT(XMT2)
+
+ ENDIF
+c write excitation mass to output common
+ XRMASS(1) = XMB
+ XRMASS(2) = XMT
+
+c minimal mass requirement
+c IF(SHAT.lt.XMB2+XMT2+0.3) GOTO 10
+ IF(SHAT.lt.XMB2+XMT2+2.D0*XMB*XMT+0.3D0) GOTO 10
+
+C transfer cm energy to mass of particle in parton-parton cm
+ CALL TRANSFONSHELL(ECM,XMB,XMT,XM2MAX,1,P1,P2,IBD)
+ IF(IBD.eq.1) THEN
+ IF(NDEBUG.gt.2) WRITE(LUN,*) ' EXCT_RMNT: excitation rejected!'
+ RETURN
+ ENDIF
+
+C... Boost 4momenta to hadron-hadron center-of-mass
+c along z only if initial partons do not carry transverse momentum
+c (cancels between val1 and val2)
+c with multiple nucleons interacting beam val partons can aquire
+c transverse momentum from the target. in this case need arbitrary boost
+ DO K = 1,4
+ GABE(k) = PTT(k)/PTT(5)
+ ENDDO
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P1(1),P1(2),P1(3),P1(4),
+ & P1TOT,P1N(1),P1N(2),P1N(3),P1N(4))
+ P1N(5)=P1(5)
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P2(1),P2(2),P2(3),P2(4),
+ & P2TOT,P2N(1),P2N(2),P2N(3),P2N(4))
+ P2N(5)=P2(5)
+
+C... Calculate new 4momentum of partons in had.-had. frame
+c P1,P2: momenta after scattering in parton-parton cm.
+c P1n,P2n: momenta after scattering in had.-had. cm
+c PBM1,2: momenta of beam partons in had.-had. before scattering
+c PTG1,2: momenta of target partons in had.-had. before scattering
+c PBM: combined momentum of all beam partons before scattering
+c PTG: combined momentum of all target partons before scattering
+
+c energy and z component
+ DO II=3,4
+ PBM1(II) = PBM1(II)*P1n(II)/PBM(II)
+ PBM2(II) = PBM2(II)*P1n(II)/PBM(II)
+
+ PTG1(II) = PTG1(II)*abs(P2N(II)/PTG(II))
+ PTG2(ii) = PTG2(ii)*abs(P2N(II)/PTG(II))
+ ENDDO
+
+c if transverse momentum prior to interaction zero then
+c assign transverse momentum of partons according to random fraction
+ IF(ABS(PBM(1)).LT.EPS10.or.ABS(PBM(2)).LT.EPS10)THEN
+ DO II = 1,2
+ XI = S_RNDM(II)
+ PBM1(II) = XI*P1N(Ii)
+ PBM2(II) = (1.D0-XI)*P1N(II)
+ ENDDO
+ ELSE
+ DO II=1,2
+ PBM1(II) = PBM1(II)*P1N(II)/PBM(II)
+ PBM2(II) = PBM2(II)*P1N(II)/PBM(II)
+ ENDDO
+ ENDIF
+
+ IF(ABS(PTG(1)).LT.EPS10.or.ABS(PTG(2)).LT.EPS10)THEN
+ DO II=1,2
+ XI = S_RNDM(II)
+ PTG1(II) = XI*P2N(II)
+ PTG2(II) = (1.D0-XI)*P2N(II)
+ ENDDO
+ ELSE
+ DO II=1,2
+ PTG1(II) = PTG1(II)*P2N(II)/PTG(II)
+ PTG2(II) = PTG2(II)*P2N(II)/PTG(II)
+ ENDDO
+ ENDIF
+
+ IF(NDEBUG.GT.3)THEN
+ write(LUN,*) ' parton 4momenta after scattering:'
+ write(LUN,*) ' PBM1:' , (PBM1(jj),jj=1,5)
+ write(LUN,*) ' PBM2:' , (PBM2(jj),jj=1,5)
+ write(LUN,*) ' sum: ' , (PBM2(jj)+PBM1(jj),jj=1,5)
+ write(LUN,*) ' PTG1:' , (PTG1(jj),jj=1,5)
+ write(LUN,*) ' PTG2:' , (PTG2(jj),jj=1,5)
+ write(LUN,*) ' sum: ' , (PTG2(jj)+PTG1(jj),jj=1,5)
+ ENDIF
+
+C... change parton 4momenta on stack
+ CALL EDT_PRTN(IBM1,PBM1(1),PBM1(2),PBM1(3),PBM1(4),PBM1(5),IDM)
+ CALL EDT_PRTN(IBM2,PBM2(1),PBM2(2),PBM2(3),PBM2(4),PBM2(5),IDM)
+
+ CALL EDT_PRTN(ITG1,PTG1(1),PTG1(2),PTG1(3),PTG1(4),PTG1(5),IDM)
+ CALL EDT_PRTN(ITG2,PTG2(1),PTG2(2),PTG2(3),PTG2(4),PTG2(5),IDM)
+
+C... add remnants
+c references are circular:
+c rmnt --> parton1 --> parton2 --> lvl2 rmnt (hadron) --> rmnt
+ IF(KRMNT.eq.1)THEN
+c beam side remnant, add only if does not exist yet otherwise edit
+ IF(IBMRDX(1).eq.0)THEN
+ CALL ADD_PRTN
+ & (P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),2,0,IBM1,IBMRDX(1))
+ ELSE
+ CALL EDT_PRTN
+ & (IBMRDX(1),P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),IREF)
+ ENDIF
+c add beam hadron as hypothetical final state
+ IF(IBMH.eq.0)THEN
+ CALL ADD_PRTN
+ & (P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),KRB,2,IBMRDX(1),IBMH)
+ ELSE
+ CALL EDT_PRTN
+ & (IBMH,P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),IREF)
+ ENDIF
+c add references rmnt --> parton1 etc
+ CALL ADD_REF(IBMRDX(1),IBM1)
+ CALL ADD_REF(IBM1,IBM2)
+ CALL ADD_REF(IBM2,IBMH)
+
+ ELSEIF(KRMNT.eq.2)THEN
+c add target side remnant
+ IF(ITGRDX(JW,1).eq.0)THEN
+ CALL ADD_PRTN
+ & (P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),
+ & -2,0,0,ITGRDX(JW,1))
+ ELSE
+ CALL EDT_PRTN
+ & (ITGRDX(JW,1),P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),IREF)
+ ENDIF
+ IF(ITGH.eq.0)THEN
+c add target hadron as hypothetical final state, always nucleon
+ CALL ADD_PRTN
+ & (P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),
+ & KRT(JW),2,ITGRDX(JW,1),ITGH)
+ ELSE
+ CALL EDT_PRTN
+ & (ITGH,P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),IREF)
+ ENDIF
+
+c add references rmnt --> parton1 etc
+ CALL ADD_REF(ITGRDX(JW,1),ITG1)
+ CALL ADD_REF(ITG1,ITG2)
+ CALL ADD_REF(ITG2,ITGH)
+
+ ELSEIF(KRMNT.eq.3)THEN
+c beam side remnant, add only if does not exist yet, otherwise edit
+ IF(IBMRDX(1).EQ.0)THEN
+ CALL ADD_PRTN
+ & (P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),2,0,0,IBMRDX(1))
+ ELSE
+ CALL EDT_PRTN
+ & (IBMRDX(1),P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),IREF)
+ ENDIF
+c add beam hadron as hypothetical final state
+ IF(IBMH.EQ.0)THEN
+ CALL ADD_PRTN
+ & (P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),KRB,2,IBMRDX(1),IBMH)
+ ELSE
+ CALL EDT_PRTN
+ & (IBMH,P1N(1),P1N(2),P1N(3),P1N(4),P1N(5),IREF)
+ ENDIF
+ CALL ADD_REF(IBMRDX(1),IBM1)
+ CALL ADD_REF(IBM1,IBM2)
+ CALL ADD_REF(IBM2,IBMH)
+
+c add target side remnant
+ IF(ITGRDX(JW,1).eq.0)THEN
+ CALL ADD_PRTN
+ & (P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),-2,0,0,IREF)
+ ITGRDX(JW,1) = IREF
+ ELSE
+ CALL EDT_PRTN
+ & (ITGRDX(JW,1),P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),IREF)
+ ENDIF
+ IF(ITGH.eq.0)THEN
+c add target hadron as hypothetical final state
+ CALL ADD_PRTN
+ & (P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),
+ & KRT(JW),2,ITGRDX(JW,1),ITGH)
+ ELSE
+ CALL EDT_PRTN
+ & (ITGH,P2N(1),P2N(2),P2N(3),P2N(4),P2N(5),IREF)
+ ENDIF
+c add references rmnt --> parton1 etc
+ CALL ADD_REF(ITGRDX(JW,1),ITG1)
+ CALL ADD_REF(ITG1,ITG2)
+ CALL ADD_REF(ITG2,ITGH)
+
+ ENDIF
+
+ 100 IF(JDIF(JW).ne.0.and.NWD.ne.1)THEN
+c incoherent diffraction case
+c add parton 4momenta to obtain c.m energy
+
+c beam side
+ IBMST1 = ICSTDX(2*(JW-1)+1,2)
+ IBMST2 = ICSTDX(2*(JW-1)+2,2)
+
+c target side
+ ITGST1 = ICSTDX(2*(JW-1)+1,3)
+ ITGST2 = ICSTDX(2*(JW-1)+2,3)
+
+ CALL RD_PRTN_4VEC(IBMST1,PBM1,IFLB1,IDM)
+ CALL RD_PRTN_4VEC(IBMST2,PBM2,IFLB2,IDM)
+ CALL ADD_4VECS(PBM1,PBM2,PBM)
+ CALL RD_PRTN_4VEC(ITGST1,PTG1,IFLT1,IDM)
+ CALL RD_PRTN_4VEC(ITGST2,PTG2,IFLT2,IDM)
+ CALL ADD_4VECS(PTG1,PTG2,PTG)
+c total 4momentum
+ CALL ADD_4VECS(PBM,PTG,PTT)
+c add diffractive system to parton stack
+c references are: diff --> diff. hadron
+c --> beam parton1 --> beam parton2 --> target parton1 etc
+ CALL ADD_PRTN_4VEC(PTT,-10*JDIF(JW),0,IBMST1,IREF)
+ CALL ADD_INT_REF(IREF,IINTDX(JW))
+c both string indices point to diff. system
+ ICSTDX(2*(JW-1)+1,1) = IREF
+ ICSTDX(2*(JW-1)+2,1) = IREF
+c add diff. beam hadron to stack
+c model assumes remnant always excited in first interaction
+ L0 = KB
+c if not first interaction or remnant excited, merge sea pair to hadron
+ IF(KRMNT.ne.0.or.JW.ne.1) THEN
+ L0 = IMRG2HAD(IFLB1,IFLB2)
+c CALL SIB_I4FLAV(IFLB1,IFLB2,IDM,IDM1,L0)
+ ENDIF
+c check kinematic limits
+c m2_max should be smaller than m2_min
+ IREJ = 1
+ EE = PTT(5)
+ EE2 = PTT(5)**2
+ K = 2-IBAR(IABS(L0))
+ IF(JDIF(jw).gt.1)THEN
+ DELTAE = EE-AM(13)
+ XMMIN=max(XM2MIN(1),(AM(IABS(l0))+AM(7)+0.02D0)**2)
+ ELSE
+ DELTAE = EE-AM(IABS(L0))
+ XMMIN=max(XM2MIN(K),(AM(IABS(l0))+AM(7)+0.02D0)**2)
+ ENDIF
+c print *,'jw,jdif,nwd,l0,ifl1,ifl2,deltae,xmin,ee,xmax',
+c & jw,jdif(jw),nwd,l0,ifl1,ifl2,deltae,xmmin,ee,par(13)*ee2
+ IF(DELTAE.lt.AM(7)+0.02D0) THEN
+ IF(ndebug.gt.2)
+ & WRITE(lun,*) ' EXCT_RMNT: inchoherent diff. :',
+ & ' not enough mass left for excitation! (DELTAE,PION,',
+ & 'IREJ,NCALL)',DELTAE,AM(7)+0.02D0,IREJ,NCALL
+ RETURN
+ ENDIF
+ IF(PAR(13)*EE2.lt.XMMIN)THEN
+ IF(ndebug.gt.2)
+ & WRITE(lun,*) ' EXCT_RMNT: inchoherent diff. :',
+ & ' not enough mass left for excitation! (min,max,',
+ & 'IREJ,NCALL)',PAR(13)*EE2,XMMIN,IREJ,NCALL
+ RETURN
+ ENDIF
+ CALL ADD_PRTN_4VEC(PTT,L0,2,IBMST1,IDHAD)
+ CALL ADD_REF(IREF,IDHAD)
+c reset references of partons
+ CALL ADD_REF(IBMST1,IBMST2)
+ CALL ADD_REF(IBMST2,ITGST1)
+ CALL ADD_REF(ITGST1,ITGST2)
+ CALL ADD_REF(ITGST2,IREF)
+ IF(ndebug.gt.2) THEN
+ WRITE(LUN,*) ' EXCT_RMNT: incoherent diff. ',
+ & '(IDX,IDX2,JDIF,ECM,L0)',IREF,IDHAD,JDIF(JW),PTT(5),L0
+ WRITE(LUN,*) ' EXCT_RMNT: DELTAE,XM2MAX:',DELTAE,PAR(13)*EE2
+ ENDIF
+ IREJ = 0
+ RETURN
+ ENDIF
+
+C... add central strings to stack
+c partons designated for central strings
+c are indexed in ICSTDX(JW,2:3)
+c pstr_j = p_j_bm + p_j_tg
+c string mass ** 2 = pstr_j ** 2
+c --> read momenta from stack, add beam and target side,
+c references are set in a loop:
+c string --> beam-parton --> target-parton --> string
+c then write string 4momentum on stack
+ IMRG = 0
+ DO JJ=1,2
+ ISTH = 0
+ IBMST = ICSTDX(2*(JW-1)+JJ,2)
+ ITGST = ICSTDX(2*(JW-1)+JJ,3)
+ CALL RD_PRTN_4VEC(IBMST,PBM1,IFL1,IDM)
+ CALL RD_PRTN_4VEC(ITGST,PTG1,IFL2,IDM)
+ CALL ADD_4VECS(PBM1,PTG1,PTT)
+c transverse mass of string end partons (pt**2)
+ CALL GET_XMT2(IBMST,XMT12)
+ CALL GET_XMT2(ITGST,XMT22)
+c available mass for string
+ EE = SQRT(PTT(4)**2-PTT(3)**2)
+c catch virtual strings
+ IF(PTT(5).lt.0.D0) THEN
+ IREJ = 1
+ IF(ndebug.gt.2)
+ & write(LUN,*)' EXCT_RMNT: virt. string (M):',EE
+ IF(ndebug.gt.3)then
+ CALL GET_IMASS2(IBMST,XM2)
+ write(LUN,*) ' PBM1:', (PBM1(j),j=1,5),XM2
+ CALL GET_IMASS2(ITGST,xm2)
+ write(LUN,*) ' PTG1:', (PTG1(j),j=1,5),XM2
+ write(LUN,*) ' Ptot:', (PTT(j),j=1,5)
+ ENDIF
+c stop
+ RETURN
+ ENDIF
+c minimal string mass requirement
+ IF(EE.lt.sqrt(XMT12)+sqrt(XMT22)+PAR(123))THEN
+ IAFL1 = IABS(IFL1)
+ IAFL2 = IABS(IFL2)
+ IF(IPAR(74).eq.1)THEN
+c try to form single meson, set merge flag
+ IF(IAFL1.gt.10.and.IAFL2.gt.10) THEN
+c skip if two diquarks need merging..
+ IREJ = 1
+ RETURN
+ ENDIF
+ IF((IAFL1/10.eq.4.or.mod(IAFL1,10).eq.4)
+ + .and.(IAFL2/10.eq.4.or.mod(IAFL2,10).eq.4)) THEN
+c skip if two charm quarks need merging..
+ IREJ = 1
+ RETURN
+ ENDIF
+ L0 = IMRG2HAD(IFL1,IFL2)
+ IF(EE.gt.AM(IABS(L0))) then
+ IMRG = IMRG + JJ
+ CALL ADD_PRTN_4VEC(PTT,L0,2,IBMST,ISTH)
+ IF(ndebug.gt.2)then
+ write(lun,*)
+ & ' EXCT_RMNT: c.string mass too low! ',
+ & 'merge into hadron..',l0
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ndebug.gt.2)then
+ write(lun,*)
+ & ' EXCT_RMNT: c.string kinematic rejection!'
+ write(lun,*) ' EE,limit,XMT1,XMT2:',
+ & EE,sqrt(XMT12)+sqrt(XMT22)+0.3D0,sqrt(XMT12),
+ & sqrt(XMT22)
+ write(lun,*) ' return to momentum sampling..'
+ endif
+ IREJ = 1
+ RETURN
+ ENDIF
+ ENDIF
+c add central string to stack, refering to beam-end parton
+ CALL ADD_PRTN_4VEC(PTT,1,0,IBMST,IREF)
+ ICSTDX(2*(JW-1)+JJ,1) = IREF
+ CALL ADD_INT_REF(Iref,IINTDX(JW))
+c add reference to target parton to beam parton
+ CALL ADD_REF(IBMST,ITGST)
+ IF(ISTH.ne.0) THEN
+c if string merged to hadron add reference corresponding reference
+ CALL ADD_REF(ITGST,ISTH)
+ CALL ADD_REF(ISTH,IREF)
+ ELSE
+c add reference to corresponding central string to target parton
+ CALL ADD_REF(ITGST,IREF)
+ ENDIF
+ ENDDO
+
+c form single hadron from string if mass was too low ..
+c need to put hadron on shell by exchanging energy with other string
+ IF(IMRG.eq.1.or.IMRG.eq.2)THEN
+ IF(ndebug.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: merging one string..',IMRG
+c one string merged
+c index of merged string and its last parton
+ IMST = ICSTDX(2*(JW-1)+IMRG,1)
+ IMST1 = ICSTDX(2*(JW-1)+IMRG,3)
+c index of ordinary string
+ IMRGBAR = 3-IMRG
+ ICST2 = ICSTDX(2*(JW-1)+IMRGBAR,1)
+c read 4momenta
+ CALL RD_REF(IMST1,ISTH)
+ CALL RD_PRTN_4VEC(ISTH,P1,L0,IREF)
+c string two
+ CALL RD_PRTN_4VEC(ICST2,P2,IFL2,IDM)
+c cm energy
+ CALL ADD_4VECS(P1,P2,PTT)
+ IF(ndebug.gt.2)THEN
+ write(lun,*)' EXCT_RMNT: string A :',(P1(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: string B :',(P2(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: total :',(PTT(i),i=1,5)
+ ENDIF
+ ECM = PTT(5)
+ XM1 = AM(IABS(L0))
+ XM2 = P2(5)
+ CALL TRANSFONSHELL(ECM,XM1,XM2,1.D0,3,P1N,P2N,LBD)
+ IF(LBD.eq.1) THEN
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: mass transfer failed!'
+ RETURN
+ ENDIF
+c by definition p1n is along +z in string cm, need to invert if pzA < pzB
+c IF(P2(3).gt.P1(3)) CALL SWTCH_LMNTS(P1N(3),P2N(3))
+
+C.. rotate parton-parton axis onto string-string axis
+c therefore boost to parton-parton cm
+c to calc. rotation angles BEFORE interaction !
+ DO K = 1,4
+ GABE(K) = PTT(K)/PTT(5)
+ enddo
+ CALL SIB_ALTRA(GABE(4),-GABE(1),-GABE(2),-GABE(3),
+ & P1(1),P1(2),P1(3),P1(4),
+ & P1TOT,PBM1(1),PBM1(2),PBM1(3),PBM1(4))
+c rotation factors
+ COD= PBM1(3)/P1TOT
+ SID= DSQRT(PBM1(1)**2+PBM1(2)**2)/P1TOT
+ COF=1.D0
+ SIF=0.D0
+ IF(P1TOT*SID.GT.EPS5) THEN
+ COF=PBM1(1)/(SID*P1TOT)
+ SIF=PBM1(2)/(SID*P1TOT)
+ ANORF=DSQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+ IF(ndebug.gt.2)THEN
+ write(lun,*)' EXCT_RMNT: momentum in cm:',(PBM1(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: rotation factors:',COD,SID,COF,SIF
+ write(lun,*)' EXCT_RMNT: rotation angles (theta,phi):',
+ & ACOS(COD),ACOS(COF),ASIN(SID),ASIN(SIF)
+ write(lun,*)' EXCT_RMNT: momentum:',
+ & sqrt(P1N(1)**2+P1N(2)**2+P1N(3)**2)
+ ENDIF
+c rotate parton momenta after interaction, still in parton-parton frame
+ CALL SIB_TRANI(P1N(1),P1N(2),P1N(3),COD,SID,COF,SIF
+ & ,PX,PY,PZ)
+ P1N(1)=PX
+ P1N(2)=PY
+ P1N(3)=PZ
+ CALL SIB_TRANI(P2N(1),P2N(2),P2N(3),COD,SID,COF,SIF
+ & ,PX,PY,PZ)
+ P2N(1)=PX
+ P2N(2)=PY
+ P2N(3)=PZ
+ IF(ndebug.gt.2) write(lun,*)' EXCT_RMNT: momentum*:',
+ & sqrt(P1N(1)**2+P1N(2)**2+P1N(3)**2)
+
+c boost back to hadron-hadron
+ DO K = 1,4
+ GABE(K) = PTT(K)/PTT(5)
+ ENDDO
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P1N(1),P1N(2),P1N(3),P1N(4),
+ & P1TOT,P1(1),P1(2),P1(3),P1(4))
+ P1(5)=P1N(5)
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P2N(1),P2N(2),P2N(3),P2N(4),
+ & P2TOT,P2(1),P2(2),P2(3),P2(4))
+ p2(5)=p2n(5)
+ IF(ndebug.gt.2)THEN
+ write(lun,*)' EXCT_RMNT: momenta after scattering:'
+ write(lun,*)' EXCT_RMNT: hadron A :',(P1(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: string B :',(P2(i),i=1,5)
+ ENDIF
+
+c edit partons on stack
+ CALL EDT_PRTN
+ & (ISTH,P1(1),P1(2),P1(3),P1(4),P1(5),IREF)
+ ICST11 = ICSTDX(2*(JW-1)+IMRG,2)
+ CALL EDT_PRTN
+ & (IMST,P1(1),P1(2),P1(3),P1(4),P1(5),ICST11)
+ ICST21 = ICSTDX(2*(JW-1)+IMRGBAR,2)
+ CALL EDT_PRTN
+ & (ICST2,P2(1),P2(2),P2(3),P2(4),P2(5),ICST21)
+
+ ELSEIF(IMRG.eq.3)THEN
+ IF(ndebug.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: merge both strings..'
+
+c both strings merged
+c index of merged string and its last parton
+ IMST1 = ICSTDX(2*(JW-1)+1,1)
+ IMST11 = ICSTDX(2*(JW-1)+1,3)
+c index of ordinary string
+ IMST2 = ICSTDX(2*(JW-1)+2,1)
+ IMST21 = ICSTDX(2*(JW-1)+2,3)
+c read 4momenta
+ CALL RD_REF(IMST11,ISTH1)
+ CALL RD_PRTN_4VEC(ISTH1,P1,L01,IREF)
+c string two
+ CALL RD_REF(IMST21,ISTH2)
+ CALL RD_PRTN_4VEC(ISTH2,P2,L02,IREF)
+ XM1 = AM(IABS(L01))
+ XM2 = AM(IABS(L02))
+c cm energy
+ CALL ADD_4VECS(P1,P2,PTT)
+ ECM = PTT(5)
+ ETOT = PTT(4)
+ IF(ndebug.gt.2)THEN
+ write(lun,*)' EXCT_RMNT: string A :',(P1(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: string B :',(P2(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: total :',(PTT(i),i=1,5)
+ ENDIF
+
+ CALL TRANSFONSHELL(ecm,xm1,xm2,1.D0,3,P1n,P2n,LBD)
+ IF(LBD.eq.1) THEN
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*)' EXCT_RMNT: mass transfer failed!'
+ RETURN
+ ENDIF
+c by definition p1n is along +z in string cm, need to invert if pzA < pzB
+c IF(P2(3).gt.P1(3)) CALL SWTCH_LMNTS(P1N(3),P2N(3))
+c rotate parton-parton axis onto string-string axis
+c boost to parton-parton cm to calc. rotation angles BEFORE interaction!
+ DO K = 1,4
+ GABE(K) = PTT(K)/PTT(5)
+ ENDDO
+ CALL SIB_ALTRA(GABE(4),-GABE(1),-GABE(2),-GABE(3),
+ & P1(1),P1(2),P1(3),P1(4),
+ & P1TOT,PBM1(1),PBM1(2),PBM1(3),PBM1(4))
+c rotation factors
+ COD= PBM1(3)/P1TOT
+ SID= DSQRT(PBM1(1)**2+PBM1(2)**2)/P1TOT
+ COF=1.D0
+ SIF=0.D0
+ IF(P1TOT*SID.GT.EPS5) THEN
+ COF=PBM1(1)/(SID*P1TOT)
+ SIF=PBM1(2)/(SID*P1TOT)
+ ANORF=DSQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+c rotate parton momenta after interaction
+ CALL SIB_TRANI(P1N(1),P1N(2),P1N(3),COD,SID,COF,SIF
+ & ,PX,PY,PZ)
+ P1N(1)=PX
+ P1N(2)=PY
+ P1N(3)=PZ
+ CALL SIB_TRANI(P2N(1),P2N(2),P2N(3),COD,SID,COF,SIF
+ & ,PX,PY,PZ)
+ P2N(1)=PX
+ P2N(2)=PY
+ P2N(3)=PZ
+
+c boost massive hadrons back to hadron-hadron
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P1N(1),P1N(2),P1N(3),P1N(4),
+ & P1TOT,P1(1),P1(2),P1(3),P1(4))
+ P1(5)=P1N(5)
+ CALL SIB_ALTRA(GABE(4), GABE(1), GABE(2), GABE(3),
+ & P2N(1),P2N(2),P2N(3),P2N(4),
+ & P2TOT,P2(1),P2(2),P2(3),P2(4))
+ P2(5)=P2N(5)
+ IF(ndebug.gt.2)THEN
+ write(lun,*)' EXCT_RMNT: hadron A :',(P1(i),i=1,5)
+ write(lun,*)' EXCT_RMNT: hadron B :',(P2(i),i=1,5)
+ ENDIF
+
+c edit partons on stack
+ CALL EDT_PRTN
+ & (ISTH1,P1(1),P1(2),P1(3),P1(4),P1(5),IREF)
+ ICST11 = ICSTDX(2*(JW-1)+1,2)
+ CALL EDT_PRTN
+ & (IMST1,P1(1),P1(2),P1(3),P1(4),P1(5),ICST11)
+
+ CALL EDT_PRTN
+ & (ISTH2,P2(1),P2(2),P2(3),P2(4),P2(5),IREF)
+ ICST21 = ICSTDX(2*(JW-1)+2,2)
+ CALL EDT_PRTN
+ & (IMST2,P2(1),P2(2),P2(3),P2(4),P2(5),ICST21)
+
+ ENDIF
+
+ IREJ = 0
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE FIREBALL_4FLV(L0,P0,PCHEXin,IREJ)
+
+C-----------------------------------------------------------------------
+C... "decay" of an excited state with the quantum numbers
+C. of particle L0 and the 5-momentum P0
+C. 4 flavor generalization /FR'13
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+ CHARACTER*6 NAMP
+ COMMON /S_CNAM/ NAMP (0:99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+ DIMENSION P0(5), LL(10), PD(10,5), IFL(3), INONLEAD(2)
+ DIMENSION LRESCHEX(6:99), LRES(6:99), LCON(6:99), LPIC(-1:1)
+ DIMENSION LSTR(6:99), LPICS(-2:2)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+c charge exchange map
+ DATA (LCON(I),I=6, 33) /7,6,6,21,22,9,9,14,13,4*0,20,19,9,10,23,
+ & 24,27,27,25,30,31,28,29,32,33/
+ DATA (LCON(I),I=34, 49)
+ & /35,34,35,38,37,39,41,42,41,42,45,44,45,48,47,49/
+ DATA (LCON(I),I=50, 83) /0,52,51,54,53,4*0,71,72,10*0,
+ & 59,60,73,74,75,76,77,80,81,78,79,0,83/
+ DATA (LCON(I),I=84, 99) /84,85,86,87,88,89,4*0,94,95,96,97,98,99/
+c pion charge conversion map
+ DATA LPIC /8,6,7/
+c kaon charge conversion map
+ DATA LPICS /9,21,0,22,10/
+c charge exchange to resonances map
+ DATA (LRESCHEX(I),I=6, 33) /26,27,27,30,31,9,9,42,41,19*0/
+ DATA (LRESCHEX(I),I=34, 39) /45,44,45,48,47,39/
+ DATA (LRESCHEX(I),I=40, 49) /41,42,43,42,45,46,45,48,47,49/
+ DATA (LRESCHEX(I),I=50, 83)
+ & /0,52,51,54,53,4*0,60,59,10*0,71,72,73,75,74,
+ & 77,76,79,78,80,81,0,83/
+ DATA (LRESCHEX(I),I=84, 99)
+ & /84,85,86,87,88,89,4*0,94,95,96,97,98,99/
+c resonance excitation map
+ DATA (LRES(I),I=6, 39)
+ & /27,25,26,28,29,9,9,41,42,19*0,44,45,46,47,48,39/
+ DATA (LRES(I),I=40, 49) /40,41,42,43,44,45,46,47,48,49/
+ DATA (LRES(I),I=50, 83)
+ & /0,51,52,53,54,4*0,78,79,10*0,71,72,73,76,77,76,
+ & 77,78,79,80,81,0,83/
+ DATA (LRES(I),I=84, 99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+c strangeness excitation map
+ DATA LSTR(6:27) /6,7,8,9,10,11,12,34,39,6*0,21,22,23,24,25,26,27/
+ DATA LSTR(28:39) /28,29,30,31,32,33,44,45,46,47,48,39/
+ DATA LSTR(40:49) /40,41,42,43,44,45,46,47,48,49/
+ DATA LSTR(50:83) /0,51,52,53,54,4*0,78,79,10*0,71,72,73,76,77,76,
+ & 77,78,79,80,81,0,83/
+ DATA LSTR(84:99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+
+c... charge exchange reaction rate
+c DATA PCHEX /0.33/
+
+c default parameter: PAR(61)
+ PCHEX = PCHEXin
+
+c split charge exchange between 2 and 3+ fireballs
+ IF(IPAR(91).eq.1.and.NPI.gt.2)THEN
+ PCHEX = 1.D0-PCHEX
+ ENDIF
+
+c hyperon production rate
+ PLAM = PAR(157)
+
+c... suppression of high mass particles in fireball
+c xmpsuppr = prob. accepting additional proton
+ XMPSUPPR=PAR(33)
+ IF(ABS(XMPSUPPR).lt.EPS3) THEN
+ WRITE(LUN,*)
+ & ' Error: too low mass suppression in 4 flv fireball!'
+ WRITE(LUN,*)
+ & ' Probably PAR(33)/IPAR(14) not properly set, aborting..'
+ STOP
+ ENDIF
+ XTEMPH=(AM(6)-AM(13))/dLOG(XMPSUPPR)
+
+ IF(Ndebug.gt.3) THEN
+ WRITE(LUN,*)' FIRBALL_4FLV: called with (L0,P0):',
+ & L0,P0
+ WRITE(LUN,*)' 2nd Proton rejection prob.:',XMPSUPPR
+ WRITE(LUN,*)' fireball temperature:',XTEMPH
+ WRITE(LUN,*)' charge exchange prob.:',PCHEX
+ WRITE(LUN,*)' multiplicity width:',PAR(38)
+ ENDIF
+
+c... special vector resonance treatment for meson projectiles
+c i.e. spin exchange probability
+ PAR5def = PAR(5)
+ IF(IPAR(14).eq.-2.and.abs(kb).lt.13)THEN
+ PAR(5)=PAR(34)
+ ENDIF
+
+ NTRY=0
+ 100 NTRY=NTRY+1
+ IF(NTRY.GT.20)THEN
+ WRITE(LUN,*)' FIRBALL_4FLV: unable to sample 4flv fireball!'
+ WRITE(LUN,*)' lacking rejection mechanism, abort..'
+ CALL SIB_REJECT ('FIRBALL_4FLV ')
+c RETURN
+ ENDIF
+
+ LA = ABS(L0)
+ ISGN = ISIGN(1,L0)
+ DELTAE = P0(5) - AM(LA)
+ IF(DELTAE.lt.AM(6)+0.02D0)THEN
+ IREJ = 1
+ IF(ndebug.gt.3)
+ & WRITE(LUN,*)' FIRBALL_4FLV: too low mass!! aborting...',IREJ
+c xa=-1.
+c xa=log(xa)
+c stop
+ RETURN
+ ENDIF
+ AV = 2.D0*SQRT(DELTAE)
+
+c... select number of particles in fireball
+c at least two
+ 200 XRNDM = GASDEV(LA)
+ NPI = INT(AV*(1.D0+PAR(38)*XRNDM))
+ XMMIN = AM(LA)+DBLE(NPI-1)*AM(6)+0.02D0
+ IF(Ndebug.gt.3)
+ & WRITE(LUN,*)' NPI,av,rndm,xmin,delta',
+ & NPI,av,XRNDM,xmmin,P0(5)-XMMIN
+
+ IF((NPI.LE.1).OR.(NPI.GT.9).OR.(P0(5).LT.XMMIN))THEN
+ GOTO 200
+ ENDIF
+ IF(Ndebug.gt.3)
+ & WRITE(LUN,*)' FIRBALL_4FLV: No. of particles sampled. ',
+ & '(NPI,DELTAE,NTRY):',NPI,DELTAE,NTRY
+
+c... sample particle list
+ NTRYL=0
+ 210 CONTINUE
+c... special vector resonance treatment with meson projectile
+ IF(IPAR(14).eq.-3.and.LA.lt.13)THEN
+c form resonance from meson beam
+cdh IF(NTRY.GT.5) GOTO 211
+ IF(NTRY.GT.5) THEN
+c split last hadron again to start hadron chain
+ CALL HSPLI (LL(I+1),IFL(1),IFL(2))
+
+ IF(Ndebug.gt.3)
+ & WRITE(LUN,*)' FIRBALL_4FLV: Input hadron split. ',
+ & '(L0,IFL1,IFL2):',LL(I+1),IFL(1),IFL(2)
+ WREM = P0(5)
+ WREM2 = AM2(ABS(LL(1)))
+ INONLEAD(1)=0
+ INONLEAD(2)=0
+ ELSE
+ I=1
+ IF(PCHEX.gt.S_RNDM(LA))THEN
+ LL(I)=LRESCHEX(LA)
+ CALL HSPLI(LCON(LA),IFL1,IFL2)
+ IFL(1)=IFL1
+ IFL(2)=IFL2
+ ELSE
+ LL(I)=LRES(LA)
+ CALL HSPLI(L0,IFL1,IFL2)
+ IFL(1)=-IFL1
+ IFL(2)=-IFL2
+ ENDIF
+ WREM = P0(5)-AM(ABS(LL(1)))
+ WREM2 = AM2(ABS(LL(1)))
+ INONLEAD(1)=1
+ INONLEAD(2)=1
+ ENDIF
+
+ ELSE
+c... baryon projectile
+c first two particles defined by charge exchange
+ I=1
+ LA1=LA
+c add strangeness
+ XLIMLAM=sqrt(AM2(35)+AM2(9)+0.4)
+ IF(S_RNDM(LA1).lt.PLAM*(1-IABS(ISTR(LA))).and.
+ & DELTAE.gt.XLIMLAM)THEN
+ LA1 = LSTR(LA)
+c print *,'xlim<deltae?: ',xlimlam,deltae
+ IF(Ndebug.gt.3)
+ &write(lun,*)' FIRBALL_4FLV: producing hyperon:',namp(LA),namp(LA1)
+ endif
+ IF(PCHEX.gt.S_RNDM(LA1))THEN
+ L1=LCON(LA1)
+ if(la.eq.42) l1 = l1 + 2 * int(2.D0*S_RNDM(L1))
+ LL(I)=L1*ISGN
+c WRITE(LUN,*)' charge exchange!',ISGN*LA,'->',L1
+ ELSE
+ L1=LA1
+ LL(I)=LA1*ISGN
+ ENDIF
+c determine remaining charge and strangeness
+ IDQ=ICHP(LA1)*ISGN-ICHP(L1)*ISIGN(1,LL(I))
+ IDS=ISTR(LA)*ISGN-ISTR(L1)*ISIGN(1,LL(I))
+ IF(ABS(IDQ).gt.1) write(lun,*) 'LA,LA1,L1',LA,LA1,L1
+ IF(IABS(IDS).gt.1)
+ & write(lun,*) 'too much strangeness,LA,LA1,L1:'
+ & ,namp(LA),namp(LA1),namp(L1)
+ IF(IDS.ne.0)THEN
+ IDX = IDS-IDQ
+ LL(I+1)=LPICS(IDX) ! compensate with strange meson if
+ ELSE
+ LL(I+1)=LPIC(IDQ) ! compensate with meson
+ ENDIF
+ IF(NPI.eq.2) GOTO 300
+c split last hadron again to start hadron chain
+cdh 211 CALL HSPLI (LL(I+1),IFL(1),IFL(2))
+ CALL HSPLI (LL(I+1),IFL(1),IFL(2))
+
+ IF(Ndebug.gt.3)
+ & WRITE(LUN,*)' FIRBALL_4FLV: Input hadron split. ',
+ & '(L0,IFL1,IFL2):',LL(I+1),IFL(1),IFL(2)
+ WREM = P0(5)
+ WREM2 = AM2(ABS(LL(1)))
+ INONLEAD(1)=0
+ INONLEAD(2)=0
+ ENDIF
+
+ IF(NTRYL.gt.20) GOTO 100
+ NTRYL=NTRYL+1
+
+ 230 I=I+1
+ JT=INT(1.5D0+S_RNDM(I))
+ JR=3-JT
+ NTRYS=0
+ IFLB=IFL(JT)
+ IDM = 5
+ 240 CALL SIB_I4FLAV (IFL(JT), 0, IDM, IFL(3), LL(I))
+ IF(NTRYS.gt.50) GOTO 210
+ NTRYS=NTRYS+1
+ W=dEXP(-AM(ABS(LL(I)))/XTEMPH)
+ IF(Ndebug.gt.4)
+ & WRITE(LUN,*)' FIRBALL_4FLV: flavor added: ',
+ & '(I,NTRYS,LL(I),IFL3,W):',I,NTRYS,LL(I),IFL(3),W
+ IF(W.LT.S_RNDM(I).and.INONLEAD(JT).eq.1) GOTO 240
+
+c... kinematic limits...
+ WREM = WREM-AM(IABS(LL(I)))
+ WREM2_2=WREM2+2.D0*dSQRT(WREM2)*AM(IABS(LL(I)))+AM2(IABS(LL(I)))
+ IF(Ndebug.gt.4)
+ & WRITE(LUN,*)' FIRBALL_4FLV: kinematic limits: ',
+ & '(I,NTRYS,P05**2,WREM2):',I,NTRYS,P0(5)**2,WREM2_2
+ IF(WREM2_2+0.2D0*S_RNDM(I+1).ge.P0(5)**2) GOTO 240
+ WREM2=WREM2_2
+ IF(Ndebug.gt.3)
+ & WRITE(LUN,*)
+ & ' FIRBALL_4FLV: Hadron added: (KF,NAMP,I,NONlead,WRME2)',
+ & LL(I),NAMP(ABS(LL(I))),I,INONLEAD(JT),WREM2
+
+ IFL(JT)=-IFL(3)
+ INONLEAD(JT)=1
+ IF(I.lt.NPI-1) GOTO 230
+ IF(ABS(IFL(JT)).gt.3.and.ABS(IFL(JR)).gt.3) THEN
+ IFL(JT)=IFLB
+ GOTO 240
+ ENDIF
+
+c... close list
+ I=I+1
+ NTRYC=0
+c$$$ IAFL1 = IABS(mod(IFL(JR),100))
+c$$$ IAFL2 = IABS(mod(IFL(jt),100))
+c$$$ IF ((IAFL1/10.eq.4.or.mod(IAFL1,10).eq.4)
+c$$$ + .and.(IAFL2/10.eq.4.or.mod(IAFL2,10).eq.4))
+c$$$ + GOTO 100 ! reject two charm quarks
+c$$$ IF(IAFL1*IAFL2.GT.100) GOTO 100
+ 250 CALL SIB_I4FLAV (IFL(JT), IFL(JR), IDM, IFL(3), LL(I))
+ IF(NTRYC.gt.10) GOTO 210
+ NTRYC=NTRYC+1
+ WREM2_2=WREM2+2.D0*dSQRT(WREM2)*AM(ABS(LL(I)))+AM2(ABS(LL(I)))
+ IF(Ndebug.gt.5)
+ & WRITE(LUN,*)' FIRBALL_4FLV: closing List: (IFL1,IFL2,KF,',
+ & 'NAMP,I,NTRYC,WREM2)',
+ & IFL(JT),IFL(JR),LL(I),NAMP(ABS(LL(I))),I,NTRYC,WREM2_2
+
+ IF(WREM2_2+0.2D0*S_RNDM(I).ge.P0(5)**2) GOTO 250
+
+ 300 IF(Ndebug.gt.3)
+ & WRITE(LUN,*)
+ & ' FIRBALL_4FLV: flavors sampled. (NPI,LL,WREM,NTRYL):',
+ & NPI,(LL(ii),ii=1,NPI),WREM,NTRYL
+
+c... fill phasespace
+ CALL DECPAR (0,P0,NPI,LL,PD)
+ DO J=1,NPI
+ NP = NP+1
+ LLIST(NP) = LL(J)
+ NPORIG(NP) = IPFLAG*2
+ niorig(NP)= iiflag
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ ENDDO
+ PAR(5)=PAR5def
+ IREJ = 0
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIG_RPP2014(L,KT,SQS,SLOPE,SIGT,SIGEL,SIGINEL,RHO)
+
+C-----------------------------------------------------------------------
+C implementation of the PDG RPP 2014 cross section fit
+C proton-, pion-, kaon-nucleon interactions
+C
+c projectile dependent parameters are stored in amp array
+c dimensions are: (beam,target,exchange mode)
+c cross section is used for interaction length in AIR
+c therefore proton and neutron cross sections are averaged.
+c
+C Input:
+c L : beam id (1: proton, 2: pion, 3: kaon)
+c KT: target id (0: Nucleon, 1: proton, 2: neutron)
+c SQS: c.m. energy in GeV
+c SLOPE: fit does not include elastic slope, need input to calc
+c elastic and inelastic cross section
+c Output:
+c SIGT,SIGEL,SIGINEL,RHO
+c cross sections and ratio of real and imaginary part of ela. amp.
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+c external types
+ DOUBLE PRECISION SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO!,SIGDIF
+ integer l,kt
+c commons
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+c internal types
+ DOUBLE PRECISION S,S0,SIG,RHO1,XI
+ INTEGER k,i,INIT
+C universal constants and parameters
+ DOUBLE PRECISION M0,ETA1,ETA2,H
+ DOUBLE PRECISION AMP(3,2,3)
+ DOUBLE PRECISION XMA(3),XMB(2)
+ SAVE
+ DATA M0,ETA1,ETA2,H /2.076D0,0.412D0,0.5626D0,0.2838D0/
+c hadron-proton
+ DATA (AMP(1,1,i),i=1,3) /33.73D0, 13.67D0, 7.77D0 /
+ DATA (AMP(2,1,i),i=1,3) /18.08D0, 10.44D0, 1.977D0 /
+ DATA (AMP(3,1,i),i=1,3) /15.84D0, 5.12D0, 3.538D0 /
+c hadron-neutron
+ DATA (AMP(1,2,i),i=1,3) /33.77D0, 14.05D0, 6.93D0 /
+ DATA (AMP(2,2,i),i=1,3) /18.08D0, 10.44D0, 1.977D0 /
+ DATA (AMP(3,2,i),i=1,3) /15.73D0, 4.81D0, 1.86D0 /
+ DATA INIT/0/
+c particle masses
+c DATA XMA /0.93827D0,0.13957D0,0.493667D0/
+c DATA XMB /0.93827D0,0.939565D0/
+
+ IF(INIT.EQ.0) THEN
+c use the masses from the mass table
+ XMA(1) = AM(13) ! proton
+ XMA(2) = AM(7) ! pi+
+ XMA(3) = AM(9) ! K+
+ XMB(1) = AM(13) ! proton
+ XMB(2) = AM(14) ! neutron
+ INIT = 1
+ ENDIF
+
+ s = SQS**2
+ sigt = 0.D0
+ rho = 0.D0
+ k = kt
+ 100 if(kt.eq.0.and.k.lt.2) k = k + 1
+ s0=XMA(l)+XMB(k)+M0
+ s0=s0**2
+ xi=s/s0
+c print *,'s,s0,xi',s,s0,xi
+c print *,'eta1,eta2,h,M0',eta1,eta2,h,M0
+c print *,'P,R1,R2',amp(l,k,1),amp(l,k,2),amp(l,k,3)
+c print *,H*log(xi)**2,amp(l,k,1),amp(l,k,2)*(1.D0/xi)**eta1,
+c & amp(l,k,3)*(1.D0/xi)**eta2
+ sig = H*log(xi)**2+amp(l,k,1)+amp(l,k,2)*(1.D0/xi)**eta1
+ & +amp(l,k,3)*(1.D0/xi)**eta2
+c print *,'sig',sig
+c print *,'pi,0.5D0,0.D0',pi,0.5D0,0.D0
+c print *,pi*h*log(xi),amp(l,k,2)*xi**(-eta1),tan(eta1*pi*0.5D0),
+c & amp(l,k,3)*xi**(-eta2),(tan(pi*eta2*0.5D0)+EPS5)
+ rho1 = PI*h*log(xi)-amp(l,k,2)*xi**(-eta1)*tan(eta1*PI*0.5D0)
+ & +amp(l,k,3)*xi**(-eta2)/(tan(PI*eta2*0.5D0)+EPS5)
+c print *,'rho:',rho1
+ rho = rho + rho1/sig
+ sigt = sigt + sig
+c write(LUN,*) ' l,k,sig,rho:',l,k,sig,rho
+ if(kt.eq.0.and.k.lt.2) goto 100
+ if(kt.eq.0) then
+ sigt = sigt*0.5D0
+ rho = rho*0.5D0
+ endif
+c derive elastic and inelastic cross section
+ sigel = sigt**2*(1.D0+rho**2)/(16.D0*PI*slope*cmbarn)
+ siginel = sigt-sigel
+ IF(ndebug.gt.2)
+ & write(LUN,*)
+ & ' SIG_RPP2014: L,KT,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO',
+ & L,KT,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO
+ end
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION FERMI(XARG,X0,XALPH)
+
+C-----------------------------------------------------------------------
+C fermi function, used to smoothen samplings
+C f = 1/(1+exp((x-x0)/alpha))
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+c externals
+ DOUBLE PRECISION XARG,X0,XALPH
+c COMMONs
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+c internals
+ fermi=1.D0+exp((xarg-x0)/xalph)
+ fermi=1.D0/fermi
+ END
+C=======================================================================
+
+ SUBROUTINE SEL_RES(XM2in,KDin,IRDX,IKDH)
+
+C--------------------------------------------------------------------
+C routine that checks if excitation should go into resonant state
+C or rather should fallback to on-shell beam hadron
+C Input: XM2in : squared excitation mass
+C KDin : projectile hadron code
+C IRDX : reference to remnant on stack
+C Output: adds hadron to stack
+C IKDH : parton stack index of final hadron
+C--------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ DOUBLE PRECISION AW,AW2
+ COMMON /S_WIDTH1/ AW(99), AW2(99)
+ INTEGER MRES(6:99,2)
+ DOUBLE PRECISION XM2,XM1,DELTAE,EMIN1,EMIN2
+ INTEGER KD
+ SAVE
+
+ DATA (MRES(k,1),k=6,22) /27,25,26,28,29,0,0,51,52,6*0,30,31/
+ DATA (MRES(k,1),k=23,33) /23,24,25,26,27,28,29,30,31,27,27/
+ DATA (MRES(k,1),k=34,49) /34,35,36,37,38,39,40,41,42,43,34,35,36,
+ & 37,38,49/
+ DATA (MRES(k,1),k=50,83) /0,51,52,53,54,4*0,78,79,10*0,80,81,73,
+ & 74,75,76,77,78,79,80,81,0,83/
+ DATA (MRES(k,1),k=84,99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+
+ DATA (MRES(k,2),k=6,22) /61,62,63,64,65,0,0,53,54,6*0,66,67/
+ DATA (MRES(k,2),k=23,33) /61,61,62,63,61,64,65,66,67,61,61/
+ DATA (MRES(k,2),k=34,49) /34,35,36,37,38,39,40,41,42,43,44,45,46,
+ & 47,48,49/
+ DATA (MRES(k,2),k=50,83) /0,51,52,53,54,4*0,78,79,10*0,80,81,73,74
+ & ,75,76,77,78,79,80,81,0,83/
+ DATA (MRES(k,2),k=84,99) /94,95,96,97,98,89,4*0,94,95,96,97,98,99/
+
+ XM2 = XM2in
+ XM1 = sqrt(XM2)
+ KD = KDin
+
+C thresholds
+c fallback threshold
+ EMIN1 = PAR(76)
+
+c resonance threshold
+ EMIN2 = PAR(77)
+
+c parton stack index of incoming hadron
+ IKDH = 0
+
+c if too low, fallback on beam
+ IF(ndebug.gt.2)
+ & write(lun,*)' SEL_RES: input (XM2in,KDin,IRDX):',XM2,KD,IRDX
+ DELTAE = XM1-AM(ABS(KD))
+ IF(ndebug.gt.1)then
+ write(lun,*)' SEL_RES: DELTAE,EMIN1,EMIN2',deltae,emin1,emin2
+ write(lun,*)' SEL_RES: XM,XM1,XM2',
+ & XM1,emin1+AM(ABS(KD)),emin2+AM(ABS(KD))
+ endif
+ IF(DELTAE.LT.EMIN1)THEN
+c fallback to beam region
+ KDH = kd
+ XM1 = AM(abs(kd))
+ XM2 = AM2(abs(kd))
+
+ ELSEIF(DELTAE.LT.EMIN2)THEN
+c form resonance
+ II = 1
+ KDH = KD
+ DO WHILE (II.le.2.and.KDH.eq.KD)
+ KDD = IABS(KD)
+
+c K0s and K0l projection on K0 and K0bar
+cdh IF(KDD.eq.11.or.KDD.eq.12)KDD=21
+cdh & +INT((2.D0-EPS10)*S_RNDM(KD))
+ IF(KDD.eq.11.or.KDD.eq.12)KDD=21
+ & +INT(0.5D0+S_RNDM(KD))
+ IL = MRES(KDD,II)
+ IF(ndebug.gt.2) then
+ write(lun,*) ' SEL_RES: res. select (KD,II,IL):',
+ & KD,II,IL
+ ENDif
+cdh to prevent index of array AW2 out of range
+ IF(IL.eq.0) write(lun,*) ' SEL_RES: KD,KDD:' , KD,KDD
+ IF(IL.eq.0) CALL SIB_REJECT('SEL_RES ')
+c sample probability for resonance to occur at this mass
+c from the relativistic breit-wigner dist.
+c scale widths to artificially increase or decrease resonance occurence
+ XWDTH = PAR(94)*AW2(IL)
+ PRES = BREIT_WIGNER(XM2,AM2(IL),XWDTH)
+ IF(ndebug.gt.2)
+ & write(lun,*)
+ & ' SEL_RES: res. proposal (AM2,AW2,Prob.):',
+ & AM2(IL),XWDTH,PRES
+ IF(S_RNDM(ii).lt.PRES) KDH = ISIGN(IL,KD)
+ II = II + 1
+ ENDDO
+c no resonance selected, fallback to beam or phasespace decay?
+ IF(IPAR(59).eq.1.and.KDH.eq.KD)THEN
+c distinguish regions in deltaE
+ IF(DELTAE.LT.EMIN1)THEN
+c fallback to beam
+ XM1 = AM(abs(kdh))
+ XM2 = AM2(abs(kdh))
+ ELSE
+ KDH = 0
+ ENDIF
+ ELSE
+c case where resonance has been selected
+c or no overlap between resonance and phasespace region exists
+c set mass to pole masses of selected particles
+ XM1 = AM(abs(kdh))
+ XM2 = AM2(abs(kdh))
+ ENDIF
+ ELSE
+c neither resonance nor fallback
+ KDH = 0
+ ENDIF
+ IF(KDH.ne.0)THEN
+c add new beam hadron to stack
+ XM2in = XM2
+ CALL ADD_PRTN
+ & (0.D0,0.D0,0.D0,0.D0,XM1,KDH,2,IRDX,IKDH)
+ endif
+ IF(ndebug.gt.2)
+ & write(lun,*)' SEL_RES: output (XM2in,KDin,KDH):',XM2,KD,KDH
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION BREIT_WIGNER(S,XM2,XWDTH2)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+C peak set to one
+ x1 = (s-xm2)**2+xm2*xwdth2
+ breit_wigner = xm2*xwdth2/x1
+ end
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION TBREIT_WIGNER(S,XM2,XWDTH2)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+C breit-wigner truncated at 2*gamma from peak
+C peak set to one
+ DATA N /10/
+
+ XMLOW = MAX(XM2-N*XWDTH2,0.D0)
+ XCUT = SIGN(1.D0,S-XMLOW)
+ XCUT = MAX(XCUT,0.D0)
+ x1 = (S-xm2)**2+xm2*xwdth2
+ TBREIT_WIGNER = xcut * xm2*xwdth2/x1
+
+ end
+C=======================================================================
+
+ SUBROUTINE FRAG_MINIJET(IDX,IBAD)
+
+C-----------------------------------------------------------------------
+C routine that fragments a gluon - gluon system \FR'14
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER IDX,IBAD
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DOUBLE PRECISION PGG,PST,PBM,PTG,E0,PT2JET,PTJET,TH,FI,S_RNDM,
+ & PAR1_def,PAR24_def,PAR3_def,PAR2_1_def,PAR2_2_def,PAR5_def,
+ & PAR6_def,PAR24_2_def,XM,QMASS,DBETJ
+ DIMENSION PST(5),PBM(5),PTG(5)
+ INTEGER IST,ITGST,IBMST,IPID,IFLB,IFLT,NOLD,IS,IFL1,IFBAD,IDM
+ SAVE
+ DATA PGG /1.D0/
+
+C read partons from stack
+c references are string --> bm-parton --> tg-parton
+c read string 4momentum from stack
+ CALL RD_PRTN_4VEC(IDX,PST,IPID,IBMST)
+ CALL RD_PRTN_4VEC(IBMST,PBM,IFLB,ITGST)
+ CALL RD_PRTN_4VEC(ITGST,PTG,IFLT,IST)
+ IF(IDX.ne.IST) then
+ write(lun,*) ' FRAG_MINIJET: reference loop broken!' , IDX
+ CALL SIB_REJECT('FRAG_MINIJET ')
+ endif
+
+C.. kinematic variables
+ E0 = PST(5) ! string mass
+ PT2JET = PBM(1)**2 + PBM(2)**2
+ PTJET = sqrt(PT2JET)
+ TH = ASIN(MIN((1.D0-EPS8),2.D0*PTJET/E0))
+c FI = ASIN(MIN((1.D0-EPS8),PBM(2)/PTJET))
+ FI = TWOPI*S_RNDM(IDX)
+c TH = PST(1)
+c FI = PST(2)
+
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' FRAG_MINIJET: IDX,EE,IFLB,IFLT,PT',
+ & IDX,E0,IFLB,IFLT,PTJET,IBAD
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' FRAG_MINIJET: PTJET,TH,FI:',
+ & PTJET,TH,FI
+
+C... parameter setup (string fragmentation)
+
+c baryon production setup
+ PAR1_def = PAR(1)
+ if( NSOF+NJET.gt.0) then
+ PAR(1)= PAR(15)
+ else
+ PAR(1)= PAR(14)
+ endif
+
+C... charm setup
+ PAR24_def = PAR(24)
+ IF(IPAR(15).eq.2.or.IPAR(15).eq.3)THEN
+ PAR(24) = PAR(25)*EXP(-PAR(26)/E0)
+ ELSEIF(IPAR(15).eq.4)THEN
+ PAR(24) = PAR(27)*EXP(-PAR(26)/E0)
+ ELSEIF(IPAR(15).eq.5)THEN
+ PAR(24) = PAR(27)*EXP(-PAR(26)/E0)
+ PAR(29) = PAR(27)*EXP(-PAR(28)/E0)
+ ELSEIF(IPAR(15).eq.6.or.IPAR(15).eq.8.or.IPAR(15).eq.9.or.
+ & IPAR(15).eq.11)THEN
+ PAR(24) = PAR(27)*EXP(-PAR(28)/E0)
+ ELSEIF(IPAR(15).eq.7)THEN
+ PAR(24) = PAR(27)
+ ELSEIF(IPAR(15).eq.10)THEN
+ WRITE(LUN,*)' FRAG_minijet: charm model not implemented!'
+ CALL SIB_REJECT('FRAG_minijet ')
+ ENDIF
+
+C... strange setup
+ PAR2_1_def = PAR(2)
+ PAR3_def = PAR(3)
+ IF(IPAR(42).eq.1)THEN
+c change to constant value
+ PAR(2) = PAR(72)
+ ELSEIF(IPAR(42).eq.2)THEN
+c change according to string mass, saturating
+ PAR(2) = PAR(72)*EXP(-PAR(73)/E0)
+ ELSEIF(IPAR(42).eq.3)THEN
+c change strange diq fraction as well
+ PAR(2) = PAR(72) ! P_s / P_ud
+ PAR(3) = PAR(73) ! P_us / P_ud
+ ENDIF
+
+C... vector setup
+ PAR5_def = PAR(5)
+ PAR6_def = PAR(6)
+ IF(IPAR(43).eq.1)THEN
+c change vector rate and kaon vector rate
+ PAR(5) = PAR(74) ! P_vec
+ PAR(6) = PAR(74) ! P_K* from K
+
+ ENDIF
+
+ NOLD = NP
+ IF ( (E0.LT.8.D0) .OR. (S_RNDM(0).GT.PGG)) THEN
+C... one string case, q - qbar
+
+C sample flavor for q-qbar minijet
+ IF( IPAR(87).eq.3 )THEN
+C flavor threshold model
+c u,d -> u,d,s -> u,d,s,c
+c s and transition from massive to massless at m_s and m_c thresholds
+c beyond the charm mass all flavors are equally likely
+ CALL SIB_ICFLAV(E0**2,0,IDM,IFL1)
+
+ ELSE
+C default u,d,s model, same rates as in hadronization (string frag.)
+ PAR2_2_def = PAR(2)
+ PAR24_2_def = PAR(24)
+C set 'leading' strange fraction
+ IF(IPAR(39).eq.2) PAR(2) = PAR(66)
+c leading charm fraction
+ IF( IPAR(87).eq.1 )THEN
+ PAR(24) = PAR(150)
+ ELSEIF( IPAR(87).eq.2 )THEN
+ PAR(24) = PAR(150)*PAR(24)
+ ENDIF
+
+ IS = -1 + 2*INT((2.D0-EPS8)*S_RNDM(0))
+ 100 IFL1 = IS*(INT((2.D0+PAR(2))*S_RNDM(0))+1)
+ XM = 2.D0*QMASS(IFL1)+0.3D0
+ if(E0.LE.XM) GOTO 100
+ IF(IABS(IFL1).eq.3)THEN
+ IF(S_RNDM(IFL1).lt.PAR(24)*PAR(125))IFL1 = IS*4
+ XM = 2.D0*QMASS(IFL1)+0.3D0
+ if(E0.LE.XM) GOTO 100
+ ENDIF
+ PAR(2) = PAR2_2_def
+ PAR(24) = PAR24_2_def
+ ENDIF
+
+ CALL STRING_FRAG_4FLV
+ & (E0,IFL1,-IFL1,0.D0,0.D0,0.D0,0.D0,IFBAD,0)
+ if(IFBAD.gt.0) then
+ IF(ndebug.gt.1)
+ & WRITE(LUN,*)
+ & ' JET_FRAG: rejection in STRING_FRAG (IFL,E0,NCALL):',
+ & IFL1,E0,NCALL
+ PAR(24) = PAR24_def
+ PAR(1) = PAR1_def
+ PAR(2) = PAR2_1_def
+ PAR(5) = PAR5_def
+ PAR(6) = PAR6_def
+ PAR(3) = PAR3_def
+ RETURN
+ ENDIF
+ ELSE
+C... two string case, gluon - gluon
+ CALL GG_FRAG_4FLV(E0)
+ ENDIF
+
+c DBETJ = (DX1J-DX2J)/(DX1J+DX2J)
+ DBETJ = PST(3)/PST(4)
+ CALL SIROBO (NOLD+1,NP,TH,FI,0.D0,0.D0,DBETJ)
+
+ if(Ndebug.gt.1) WRITE(LUN,*)
+ & ' JET_FRAG: particles produced:',NP-NOLD
+ PAR(24) = PAR24_def
+ PAR(1) = PAR1_def
+ PAR(2) = PAR2_1_def
+ PAR(5) = PAR5_def
+ PAR(6) = PAR6_def
+ PAR(3) = PAR3_def
+ IBAD = 0
+ END
+C=======================================================================
+
+ SUBROUTINE INT_H_NUC (IA, SIGT, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+C...Compute with a montecarlo method the "multiple interaction structure"
+C. of an hadron-nucleus collision.
+C.
+C.
+C. INPUT : IA = mass of target nucleus
+C. SIGT (mbarn) = total hp cross section
+C. SLOPE (GeV**-2) = slope of hp elastic scattering
+C. RHO = real/imaginary part of forward elastic
+C. scattering amplitude
+C.
+C. OUTPUT : in COMMON block /CNCMS0/
+C. B = impact parameter (fm)
+C. BMAX = maximum impact parameter for generation
+C. NTRY = number of "trials" before one interaction
+C. NA = number of wounded nucleons in A
+C. Author : P.Lipari (may 1993)
+C---------------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (IAMAX=56)
+ COMMON /S_CNCM0/ B, BMAX, NTRY, NA
+ DIMENSION XA(IAMAX), YA(IAMAX)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+
+ PI=4.d0*atan(1.d0)
+
+ CC = SIGT/(4.D0*PI*SLOPE*CMBARN)
+ DEN = 2.D0*SLOPE*CMBARN*0.1D0
+ BMAX = 1.D0*10.D0 ! fm
+ NTRY = 0
+ CALL NUC_CONF (IA, XA, YA)
+1000 CONTINUE
+ B = BMAX*dSQRT(S_RNDM(0))
+ PHI = 2.D0*PI*S_RNDM(NTRY)
+ BX = B*DCOS(PHI)
+ BY = B*DSIN(PHI)
+ NTRY = NTRY + 1
+ NA = 0
+ DO JA=1,IA
+ S = (XA(JA)-BX)**2 + (YA(JA)-BY)**2
+ F = dEXP(-S/DEN)
+ PEL = CC*CC*(1.D0+RHO*RHO)*F*F
+ PINEL = 2.D0*CC*F-PEL
+ R = S_RNDM(JA)
+ IF (R .LT. PINEL) THEN
+ NA = NA + 1
+ ENDIF
+ ENDDO
+ IF (NA .EQ. 0 .and. NTRY .lt. 1000) GOTO 1000
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_REJECT(text)
+
+C-----------------------------------------------------------------------
+c subroutine dumps state of random number generator
+c at beginning of event to file then produces fpe/stops
+C----------------------------------------------------------
+ IMPLICIT NONE
+
+ character*16 text
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER II2,JJ2
+ DOUBLE PRECISION U2,C2,CD2,CM2
+ COMMON /SIB_RAND/ U2(97),C2,CD2,CM2,II2,JJ2
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION XDM
+c CHARACTER*13 FILENA
+ SAVE
+c DATA FILENA /'sib_rjctn.rnd'/
+
+ WRITE(LUN,*)
+ & ' SIB_REJECT:(from,ncall,KB,iat,ECM) ',
+ & text,ncall,kb,iat,sqs
+c produce floating point error
+ XDM = -1.D0
+ XDM = LOG(XDM)
+ STOP
+ END
+C=======================================================================
+
+ SUBROUTINE CUT_PRO (L, SQS, PTmin, NSOFR, NJETR)
+
+C-----------------------------------------------------------------------
+C... Generate a number of soft/hard (jet-)pairs for a 'projectile'
+C (K=1:p),(K=2:pi) interacting with a nucleon at sqrt(s)=SQS(GeV)
+C the interaction structure is only destinguished between nucleons
+C (L=1) and mesons (L=2), for cross sections there is a
+C distinction between pions and kaons as well (L=2 or 3).
+C For Hyperons the same cross section and interaction structure
+C as for nucleons is used (L=1).
+C
+C requires initialization by JET_INI /FR'14
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+c COMMON /S_DEBUG/ Ncall, Ndebug, Lun
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+C check if tables initialized
+ IF(NSQS.eq.0) THEN
+ WRITE(LUN,*) ' CUT_PRO: tables not initialized! aborting...'
+ xa = -1.D0
+ xa = log(xa)
+ stop
+ ENDIF
+ IF(NDEBUG.GT.1)
+ & WRITE(LUN,*) ' CUT_PRO: input: L, SQS, PTmin',L, SQS, PTmin
+
+c choose nucleon or meson table
+ K = L
+ if(K.eq.3) K = 2
+
+ AL = dLOG10 (SQS)
+ IF (AL .LT. ASQSMIN) THEN
+ WRITE(LUN,*) ' CUT_PRO: low sqrt(s) ', SQS
+ NSOFR = 1
+ NJETR = 0
+ RETURN
+ ENDIF
+ IF (AL .GT. ASQSMAX) THEN
+ WRITE(LUN,*) ' CUT_PRO: sqrt(s) out of bounds ', SQS
+ NJETR = 0
+ RETURN
+ ENDIF
+
+ J1 = INT((AL - ASQSMIN)/DASQS + 1)
+ J1 = MIN(J1,60)
+ J1 = MAX(J1,1)
+ J2 = J1+1
+ T = (AL-ASQSMIN)/DASQS - DBLE(J1-1)
+
+ R = (1.D0-EPS8)*S_RNDM(0)
+ DO I=0,NS_max
+ DO J=0,NH_max
+ IF (R.LT.(1.D0-T)*PJETC(I,J,J1,K)+T*PJETC(I,J,J2,K)) GOTO 100
+ ENDDO
+ ENDDO
+100 CONTINUE
+
+C...phase space limitation
+
+ 120 CONTINUE
+ XM = DBLE(2*I)*STR_mass_sea + DBLE(2*J)*PTmin
+ PACC = EXP(PAR(9)*(2.D0-XM)/SQS)
+ IF(S_RNDM(0).GT.PACC) THEN
+ IF(I+J.GT.1) THEN
+ IF(I.GT.0) THEN
+ I = I-1
+ GOTO 120
+ ELSE IF(J.GT.0) THEN
+ J = J-1
+ GOTO 120
+ ENDIF
+ ENDIF
+ ENDIF
+
+ NSOFR = I
+ NJETR = J
+
+ if(Ndebug.gt.1)
+ & write(lun,*)' CUT_PRO: (L,SQS,PTmin,Ns,Nh) ',K,SQS,PTmin,I,J
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE JET_INI
+
+C-----------------------------------------------------------------------
+C...Compute table of cross sections, and table of probability
+C. for the production of multiple soft and hard interactions
+C.
+C. The output of this routine is the COMMON block /S_CCSIG/
+C. that contains the cross sections h-p, h-Air, and the
+C. cumulative probability of NS soft and NH hard interactions
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ DOUBLE PRECISION SSIG_TOT,SSIG_SD1,SSIG_SD2,SSIG_DD,SSIG_B,
+ & SSIG_RHO
+ COMMON /S_CCSIG2/ SSIG_TOT(61,3),SSIG_SD1(61,3),SSIG_SD2(61,3),
+ & SSIG_DD(61,3),SSIG_B(61,3),SSIG_RHO(61,3)
+ DOUBLE PRECISION SSIG_SD1LM,SSIG_SD1HM,SSIG_SD2LM,SSIG_SD2HM,
+ & SSIG_DDLM,SSIG_DDHM
+ COMMON /S_CCSIG3/ SSIG_SD1LM(61,3),SSIG_SD1HM(61,3),
+ & SSIG_SD2LM(61,3),SSIG_SD2HM(61,3),
+ & SSIG_DDLM(61,3),SSIG_DDHM(61,3)
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+ DIMENSION Pjet(0:NS_max,0:NH_max)
+ DIMENSION SIG_df(3),SIG_df2(3,2),SIGDIF(3),SIGDIF_pi(3),
+ & PS_tab(61),PH_tab(61),PT_tab(61)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+C...spacing in energy for table of cross sections.
+
+ NSQS = 61
+ ASQSMIN = 1.D0
+ ASQSMAX = 7.D0
+ DASQS = (ASQSMAX-ASQSMIN)/DBLE(NSQS-1)
+
+C...initialization of proton and pion tables
+
+ IF(LUN.ne.6) WRITE(6,*)' Calculating cross section tables...'
+ DO KK=1,2
+
+ IF(NDEBUG.gt.0)
+ & WRITE(LUN,'(2(/,1X,A,A))')
+ & 'Table: J, sqs, PT_cut, SIG_tot, SIG_inel, B_el, ',
+ & 'rho, <n_s>, <n_h>, SIG_SD, SD1_lm, SD1_hm',
+ & '---------------------------------------------------',
+ & '----------------------------------------------'
+
+ JINT = KK
+ DO J=1, NSQS
+ ASQS = ASQSMIN + DASQS*DBLE(J-1)
+ SQS = 10.D0**ASQS
+
+ CALL SIB_SIG (JINT, SQS, PTmin,
+ & SIG_tot, SIG_inel, SIG_df, SIG_df2, B_el, Pjet)
+
+C...low-energy interpolation with data-parametrizations
+ CALL SIB_HADCSL(JINT,SQS,
+ & SIGTOT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+ if(SQS.le.100.D0) then
+ SIG_TOT = SIGTOT
+ SIG_inel = SIGINEL
+ B_EL = SLOPE
+ else if(SQS.le.1000.D0) then
+ Xi = dlog(SQS/100.D0)/2.30258509299405D0
+ SIG_TOT = Xi*SIG_TOT+(1.D0-Xi)*SIGTOT
+ SIG_inel = Xi*SIG_inel+(1.D0-Xi)*SIGINEL
+ B_EL = Xi*B_EL+(1.D0-Xi)*SLOPE
+ endif
+
+ SSIG_TOT(J,KK) = SIG_TOT
+ SSIG(J,KK) = SIG_inel
+ SSIG_SD1(J,KK) = SIGDIF(1)
+ SSIG_SD2(J,KK) = SIGDIF(2)
+ SSIG_DD(J,KK) = SIG_df(3)
+ SSIG_B(J,KK) = B_EL
+ SSIG_RHO(J,KK) = RHO
+
+ SSIG_SD1LM(J,KK) = SIG_df2(1,1)
+ SSIG_SD1HM(J,KK) = SIG_df2(1,2)
+ SSIG_SD2LM(J,KK) = SIG_df2(2,1)
+ SSIG_SD2HM(J,KK) = SIG_df2(2,2)
+ SSIG_DDLM(J,KK) = SIG_df2(3,1)
+ SSIG_DDHM(J,KK) = SIG_df2(3,2)
+
+ PSUM = 0.D0
+ PH = 0.D0
+ PS = 0.D0
+ DO NS=0,NS_max
+ DO NJ=0,NH_max
+
+ PS = PS+DBLE(NS)*Pjet(NS,NJ)
+ PH = PH+DBLE(NJ)*Pjet(NS,NJ)
+
+ PSUM = PSUM+Pjet(NS,NJ)
+ PJETC(NS,NJ,J,KK) = PSUM
+
+ ENDDO
+ ENDDO
+ PS_tab(J) = PS
+ PH_tab(J) = PH
+ PT_tab(J) = PTmin
+
+ IF(NDEBUG.gt.0)
+ & WRITE(LUN,'(3X,I2,1P,E12.3,0P,4F8.2,6F8.3)')
+ & JINT,SQS,PTmin,SIG_tot,SIG_inel,B_el,RHO,PS,PH
+ & ,SIGDIF(1)+SIGDIF(2),SIG_df2(1,1),SIG_df2(1,2)
+
+ ENDDO
+ ENDDO
+
+C...initialization of kaon tables
+
+ JINT = 3
+
+ IF(NDEBUG.gt.0)
+ & WRITE(LUN,'(2(/,1X,A,A))')
+ & 'Table: J, sqs, PT_cut, SIG_tot, SIG_inel, B_el, ',
+ & 'rho, <n_s>, <n_h>',
+ & '---------------------------------------------------',
+ & '---------------------'
+ DO J=1, NSQS
+ ASQS = ASQSMIN + DASQS*DBLE(J-1)
+ SQS = 10.D0**ASQS
+C...use pion cross section rescaled for high-energy extrapolation
+ SIG_tot = SSIG_TOT(J,2)
+ SIG_inel = SSIG(J,2)
+ SIG_df(1) = SSIG_SD1(J,2)
+ SIG_df(2) = SSIG_SD2(J,2)
+ SIG_df(3) = SSIG_DD(J,2)
+ B_el = SSIG_B(J,2)
+ PTmin = PT_tab(J)
+ PS = PS_tab(J)
+ PH = PH_tab(J)
+
+C...low-energy interpolation with data-parametrizations
+ CALL SIB_HADCSL(2,SQS,
+ & SIGTOT_pi,SIGEL_pi,SIGINEL,SIGDIF_pi,SLOPE,RHO)
+ CALL SIB_HADCSL(3,SQS,
+ & SIGTOT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+ SIG_el = (SIGEL/SIGEL_pi)*(SIG_TOT-SIG_inel)
+ SIG_TOT = (SIGTOT/SIGTOT_pi)*SIG_TOT
+ SIG_inel = SIG_TOT-SIG_el
+ SIG_df(3) = (SIGDIF(3)/SIGDIF_pi(3))*SIG_df(3)
+ if(SQS.le.100.D0) then
+ SIG_TOT = SIGTOT
+ SIG_inel = SIGINEL
+ B_EL = SLOPE
+ else if(SQS.le.1000.D0) then
+ Xi = dlog(SQS/100.D0)/2.30258509299405D0
+ SIG_TOT = Xi*SIG_TOT+(1.D0-Xi)*SIGTOT
+ SIG_inel = Xi*SIG_inel+(1.D0-Xi)*SIGINEL
+ B_EL = Xi*B_EL+(1.D0-Xi)*SLOPE
+ endif
+
+ SSIG_TOT(J,3) = SIG_TOT
+ SSIG(J,3) = SIG_inel
+ SSIG_SD1(J,3) = SIGDIF(1)
+ SSIG_SD2(J,3) = SIGDIF(2)
+ SSIG_DD(J,3) = SIG_df(3)
+ SSIG_B(J,3) = B_EL
+ SSIG_RHO(J,3) = RHO
+
+ IF(NDEBUG.gt.0)
+ & WRITE(LUN,'(3X,I2,1P,E12.3,0P,4F8.2,3F8.3)')
+ & JINT,SQS,PTmin,SIG_tot,SIG_inel,B_el,RHO,PS,PH
+
+ ENDDO
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE INI_WRITE (LUN)
+
+C-----------------------------------------------------------------------
+C This subroutine prints on unit LUN
+C a table of the cross sections used in the program
+C and of the average number of hard interactions, and the average
+C number of wounded nucleons in a hadron-air interaction
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ DIMENSION PJ(2),PS(2),PW(2)
+
+ SAVE
+ DATA ATARGET /14.514D0/
+
+ if ( ndebug .gt. 3 ) CALL PARAM_PRINT(LUN)
+ if ( ndebug .gt. 0 ) THEN
+ WRITE (LUN, 10)
+ WRITE (LUN, 15)
+ WRITE (LUN, 16)
+ WRITE (LUN, 18)
+10 FORMAT(//,' Table of cross sections, and average number',
+ & ' of minijets and wounded nucleons ')
+15 FORMAT(' [sqrt(s) in GeV, cross sections in mbarn]. ')
+16 FORMAT(' sqrt(s) sig(pp) sig(pA) <n_s> <n_j> <n_w>',
+ & ' sig(pip) sig(piA) <n_s> <n_j> <n_w>')
+18 FORMAT(1X,77('-') )
+ DO J=1,61,1
+ SQS = 10.D0**(ASQSMIN + DASQS*DBLE(J-1))
+
+ DO K=1,2
+
+ PW(K) = ATARGET*SSIG(J,K)/SSIGN(J,K)
+
+ PJ(K) = 0.D0
+ PS(K) = 0.D0
+ DO NS=0,NS_max
+ DO NJ=0,NH_max
+ IF(NJ.GT.0) THEN
+ PROB = PJETC(NS,NJ,J,K) - PJETC(NS,NJ-1,J,K)
+ ELSE IF(NS.GT.0) THEN
+ PROB = PJETC(NS,NJ,J,K) - PJETC(NS-1,NH_max,J,K)
+ ELSE
+ PROB = 0.D0
+ ENDIF
+ PJ(K) = PJ(K)+DBLE(NJ)*PROB
+ PS(K) = PS(K)+DBLE(NS)*PROB
+ ENDDO
+ ENDDO
+
+ ENDDO
+
+ WRITE(LUN,20) SQS,SSIG(J,1),SSIGN(J,1),PS(1),PJ(1),PW(1)
+ & ,SSIG(J,2),SSIGN(J,2),PS(2),PJ(2),PW(2)
+
+ ENDDO
+
+ WRITE(LUN, 18)
+ endif
+20 FORMAT(1p,E10.2,2(2F7.1,1X,3F6.2,1X))
+
+ return
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIG_AIR_INI
+
+C-----------------------------------------------------------------------
+C...Initialize the cross section and interaction lengths on air
+C. (this version initializes p-air, pi-air, and K-air cross sections)
+C.
+C. also calculates the low mass beam diffraction cross section in hAir \FR
+C. using the same lambda for all hadrons
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ COMMON /GLAUB_SCR/ XI_MAX , ALAM(61)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DIMENSION SIGDIF(3)
+
+ SAVE
+ DATA AVOG /6.0221367D-04/
+ DATA ATARGET /14.514D0/
+
+
+c PRINT *,'inel. screening in hadron - nucleus interactions'
+c ALAM = 0.5
+c PRINT *,'const. coupling: ', ALAM
+ IF ( IPAR(12).GT.0 ) THEN
+ if (ndebug.gt.0) then
+ WRITE(LUN,*) ' SIG_AIR_INI:'
+ WRITE(LUN,*)' using Goulianos param. for res.coupling..'
+ endif
+ XI_MAX = 0.02D0
+ if (ndebug.gt.0)WRITE(LUN,*)' low mass Xi_max: ' , XI_MAX
+ ENDIF
+
+C...particle loop (p, pi, K)
+ DO K=1,3
+
+ if (NDEBUG .gt. 0 ) then
+ WRITE(LUN,'(/,1X,A,A)')
+ & 'Table: J, sqs, SIGtot, SIGprod, SIG_SD,',
+ & ' Lambda '
+ WRITE(LUN,*)
+ & '-------------------------------------------------',
+ & '-------------'
+ endif
+ DO J=1,NSQS
+
+ ASQS = ASQSMIN + DASQS*DBLE(J-1)
+ SQS = 10.D0**ASQS
+
+ IF (K.EQ.1) THEN
+c Goulianos param. from GAP-2012-056, Mx**2s = 0.02
+c against PDG elastic cross section
+ CALL SIB_HADCS1(K,SQS,SIGT1,SIGEL1,SIGINEL1,SLOPE1,RHO1)
+ SIGEFF = 0.68D0*(1.D0+36.D0/SQS**2)*
+ & dlog(0.6D0+XI_MAX/1.5D0*SQS**2)
+ ALAM(J) = dSQRT(SIGEFF/SIGEL1)
+ ENDIF
+
+c CALL SIB_HADCSL(k,SQS,
+c & SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+ CALL SIB_SIGMA_HP(K,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+ CALL SIG_H_AIR
+ & (SIGT, SLOPE, RHO, ALAM(J),
+ & SSIGT, SSIGEL, SSIGQE, SSIGSD, SSIGQSD)
+
+ if (ndebug .gt. 0 ) WRITE(LUN,'(1X,I2,1P,5E12.3)')
+ & K,SQS,SSIGT,SSIGT-SSIGQE,SSIGQSD,ALAM(J)
+C particle production cross section
+ SSIGN(J,K) = SSIGT-SSIGQE
+ SSIGNSD(J,K) = SSIGQSD
+ ALINT(J,K) = 1.D0/(AVOG*SSIGn(j,K)/ATARGET)
+ ENDDO
+ ENDDO
+
+ if (ndebug .gt. 0 ) then
+ WRITE(LUN,'(/,1X,A)')
+ & ' SIG_AIR_INI: NUCLIB interaction lengths [g/cm**2]'
+ WRITE(LUN,'(1X,A)')
+ & ' sqs, p-air, pi-air, K-air'
+ DO J=1,NSQS
+ ASQS = ASQSMIN + DASQS*DBLE(J-1)
+ SQS = 10.D0**ASQS
+ WRITE(LUN,'(1X,1P,4E12.3)')
+ & SQS,ALINT(J,1),ALINT(J,2),ALINT(J,3)
+ ENDDO
+ endif
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_TARGET(NW,XCHG,KRMNT,XJET,Irec,IREJ)
+
+C----------------------------------------------------------------------- /
+C...Subroutine to sample valence and sea quark kinematic variables
+C on the target side
+C. fills IFLT,X2 and PXT,PYT
+C. 1,2 are valence quarks, 3,4 are additional sea quarks
+C. transverse momentum is shared between the val. and sea pairs
+C. X and flv are exchanged occasionally, not pt so far
+C-------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+c external types
+ DOUBLE PRECISION XJET,XCHG
+ DIMENSION XJET(NW_max)
+ INTEGER KRMNT,NW,IREC,IREJ
+ DIMENSION KRMNT(NW_max)
+
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ INTEGER IRMNT,KRB,KRT
+ DOUBLE PRECISION XRMASS,XRMEX
+ COMMON /S_RMNT/ XRMASS(2),XRMEX(2),IRMNT(NW_max),KRB,KRT(NW_max)
+
+c internal types
+ DOUBLE PRECISION XX,X2,PX,PXT,PY,PYT,PZ,PZ1,PZ2
+ DIMENSION XX(2*NW_max+2),PX(2*NW_max+2),PY(2*NW_max+2)
+ DIMENSION X2(4*NW_max),PXT(4*NW_max),PYT(4*NW_max)
+ INTEGER IFL,IFLT,IREJ1,J,J1,J2,J3,J4,JJ,JJJ,JI,I,KID,Iref1,
+ & Iref,KID1
+ DIMENSION IFL(2*NW_max+2),IFLT(4*NW_max)
+ SAVE
+
+ IREJ1 = 1
+
+ IF(ndebug.gt.2)
+ + WRITE(LUN,*)
+ + ' SAMPLE_TARGET: NW,XCHG,LRMNT,XJET,IREC,IREJ',
+ + NW,XCHG,(KRMNT(j),j=1,NW),(XJET(j),j=1,NW),IREC,IREJ
+
+ DO J=1,NW ! zero arrays
+ j1 = 1+4*(j-1)
+ j2 = j1 + 1
+ j3 = j2 + 1
+ j4 = j3 + 1
+ X2(j1) = 0.D0
+ X2(j2) = 0.D0
+ X2(j3) = 0.D0
+ X2(j4) = 0.D0
+ PXT(j1) = 0.D0
+ PXT(j2) = 0.D0
+ PXT(j3) = 0.D0
+ PXT(j4) = 0.D0
+ PyT(j1) = 0.D0
+ PyT(j2) = 0.D0
+ PyT(j3) = 0.D0
+ PyT(j4) = 0.D0
+ ENDDO
+
+ DO j=1,NW
+c read target id from event info
+ KID = KT(J)
+c reset rejection
+ IREJ = IREJ1
+c always fills remnant partons into 1,2 and c.strings into 3,4
+c so far only one interaction possible (beam is always a single hadron!)
+ CALL SAMPLE_PROJECTILE
+ + (KID,1,KRMNT(j),XCHG,XJET(j),XX,PX,PY,IFL,KID1,IREJ)
+ IF(IREJ.ne.0) RETURN
+
+c write to target variables
+ do jj=3-2*KRMNT(j),4
+ ji = jj+4*(j-1)
+ IFLT(ji) = IFL(jj)
+ X2(ji) = XX(jj)
+ PXT(ji) = PX(jj)
+ PYT(ji) = PY(jj)
+ enddo
+
+ IF(KRMNT(j).ne.0)THEN
+c by convention hadron is split such that diq is 2nd flv
+c for string frag routine argument flv1 is along +z, flv2 -z
+c by convention again flv2 in the remnant is passed to +z and flv1 to -z
+c therefor on the target side the flavors need to be switched such that
+c the diq is along -z
+ j1 = 1+4*(j-1)
+ j2 = j1 + 1
+ CALL ISWTCH_LMNTS(IFLT(j1),IFLT(j2))
+ ENDIF
+
+c central strings
+c flavors need to be switched as well (strictly speaking color)
+c in dual-parton model: q : color , diq : anticolor
+c need to combine q with diq for color neutral system..
+ j3 = 3+4*(j-1)
+ j4 = j3 + 1
+ CALL ISWTCH_LMNTS(IFLT(j3),IFLT(j4))
+ CALL SWTCH_LMNTS(X2(j3),X2(j4))
+
+c reset remnant id
+c might have changed in flavor exchange (actually color)...
+ KRT(J) = KID1
+ ENDDO
+
+C.. write target partons to stack
+ DO I=1,NW
+ IF(KRMNT(I).ne.0)THEN
+c add proto-remnant
+ j1 = 1+4*(i-1)
+ j2 = j1 + 1
+ CALL ADD_PRTN(PXT(J1)+PXT(J2),PYT(J1)+PYT(J2),
+ & -0.5D0*SQS*(X2(J1)+X2(j2)),0.5D0*SQS*(X2(J1)+X2(j2)),
+ & 0.D0,-2,0,0,Iref1)
+ ITGRDX(I,1) = Iref1
+ CALL ADD_INT_REF(Iref1,IINTDX(I))
+c add quarks to stack
+ do j = 1,2
+ jj = 4*(i-1)+j
+ jjj = 4*(i-1)+j + 2
+ pz1 = (0.5D0*SQS*X2(JJ))**2
+c PZ1 = (0.5D0*SQS*X2(JJ))**2-PXT(JJ)**2-PYT(JJ)**2
+ CALL ADD_PRTN(PXT(JJ),PYT(JJ),-sqrt(pz1),
+ & 0.5D0*SQS*X2(JJ),0.D0,IFLT(JJ),1,Iref1,Iref)
+ ITGRDX(I,j+1) = Iref
+ pz2 = (0.5D0*SQS*X2(JJj))**2
+c pz2 = (0.5D0*SQS*X2(JJj))**2-PXT(JJj)**2-PYT(JJj)**2
+ CALL ADD_PRTN(PXT(JJj),PYT(JJj),-sqrt(pz2),
+ & 0.5D0*SQS*X2(JJj),0.D0,IFLT(JJj),1,0,Iref)
+ ICSTDX(2*(I-1)+j,3) = Iref
+ enddo
+ else
+ do j = 3,4
+ jj = 4*(i-1)+j
+ pz = (0.5D0*SQS*X2(JJ))**2
+c pz = (0.5D0*SQS*X2(JJ))**2-PXT(JJ)**2-PYT(JJ)**2
+ CALL ADD_PRTN(PXT(JJ),PYT(JJ),-sqrt(pz),
+ & 0.5D0*SQS*X2(JJ),0.D0,IFLT(JJ),1,0,Iref)
+ ICSTDX(2*(I-1)+(J-2),3) = Iref
+ enddo
+ ENDIF
+ ENDDO
+ IF(NDEBUG.GT.3) CALL PRNT_PRTN_STCK
+
+ IREJ = 0
+ END
+C=======================================================================
+
+ SUBROUTINE SIGMA_NUC_AIR(IA,ECM,KINT)
+
+C-----------------------------------------------------------------------
+C. wrapping for SIGMA_NUC in NUCLIB
+C...Compute with a montecarlo method the "production"
+C. and "quasi-elastic" cross section for
+C. a nucleus-nucleus interaction
+C. nucleon - nucleon cross section is taken from
+C. the table calculated by SIBYLL_INI
+C.
+C. INPUT : IA = mass of target nucleus
+C. ECM = c.m. energy
+C. KINT = number of interactions to generate
+C. OUTPUT : SIGMA (mbarn) = "production" cross section
+C. DSIGMA " = error
+C. SIGQE " = "quasi-elastic" cross section
+C. DSIGQE " = error
+C. in COMMON /NUCNUCSIG/
+C. additional output is in the common block /CPROBAB/
+C. Prob(n_A), Prob(n_B), Prob(n_int)
+C..........................................................................
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /NUCNUCSIG/ SIGPROD,DSIGPROD,SIGQE,DSIGQE,IBE,ITG
+ DIMENSION SIGDIF(3)
+ SAVE
+ DATA NDB /0/
+
+ DSIGPROD = 0.D0
+ DSIGQE = 0.D0
+
+ CALL SIB_SIGMA_HP(1,ECM,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+ CALL SIGMA_AIR(IA,SIGINEL,SIGEL,KINT,SIGPROD,DSIGPROD,
+ + SIGQE,DSIGQE)
+ IBE = IA
+ ITG = 0
+ IF(DSIGPROD/SIGPROD.gt.0.1D0)THEN
+ IF( NDB.EQ.0 )
+ + PRINT*,'SIG_NUC_AIR: warning! : large error in cross section'
+ NDB = 1
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIG_NUC_AIR(IA,SIGPP,SIGPPEL,KINT)
+
+C-----------------------------------------------------------------------
+C. wrapping for SIGMA_NUC in NUCLIB
+C...Compute with a montecarlo method the "production"
+C. and "quasi-elastic" cross section for
+C. a nucleus-nucleus interaction
+C.
+C. INPUT : IA = mass of target nucleus
+C. IB = mass of projectile nucleus
+C. SIGPP (mbarn) = inelastic pp cross section
+C. SIGPPEL = elastic pp cross section
+C. KINT = number of interactions to generate
+C. OUTPUT : SIGMA (mbarn) = "production" cross section
+C. DSIGMA " = error
+C. SIGQE " = "quasi-elastic" cross section
+C. DSIGQE " = error
+C. in COMMON /NUCNUCSIG/
+C. additional output is in the common block /CPROBAB/
+C. Prob(n_A), Prob(n_B), Prob(n_int)
+C..........................................................................
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /NUCNUCSIG/ SIGPROD,DSIGPROD,SIGQE,DSIGQE,IBE,ITG
+ SAVE
+
+ DSIGPROD = 0.D0
+ DSIGQE = 0.D0
+ CALL SIGMA_AIR(IA,SIGPP,SIGPPEL,KINT,SIGPROD,DSIGPROD,
+ + SIGQE,DSIGQE)
+ IBE = IA
+ ITG = 0
+ IF(DSIGPROD/SIGPROD.gt.0.1D0)THEN
+ IF( NDB.EQ.0 )
+ + PRINT*,'SIG_NUC_AIR: warning! : large error in cross section'
+ NDB = 1
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIG_NUC_NUC(IA,IB,SIGPP,SIGPPEL,KINT)
+
+C-----------------------------------------------------------------------
+C. wrapping for SIGMA_NUC in NUCLIB
+C...Compute with a montecarlo method the "production"
+C. and "quasi-elastic" cross section for
+C. a nucleus-nucleus interaction
+C.
+C. INPUT : IA = mass of target nucleus
+C. IB = mass of projectile nucleus
+C. SIGPP (mbarn) = inelastic pp cross section
+C. SIGPPEL = elastic pp cross section
+C. KINT = number of interactions to generate
+C. OUTPUT : SIGMA (mbarn) = "production" cross section
+C. DSIGMA " = error
+C. SIGQE " = "quasi-elastic" cross section
+C. DSIGQE " = error
+C. in COMMON /NUCNUCSIG/
+C. additional output is in the common block /CPROBAB/
+C. Prob(n_A), Prob(n_B), Prob(n_int)
+C..........................................................................
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /NUCNUCSIG/ SIGPROD,DSIGPROD,SIGQE,DSIGQE,IBE,ITG
+ SAVE
+
+ DSIGPROD = 0.D0
+ DSIGQE = 0.D0
+ CALL SIGMA_MC(IA,IB,SIGPP,SIGPPEL,KINT,SIGPROD,DSIGPROD,
+ + SIGQE,DSIGQE)
+ IBE = IA
+ ITG = IB
+ IF(DSIGPROD/SIGPROD.gt.0.1D0)THEN
+ IF( NDB.EQ.0 )
+ + PRINT*,'SIG_NUC_NUC: warning! : large error in cross section'
+ NDB = 1
+ ENDIF
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIG_HAD_NUC(L,IA,ECM,ALAM,ICSMOD,IPARM)
+
+C-----------------------------------------------------------------------
+C**********************************************************************
+C...Subroutine to compute hadron-nucleus cross sections
+C. according to:
+C. R.J. Glauber and G.Matthiae Nucl.Phys. B21, 135, (1970)
+C.
+C.
+C. INPUT : L projectile particle (1:p , 2:pi, 3:K )
+C. IA mass-number of target nucleus
+C. SSIG (mbarn) total pp cross section
+C. SLOPE (GeV**-2) elastic scattering slope for pp
+C. ALPHA real/imaginary part of the forward pp elastic
+C. scattering amplitude
+C. ALAM: inel. screening coupling
+C.
+C. OUTPUT : ( in COMMON block /NUCSIG/ )
+C. SIGT = Total cross section
+C. SIGEL = Elastic cross section
+C. SIGQEL = Elastic + Quasi elastic cross section
+C. SIGSD = beam single diff. cross section
+C......................................................................
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /NUCSIG/ SIGT,SIGEL,SIGINEL,SIGQE,SIGSD,
+ + SIGQSD,SIGPPT,SIGPPEL,SIGPPSD,ITG
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+c double precision dplab
+c double precision DSSIG,DSLOPE,DALPHA,DALAM
+c DOUBLE PRECISION SG1,SGEL1,SGQE1,SGSD1,SGQSD1
+ DIMENSION SSIGDIF(3),XM(4)
+ SAVE
+c DATA XM / 0.93956563, 0.13956995, 0.493677, 0.93956563 /
+ DATA GEV2MB /0.3893D0/
+ DATA INIT/0/
+
+ IF(INIT.EQ.0) THEN
+c use the masses from the mass table
+cdh XM(1) = AM(14) ! neutron
+ XM(1) = AM(13) ! proton
+ XM(2) = AM(7) ! pi+
+ XM(3) = AM(9) ! K+
+ XM(4) = AM(14) ! neutron
+ INIT = 1
+ ENDIF
+
+ xma = XM(L)
+ xmb = (XM(1)+XM(4))/2.D0
+
+ Plab = dsqrt(((ecm**2-xma**2-xmb**2)/(2.D0*xmb))**2-xma**2)
+
+C hadron proton cross section to be used for calculation
+
+ IF( ICSMOD.EQ.1 ) THEN
+c sibyll 2.1 cross section
+
+ CALL SIB_SIGMA_HP(L,ECM,SSIG,SSIGEL,SSIGINEL,SSIGDIF,SLOPE,RHO)
+
+ ELSEIF( ICSMOD.EQ.0 ) THEN
+c cross section parametrizations
+
+ if(Ecm.gt.12.D0) then
+
+ CALL SIB_HADCSL(L,ECM,SSIG,SSIGEL,SSIGINEL,SSIGDIF,SLOPE,RHO)
+
+ else
+c low energy parametrization
+ SSIG = (sigtot_pp(Plab)+sigtot_pn(plab))/2.D0
+ SSIGEL = (sigela_pp(Plab)+sigela_pn(plab))/2.D0
+C parametrization from U. Dersch et al. Nucl Phys. B579 (2000) 277
+ RHO = 6.8D0/plab**0.742D0-6.6D0/plab**0.599D0+0.124D0
+ SLOPE = (1.D0+RHO**2)*SIGTOT**2/(16.D0*PI*SIGEL)/GEV2MB
+ SSIGDIF(1) = 0.D0
+ SSIGDIF(2) = 0.D0
+ SSIGDIF(3) = 0.D0
+ endif
+ ENDIF
+ SSIGSD = SSIGDIF(1) + SSIGDIF(2)
+
+c energy dependence of lambda parameter
+ if( IPARM.eq.1 ) then
+
+c empirical parametrization
+ SIGEFF = 0.25D0*Ecm**2/(Ecm**2+10.D0**2)*dLOG(1000.D0*Ecm**2)
+ & -1.5D0/2.D0
+ SIGEFF = MAX(0.D0,SIGEFF)
+
+ ALAM = dsqrt(SIGEFF/SSIGEL)
+
+ SSIGSD = 2.D0 * SIGEFF
+
+ elseif( IPARM.EQ.2 ) then
+
+c lambda derived from proton interactions
+ CALL SIB_HADCS1(1,ECM,SIGT1,SSIGEL1,SIGINEL1,SLOPE1,RHO1)
+C parametrization by Goulianos for diff. interaction
+ SIGEFF = 0.68D0*(1.D0+36.D0/Ecm**2)
+ & *LOG(0.6D0+0.02D0/1.5D0*Ecm**2)
+ SIGEFF = MAX(0.D0,SIGEFF)
+ ALAM = sqrt(SIGEFF/SSIGEL1)
+
+ SSIGSD = 2.D0 * SIGEFF
+
+ elseif( IPARM.eq.3)then
+
+C data from Paolo Lipari's note
+ SIGTOT = 129.D0
+ SIGEL = 0.3D0*SIGTOT
+ SIGEFF = ECM*0.01D0*SIGTOT
+ RHO = 0.D0
+ SLOPE = (1.D0+RHO**2)*SIGTOT**2/(16.D0*PI*SIGEL)/GEV2MB
+ ALAM = dsqrt(SIGEFF/SIGEL)
+
+ SSIG = SIGTOT
+ SSIGEL = SIGEL
+ SSIGSD = 2.D0 * SIGEFF
+ endif
+
+ ALPHA = RHO
+
+C hadron - nucleon cross section
+
+ IF( IA.EQ.0 ) THEN
+ CALL SIG_H_AIR
+ + (SSIG,SLOPE,ALPHA,ALAM,SG1,SGEL1,SGQE1,SGSD1,SGQSD1)
+ else
+ CALL GLAUBER2
+ + (IA,SSIG,SLOPE,ALPHA,ALAM,SG1,SGEL1,SGQE1,SGSD1,SGQSD1)
+ endif
+
+ ITG = IA
+
+ SIGPPT = SSIG
+ SIGPPEL = SSIGEL
+ SIGPPSD = SSIGSD
+ SIGT = SG1
+ SIGEL = SGEL1
+ SIGQE = SGQE1
+ SIGSD = SGSD1
+ SIGQSD = SGQSD1
+ SIGINEL = SIGT - SIGEL
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIG_H_AIR
+ + (SSIG,SLOPE,ALPHA,ALAM,SIGT,SIGEL,SIGQE,SIGSD,SIGQSD)
+
+C-----------------------------------------------------------------------
+C**********************************************************************
+C...Subroutine to compute hadron-air cross sections
+C. according to:
+C. R.J. Glauber and G.Matthiae Nucl.Phys. B21, 135, (1970)
+C.
+C. Air is a linear combination of Nitrogen and oxygen
+C.
+C. INPUT : SSIG (mbarn) total pp cross section
+C. SLOPE (GeV**-2) elastic scattering slope for pp
+C. ALPHA real/imaginary part of the forward pp elastic
+C. scattering amplitude
+C. OUTPUT : SIGT = Total cross section
+C. SIGEL = Elastic cross section
+C. SIGQEL = Elastic + Quasi elastic cross section
+C. SIGSD = single diff. cross section (beam)
+C. SIGQSD = Elastic + Quasi elastic SD cross section (beam)
+C.
+C. ALSO including interface from single precision in SIBYLL to
+C. double precision in GLAUBER2
+C......................................................................
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+ DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air
+
+ CALL GLAUBER2
+ + (14,SSIG,SLOPE,ALPHA,ALAM,SIG1,SIGEL1,SIGQE1,SIGSD1,SIGQSD1)
+ CALL GLAUBER2
+ + (16,SSIG,SLOPE,ALPHA,ALAM,SIG2,SIGEL2,SIGQE2,SIGSD2,SIGQSD2)
+
+ SIGT = (1.D0-FOX)*SIG1 + FOX*SIG2
+ SIGEL = (1.D0-FOX)*SIGEL1 + FOX*SIGEL2
+ SIGQE = (1.D0-FOX)*SIGQE1 + FOX*SIGQE2
+ SIGSD = (1.D0-FOX)*SIGSD1 + FOX*SIGSD2
+ SIGQSD = (1.D0-FOX)*SIGQSD1 + FOX*SIGQSD2
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE GLAUBER2
+ + (JA,SSIG,SLOPE,ALPHA,ALAM,SIGT,SIGEL,SIGQEL,SIGSD,SIGQSD)
+
+C-----------------------------------------------------------------------
+C...Subroutine to compute hadron-Nucleus cross sections
+C. according to:
+C. R.J. Glauber and G.Matthiae Nucl.Phys. B21, 135, (1970)
+C.
+C. This formulas assume that the target nucleus density is
+C. modeled by a shell-model form. A reasonable range of models
+C. is 4 < JA < 18
+C.
+C. This is a modified version with a two-channel model for inelastic
+C. intermediate states of low mass (R. Engel 2012/03/26)
+C.
+C. INPUT : A = mass number of the nucleus
+C. SSIG (mbarn) total pp cross section
+C. SLOPE (GeV**-2) elastic scattering slope for pp
+C. ALAM enhancement factor (sqrt of sigma_sd1/sigma_ela)
+C. ALPHA real/imaginary part of the forward pp elastic
+C. scattering amplitude
+C. OUTPUT : SIGT = Total cross section
+C. SIGEL = Elastic cross section
+C. SIGQEL = Elastic + Quasi elastic cross section
+C. SIGSD = single diff. cross section
+C. SIGQSD = Quasi single diff. cross section
+C.
+C. Internally everything is computed in GeV (length = GeV**-1)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CA0SH/ R0, R02
+ COMPLEX*16 ZS1, ZS2, ZP1, ZP2, Z1, Z2, OM12
+ DIMENSION RR(18)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+ DATA BMAX /100.D0/ ! GeV**-1
+ DATA NB /500/
+C...data on Sqrt[<r**2>] (fm). (A=5,8 are not correct).
+C From Barett and Jackson
+ DATA RR /0.81,2.095,1.88,1.674, 2.56,2.56,2.41,2.5,2.519,2.45
+ + ,2.37, 2.460, 2.440, 2.54, 2.58, 2.718, 2.662,2.789 /
+
+ A = DBLE(JA)
+C...Parameter of shell model density
+ R0 = RR(JA)/0.197D0/dSQRT(5.D0/2.D0 - 4.D0/A) ! GeV**-1
+ R02 = R0*R0
+
+ SIG1 = (1.D0+ALAM) * SSIG/CMBARN ! GeV**-2
+ SIG2 = (1.D0-ALAM) * SSIG/CMBARN
+ SIG12 = dSQRT((1.D0+ALAM)*(1.D0-ALAM)) * SSIG/CMBARN
+ DB = BMAX/DBLE(NB)
+ SUM0 = 0.D0
+ SUM1 = 0.D0
+ SUM2 = 0.D0
+ SUM3 = 0.D0
+ SUM4 = 0.D0
+ DO JB=1,NB
+
+ B = DB*(DBLE(JB)-0.5D0)
+
+ GS1 = GLAUBGS_D (B,SLOPE, SIG1)
+ XS1 = (1.D0- GS1)
+ YS1 = GS1*ALPHA
+ ZS1 = DCMPLX(XS1,YS1)
+
+ GP1 = GLAUBGP_D (B,SLOPE, SIG1)
+ XP1 = (1.D0- GP1)
+ YP1 = GP1*ALPHA
+ ZP1 = DCMPLX(XP1,YP1)
+
+ Z1 = ZS1**4 * ZP1**(A-4.D0)
+
+ GS2 = GLAUBGS_D (B,SLOPE, SIG2)
+ XS2 = (1.D0- GS2)
+ YS2 = GS2*ALPHA
+ ZS2 = DCMPLX(XS2,YS2)
+
+ GP2 = GLAUBGP_D (B,SLOPE, SIG2)
+ XP2 = (1.D0- GP2)
+ YP2 = GP2*ALPHA
+ ZP2 = DCMPLX(XP2,YP2)
+
+ Z2 = ZS2**4 * ZP2**(A-4.D0)
+
+ XZ = 0.5D0 * DREAL(Z1+Z2)
+ YZ = 0.5D0 * DIMAG(Z1+Z2)
+
+ XZ2 = 0.5D0 * DREAL(Z2-Z1)
+ YZ2 = 0.5D0 * DIMAG(Z2-Z1)
+
+ SUM0 = SUM0 + (1.D0-XZ)*B
+
+ SUM1 = SUM1 + ((1.D0-XZ)**2 + YZ**2)*B
+
+ SUM3 = SUM3 + (XZ2**2 + YZ2**2)*B
+
+ OMS1 = OMEGAS_D(B,SIG1,SLOPE,ALPHA)
+ OMS2 = OMEGAS_D(B,SIG2,SLOPE,ALPHA)
+ OMS12 = OMEGAS_D(B,SIG12,SLOPE,ALPHA)
+
+ OMP1 = OMEGAP_D(B,SIG1,SLOPE,ALPHA)
+ OMP2 = OMEGAP_D(B,SIG2,SLOPE,ALPHA)
+ OMP12 = OMEGAP_D(B,SIG12,SLOPE,ALPHA)
+
+ OM1 = (1.D0 - 2.D0*GS1 + OMS1)**4
+ & * (1.D0 - 2.D0*GP1 + OMP1)**(A-4.D0)
+ OM2 = (1.D0 - 2.D0*GS2 + OMS2)**4
+ & * (1.D0 - 2.D0*GP2 + OMP2)**(A-4.D0)
+ OM12 = (1.D0 - GS1*DCMPLX(1.D0,ALPHA)-GS2*DCMPLX(1.D0,-ALPHA)
+ & + OMS12)**4
+ & * (1.D0 - GP1*DCMPLX(1.D0,ALPHA)-GP2*DCMPLX(1.D0,-ALPHA)
+ & + OMP12)**(A-4.D0)
+ SUM2 = SUM2 + (1.D0-2.D0*XZ + (OM1+OM2)/4.D0
+ & + DREAL(OM12)/2.D0)*B
+ SUM4 = SUM4 + ((OM1+OM2)/4.D0
+ & - DREAL(OM12)/2.D0)*B
+
+ ENDDO
+
+ SIGT = SUM0 * DB * 4.D0*PI * CMBARN
+ SIGEL = SUM1 * DB * TWOPI * CMBARN
+ SIGQEL = SUM2 * DB * TWOPI * CMBARN
+ SIGSD = SUM3 * DB * TWOPI * CMBARN
+ SIGQSD = SUM4 * DB * TWOPI * CMBARN
+ END
+
+C=======================================================================
+
+ FUNCTION GLAUBGS_D (B,SLOPE, SIG)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CA0SH/ A0, A02
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ GAMMA2 = A02/4.D0 + 0.5D0*SLOPE
+ ARG = B**2/(4.D0*GAMMA2)
+ GLAUBGS_D = SIG/(8.D0*PI*GAMMA2) * EXP(-ARG)
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION GLAUBGP_D (B,SLOPE, SIG)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CA0SH/ A0, A02
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ GAMMA2 = A02/4.D0 + 0.5D0*SLOPE
+ ARG = B**2/(4.D0*GAMMA2)
+ C1 = 1.D0- A02/(6.D0*GAMMA2)*(1.D0-ARG)
+ GLAUBGP_D = SIG/(8.D0*PI*GAMMA2) * C1 * EXP(-ARG)
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION OMEGAS_D (B, SIG, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CA0SH/ A0, A02
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ ETA2 = 0.25D0*(A02 + SLOPE)
+ F02 = SIG*SIG*(1.D0+RHO*RHO)/(16.D0*PI**2)
+ ARG = -B*B/(4.D0*ETA2)
+ OMEGAS_D = F02/(4.D0*ETA2*SLOPE) *EXP(ARG)
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION OMEGAP_D (B, SIG, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CA0SH/ A0, A02
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ ETA2 = 0.25D0*(A02 + SLOPE)
+ F02 = SIG*SIG*(1.D0+RHO*RHO)/(16.D0*PI**2)
+ ARG = -B*B/(4.D0*ETA2)
+ OMEGAP_D=F02/(4.D0*ETA2*SLOPE)*(1.D0-A02/(6.D0*ETA2)*(1.D0+ARG))
+ $ *EXP(ARG)
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE REMOVE_PI0(XRATE,N1,N2)
+
+C-----------------------------------------------------------------------
+C routine to exchange pi0 on stack with charged pions
+C violating charge conservation.
+C final pions will be off-shell
+C
+C Input: exchange rate and stack positions inbetween
+C which pions shall be exchanged.
+C
+C---------------------------------------------------------
+ IMPLICIT NONE
+c Commons
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+C external types
+ DOUBLE PRECISION XRATE
+ INTEGER N1,N2
+C internals
+ INTEGER I,LL,LA,IFPI0
+ DOUBLE PRECISION S_RNDM
+ SAVE
+
+ IF(NDEBUG.gt.0)write(lun,*)
+ & ' REMOVE_PI0: Rate,Mode:',xrate,IPAR(50)
+C select exchange model
+ IF(IPAR(50).eq.1)THEN
+C stack loop
+ DO I=N1,N2
+ LL = MOD(LLIST(I),10000)
+ LA = IABS(LL)
+c IF(LA.eq.6)THEN
+ IFPI0=(1-MIN(IABS(1-LA/6),1))*MAX(1-MOD(LA,6),0)
+c replace with pi+ or pi-
+ LL=LL+IFPI0*(2-INT(MIN((2.D0+XRATE)*S_RNDM(LA),
+ & 3.D0-EPS10)))
+ LLIST(I) = LL
+ IF(NDEBUG.gt.1)
+ & WRITE(LUN,*) ' REMOVE_PI0: LA,IFPI0,LNEW:',LA,IFPI0,LL
+ ENDDO
+ ENDIF
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_SEA_INDV(KRMNT,XMINA,XMINA_SEA,NSEA,
+ & XREM0,ALPHA,ASUP,XQMASS,XMAX,XX,IREJ)
+
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+
+ DOUBLE PRECISION XMINA,XMINA_SEA,XREM0,ALPHA,ASUP,XQMASS,XMAX
+ INTEGER NSEA,KRMNT
+ DOUBLE PRECISION XX
+ DIMENSION XX(2*NW_max+2)
+ INTEGER IREJ
+
+ DOUBLE PRECISION XREM,XKIN,X1,X2,pt,S_RNDM,XQM
+ INTEGER ICNT2,J,jj1,jj2
+ SAVE
+ DATA ICNT2 /0/
+
+ IF(ndebug.gt.2)
+ & write(lun,*)' SAMPLE_SEA_INDV: called with ',
+ & '(KRMNT,XMINA,XMINA_SEA,NSEA,XREM0,ALPHA,ASUP,XQMASS,XMAX):',
+ & KRMNT,XMINA,XMINA_SEA,NSEA,XREM0,ALPHA,ASUP,XQMASS,XMAX
+ XREM = 0.D0
+ XKIN = 0.1D0
+ XQM = XQMASS
+ ITRY(4) = 0
+ DO WHILE ( XREM .lt. XMINA )
+ XREM = XREM0
+ IF ( XREM .LT. 2.D0*XMINA + Nsea*XMINA_SEA
+ & +XKIN*(1.5D0-S_RNDM(ICNT2)) ) THEN
+ IREJ = 2 ! resample event
+ RETURN
+ ENDIF
+ IF(ITRY(4).gt.Nsea/2*NREJ(4))THEN
+ ICNT2 = ICNT2 + 1
+ IF(ndebug.gt.2)THEN
+ IF(ICNT2.le.5)THEN
+ write(lun,*)' SAMPLE_SEA_INDV: rejection!'
+ write(lun,*)' reached max. no. of trials!', NREJ(4)
+ write(lun,*)' XREM0,N,XMIN:' ,XREM0,Nsea,XMINA_SEA
+ ENDIF
+ IF(ICNT2.eq.5)
+ & write(lun,*)' last warning of this type..'
+ ENDIF
+ IREJ = IPAR(51)
+ RETURN
+ ENDIF
+ DO j=1,Nsea/2
+c scale for interactions other than first if Nw>1
+ IF(IPAR(75).eq.1.and.J.gt.1) XQM = XQM*PAR(118)
+ CALL SAMPLE_SEA(ALPHA,ASUP,XQM,XMAX,x1,x2,pt)
+ jj1 = 2 + 2*(j-1) + 1
+ IF(KRMNT.eq.0) jj1 = 4+2*(j-1) + 1
+ jj2 = jj1 + 1
+ XX(jj1) = x1
+ XX(jj2) = x2
+ XREM = XREM - XX(jj1) - XX(jj2)
+ IF(NDEBUG.gt.2)
+ & WRITE(LUN,*) ' x-frac: JW,X3,X4,XREM',
+ & J,XX(jj1),XX(jj2),XREM
+ ENDDO
+ ITRY(4) = ITRY(4) + 1
+ IF(NDEBUG.gt.1) WRITE(LUN,*)
+ & ' SAMPLE_SEA_INDV: ISMPL,XREM0,XREM,XMINA,XMINSEA',
+ & ITRY(4),XREM0,XREM,XMINA,XMINA_SEA
+ ENDDO
+ XREM0 = XREM
+ IREJ = 0
+ END
+C=======================================================================
+
+ SUBROUTINE FORCE_VECTORS(XRATE,N1,N2)
+
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c external types
+ double precision xrate
+ integer n1,n2
+
+c internal types
+ integer ipi2vec,lcon,lreschex,ll,la,la_new,i,j,kba
+ DIMENSION IPI2VEC(99)
+ double precision pz2,xmts,xf,xfs,S_RNDM!,pts
+
+ DIMENSION LCON(6:43),LRESCHEX(6:39)
+ INTEGER IFIRST
+ SAVE
+c charge exchange map, i.e. pip -> pi0 ...
+ DATA LCON /7,6,6,22,21,9,9,14,13,4*0,20,19,10,9,23,24,27,27,25,
+ & 31,30,29,28,32,33,35,34,35,38,37,39,41,42,41,42/
+c charge and spin exchange map, i.e. pip -> rho0
+c approximate, proton and neutron should go to N(1520) not Delta
+ DATA LRESCHEX /26,27,27,31,30,9,9,42,41,19*0,45,44,45,48,47,39/
+ DATA IFIRST /0/
+
+ if(ifirst.eq.0)then
+ print *,'initializing..'
+ do j=1,99
+ IPI2VEC(J) = J
+ enddo
+ IPI2VEC(6) = 27 ! pi(0) ---> rho(0)
+ IPI2VEC(7) = 25 ! pi+ ---> rho+
+ IPI2VEC(8) = 26 ! pi- ---> rho-
+ ifirst = 1
+ endif
+
+ KBA = IABS(KB)
+
+ IF(IPAR(45).eq.1)THEN
+c trivial exchange model
+ do I=N1,N2
+c replace pions with vector mesons
+ LL = mod(llist(I),10000)
+ LA = abs(LL)
+ IF(S_RNDM(I).lt.xrate)then
+c put back on mass shell
+ la_new = IPI2VEC(LA)
+ xmts = p(i,1)**2 + p(i,2)**2 + am2(la_new)
+ pz2 = p(i,4)**2 - xmts
+ if(pz2.gt.EPS8)then
+ p(i,3) = sign(sqrt(pz2),p(i,3))
+ p(i,5) = am(la_new)
+ LLIST(I) = ISIGN(la_new,ll)
+ endif
+ endif
+ enddo
+
+ ELSEIF(IPAR(45).eq.2)THEN
+c large xf only, neutral pions only
+ do I=N1,N2
+ LL = mod(llist(I),10000)
+ LA = abs(LL)
+ IF(LA.eq.6)then
+ xf = 2.D0*p(i,3)/SQS
+ IF(S_RNDM(I).lt.xrate*xf)then
+c exhcange and put back on mass shell
+ la_new = IPI2VEC(la)
+ xmts = p(i,1)**2 + p(i,2)**2 + am2(la_new)
+ pz2 = p(i,4)**2 - xmts
+ if(pz2.gt.EPS8)then
+ p(i,3) = sign(dsqrt(pz2),p(i,3))
+ p(i,5) = am(la_new)
+ LLIST(I) = ISIGN(la_new,ll)
+ endif
+ endif
+ endif
+ enddo
+
+ ELSEIF(IPAR(45).eq.3)THEN
+c large xf only, charge and spin exchange
+ do I=N1,N2
+ LL = mod(llist(I),10000)
+ LA = abs(LL)
+ IF(ll.eq.LCON(KBA))then
+ xf = 2.D0*p(i,3)/sqs
+ IF(S_RNDM(I).lt.xrate*xf)then
+c replace charge exchange product of beam with
+c charge and spin exchange product, i.e.
+c pip-beam -> rho0 instead of pip-beam -> pi0
+c so replace pi0 with rho0 in final state
+ la_new = LRESCHEX(KBA)
+c put back on mass shell
+ xmts = p(i,1)**2 + p(i,2)**2 + am2(la_new)
+ pz2 = p(i,4)**2 - xmts
+ if(pz2.gt.EPS8)then
+ p(i,3) = sign(dsqrt(pz2),p(i,3))
+ p(i,5) = am(la_new)
+ LLIST(I) = ISIGN(la_new,ll)
+ endif
+ endif
+ endif
+ enddo
+
+ ELSEIF(IPAR(45).eq.4)THEN
+c large xf only, charge and spin exchange
+ do I=N1,N2
+ LL = mod(llist(I),10000)
+ LA = abs(ll)
+ IF(LL.eq.LCON(KBA))then
+ xf = 2.D0*p(i,3)/sqs
+ xfs = xf ** 2
+ IF(S_RNDM(I).lt.xrate*xfs)then
+c replace charge exchange product of beam with
+c charge and spin exchange product, i.e.
+c pip-beam -> rho0 instead of pip-beam -> pi0
+c so replace pi0 with rho0 in final state
+ la_new = LRESCHEX(KBA)
+c put back on mass shell
+ xmts = p(i,1)**2 + p(i,2)**2 + am2(la_new)
+ pz2 = p(i,4)**2 - xmts
+ if(pz2.gt.EPS8)then
+ p(i,3) = sign(dsqrt(pz2),p(i,3))
+ p(i,5) = am(la_new)
+ LLIST(I) = ISIGN(la_new,ll)
+ endif
+ endif
+ endif
+ enddo
+ ENDIF
+ if(ndebug.ge.5) CALL SIB_LIST(6)
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_BEAM(KID,NW,XCHG,KRMNT,XJET,IREJ)
+
+C-----------------------------------------------------------------------
+C...Subroutine to sample valence and sea quark kinematics
+C. fills IFL?,X? and PX?,PY?
+C. 1,2 are valence quarks, 3,4 are additional sea quarks
+C. transverse momentum is shared between the val. and sea pairs
+C. X and flv are exchanged occasionally
+C-------------------------------------------------------------------
+ IMPLICIT NONE
+
+ DOUBLE PRECISION XCHG,XJET
+ INTEGER KID,NW,KRMNT,IREJ
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+
+ INTEGER IRMNT,KRB,KRT
+ DOUBLE PRECISION XRMASS,XRMEX
+ COMMON /S_RMNT/ XRMASS(2),XRMEX(2),IRMNT(NW_max),KRB,KRT(NW_max)
+
+ DOUBLE PRECISION X1,PXB,PYB
+ DIMENSION X1(2*NW_max+2),PXB(2*NW_max+2),PYB(2*NW_max+2)
+ INTEGER IFLB,KID1,J,J1,J2,J3,J4,Iref1,Iref,Idm
+ DIMENSION IFLB(2*NW_max+2)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+c default rejection
+c options are: 1: resample minijets (Xjet)..
+c 2: resample non-diff event (Ns,Nh)..
+c 3: resample event (Nw,diff,ndiff)..
+ IREJ = 1
+
+ IF(ndebug.gt.2)
+ + WRITE(LUN,*)
+ + ' SAMPLE_BEAM: KID,NW,XCHG,KRMNT,XJET,IREJ',
+ + KID,NW,XCHG,KRMNT,XJET,IREJ
+
+ CALL SAMPLE_PROJECTILE
+ + (KID,NW,KRMNT,XCHG,XJET,X1,PXB,PYB,IFLB,KID1,IREJ)
+ IF(IREJ.ne.0) RETURN
+
+c set remnant id to beam
+c will be changed if flavor is exchanged between central strings and remnant
+ KRB = KID1
+
+C.. write beam partons to stack
+c order is: val1, val2, q, qbar etc
+ IF(KRMNT.ne.0)THEN
+ j1 = 1
+ j2 = 2
+c add proto-remnant (still massless)
+ CALL ADD_PRTN(PXB(J1)+PXB(J2),PYB(J1)+PYB(J2),
+ & 0.5D0*SQS*(X1(J1)+X1(J2)),
+ & 0.5D0*SQS*(X1(J1)+X1(J2)),0.D0,2,0,0,Iref1)
+ IBMRDX(1) = Iref1
+c beam remnant always associated with first interaction
+ CALL ADD_INT_REF(Iref1,IINTDX(1))
+c add quarks designated for remnant
+ IF(KID.lt.0)THEN
+c if beam is antibaryon then hspli puts diq into 1st flv
+c need to switch to fit call to string frag routine
+c such that diq is along +z
+ CALL ISWTCH_LMNTS(IFLB(j1),IFLB(j2))
+ ENDIF
+ CALL ADD_PRTN(PXB(J1),PYB(J1),0.5D0*SQS*X1(J1),
+ & 0.5D0*SQS*X1(J1),0.D0,IFLB(J1),1,Iref1,Iref)
+ IBMRDX(2) = Iref
+ CALL ADD_PRTN(PXB(J2),PYB(J2),0.5D0*SQS*X1(J2),
+ & 0.5D0*SQS*X1(J2),0.D0,IFLB(J2),1,Idm,Iref)
+ IBMRDX(3) = Iref
+ ENDIF
+ DO j=1,NW
+ j3 = 3+(j-1)*2
+ j4 = j3+1
+c add sea quarks
+ CALL ADD_PRTN(PXB(J3),PYB(J3),0.5D0*SQS*X1(J3),
+ & 0.5D0*SQS*X1(J3),0.D0,IFLB(J3),1,0,Iref)
+ ICSTDX(2*(J-1)+1,2) = Iref
+ CALL ADD_PRTN(PXB(J4),PYB(J4),0.5D0*SQS*X1(J4),
+ & 0.5D0*SQS*X1(J4),0.D0,IFLB(J4),1,0,Iref)
+ ICSTDX(2*(J-1)+2,2) = Iref
+c add parton index to cache
+ ENDDO
+ IF(NDEBUG.GT.3) CALL PRNT_PRTN_STCK
+
+ IREJ = 0
+
+ END
+C=======================================================================
+
+ SUBROUTINE FRAG_INCHRNT_DIFF(IDX,LBAD)
+
+C-----------------------------------------------------------------------
+C routine that fragments a diffractive system \FR'15
+C
+C INPUT: IDX : parton stack index of 4momentum
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER IDX,LBAD
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+ DOUBLE PRECISION PST,PDIFF,GABE,P2,EE,P1TOT
+ DIMENSION PST(5),PDIFF(5),GABE(4),P2(4)
+ INTEGER IDIFF1,IDIFF,IPID,L0,JDIFF,NOLD,LXBAD,K,II
+ SAVE
+
+ LBAD = 2
+
+c references are diff --> diff.hadron --> bm-partons --> tg-partons
+c only diff and diff. hadron are read out
+c read diff 4momentum from stack
+ CALL RD_PRTN_4VEC(IDX,PST,IPID,IDIFF1)
+ CALL RD_PRTN_4VEC(IDIFF1,PDIFF,L0,IDIFF)
+
+C kinematic variables
+ EE = PDIFF(5) ! center of mass energy in diff. system
+
+c set diffraction code of system (1:beam,2:target,3:double)
+ JDIFF = ABS(IPID)/10
+
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' FRAG_INCHRNT_DIFF: IDX,EE,L0',
+ & IDX,EE,L0
+
+ IPFLAG = -1
+
+ NOLD = NP
+
+c diffractive interaction in center-of-mass system of (sea,rmnt)-nuc
+ CALL SIB_DIFF(L0,JDIFF,EE,0,LXBAD)
+ IF(LXBAD.ne.0) THEN
+ IF(NDEBUG.gt.1)
+ & WRITE(LUN,*)' FRAG_INCHRNT_DIFF: fragmentation rejection'
+ RETURN
+ ENDIF
+ IF(NDEBUG.gt.1)
+ & WRITE(LUN,*)' FRAG_INCHRNT_DIFF: particles before/after :',
+ & NOLD,NP
+
+c boost to hadron - hadron center-of-mass
+ do ii=1,4
+ gabe(ii) = PDIFF(ii)/PDIFF(5)
+ enddo
+ DO K=NOLD+1,NP
+ CALL SIB_ALTRA(gabe(4),gabe(1),gabe(2),
+ & gabe(3),P(k,1),p(k,2),p(k,3),p(k,4),
+ & P1TOT,p2(1),p2(2),p2(3),p2(4))
+ do ii=1,4
+ P(K,ii)=P2(ii)
+ enddo
+ ENDDO
+
+ LBAD = 0
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_MINIJET
+ & (L,NW,NNJET,NNSOF,NJET,NSOF,X1JET,X2JET,LBAD)
+
+C-----------------------------------------------------------------------
+C routine to sample minijets
+C INPUT: L - hadron type (1:nucleon,2:pion or 3:kaon)
+C NW - number of hadron-nucleon interactions
+C NNJET(1:NW) - number of hard interactions per nucleon
+C NNSOF(1:NW) - number of soft interactions per nucleon
+C OUTPUT: X1JET - momentum fraction of beam in minijets
+C X2JET(1:NW) - momentum fraction of target in minijets
+C
+C in addition minijets are added to parton stack
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ INTEGER L,NW,NNJET,NNSOF,NJET,NSOF,LBAD
+ DOUBLE PRECISION X1JET,X2JET
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+ DIMENSION NNSOF(NW_max),NNJET(NW_max),X2JET(NW_max)
+
+c internal types
+ INTEGER NALL,JW,JJ,IREF,IREFG1,IREFG2,NSOF_JW,II
+ DOUBLE PRECISION X1JJ,X2JJ,PTJET,FI,S_RNDM,SQSHALF,XM,
+ & X1S,X2S,PTSOF,PZ,EN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ if(Ndebug.gt.1) WRITE(LUN,*)
+ & ' SAMPLE_MINIJETS: (L,NW,NNJET,NNSOF):',
+ & L,NW,(NNJET(ii),ii=1,nw),(NNSOF(ii),ii=1,nw)
+
+ IF(L.eq.0) THEN
+ WRITE(LUN,*) 'SAMPLE_minijets: unknown particle? L=',L
+ CALL SIB_REJECT('SAMPLE_minijets ')
+ ENDIF
+
+ NJET = 0
+ NSOF = 0
+ Nall = 0
+ X1JET = 0.D0
+ DO JW=1,NW
+C...hard sea-sea interactions
+ X2JET(JW) = 0.D0
+ DO JJ=1,NNJET(JW)
+ Nall = Nall+1
+ NJET = NJET+1
+ CALL SAMPLE_HARD (L,X1Jj,X2Jj,PTJET)
+ X1JET = X1JET + X1Jj
+ X2JET(JW) = X2JET(JW)+X2Jj
+ if(Ndebug.gt.2) THEN
+ WRITE(LUN,*)
+ & ' SAMPLE_MINIJETS: hard JJ,JW,X1JET,X2JET(JW):',
+ & JJ,JW,X1JET,X2JET(JW)
+ WRITE(LUN,*)
+ & ' X1,X2,PT:',X1JJ,X2JJ,PTJET
+ ENDIF
+ IF ((X2JET(JW).GT.0.9D0).OR.(X1JET.GT.0.9D0)) then
+ if(Ndebug.gt.2) WRITE(LUN,*)
+ & ' SAMPLE_MINIJETS: not enough phase space',
+ & ' (Ncall,Njet,lbad):',Ncall,Njet,lBAD
+ return
+ ENDIF
+ FI = TWOPI*S_RNDM(JJ)
+ XM = SQS*sqrt(X1jj*X2jj)
+ SQSHALF = 0.5D0*SQS
+c TH = ASIN(MIN((1.D0-EPS8),2.D0*PTJET/XM))
+c add gluon-gluon string to stack
+ CALL ADD_PRTN
+ & (0.D0,0.D0,SQSHALF*(X1jj-X2jj),SQSHALF*(X1jj+X2jj),
+ & XM,100,0,0,Iref)
+ CALL ADD_INT_REF(Iref,IINTDX(JW))
+c add gluon-gluon system to hard minijet index
+ IHMJDX(NJET) = Iref
+c add gluons to stack
+ CALL ADD_PRTN(PTJET*COS(FI),PTJET*SIN(FI),
+ & SQSHALF*X1jj,SQSHALF*X1jj,0.D0,0,1,0,Irefg1)
+ CALL ADD_PRTN(-PTJET*COS(FI),-PTJET*SIN(FI),
+ & -SQSHALF*X2jj,SQSHALF*X2jj,0.D0,0,1,Iref,Irefg2)
+c set up references
+c minijet --> gluon1 --> gluon2 --> minijet
+ CALL ADD_REF(Irefg1,Irefg2)
+ CALL ADD_REF(Iref,Irefg1)
+
+ ENDDO
+
+C...soft sea-sea interactions
+ NSOF_JW = 0
+ DO JJ=1,NNSOF(JW)-1
+c different soft distributions
+ CALL SAMPLE_SOFT6 (STR_mass_sea,X1S,X2S,PTSOF)
+ IF ((X2JET(JW)+X2S.LT.0.9D0).AND.(X1JET+X1S.LT.0.9D0)) THEN
+ NSOF = NSOF+1
+ Nall = Nall+1
+ NSOF_JW = NSOF_JW+1
+ X1JET = X1JET + X1S
+ X2JET(JW) = X2JET(JW)+X2S
+c add to stack
+c add gluon-gluon string to stack
+ XM = SQS*SQRT(X1S*X2S)
+ SQSHALF = 0.5D0*SQS
+ PZ = SQSHALF*(X1S-X2S)
+ EN = SQSHALF*(X1S+X2S)
+ FI = TWOPI*S_RNDM(JJ)
+ CALL ADD_PRTN(0.D0,0.D0,PZ,EN,XM,10,0,0,Iref)
+ CALL ADD_INT_REF(Iref,IINTDX(JW))
+c add gluons to stack
+c add gluon-gluon system to soft minijet index
+ ISMJDX(NSOF) = Iref
+ CALL ADD_PRTN(PTSOF*COS(FI),PTSOF*SIN(FI),
+ & SQSHALF*X1S,SQSHALF*X1S,0.D0,0,1,0,Irefg1)
+ CALL ADD_PRTN(-PTSOF*COS(FI),-PTSOF*SIN(FI),
+ & -SQSHALF*X2S,SQSHALF*X2S,0.D0,0,1,Iref,Irefg2)
+c set up references
+c minijet --> gluon1 --> gluon2 --> minijet
+ CALL ADD_REF(Irefg1,Irefg2)
+ CALL ADD_REF(Iref,Irefg1)
+ IF(Ndebug.gt.2)THEN
+ WRITE(LUN,*)
+ & ' SAMPLE_MINIJETS: soft JJ,JW,X1JET,X2JET(JW):',
+ & JJ,JW,X1JET,X2JET(JW)
+ WRITE(LUN,*)
+ & ' X1,X2,PT:',X1s,X2s,PTSOF
+ ENDIF
+ ELSE
+ IF(Ndebug.gt.1) WRITE(LUN,*)
+ & ' SAMPLE_MINIJETS: not enough phase space',
+ & ' (Ncall,Nsof,lbad):',Ncall,Njet,lBAD
+ RETURN
+ ENDIF
+ ENDDO
+ NNSOF(JW) = NSOF_JW+1
+ ENDDO
+ lbad = 0
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_SIGMA_EXT
+ & (L0,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO)
+
+C-----------------------------------------------------------------------
+C Hadron-proton cross sections
+C taken from EXTERNAL(!) interpolation table (calculated elsewhere)
+C can be used to run NUCLIB with alternative cross section/int.length
+C
+C input: L 1,2,3 proton-,pion-,kaon-proton
+C SQS sqrt(s)
+C
+C output: SIGT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGINEL inelastic cross section (mb)
+C SLOPE elastic slope parameter (GeV^-2)
+C RHO real/imaginary part of forward amplitude
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ DOUBLE PRECISION SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO
+ INTEGER L0
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c external cross section tables
+C cross sections in model: 23rc1_sib23
+ INTEGER K
+ DOUBLE PRECISION SSIG_TOT(61,3)
+ DOUBLE PRECISION SSIG(61,3)
+ DOUBLE PRECISION SSIG_B(61,3)
+ DOUBLE PRECISION SSIG_RHO(61,3)
+c internal type declarations
+ DOUBLE PRECISION T,AL,ASQSMIN,ASQSMAX,DASQS
+ INTEGER LL,L,J1,NSQS
+ DIMENSION LL(39)
+ SAVE
+C proton-proton:
+C total cross section
+ DATA (SSIG_TOT(K,1),K= 1, 61) /
+ &3.8328D+01,3.8267D+01,3.8435D+01,3.8838D+01,3.9463D+01,
+ &4.0288D+01,4.1277D+01,4.2391D+01,4.3586D+01,4.4918D+01,
+ &4.6354D+01,4.7836D+01,4.9394D+01,5.1050D+01,5.2835D+01,
+ &5.4789D+01,5.6957D+01,5.9392D+01,6.2151D+01,6.5294D+01,
+ &6.8883D+01,7.2529D+01,7.6458D+01,8.0673D+01,8.5172D+01,
+ &8.9955D+01,9.5017D+01,1.0035D+02,1.0595D+02,1.1181D+02,
+ &1.1790D+02,1.2423D+02,1.3077D+02,1.3751D+02,1.4444D+02,
+ &1.5156D+02,1.5885D+02,1.6631D+02,1.7392D+02,1.8169D+02,
+ &1.8960D+02,1.9766D+02,2.0584D+02,2.1416D+02,2.2260D+02,
+ &2.3115D+02,2.3982D+02,2.4860D+02,2.5749D+02,2.6648D+02,
+ &2.7556D+02,2.8475D+02,2.9403D+02,3.0340D+02,3.1287D+02,
+ &3.2242D+02,3.3206D+02,3.4179D+02,3.5159D+02,3.6149D+02,
+ &3.7146D+02/
+C inel. cross section
+ DATA (SSIG(K,1),K= 1, 61) /
+ &3.0881D+01,3.1156D+01,3.1540D+01,3.2046D+01,3.2673D+01,
+ &3.3410D+01,3.4236D+01,3.5126D+01,3.6050D+01,3.7062D+01,
+ &3.8139D+01,3.9280D+01,4.0476D+01,4.1740D+01,4.3092D+01,
+ &4.4556D+01,4.6161D+01,4.7937D+01,4.9918D+01,5.2137D+01,
+ &5.4629D+01,5.7057D+01,5.9635D+01,6.2361D+01,6.5230D+01,
+ &6.8236D+01,7.1376D+01,7.4643D+01,7.8029D+01,8.1529D+01,
+ &8.5138D+01,8.8847D+01,9.2654D+01,9.6552D+01,1.0054D+02,
+ &1.0461D+02,1.0875D+02,1.1298D+02,1.1727D+02,1.2164D+02,
+ &1.2607D+02,1.3057D+02,1.3512D+02,1.3974D+02,1.4441D+02,
+ &1.4914D+02,1.5393D+02,1.5877D+02,1.6365D+02,1.6859D+02,
+ &1.7357D+02,1.7860D+02,1.8368D+02,1.8880D+02,1.9397D+02,
+ &1.9918D+02,2.0443D+02,2.0972D+02,2.1505D+02,2.2042D+02,
+ &2.2583D+02/
+C slope parameter
+ DATA (SSIG_B(K,1),K= 1, 61) /
+ &1.0828D+01,1.1096D+01,1.1363D+01,1.1629D+01,1.1894D+01,
+ &1.2159D+01,1.2424D+01,1.2688D+01,1.2953D+01,1.3217D+01,
+ &1.3482D+01,1.3728D+01,1.3980D+01,1.4237D+01,1.4500D+01,
+ &1.4770D+01,1.5047D+01,1.5333D+01,1.5632D+01,1.5945D+01,
+ &1.6278D+01,1.6613D+01,1.6961D+01,1.7324D+01,1.7703D+01,
+ &1.8100D+01,1.8515D+01,1.8949D+01,1.9404D+01,1.9880D+01,
+ &2.0378D+01,2.0899D+01,2.1443D+01,2.2010D+01,2.2600D+01,
+ &2.3212D+01,2.3845D+01,2.4499D+01,2.5173D+01,2.5867D+01,
+ &2.6579D+01,2.7309D+01,2.8055D+01,2.8819D+01,2.9599D+01,
+ &3.0394D+01,3.1205D+01,3.2031D+01,3.2870D+01,3.3724D+01,
+ &3.4590D+01,3.5470D+01,3.6362D+01,3.7266D+01,3.8181D+01,
+ &3.9109D+01,4.0047D+01,4.0995D+01,4.1955D+01,4.2924D+01,
+ &4.3903D+01/
+C
+ DATA (SSIG_RHO(K,1),K= 1, 61) /
+ &-1.8490D-01,-1.2654D-01,-7.7648D-02,-3.7250D-02,-4.2495D-03,
+ &2.2457D-02,4.3908D-02,6.1032D-02,7.4637D-02,8.5403D-02,
+ &9.3897D-02,1.0058D-01,1.0583D-01,1.0995D-01,1.1318D-01,
+ &1.1571D-01,1.1768D-01,1.1923D-01,1.2044D-01,1.2138D-01,
+ &1.2212D-01,1.2269D-01,1.2314D-01,1.2349D-01,1.2376D-01,
+ &1.2398D-01,1.2414D-01,1.2427D-01,1.2437D-01,1.2445D-01,
+ &1.2451D-01,1.2456D-01,1.2460D-01,1.2463D-01,1.2465D-01,
+ &1.2467D-01,1.2468D-01,1.2470D-01,1.2470D-01,1.2471D-01,
+ &1.2472D-01,1.2472D-01,1.2472D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01/
+C pion-proton:
+C total cross section
+ DATA (SSIG_TOT(K,2),K= 1, 61) /
+ &2.3119D+01,2.3225D+01,2.3487D+01,2.3867D+01,2.4328D+01,
+ &2.4886D+01,2.5529D+01,2.6249D+01,2.7038D+01,2.7890D+01,
+ &2.8802D+01,2.9725D+01,3.0766D+01,3.1961D+01,3.3355D+01,
+ &3.4994D+01,3.6931D+01,3.9223D+01,4.1928D+01,4.5104D+01,
+ &4.8811D+01,5.2129D+01,5.5692D+01,5.9498D+01,6.3545D+01,
+ &6.7832D+01,7.2350D+01,7.7094D+01,8.2059D+01,8.7235D+01,
+ &9.2612D+01,9.8183D+01,1.0394D+02,1.0987D+02,1.1596D+02,
+ &1.2221D+02,1.2862D+02,1.3518D+02,1.4188D+02,1.4871D+02,
+ &1.5568D+02,1.6278D+02,1.7001D+02,1.7735D+02,1.8481D+02,
+ &1.9239D+02,2.0008D+02,2.0788D+02,2.1578D+02,2.2378D+02,
+ &2.3189D+02,2.4009D+02,2.4839D+02,2.5679D+02,2.6528D+02,
+ &2.7386D+02,2.8253D+02,2.9129D+02,3.0014D+02,3.0908D+02,
+ &3.1810D+02/
+C inel. cross section
+ DATA (SSIG(K,2),K= 1, 61) /
+ &1.9941D+01,2.0212D+01,2.0566D+01,2.0995D+01,2.1492D+01,
+ &2.1955D+01,2.2477D+01,2.3056D+01,2.3685D+01,2.4360D+01,
+ &2.5076D+01,2.5721D+01,2.6455D+01,2.7304D+01,2.8298D+01,
+ &2.9466D+01,3.0844D+01,3.2465D+01,3.4364D+01,3.6574D+01,
+ &3.9128D+01,4.1429D+01,4.3864D+01,4.6428D+01,4.9117D+01,
+ &5.1926D+01,5.4847D+01,5.7875D+01,6.1006D+01,6.4233D+01,
+ &6.7551D+01,7.0956D+01,7.4444D+01,7.8010D+01,8.1651D+01,
+ &8.5363D+01,8.9145D+01,9.2994D+01,9.6906D+01,1.0088D+02,
+ &1.0491D+02,1.0901D+02,1.1315D+02,1.1736D+02,1.2161D+02,
+ &1.2592D+02,1.3028D+02,1.3469D+02,1.3915D+02,1.4366D+02,
+ &1.4821D+02,1.5281D+02,1.5746D+02,1.6215D+02,1.6688D+02,
+ &1.7166D+02,1.7648D+02,1.8134D+02,1.8625D+02,1.9119D+02,
+ &1.9618D+02/
+C slope parameter
+ DATA (SSIG_B(K,2),K= 1, 61) /
+ &1.0120D+01,1.0270D+01,1.0416D+01,1.0559D+01,1.0698D+01,
+ &1.0836D+01,1.0971D+01,1.1105D+01,1.1238D+01,1.1371D+01,
+ &1.1502D+01,1.1435D+01,1.1392D+01,1.1377D+01,1.1395D+01,
+ &1.1452D+01,1.1549D+01,1.1690D+01,1.1878D+01,1.2118D+01,
+ &1.2413D+01,1.2781D+01,1.3163D+01,1.3558D+01,1.3967D+01,
+ &1.4391D+01,1.4829D+01,1.5282D+01,1.5751D+01,1.6236D+01,
+ &1.6738D+01,1.7256D+01,1.7791D+01,1.8343D+01,1.8912D+01,
+ &1.9498D+01,2.0100D+01,2.0718D+01,2.1351D+01,2.1999D+01,
+ &2.2661D+01,2.3338D+01,2.4029D+01,2.4733D+01,2.5451D+01,
+ &2.6182D+01,2.6926D+01,2.7682D+01,2.8450D+01,2.9231D+01,
+ &3.0023D+01,3.0827D+01,3.1642D+01,3.2468D+01,3.3305D+01,
+ &3.4152D+01,3.5010D+01,3.5878D+01,3.6757D+01,3.7645D+01,
+ &3.8543D+01/
+C
+ DATA (SSIG_RHO(K,2),K= 1, 61) /
+ &-6.7332D-02,-3.0879D-02,-5.4256D-04,2.4410D-02,4.4739D-02,
+ &6.1172D-02,7.4371D-02,8.4920D-02,9.3315D-02,9.9976D-02,
+ &1.0525D-01,1.0941D-01,1.1269D-01,1.1528D-01,1.1731D-01,
+ &1.1891D-01,1.2016D-01,1.2115D-01,1.2192D-01,1.2253D-01,
+ &1.2300D-01,1.2338D-01,1.2367D-01,1.2390D-01,1.2408D-01,
+ &1.2422D-01,1.2433D-01,1.2442D-01,1.2449D-01,1.2454D-01,
+ &1.2458D-01,1.2462D-01,1.2464D-01,1.2466D-01,1.2468D-01,
+ &1.2469D-01,1.2470D-01,1.2471D-01,1.2471D-01,1.2472D-01,
+ &1.2472D-01,1.2472D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01/
+C kaon-proton:
+C total cross section
+ DATA (SSIG_TOT(K,3),K= 1, 61) /
+ &1.8299D+01,1.8827D+01,1.9408D+01,2.0016D+01,2.0633D+01,
+ &2.1318D+01,2.2044D+01,2.2810D+01,2.3615D+01,2.4458D+01,
+ &2.5339D+01,2.6253D+01,2.7209D+01,2.8235D+01,2.9372D+01,
+ &3.0683D+01,3.2250D+01,3.4173D+01,3.6576D+01,3.9602D+01,
+ &4.3417D+01,4.6380D+01,4.9560D+01,5.2954D+01,5.6563D+01,
+ &6.0384D+01,6.4411D+01,6.8639D+01,7.3062D+01,7.7674D+01,
+ &8.2464D+01,8.7426D+01,9.2551D+01,9.7831D+01,1.0326D+02,
+ &1.0883D+02,1.1454D+02,1.2037D+02,1.2634D+02,1.3243D+02,
+ &1.3864D+02,1.4496D+02,1.5139D+02,1.5793D+02,1.6458D+02,
+ &1.7133D+02,1.7817D+02,1.8512D+02,1.9215D+02,1.9928D+02,
+ &2.0650D+02,2.1380D+02,2.2119D+02,2.2867D+02,2.3623D+02,
+ &2.4387D+02,2.5160D+02,2.5940D+02,2.6728D+02,2.7524D+02,
+ &2.8328D+02/
+C inel. cross section
+ DATA (SSIG(K,3),K= 1, 61) /
+ &1.6131D+01,1.6687D+01,1.7256D+01,1.7835D+01,1.8414D+01,
+ &1.8990D+01,1.9596D+01,2.0228D+01,2.0887D+01,2.1572D+01,
+ &2.2282D+01,2.3007D+01,2.3748D+01,2.4525D+01,2.5373D+01,
+ &2.6337D+01,2.7475D+01,2.8859D+01,3.0574D+01,3.2718D+01,
+ &3.5399D+01,3.7521D+01,3.9768D+01,4.2138D+01,4.4626D+01,
+ &4.7228D+01,4.9939D+01,5.2752D+01,5.5666D+01,5.8673D+01,
+ &6.1770D+01,6.4952D+01,6.8215D+01,7.1555D+01,7.4969D+01,
+ &7.8453D+01,8.2007D+01,8.5626D+01,8.9308D+01,9.3052D+01,
+ &9.6855D+01,1.0072D+02,1.0463D+02,1.0861D+02,1.1263D+02,
+ &1.1671D+02,1.2084D+02,1.2501D+02,1.2924D+02,1.3352D+02,
+ &1.3784D+02,1.4220D+02,1.4662D+02,1.5107D+02,1.5558D+02,
+ &1.6012D+02,1.6471D+02,1.6934D+02,1.7401D+02,1.7872D+02,
+ &1.8348D+02/
+C slope parameter
+ DATA (SSIG_B(K,3),K= 1, 61) /
+ &8.8352D+00,9.1363D+00,9.4011D+00,9.6374D+00,9.8515D+00,
+ &1.0048D+01,1.0230D+01,1.0402D+01,1.0564D+01,1.0720D+01,
+ &1.0870D+01,1.1058D+01,1.1205D+01,1.1322D+01,1.1419D+01,
+ &1.1511D+01,1.1611D+01,1.1734D+01,1.1897D+01,1.2116D+01,
+ &1.2413D+01,1.2781D+01,1.3163D+01,1.3558D+01,1.3967D+01,
+ &1.4391D+01,1.4829D+01,1.5282D+01,1.5751D+01,1.6236D+01,
+ &1.6738D+01,1.7256D+01,1.7791D+01,1.8343D+01,1.8912D+01,
+ &1.9498D+01,2.0100D+01,2.0718D+01,2.1351D+01,2.1999D+01,
+ &2.2661D+01,2.3338D+01,2.4029D+01,2.4733D+01,2.5451D+01,
+ &2.6182D+01,2.6926D+01,2.7682D+01,2.8450D+01,2.9231D+01,
+ &3.0023D+01,3.0827D+01,3.1642D+01,3.2468D+01,3.3305D+01,
+ &3.4152D+01,3.5010D+01,3.5878D+01,3.6757D+01,3.7645D+01,
+ &3.8543D+01/
+C
+ DATA (SSIG_RHO(K,3),K= 1, 61) /
+ &-2.4506D-02,9.2028D-03,3.5513D-02,5.5961D-02,7.1799D-02,
+ &8.4036D-02,9.3471D-02,1.0074D-01,1.0632D-01,1.1061D-01,
+ &1.1391D-01,1.1643D-01,1.1837D-01,1.1986D-01,1.2100D-01,
+ &1.2187D-01,1.2254D-01,1.2305D-01,1.2345D-01,1.2375D-01,
+ &1.2398D-01,1.2416D-01,1.2429D-01,1.2439D-01,1.2447D-01,
+ &1.2453D-01,1.2458D-01,1.2462D-01,1.2464D-01,1.2467D-01,
+ &1.2468D-01,1.2469D-01,1.2470D-01,1.2471D-01,1.2472D-01,
+ &1.2472D-01,1.2472D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,1.2473D-01,
+ &1.2473D-01/
+
+ DATA LL /5*0,3*2,4*3,2*1,19*0,6*1/
+
+
+ L = L0
+ NSQS = 61
+ ASQSMIN = 1.D0
+ ASQSMAX = 7.D0
+ DASQS = (ASQSMAX-ASQSMIN)/DBLE(NSQS-1)
+
+ IF(NSQS.LE.0) THEN
+ WRITE(LUN,'(//,1X,A)')
+ & 'SIB_SIGMA_EXT: interpolation table not initialized.'
+ STOP
+ ENDIF
+ IF(IABS(L).gt.39)THEN
+ WRITE(LUN,*)
+ & ' SIB_SIGMA_EXT: unknown beam particle!',L
+ STOP
+ ENDIF
+ IF(L.GT.3) L=LL(IABS(L))
+ IF(L.EQ.0)THEN
+ WRITE(LUN,*)
+ & ' SIB_SIGMA_EXT: unknown beam particle!', L
+ STOP
+ ENDIF
+
+ AL = LOG10(SQS)
+ J1 = INT((AL-1.D0)*10.D0 + 1)
+ if((j1.lt.1).or.(j1.gt.NSQS)) then
+ if (ndebug .gt. 0)
+ * write (LUN,'(1x,a,i3,1p,e12.3)')
+ & ' SIB_SIGMA_EXT: energy out of range ',L,sqs
+ endif
+ if((j1.lt.1).or.(j1.ge.NSQS)) then
+ J1 = min(J1,NSQS-1)
+ J1 = max(J1,1)
+ endif
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGT = SSIG_TOT(J1,L)*(1.D0-T) + SSIG_TOT(J1+1,L)*T
+ SIGINEL = SSIG(J1,L)*(1.D0-T) + SSIG(J1+1,L)*T
+ SIGEL = SIGT-SIGINEL
+ SLOPE = SSIG_B(J1,L) *(1.D0-T) + SSIG_B(J1+1,L)*T
+ RHO = SSIG_RHO(J1,L) *(1.D0-T) + SSIG_RHO(J1+1,L)*T
+
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_PROJECTILE
+ + (KID,KINT,LRMNT,XCHG,XJET,XX,PX,PY,IFL,KID1,IREJ)
+
+C-----------------------------------------------------------------------
+C... Subroutine to sample sea and valence quarks in a hadron.
+C. variables are stored in xx,px,py and ifl arrays.
+C. for each interaction the hadron undergoes there is one
+C. pair of partons attached to the ends of two strings
+C. (one cut pomeron)
+C. In addition flavor and momentum may be set aside for the remnant
+C. arrays are filled: rmnt1,rmnt2, c.str1,c.str2, etc..
+C. i.e. positions 1 and 2 are reserved for remnant.
+C.
+C. Input: KINT : number of interactions the hadron takes part in
+C. KID : particle id of hadron
+C. LRMNT : remnant excitation flag,
+C. defines if valence quarks need to be sampled
+C. XCHG : flavor exchange prob. between remnant and
+C. central strings
+C. XJET : momentum fraction already asigned to minijets
+C. IREJ : rejection flag, default set in calling routine
+C.
+C. Output: XX,IFL,PX,PY : arrays of momentum fractions, flavor
+C. and transverse momentum
+C. KID1 : new hadron id (in case of flavor exchange)
+C-------------------------------------------------------------------
+ IMPLICIT NONE
+
+C include COMMONs
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+
+C input type declarations
+ INTEGER KID,KINT,LRMNT
+ DOUBLE PRECISION XCHG,XJET
+
+C output type declarations
+ DOUBLE PRECISION XX,PX,PY
+ INTEGER IFL,KID1,IREJ
+ DIMENSION XX(2*NW_max+2),PX(2*NW_max+2),PY(2*NW_max+2),
+ & IFL(2*NW_max+2)
+
+c local type declarations
+ INTEGER ICNT1,ICNT2,J,JJ,j1,j2,j3,j4,KRMNT,IRNK,
+ & IDXVAL,IDX,ISWTD,i,IFLS,NVAL,NSEA,IR,IDUM,IDUM2,KIDA,IMRG2HAD
+ DOUBLE PRECISION XSEAJET,XVAL,XMINA,XMINA_SEA,GAMMA,XREM,XMINA2,
+ & XMAX2,ALPHA,XM2DIS,ASUP,XMAX,XQM,S_RNDM,
+ & CHIDIS,CHI,GAMDIQ,XSUPP,XSUPP1,PAR53_def,PAR5_def,PAR6_def,
+ & PAR7_def,PAR143_def,XSUM,STR_mass,PTS,XSCL
+ SAVE
+ DATA ICNT1,ICNT2 /0,0/
+
+C.. initialization
+ ITRY(3) = 0
+ XVAL = 0.D0
+ XSCL = 1.D0
+ XSEAJET = 0.D0
+ XSUM = 0.D0
+ DO J=1,KINT ! zero arrays
+ j1 = 1+2*(j-1)
+ j2 = j1 + 1
+ j3 = 3+2*(j-1)
+ j4 = j3 + 1
+ XX(j1) = 0.D0
+ XX(j2) = 0.D0
+ XX(j3) = 0.D0
+ XX(j4) = 0.D0
+ PX(j1) = 0.D0
+ PX(j2) = 0.D0
+ PX(j3) = 0.D0
+ PX(j4) = 0.D0
+ ENDDO
+
+ KRMNT = MIN(LRMNT,1)
+
+ IF(ndebug.gt.3)
+ + WRITE(LUN,*)
+ + ' SAMPLE_PROJECTILE: KID,KINT,KRMNT,XCHG,XJET,IREJ',
+ + KID,KINT,KRMNT,XCHG,XJET,IREJ
+
+ KID1 = KID
+ KIDA = IABS(KID)
+
+c number of valence quarks to sample
+c if remnant is resolved (krmnt=1) no valence pair needed
+ Nval = 2*(1-KRMNT)
+
+c number of sea quarks to sample (one pair per interaction)
+c if remnant is not resolved then on pair less is needed
+c (valence pair takes role of one sea pair)
+ Nsea = 2*(KINT-(1-KRMNT))
+
+ IF(ndebug.gt.3)
+ + WRITE(LUN,*)
+ + ' SAMPLE_PROJECTILE: number of partons to sample ',
+ + '(tot,val,sea):',Nval+Nsea,Nval,Nsea
+
+c change proton splitting to enhance charge exchange by allowing
+c ud more often than uu, default scenario is ud,du,uu: 3:1:2
+ PAR53_def = PAR(53)
+ PAR(53) = PAR(84)
+c change proton splitting in case no remnant is present
+ IF(LRMNT.eq.0) PAR(53) = PAR(127)
+
+ 20 ITRY(3) = ITRY(3) + 1
+ IF(ITRY(3).gt.NREJ(3)) THEN
+ ICNT1 = ICNT1 + 1
+ IF(ICNT1.lt.10)THEN
+ if (NDEBUG.gt.0) then
+ WRITE(LUN,*)' SAMPLE_PROJECTILE: trials exceeded! return..'
+ WRITE(LUN,*)
+ + ' KID,KINT,KRMNT,XCHG,XJET,XVAL,IREJ,NCALL',
+ + KID,KINT,KRMNT,XCHG,XJET,XVAL,IREJ,NCALL
+ endif
+ ENDIF
+ PAR(53) = PAR53_def
+ RETURN
+ ENDIF
+
+C... kinematic limits
+ 22 XSEAJET = XJET
+ IF(KRMNT.eq.0)THEN
+c minimal momentum fraction for valences
+ XMINA = 2.D0*STR_mass_val/SQS
+c default for valence quarks: 0.35 , xmin@10GeV = 0.07
+c taken from COMMON s_cutoff
+ IF(ISTR(KIDA)*IBAR(KIDA).ne.0)
+ & XMINA = 2.D0*STR_mass_val_hyp/SQS
+ ELSE
+ IF(IPAR(47).eq.4.or.IPAR(47).eq.4.or.IPAR(47).eq.6)then
+c no valence sampling model
+c if remnant present then the minimal remnant mass has to be provided
+ XMINA = PAR(96)*AM(IABS(KID))/SQS
+ ELSEIF(IPAR(47).lt.4)THEN
+c valences sampled, even if combined again in remnant
+ XMINA = 2.D0*STR_mass_val/SQS
+ ELSEIF(IPAR(47).eq.7)THEN
+c minimal remnant mass not requiered,
+c mass is taken from central strings anyway..
+ XMINA = AM(IABS(KID))/SQS
+ ENDIF
+ ENDIF
+
+c minimal momentum fraction for sea partons
+ IF(IPAR(47).eq.0.or.IPAR(47).eq.3)THEN
+c same as valence quarks
+ STR_mass = STR_mass_val
+ ELSEIF(IPAR(47).eq.1.or.IPAR(47).eq.2.or.IPAR(47).gt.4)THEN
+c set by parameter
+ STR_mass = PAR(87)
+ ELSEIF(IPAR(47).eq.4)THEN
+c same as soft minijets
+ STR_mass = STR_mass_sea
+ ENDIF
+ IF(IPAR(72).eq.2.and.KINT.gt.1)THEN
+ STR_mass = STR_mass * PAR(118)
+ ENDIF
+ XMINA_SEA = 2.D0*STR_mass/SQS
+c default for sea quarks: 1.0 , xmin@10GeV = 0.2
+c taken from COMMON s_cutoff or s_cflafr
+c should be the same as min. string mass in SAMPLE_SOFT !
+
+c dependence on number of interactions
+ IF(IPAR(72).eq.1.and.KINT.gt.1)THEN
+ XMINA_SEA = XMINA_SEA * PAR(118)
+ ENDIF
+
+C.. check if enough energy left to sample all partons
+ IF (1.D0-XJET.LT.(Nsea*XMINA_SEA+2.D0*XMINA))THEN
+ ICNT2 = ICNT2 + 1
+ IF(ICNT2.le.10)THEN
+ IF(NDEBUG.gt.3)THEN
+ write(lun,*)' SAMPLE_PROJECTILE: rejection!'
+ write(lun,*)' too little energy to sample all partons!'
+ write(lun,*)' (NW,Ntot,Nval,Nsea,XMIN,XMIN*N',
+ & 'XREM,XALL,NCALL,ICNT:)',KINT,nval+nsea,Nval,nsea,
+ & 2*xmina,nsea*xmina_sea,1.D0-xjet,
+ & Nsea*XMINA_SEA+2*XMINA,NCALL,ICNT2
+ IF(ICNT2.eq.10) write(lun,*)' last warning ! good luck..'
+ ENDIF
+ ENDIF
+
+ IREJ = 2
+ PAR(53) = PAR53_def
+ RETURN
+ ENDIF
+
+
+C... sample sea partons
+c if no additional partons need to be sampled
+C jump straight to valence quarks
+ IF(Nsea.EQ.0) GOTO 100
+
+C select sea quark model
+ IF(IPAR(47).eq.0.or.IPAR(47).eq.3.or.IPAR(47).eq.4.or.
+ & IPAR(47).eq.5.or.IPAR(47).eq.7)THEN
+ GAMMA = PAR(103)
+ IF(IPAR(73).eq.1.and.KINT.gt.1) GAMMA = PAR(119)
+ CALL SAMPLE_SEA_TOT
+ & (KRMNT,KINT,NSEA,GAMMA,XJET,STR_MASS,XSEAJET,XX)
+
+ ELSEIF(IPAR(47).eq.1)THEN
+c sample from 1/x individually then reject if too large
+ XREM = 0.D0
+ XMINA2 = XMINA_SEA ** 2
+ XMAX2 = 0.8D0**2
+ ALPHA = 1.D0
+ DO WHILE ( XREM .lt. 2*XMINA )
+ XREM = 1.D0-XJET
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*) ' N,XREM,XMINA,XMIN2,XMAX2,ALPHA',
+ & Nsea,XREM,XMINA_SEA,XMINA2,XMAX2,ALPHA
+ DO j=1,Nsea
+ jj = 2 + j
+ IF(KRMNT.eq.0) jj = 4+j
+ XX(jj) = XM2DIS(XMINA2,XMAX2,ALPHA)
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*) ' J,X,XREM',JJ,XX(JJ),XREM
+ XREM = XREM - XX(jj)
+ ENDDO
+ ENDDO
+ XSEAJET = 1.D0-XREM
+
+ ELSEIF(IPAR(47).eq.2.or.IPAR(47).eq.6)THEN
+c sample from (1-x)**b / x with common mass constraint
+ XREM = 1.D0-XJET
+ XMAX = PAR(88)
+ ALPHA = PAR(85)
+ ASUP = PAR(86)
+ XQM = STR_mass
+ CALL SAMPLE_SEA_INDV(KRMNT,XMINA,XMINA_SEA,NSEA,
+ & XREM,ALPHA,ASUP,XQM,XMAX,XX,IR)
+ IF(IR.ne.0)THEN
+ IREJ = IR
+ PAR(53) = PAR53_def
+ RETURN
+ ENDIF
+
+ XSEAJET = 1.D0-XREM
+ ENDIF
+
+C... sample sea flavor: u,d,s,c
+c write to ifl after valences..
+ DO J=1+Nval/2,KINT
+ j3 = 3+2*(j-1)
+ j4 = j3 + 1
+c turn on strange sea..
+ IF(IPAR(29).eq.1)THEN
+ IF(IPAR(69).ne.0)THEN
+c sample asymmetric u,d
+ IFL(j3) = MIN(2,1+INT((2.D0+PAR(114))*S_RNDM(KID)))
+c sample strange
+ IFLS = 3*(INT((2+PAR(43))*S_RNDM(j3))/2)
+ IFL(j3) = MAX(IFL(j3),IFLS)
+ else
+ IFL(j3) = 1+INT((2.D0+PAR(43))*S_RNDM(j4))
+ endif
+c sample charm
+c scale up for mesons
+ IF(IPAR(76).eq.1) XSCL=XSCL+(1-IABS(IBAR(KIDA)))*PAR(126)
+ IF(IFL(j3).eq.3.and.S_RNDM(kid).lt.PAR(97)*PAR(125)*XSCL)
+ & IFL(j3) = 4
+ ELSE
+ IFL(j3) = INT(1.5D0+S_RNDM(KID))
+ ENDIF
+ IFL(j4) = -IFL(j3)
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*) ' flavor: JW,FLV1,FLV2',J,IFL(j3),IFL(j4)
+
+C... sample sea pt
+ 33 IF(IPAR(49).eq.1)THEN
+c in-string pt for sea partons
+c flavor and cm energy dependent avg, exponential dist.
+c avg pt (defined in subroutine ptsetup ):
+c u,d : PAR(46)+PAR(68)*log10(sqs/20.D0)**2
+c s: PAR(47)+PAR(70)*log10(sqs/20.D0)**2
+c diq: PAR(48)+PAR(69)*log10(sqs/20.D0)**2
+ CALL PTDIS_4FLV (IFL(j3),PX(j3),PY(j3))
+ PX(j4) = -PX(j3)
+ PY(j4) = -PY(j3)
+
+ ELSEIF(IPAR(49).eq.2)THEN
+c 'primordial' pt
+c c.m. energy dependent avg, exponential
+c same for all flavors
+c avg: PAR(49)+PAR(69)*log10(sqs/20.)**2
+ CALL PTDIS_4FLV (10,PX(j3),PY(j3))
+ PX(j4) = -PX(j3)
+ PY(j4) = -PY(j3)
+
+ ELSEIF(IPAR(49).eq.3)THEN
+c constant pt
+ PX(j3) = EPS5
+ PY(j3) = EPS5
+ PX(j4) = -PX(j3)
+ PY(j4) = -PY(j3)
+
+ ELSEIF(IPAR(49).eq.4)THEN
+c sea pt, same as primordial but different params..
+c c.m. energy dependent avg, exponential
+c same for all flavors
+c avg: PAR(132)
+ CALL PTDIS_4FLV (30,PX(j3),PY(j3))
+ PX(j4) = -PX(j3)
+ PY(j4) = -PY(j3)
+ ENDIF
+c limit parton virtuality
+ PTS = MAX(PX(j3)**2+PY(j3)**2,EPS10)
+ IF((XX(j3)**2+XX(J4)**2)/PTS.lt.8.D0*PAR(122)/S) GOTO 33
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*)' pt: JW,PX,PY,pt',J,Px(j3),Py(j3),sqrt(pts)
+ ENDDO
+
+C... Prepare the valence partons
+ 100 XVAL=1.D0-XSEAJET
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_PROJECTILE: val. fraction remaining:',
+ & XVAL
+
+ IF(IPAR(47).eq.7)THEN
+c no remnant, sample valence quarks
+ IF(KRMNT.eq.0) THEN
+c enough momentum left?
+ IF (XVAL.LT.XMINA) goto 20 ! reject sea kinematics
+ ELSE
+c sample remnant
+ IF(IPAR(53).eq.1)THEN
+c momentum dis: x**alpha
+ IF(S_RNDM(KID).gt.XVAL**(PAR(100)+1)) GOTO 22
+ ENDIF
+c split remnant momentum into partons, just to fill slots
+
+ ENDIF
+ ELSE
+ IF(KRMNT.eq.0.or.IPAR(47).lt.4)THEN
+ IF (XVAL.LT.XMINA) goto 20 ! reject sea kinematics
+ ENDIF
+c remnant momentum fraction
+ IF(KRMNT.ne.0.and.IPAR(53).eq.1)THEN
+ IF(S_RNDM(KID).gt.XVAL**(PAR(100)+1)) GOTO 22
+ ENDIF
+ ENDIF
+c valence quarks are in 1,2 of IFL,XX etc.
+ IDXVAL = 3
+ IF(KRMNT.ne.0) IDXVAL = 1
+ CALL HSPLI (KID,IFL(IDXVAL),IFL(IDXVAL+1))
+ 110 CHI = CHIDIS(KID,IFL(IDXVAL),IFL(IDXVAL+1))
+ XX(IDXVAL) = MAX(CHI*XVAL,XMINA)
+ XX(IDXVAL) = MIN(XX(IDXVAL),XVAL-XMINA)
+C FOR MESONS, SPLIT ENERGY SYMMETRICALLY.
+ IF (IABS(KID).LT.13.AND.S_RNDM(0).LE.0.5D0)
+ & XX(IDXVAL)=XVAL-XX(IDXVAL)
+ XX(IDXVAL+1)=XVAL-XX(IDXVAL)
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_PROJECTILE: val. sampled (x1,x2):',
+ & XX(IDXVAL),XX(IDXVAL+1)
+c for baryons force diq distribution
+ IF(IBAR(IABS(KID)).ne.0.and.IPAR(47).ne.7)THEN
+ IF(IPAR(52).eq.1)THEN
+ GAMDIQ=PAR(95)
+ IF(S_RNDM(KID).gt.XX(IDXVAL+1)**(GAMDIQ+1)) GOTO 110
+ ELSE
+ IF(KRMNT.eq.0.or.IPAR(47).lt.4.and.IPAR(53).eq.0)THEN
+c force diquark distribution
+ GAMDIQ=PAR(95)
+ IF(S_RNDM(KID).gt.XX(IDXVAL+1)**(GAMDIQ+1)) GOTO 20
+ ENDIF
+ ENDIF
+ ENDIF
+C... val. quark transverse momentum
+ CALL PTDIS_4FLV (10,PX(IDXVAL),PY(IDXVAL))
+ PX(IDXVAL+1) = -PX(IDXVAL)
+ PY(IDXVAL+1) = -PY(IDXVAL)
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_PROJECTILE: val. pt (px,py):',
+ & PX(IDXVAL),PY(IDXVAL)
+
+C... exchange flavor between central strings and remnant
+c there is one pair of strings for each interaction with another hadron
+c in general allowed for both flavors but diquarks usually strongly suppressed
+c Xchg : prob. of flv exchange between strgs and rmnt
+ IF(KRMNT.ne.0)THEN
+ do idx=1,2
+ iswtd = 0
+ i = 1
+ XSUPP = 1.D0
+ IF(iabs(ifl(idx)).gt.10)THEN
+c suppress exchange of diq: prob_exchange = prob0 * xsupp
+ XSUPP = PAR(83)
+ ELSEIF(IPAR(46).eq.2)THEN
+c suppress exchange for fast quark ( usually in mesons )
+ IF(xx(idx).gt.xx(3-idx)) XSUPP = PAR(139)
+ ENDIF
+ DO WHILE (ISWTD.eq.0.and.i.le.KINT)
+c sea flavor index
+ jj = idx+2*i
+c forbid exchange for charmed hadrons if sea pair is charmed too
+c needed to avoid double charmed particles
+ XSUPP1 = XSUPP
+ IF(IABS(KID).gt.50.and.IABS(IFL(JJ)).eq.4) XSUPP1 = 0.D0
+ if(S_RNDM(I).lt.XCHG*XSUPP1) THEN
+c exchange flavor between remnant and sea
+ CALL ISWTCH_LMNTS(ifl(jj),ifl(idx))
+c also exchange momentum fraction
+ IF(IPAR(46).ne.0) CALL SWTCH_LMNTS(xx(jj),xx(idx))
+c change flavor id accordingly, i.e. reassamble remnant from new flavor
+ IF(IPAR(58).eq.0)THEN
+c combine to any hadron that matches flavor wise, ignoring (iso)spin
+ CALL SIB_I4FLAV(ifl(1),ifl(2),idum,idum2,KID1)
+ ELSEIF(IPAR(58).eq.1)THEN
+c combine to lightest hadron
+ KID1 = IMRG2HAD(IFL(1),IFL(2))
+ ELSEIF(IPAR(58).eq.2.or.IPAR(58).eq.3)THEN
+c combine to any hadron that matches flavor wise, ignoring (iso)spin
+c set vector meson rate
+ PAR5_def = PAR(5)
+ PAR(5) = PAR(104)
+c set strange vector rate
+ PAR6_def = PAR(6)
+ PAR(6) = PAR(121)
+c set spin3/2 vs spin1/2 rate
+ PAR7_def = PAR(7)
+ PAR(7) = PAR(105)
+c set rho / omega-phi rate
+ PAR143_def = PAR(143)
+ if(ibar(iabs(kb)).eq.0.and.IPAR(85).eq.1)
+ & PAR(143) = PAR(145)
+ irnk = 0
+ IF(IPAR(58).eq.3) irnk = 1
+ CALL SIB_I4FLAV(ifl(1),ifl(2),irnk,idum2,KID1)
+ PAR(5) = PAR5_def
+ PAR(6) = PAR6_def
+ PAR(7) = PAR7_def
+ PAR(143) = PAR143_def
+
+c reject spin1,isospin singlett
+ IF(KID1.eq.32.and.PAR(111).gt.S_RNDM(KID1))
+ & KID1 = 27
+ ENDIF
+ iswtd = 1
+ endif
+ i = i + 1
+ ENDDO
+ enddo
+ ENDIF
+ IF(ndebug.gt.3)THEN
+ WRITE(LUN,*)' SAMPLE_PROJECTILE: rmnt PID,NTRY: ',KID1,ITRY(3)
+ WRITE(LUN,*)' SAMPLE_PROJECTILE: output: I,FLV,PX,PY,X,XSUM'
+ ENDIF
+ XSUM = XJET
+ DO j=IDXVAL,2*(KINT+Krmnt)+2*(1-Krmnt)
+ XSUM = XSUM + XX(j)
+ IF(NDEBUG.gt.3) WRITE(LUN,*) j,IFL(j),PX(J),PY(J),XX(j),XSUM
+ ENDDO
+ IF(ABS(XSUM-1.D0).gt.EPS3) THEN
+ WRITE(LUN,*)' SAMPLE_PROJECTILE: parton sum incomplete!',
+ & '(ID,XSUM,NCALL):' , KID1,XSUM, NCALL,' aborting..'
+ CALL SIB_REJECT('SAMPLE_PROJECTIL')
+ ENDIF
+ IREJ = 0
+
+ END
+C=======================================================================
+
+ SUBROUTINE DECSIB
+
+C-----------------------------------------------------------------------
+C...Decay all unstable particle in Sibyll
+C. decayed particle have the code increased by 10000
+C
+C changed to allow for multiple calls to DECSIB in one event
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION CBR
+ INTEGER KDEC,LBARP,IDB
+ COMMON /S_CSYDEC/ CBR(223+16+12+8), KDEC(1338+6*(16+12+8)),
+ & LBARP(99), IDB(99)
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+ INTEGER LLIST1
+ COMMON /S_PLIST1/ LLIST1(8000)
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ INTEGER LRNK
+ COMMON /SIB_RNK/ LRNK(8000)
+ DIMENSION P0(5), LL(10), PD(10,5)
+ SAVE
+
+c call pythia decay routine
+c IF(IPAR(44).eq.1) CALL PYDEC
+
+c decay with sibyll
+ NN = 1
+ IF(IPAR(44).ne.1)THEN
+ DO J=1,NP
+ LLIST1(J) = 0
+ ENDDO
+ ENDIF
+ DO WHILE (NN .LE. NP)
+ L= LLIST(NN)
+ LA = IABS(L)
+ if(LA.lt.100) then
+ IF (IDB(LA) .GT. 0) THEN
+ DO K=1,5
+ P0(K) = P(NN,K)
+ ENDDO
+ CALL DECPAR (L,P0,ND,LL,PD)
+ LLIST(NN) = LLIST(NN)+ISIGN(10000,LLIST(NN))
+ DO J=1,ND
+ NP = NP+1
+ if(NP.gt.8000) then
+ write(LUN,'(1x,a,2i8)')
+ & ' DECSIB: no space left in S_PLIST (NP,ND):',NP,ND
+ NP = NP-1
+ return
+ endif
+ DO K=1,5
+ P(NP,K) = PD(J,K)
+ ENDDO
+ LLIST(NP)=LL(J)
+ LLIST1(NP)=NN
+ LRNK(NP)=LRNK(NN)
+ NPORIG(NP)= NPORIG(NN)
+ niorig(NP)= NIORIG(NN)
+ NFORIG(NP) = L
+ ENDDO
+ ENDIF
+ endif
+ NN = NN+1
+ ENDDO
+
+c CALL SIB_LIST(20)
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_SIGMA_HP
+ & (L0,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+C-----------------------------------------------------------------------
+C Hadron-proton cross sections, taken from interpolation table
+C calculated by SIBYLL_INI
+C
+C input: L 1 proton-proton
+C 2 pi-proton
+C 3 K-proton
+C SQS sqrt(s)
+C
+C output: SIGT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGINEL inelastic cross section (mb)
+C SIGDIF diffraction dissociation CS (mb)
+C SLOPE elastic slope parameter (GeV^-2)
+C RHO real/imaginary part of forward amplitude
+C-----------------------------------------------------------------------
+Cf2py integer, intent(in) :: L0
+Cf2py double precision, intent(in) :: SQS
+Cf2py double precision, intent(out) :: SIGT,SIGEL,SIGINEL,SLOPE,RHO
+Cf2py double precision(3), intent(out) :: SIGDIF
+ IMPLICIT NONE
+
+c external types
+ DOUBLE PRECISION SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO
+ DIMENSION SIGDIF(3)
+ INTEGER L0
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ DOUBLE PRECISION SSIG_TOT,SSIG_SD1,SSIG_SD2,SSIG_DD,SSIG_B,
+ & SSIG_RHO
+ COMMON /S_CCSIG2/ SSIG_TOT(61,3),SSIG_SD1(61,3),SSIG_SD2(61,3),
+ & SSIG_DD(61,3),SSIG_B(61,3),SSIG_RHO(61,3)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c internal type declarations
+ DOUBLE PRECISION T,AL
+ INTEGER LL,L,J1
+ DIMENSION LL(39)
+ SAVE
+ DATA LL /5*0,3*2,4*3,2*1,19*0,6*1/
+
+
+ L = L0
+ IF(NSQS.LE.0) THEN
+ WRITE(LUN,'(//,1X,A)')
+ & ' SIB_SIGMA_HP: interpolation table not initialized.'
+ STOP
+ ENDIF
+ IF(IABS(L).gt.39)THEN
+ WRITE(LUN,*)
+ & ' SIB_SIGMA_HP: unknown beam particle!',L
+ STOP
+ ENDIF
+ IF(L.GT.3) L=LL(IABS(L))
+ IF(L.EQ.0)THEN
+ WRITE(LUN,*)
+ & ' SIB_SIGMA_HP: unknown beam particle!', L
+ STOP
+ ENDIF
+
+ AL = LOG10(SQS)
+ J1 = INT((AL-1.D0)*10.D0 + 1)
+ if((j1.lt.1).or.(j1.gt.NSQS)) then
+ if(ndebug.gt.0)
+ & write (LUN,'(1x,a,i3,1p,e12.3)')
+ & ' SIB_SIGMA_HP: energy out of range ',L,sqs
+ endif
+ if((j1.lt.1).or.(j1.ge.NSQS)) then
+ J1 = min(J1,NSQS-1)
+ J1 = max(J1,1)
+ endif
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGT = SSIG_TOT(J1,L)*(1.D0-T) + SSIG_TOT(J1+1,L)*T
+ SIGINEL = SSIG(J1,L)*(1.D0-T) + SSIG(J1+1,L)*T
+ SIGEL = SIGT-SIGINEL
+ SIGDIF(1) = SSIG_SD1(J1,L)*(1.D0-T) + SSIG_SD1(J1+1,L)*T
+ SIGDIF(2) = SSIG_SD2(J1,L)*(1.D0-T) + SSIG_SD2(J1+1,L)*T
+ SIGDIF(3) = SSIG_DD(J1,L)*(1.D0-T) + SSIG_DD(J1+1,L)*T
+ SLOPE = SSIG_B(J1,L) *(1.D0-T) + SSIG_B(J1+1,L)*T
+ RHO = SSIG_RHO(J1,L) *(1.D0-T) + SSIG_RHO(J1+1,L)*T
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_SIGMA_HP2
+ + (L,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+C-----------------------------------------------------------------------
+C Hadron-proton cross sections, taken from interpolation table
+C calculated by SIBYLL_INI
+C
+C input: L 1 proton-proton
+C 2 pi-proton
+C 3 K-proton
+C SQS sqrt(s)
+C
+C output: SIGT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGINEL inelastic cross section (mb)
+C SIGDIF diffraction dissociation CS (mb)
+C split in high and low mass !!
+C ( taken from S_CCSIG3 )
+C SLOPE elastic slope parameter (GeV^-2)
+C RHO real/imaginary part of forward amplitude
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+c external types
+ DOUBLE PRECISION SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO
+ DIMENSION SIGDIF(3,2)
+ INTEGER L
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+ DOUBLE PRECISION SSIG_TOT,SSIG_SD1,SSIG_SD2,SSIG_DD,SSIG_B,
+ & SSIG_RHO
+ COMMON /S_CCSIG2/ SSIG_TOT(61,3),SSIG_SD1(61,3),SSIG_SD2(61,3),
+ & SSIG_DD(61,3),SSIG_B(61,3),SSIG_RHO(61,3)
+ DOUBLE PRECISION SSIG_SD1LM,SSIG_SD1HM,SSIG_SD2LM,SSIG_SD2HM,
+ & SSIG_DDLM,SSIG_DDHM
+ COMMON /S_CCSIG3/ SSIG_SD1LM(61,3),SSIG_SD1HM(61,3),
+ & SSIG_SD2LM(61,3),SSIG_SD2HM(61,3),
+ & SSIG_DDLM(61,3),SSIG_DDHM(61,3)
+
+c internal types
+ INTEGER J1
+ DOUBLE PRECISION T,AL
+ SAVE
+
+ IF(NSQS.LE.0) THEN
+ WRITE(LUN,'(//,1X,A)')
+ & ' SIB_SIGMA_HP2: interpolation table not initialized.'
+ STOP
+ ENDIF
+
+ AL = dLOG10(SQS)
+ J1 = INT((AL - 1.D0)*10.D0 + 1)
+ if((j1.lt.1).or.(j1.gt.NSQS)) then
+ if(ndebug.gt.0)write(LUN,'(1x,a,i3,1p,e12.3)')
+ & ' SIB_SIGMA_HP2: energy out of range ',L,sqs
+ endif
+ if((j1.lt.1).or.(j1.ge.NSQS)) then
+ J1 = min(J1,NSQS-1)
+ J1 = max(J1,1)
+ endif
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGT = SSIG_TOT(J1,L)*(1.D0-T) + SSIG_TOT(J1+1,L)*T
+ SIGINEL = SSIG(J1,L)*(1.D0-T) + SSIG(J1+1,L)*T
+ SIGEL = SIGT-SIGINEL
+ SIGDIF(1,1) = SSIG_SD1LM(J1,L)*(1.D0-T) + SSIG_SD1LM(J1+1,L)*T
+ SIGDIF(1,2) = SSIG_SD1HM(J1,L)*(1.D0-T) + SSIG_SD1HM(J1+1,L)*T
+ SIGDIF(2,1) = SSIG_SD2LM(J1,L)*(1.D0-T) + SSIG_SD2LM(J1+1,L)*T
+ SIGDIF(2,2) = SSIG_SD2HM(J1,L)*(1.D0-T) + SSIG_SD2HM(J1+1,L)*T
+ SIGDIF(3,1) = SSIG_DDLM(J1,L)*(1.D0-T) + SSIG_DDLM(J1+1,L)*T
+ SIGDIF(3,2) = SSIG_DDHM(J1,L)*(1.D0-T) + SSIG_DDHM(J1+1,L)*T
+ SLOPE = SSIG_B(J1,L) *(1.D0-T) + SSIG_B(J1+1,L)*T
+ RHO = SSIG_RHO(J1,L) *(1.D0-T) + SSIG_RHO(J1+1,L)*T
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_SIGMA_HAIR (L,SQS,SIGprod,SIGbdif)
+
+C-----------------------------------------------------------------------
+C Hadron-air cross sections, taken from interpolation table
+C calculated by SIBYLL_INI
+C
+C input: L 1 proton-air
+C 2 pi-air
+C 3 K-air
+C SQS sqrt(s)
+C
+C output: SIGprod particle production cross section (mb)
+C SIGbdif q.ela and ela beam diff. cross section
+C-----------------------------------------------------------------------
+Cf2py integer, intent(in) :: L
+Cf2py double precision, intent(in) :: SQS
+Cf2py double precision, intent(out) :: SIGprod,SIGbdif
+ IMPLICIT NONE
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+
+c external
+ DOUBLE PRECISION SQS,SIGPROD,SIGBDIF
+ INTEGER L
+
+c internal
+ DOUBLE PRECISION AL,T
+ INTEGER J1
+ SAVE
+
+ IF(NSQS.LE.0) THEN
+ WRITE(LUN,'(//,1X,A)')
+ & ' SIB_SIGMA_HAIR: interpolation table not initialized.'
+ STOP
+ ENDIF
+
+ AL = LOG10(SQS)
+ J1 = INT((AL - 1.D0)*10.D0 + 1)
+ if((j1.lt.1).or.(j1.gt.NSQS)) then
+ if (ndebug .gt. 0)
+ & write (LUN,'(1x,a,i3,1p,e12.3)')
+ & ' SIB_SIGMA_HAIR: energy out of range ',L,sqs
+ endif
+ if((j1.lt.1).or.(j1.ge.NSQS)) then
+ J1 = min(J1,NSQS-1)
+ J1 = max(J1,1)
+ endif
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGprod = SSIGN(J1,L)*(1.D0-T) + SSIGN(J1+1,L)*T
+ SIGbdif = SSIGNSD(J1,L)*(1.D0-T) + SSIGNSD(J1+1,L)*T
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_SIGMA_HNUC (L,IAT,SQS,SIGprod,SIGbdif)
+
+C-----------------------------------------------------------------------
+C calculate Hadron-nucleus cross sections
+C
+C input: L 1 proton-nuc
+C 2 pi-nuc
+C 3 K-nuc
+C IAT 0-18 mass number of target nucleus
+C (beyond A=18 nuclear profiles are inaccurate)
+C SQS sqrt(s)
+C
+C output: SIGprod particle production cross section (mb)
+C SIGbdif q.ela and ela beam diff. cross section
+C-----------------------------------------------------------------------
+Cf2py integer, intent(in) :: L,IAT
+Cf2py double precision, intent(in) :: SQS
+Cf2py double precision, intent(out) :: SIGprod,SIGbdif
+ IMPLICIT NONE
+
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX,
+ & DASQS
+ INTEGER NSQS
+ COMMON /S_CCSIG/ SSIG(61,3), PJETC(0:NS_max,0:NH_max,61,2),
+ & SSIGN(61,3), SSIGNSD(61,3), ALINT(61,3),
+ & ASQSMIN, ASQSMAX, DASQS, NSQS
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ DOUBLE PRECISION SIGT,SIGEL,SIGINEL,SIGQE,SIGSD,SIGQSD,SIGPPT,
+ & SIGPPEL,SIGPPSD
+ INTEGER ITG
+ COMMON /NUCSIG/ SIGT,SIGEL,SIGINEL,SIGQE,SIGSD,
+ + SIGQSD,SIGPPT,SIGPPEL,SIGPPSD,ITG
+
+c external
+ DOUBLE PRECISION SQS,SIGPROD,SIGBDIF
+ INTEGER L,IAT
+
+c internal
+ DOUBLE PRECISION ALAM
+ INTEGER IPARM,ICSMOD
+ SAVE
+
+ IF(NSQS.LE.0) THEN
+ WRITE(LUN,'(//,1X,A)')
+ & ' SIB_SIGMA_HNUC: interpolation table not initialized.'
+ STOP
+ ENDIF
+
+ IF(IAT.ge.0.and.IAT.lt.19)THEN
+ IF(ndebug.gt.0)THEN
+ WRITE(LUN,'(1X,A,2I4,F8.2)')
+ & 'SIB_SIGMA_HNUC: L,IAT,SQS:',L,IAT,SQS
+ ENDIF
+c calculate hadron - nucleus cross section
+c dummy arg, coupling derived from dif xsctn
+ ALAM = 1.D0
+c use Sibyll p-p cross section as input
+ ICSMOD = 1
+c use Goulianos param. for inel. coupling param.
+ IPARM = 2
+ CALL SIG_HAD_NUC(L,IAT,SQS,ALAM,ICSMOD,IPARM)
+C particle production cross section
+ SIGprod = SIGT-SIGQE
+C quasi elastic + elastic singl. diff cross section
+ SIGbdif = SIGQSD
+ if(ndebug.gt.0)THEN
+ WRITE(LUN,'(1X,A,3F8.2)')
+ & 'SIB_SIGMA_HNUC: SIGprod, SIGbdif, ALAM:',
+ & SIGprod, SIGbdif, ALAM
+ ENDIF
+ ELSE
+ WRITE(LUN,'(//,1X,A)')
+ & ' SIB_SIGMA_HNUC: number of target nucleons too large!',
+ & ' (0<=IAT<=18)'
+ SIGprod = -1.D0
+ ENDIF
+ RETURN
+ END
+
+C----------------------------------------------------------------------
+C sampling routines for hard partons in SIBYLL
+C includes GRV98 pdf table and initialization routines
+C----------------------------------------------------------------------
+C=======================================================================
+
+ SUBROUTINE SAMPLE_HARD (L,X1,X2,PT)
+
+C-----------------------------------------------------------------------
+C...Routine for sampling the kinematical variables
+C. that determine a jet-jet (gluon - gluon) system (x1,x2, pT)
+C. from the differential cross section:
+C. d3sigma/(dx1 dx2 dpT)
+C. This version assumes the `single parton approximation'
+C. INPUT: L=1 incident proton, L=2 incident pi
+C. NPLD: position on parton stack
+C. OUTPUT: gluon 4momenta
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ INTEGER L
+ DOUBLE PRECISION X1,X2,PT
+
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+c internal types
+ DOUBLE PRECISION Z1,Z2,SIG,S_RNDM,Q2,ZSAMPLE
+ SAVE
+
+ IF(ndebug.gt.2)then
+ write(lun,*) ' SAMPLE_HARD: (SQS,S,PTmin,Xmin,Zmin)',
+ & SQS,S,PTmin,Xmin,Zmin
+ endif
+
+ 100 Z1=ZSAMPLE (ZMIN,L) ! beam L=1,2 for proton or pion
+ Z2=ZSAMPLE (ZMIN,1) ! target always a nucleon
+ SIG=1.D0-XMIN*dEXP(-Z1-Z2)
+ IF (SIG .LT. S_RNDM(0)) GOTO 100
+ X1=dEXP(Z1)
+ X2=dEXP(Z2)
+ IF (X1.gt.0.9D0.or.X2.gt.0.9D0) GOTO 100
+ Q2=PTmin**2/(1.D0-S_RNDM(L)*SIG)
+ IF(Q2.gt.S*X1*X2) goto 100
+ PT=dSQRT(Q2*(1.D0-Q2/(S*X1*X2)))
+
+ IF(ndebug.gt.2)then
+ write(lun,*) ' SAMPLE_HARD: (X1,X2,PT)',
+ & X1,X2,PT
+ endif
+
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION ZSAMPLE (ZMIN,L)
+
+C-----------------------------------------------------------------------
+C...This function returns as output a value z=log(x)
+C. distributed as f(x) = g(x) + 4/9 *(q(x) + qbar(x))
+C. from a minimum value ZMIN to 0,
+C. for a proton (L=1) or a pi (L=2)
+C. needs to be initialised with: CALL ZSAMPLE_INI
+C.....................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ PARAMETER (b=0.268D0)
+ PARAMETER (bpi=3.7D0)
+ PARAMETER (cpi=0.698D0)
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ SAVE
+
+ F = PART_INT(ZMIN,L)*S_RNDM(0)
+ IF (F .GE. FFA(L)) THEN
+ IF(IPAR(8).EQ.0)THEN
+ ZSAMPLE = ZA(L) - (F-FFA(L))/APART(L)
+ ELSE
+ if(L.eq.1) then
+ ZSAMPLE = -1.D0/b * dLOG( 1.D0 - F / APART(L) )
+ else
+ ZSAMPLE = -1.D0 * ( (F - cpi)/APART(L) )**(1.D0/bpi)
+ endif
+ ENDIF
+ ELSE IF (F .GE. FFB(L)) THEN
+ JF = INT((F-FFB(L))/DFZ(L) + 1.D0)
+ JF = min(JF,199)
+ F0 = FFB(L) + DFZ(L)*DBLE(JF-1)
+ T = (F-F0)/DFZ(L)
+ ZSAMPLE = ZZ(JF,L)*(1.D0-T)+ZZ(JF+1,L)*T
+ ELSE
+ JF = INT(F/DFX(L)+1.D0)
+ JF = min(JF,199)
+ F0 = DFX(L)*DBLE(JF-1)
+ T = (F-F0)/DFX(L)
+ X = XX(JF,L)*(1.D0-T)+XX(JF+1,L)*T
+ ZSAMPLE = dLOG(X)
+ ENDIF
+
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION PART_INT (ZMIN,L)
+
+C-----------------------------------------------------------------------
+C...This function returns as output the integral of
+C. the parton structure function:
+C. f(x) = g(x) + 4/9 *(q(x) + qbar(x))
+C. from xmin = exp(zmin) to 1
+C. for a proton (L=1) or a pi (L=2)
+C. needs to be initialised with: CALL ZSAMPLE_INI
+C.....................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ DOUBLE PRECISION b,bpi,cpi
+ PARAMETER (b=0.268D0)
+ PARAMETER (bpi=3.7D0)
+ PARAMETER (cpi=0.698D0)
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ SAVE
+
+ IF (ZMIN .LT. ZA(L)) THEN
+ IF(IPAR(8).EQ.0)THEN
+ PART_INT = FFA(L) + APART(L) * (ZA(L) - ZMIN)
+ ELSE
+ if(L.eq.1) then
+ PART_INT = APART(L) * ( 1.D0 - dEXP(-b*ZMIN) )
+ else
+ PART_INT = APART(L) * ( -ZMIN )**bpi + cpi
+ endif
+ ENDIF
+ ELSE IF (ZMIN .LT. ZB(L)) THEN
+ JZ = INT((ZB(L)-ZMIN)/DZ(L)+1.D0)
+ JZ = min(JZ,199)
+ Z0 = ZB(L)-DZ(L)*DBLE(JZ-1)
+ T = (Z0-ZMIN)/DZ(L)
+ PART_INT = FFZ(JZ,L)*(1.D0-T) + FFZ(JZ+1,L)*T
+
+ ELSE
+ X = EXP(ZMIN)
+ JX = INT((XMAX-X)/DX(L)+1.D0)
+ JX = min(JX,199)
+ X0 = XMAX-DX(L)*DBLE(JX-1)
+ T = (X0-X)/DX(L)
+ PART_INT = FFX(JX,L)*(1.D0-T) + FFX(JX+1,L)*T
+
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE GRV_INI
+
+C-----------------------------------------------------------------------
+C...This subroutine initializes the COMMON block
+C used for sampling z, according to the GRV98LO
+C pdf set
+C..................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ DOUBLE PRECISION b,bpi,cpi
+ PARAMETER (b=0.268D0)
+ PARAMETER (bpi=3.7D0)
+ PARAMETER (cpi=0.698D0)
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ SAVE
+
+ IPAR(8) = 1
+
+ XA(1) = 1.D-06
+ XB(1) = 1.D-01
+
+ XA(2) = 1.D-04
+ XB(2) = 1.D-01
+
+ XMAX = 0.8D0
+ ZMAX = dLOG(XMAX)
+ NX = 200
+ NZ = 200
+
+ DO L=1,2
+
+ ZA(L) = dLOG(XA(L))
+ ZB(L) = dLOG(XB(L))
+ DX(L) = (XMAX-XB(L))/DBLE(NX)
+ DZ(L) = (ZB(L)-ZA(L))/DBLE(NZ)
+
+C large x: interpolation in x
+ FFX(1,L) = 0.D0
+ DO J=2,NX
+ X = XMAX - DX(L)*(DBLE(J)-1.D0)
+ G = PARTON(X,L)/X
+ FFX(J,L) = FFX(J-1,L)+G*DX(L)
+ ENDDO
+ CALL INVERT_ARRAY (FFX(1,L),XMAX,-DX(L),NX,XX(1,L),FMIN,DFX(L))
+
+C small x: interpolation in log(x)
+ FFZ(1,L) = FFX(NX,L)
+ DO J=2,NZ
+ Z = ZB(L) - DZ(L)*(DBLE(J)-1.D0)
+ X = dEXP(Z)
+ G = PARTON(X,L)
+ FFZ(J,L) = FFZ(J-1,L)+G*DZ(L)
+ ENDDO
+ CALL INVERT_ARRAY(FFZ(1,L),ZB(L),-DZ(L),NZ,ZZ(1,L),FMIN,DFZ(L))
+ FFA(L) = FFZ(NZ,L)
+ FFB(L) = FFX(NX,L)
+
+C very small x: f(x) = A/x**b b=1.268
+ IF(L.eq.1) THEN
+ APART(L) = FFA(L) / ( 1.D0 - dEXP(-b*ZA(L)) )
+ ELSE
+ APART(L) = ( FFA(L) - cpi ) / ( -ZA(L) )**bpi
+ ENDIF
+ ENDDO
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE ZSAMPLE_INI
+
+C-----------------------------------------------------------------------
+C...This subroutine initialise the generation of
+C. z = log(x) for the generation of z according
+C. to the structure functions
+C..................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ SAVE
+
+ IPAR(8) = 0
+
+ XA(1) = 1.D-04
+ XB(1) = 1.D-01
+ XMAX = 0.8D0
+ ZA(1) = dLOG(XA(1))
+ ZB(1) = dLOG(XB(1))
+ ZMAX = dLOG(XMAX)
+ NX = 200
+ NZ = 200
+ DX(1) = (XMAX-XB(1))/DBLE(NX-1)
+ DZ(1) = (ZB(1)-ZA(1))/DBLE(NZ-1)
+
+ XA(2) = 1.D-04
+ XB(2) = 1.D-01
+ XMAX = 0.8D0
+ ZA(2) = dLOG(XA(2))
+ ZB(2) = dLOG(XB(2))
+ ZMAX = dLOG(XMAX)
+ NX = 200
+ NZ = 200
+ DX(2) = (XMAX-XB(2))/DBLE(NX-1)
+ DZ(2) = (ZB(2)-ZA(2))/DBLE(NZ-1)
+
+ DO L=1,2
+
+C very small x: f(x) = A/x
+ APART(L) = PARTON(0.D0,L)
+
+C large x: interpolation in x
+ FFX(1,L) = 0.D0
+ DO J=2,NX
+ X = XMAX - DX(L)*(DBLE(J)-0.5D0)
+ G = PARTON(X,L)/X
+ FFX(J,L) = FFX(J-1,L)+G*DX(L)
+ ENDDO
+ CALL INVERT_ARRAY (FFX(1,L),XMAX,-DX(L),NX,XX(1,L),FMIN,DFX(L))
+
+C small x: interpolation in log(x)
+ FFZ(1,L) = FFX(NX,L)
+ DO J=2,NZ
+ Z = ZB(L) - DZ(L)*(DBLE(J)-0.5D0)
+ X = dEXP(Z)
+ G = PARTON(X,L)
+ FFZ(J,L) = FFZ(J-1,L)+G*DZ(L)
+ ENDDO
+ CALL INVERT_ARRAY(FFZ(1,L),ZB(L),-DZ(L),NZ,ZZ(1,L),FMIN,DFZ(L))
+ FFA(L) = FFZ(NZ,L)
+ FFB(L) = FFX(NX,L)
+
+ ENDDO
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION PARTON(X,L)
+
+C-----------------------------------------------------------------------
+C...This function returns the structure function
+C. f(x) = x * [ g(x) + 4/9 *(q(x) + qbar(x)) ]
+C. for a proton.
+C................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ PARAMETER (beta=1.925978D0)
+ SAVE
+ DATA NOUTP /0/
+
+c effective scale
+ Q2inp = PAR(22)
+ IF (L .EQ. 2) GOTO 1000
+
+ IF(IPAR(8).eq.0) THEN
+C... Eichten et al. (set 1)
+c tp060203 100 uv = 1.78 * x**0.5 * (1.-x**1.51)**3.5
+ uv = 1.78D0 * x**0.5D0 * (1.D0-x**1.51D0)**3.5D0
+ dv = 0.67D0 * x**0.4D0 * (1.D0-x**1.51D0)**4.5D0
+ us = 0.182D0 * (1.D0-x)**8.54D0
+ ss = 0.081D0 * (1.D0-x)**8.54D0
+ qq0 = uv + dv + 4.D0*us + 2.D0*ss
+ glu0 = (2.62D0 + 9.17D0*x)* (1.D0-x)**5.9D0
+ ELSE
+ IF( NOUTP.eq.0 ) print *,' using GRV pdf set'
+ IF( NOUTP.eq.0 ) print *,' Q2 scale in pdf:',Q2INP
+ NOUTP = 1
+
+ CALL SIB_DOR98LO (X, Q2inp, UV, DV, US, DS, SS, GL)
+ qq0 = uv + dv + 4.D0* (us + ds) + 2.D0*ss
+ glu0 = gl
+ ENDIF
+ parton = glu0 + 4.D0/9.D0*qq0
+ RETURN
+
+ 1000 CONTINUE
+ IF(IPAR(8).eq.0) THEN
+C...Owens set 1 from STRF from Wisc. Pheno. group. for q2=q2_min
+ AV=0.4D0
+ BV=0.7D0
+c BETA=GGAMMA(AV)*GGAMMA(BV+1.)/GGAMMA(AV+BV+1.) =1.925978
+ uv=X**(AV)*(1.D0-X)**BV/BETA
+ dv=uv
+
+ A=0.9D0
+ BET=5.D0
+ us=(A*(1.D0-X)**BET)/6.D0
+
+ A=0.888D0
+ BET=3.11D0
+ GA1=6.D0
+ glu0=A*(1.D0-X)**BET*(1.D0+GA1*X)
+c Bug Fix thanks to Sue Kashahara- correct factor in front of
+c sea quarks for Owens S.F. 5-94
+ qq0 = uv + dv + 6.D0*us
+ parton = (glu0 + 4.D0/9.D0*qq0)
+ RETURN
+ ELSE
+
+c duv = valence quark distribution
+c dgl = gluon distribution
+c dus = sea quark distribution (u,d,s)
+c dds = sea charm quark ( neglected )
+c dss = sea bottom quark ( neglected )
+ CALL DORPLO (X, Q2inp, uv, gl, us, ds, ss)
+ qq0 = uv + dv + 4.D0*us
+ glu0 = gl
+ parton = (glu0 + 4.D0/9.D0*qq0)
+ RETURN
+ ENDIF
+ END
+C=======================================================================
+
+ SUBROUTINE PDF_INI
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ SAVE
+
+ IF(IPAR(8).eq.0) THEN
+ if (ndebug .gt. 0 ) WRITE(LUN,*)
+ * ' PDF_INI: calcuLating pdf table using Eichten param..'
+ CALL ZSAMPLE_INI
+ ELSEIF(IPAR(8).eq.2) THEN
+ if (ndebug .gt. 0 ) then
+ WRITE(LUN,*)' PDF_INI: calculating pdf table using GRV',
+ * ' param..'
+ WRITE(LUN,*)' does not work with -fbounds-check !!'
+ endif
+ CALL GRV_INI
+ ELSE
+ if (ndebug .gt. 0 ) WRITE(LUN,*)
+ * ' PDF_INI: using common table of GRV parametrization..'
+ ENDIF
+ if (ndebug .gt. 0 ) THEN
+ WRITE(LUN,*)APART(1),FFA(1),FFB(1),DX(1),DZ(1)
+ WRITE(LUN,*)APART(2),FFA(2),FFB(2),DX(2),DZ(2)
+ ENDIF
+ END
+
+C=======================================================================
+
+ BLOCK DATA PDFINI
+
+C-----------------------------------------------------------------------
+C.. tabled parton distribution function
+c Proton: GRV98LO , Eur.Phys.J. C5(1998) 461-470
+c Pion: GRV91 , Z. Phys. C53, 651-655 (1992)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /S_CZGEN/ XA(2),XB(2),XMAX,ZA(2),ZB(2),ZMAX,
+ + DX(2),DZ(2),APART(2),FFA(2),FFB(2),
+ + DFX(2),DFZ(2),XX(200,2),ZZ(200,2),FFX(200,2),FFZ(200,2),
+ + NX,NZ
+ SAVE
+ DATA XA /1.D-06,0.0001D0/
+ DATA XB /0.1D0,0.1D0/
+ DATA XMAX /0.800000011921D0/
+ DATA ZMAX /-0.223143532872D0/
+ DATA NX /200/
+ DATA NZ /200/
+ DATA ZA /-13.8155D0,-9.21034D0/
+ DATA ZB /-2.30259D0,-2.30259D0/
+ DATA DX /0.00351759D0,0.00351759D0/
+ DATA DZ /0.0578539D0,0.0347123D0/
+ DATA DFX /0.00952501D0,0.00847474D0/
+ DATA DFZ /1.93863D0,0.326082D0/
+ DATA APART /-9.80215D0,0.0178207D0/
+ DATA FFA /387.684D0,66.5767D0/
+ DATA FFB /1.89548D0,1.68647D0/
+
+ DATA (FFX(K,1),K=1,200 ) /
+ &0.000D+00,6.380D-05,1.315D-04,2.034D-04,2.795D-04,
+ &3.601D-04,4.454D-04,5.356D-04,6.309D-04,7.315D-04,
+ &8.377D-04,9.497D-04,1.068D-03,1.192D-03,1.323D-03,
+ &1.460D-03,1.605D-03,1.756D-03,1.916D-03,2.083D-03,
+ &2.258D-03,2.441D-03,2.633D-03,2.835D-03,3.045D-03,
+ &3.265D-03,3.496D-03,3.736D-03,3.988D-03,4.250D-03,
+ &4.524D-03,4.810D-03,5.108D-03,5.418D-03,5.742D-03,
+ &6.078D-03,6.429D-03,6.794D-03,7.174D-03,7.570D-03,
+ &7.981D-03,8.408D-03,8.852D-03,9.313D-03,9.793D-03,
+ &1.029D-02,1.081D-02,1.134D-02,1.190D-02,1.247D-02,
+ &1.307D-02,1.369D-02,1.433D-02,1.500D-02,1.568D-02,
+ &1.640D-02,1.714D-02,1.790D-02,1.869D-02,1.951D-02,
+ &2.035D-02,2.123D-02,2.213D-02,2.307D-02,2.403D-02,
+ &2.503D-02,2.607D-02,2.713D-02,2.823D-02,2.937D-02,
+ &3.054D-02,3.176D-02,3.301D-02,3.430D-02,3.563D-02,
+ &3.701D-02,3.842D-02,3.989D-02,4.139D-02,4.295D-02,
+ &4.455D-02,4.620D-02,4.791D-02,4.966D-02,5.147D-02,
+ &5.334D-02,5.526D-02,5.724D-02,5.927D-02,6.137D-02,
+ &6.353D-02,6.576D-02,6.805D-02,7.041D-02,7.284D-02,
+ &7.534D-02,7.791D-02,8.056D-02,8.329D-02,8.609D-02,
+ &8.898D-02,9.195D-02,9.500D-02,9.814D-02,1.014D-01,
+ &1.047D-01,1.081D-01,1.116D-01,1.153D-01,1.190D-01,
+ &1.228D-01,1.267D-01,1.308D-01,1.350D-01,1.392D-01,
+ &1.436D-01,1.481D-01,1.528D-01,1.575D-01,1.624D-01,
+ &1.674D-01,1.725D-01,1.778D-01,1.832D-01,1.888D-01,
+ &1.946D-01,2.005D-01,2.066D-01,2.128D-01,2.193D-01,
+ &2.259D-01,2.327D-01,2.397D-01,2.469D-01,2.543D-01,
+ &2.619D-01,2.698D-01,2.778D-01,2.862D-01,2.947D-01,
+ &3.035D-01,3.125D-01,3.218D-01,3.314D-01,3.413D-01,
+ &3.514D-01,3.618D-01,3.726D-01,3.836D-01,3.950D-01,
+ &4.067D-01,4.188D-01,4.312D-01,4.440D-01,4.572D-01,
+ &4.708D-01,4.848D-01,4.992D-01,5.141D-01,5.294D-01,
+ &5.452D-01,5.615D-01,5.783D-01,5.956D-01,6.134D-01,
+ &6.319D-01,6.509D-01,6.706D-01,6.909D-01,7.118D-01,
+ &7.334D-01,7.558D-01,7.789D-01,8.029D-01,8.276D-01,
+ &8.532D-01,8.797D-01,9.072D-01,9.356D-01,9.650D-01,
+ &9.956D-01,1.027D+00,1.060D+00,1.094D+00,1.130D+00,
+ &1.167D+00,1.205D+00,1.245D+00,1.287D+00,1.331D+00,
+ &1.376D+00,1.423D+00,1.473D+00,1.525D+00,1.579D+00,
+ &1.636D+00,1.696D+00,1.759D+00,1.826D+00,1.895D+00/
+
+ DATA (FFX(K,2),K=1,200 ) /
+ &0.000D+00,7.266D-04,1.470D-03,2.231D-03,3.009D-03,
+ &3.805D-03,4.619D-03,5.450D-03,6.300D-03,7.168D-03,
+ &8.055D-03,8.961D-03,9.886D-03,1.083D-02,1.179D-02,
+ &1.278D-02,1.378D-02,1.481D-02,1.585D-02,1.692D-02,
+ &1.800D-02,1.911D-02,2.024D-02,2.139D-02,2.256D-02,
+ &2.376D-02,2.498D-02,2.622D-02,2.748D-02,2.877D-02,
+ &3.008D-02,3.142D-02,3.278D-02,3.416D-02,3.557D-02,
+ &3.701D-02,3.847D-02,3.996D-02,4.147D-02,4.301D-02,
+ &4.458D-02,4.617D-02,4.779D-02,4.945D-02,5.112D-02,
+ &5.283D-02,5.457D-02,5.634D-02,5.813D-02,5.996D-02,
+ &6.182D-02,6.371D-02,6.563D-02,6.759D-02,6.957D-02,
+ &7.159D-02,7.365D-02,7.573D-02,7.786D-02,8.001D-02,
+ &8.221D-02,8.443D-02,8.670D-02,8.900D-02,9.134D-02,
+ &9.372D-02,9.614D-02,9.860D-02,1.011D-01,1.036D-01,
+ &1.062D-01,1.088D-01,1.115D-01,1.142D-01,1.170D-01,
+ &1.197D-01,1.226D-01,1.255D-01,1.284D-01,1.314D-01,
+ &1.344D-01,1.375D-01,1.406D-01,1.438D-01,1.470D-01,
+ &1.503D-01,1.536D-01,1.570D-01,1.605D-01,1.640D-01,
+ &1.675D-01,1.712D-01,1.748D-01,1.786D-01,1.824D-01,
+ &1.862D-01,1.901D-01,1.941D-01,1.982D-01,2.023D-01,
+ &2.065D-01,2.107D-01,2.151D-01,2.195D-01,2.239D-01,
+ &2.285D-01,2.331D-01,2.378D-01,2.426D-01,2.474D-01,
+ &2.524D-01,2.574D-01,2.625D-01,2.677D-01,2.730D-01,
+ &2.784D-01,2.839D-01,2.895D-01,2.951D-01,3.009D-01,
+ &3.068D-01,3.128D-01,3.189D-01,3.251D-01,3.314D-01,
+ &3.378D-01,3.443D-01,3.510D-01,3.578D-01,3.647D-01,
+ &3.717D-01,3.789D-01,3.862D-01,3.937D-01,4.012D-01,
+ &4.090D-01,4.169D-01,4.249D-01,4.331D-01,4.415D-01,
+ &4.500D-01,4.587D-01,4.676D-01,4.767D-01,4.859D-01,
+ &4.954D-01,5.050D-01,5.148D-01,5.249D-01,5.352D-01,
+ &5.457D-01,5.564D-01,5.674D-01,5.786D-01,5.901D-01,
+ &6.019D-01,6.139D-01,6.262D-01,6.388D-01,6.517D-01,
+ &6.649D-01,6.785D-01,6.923D-01,7.066D-01,7.212D-01,
+ &7.362D-01,7.516D-01,7.673D-01,7.836D-01,8.002D-01,
+ &8.174D-01,8.350D-01,8.532D-01,8.718D-01,8.911D-01,
+ &9.109D-01,9.313D-01,9.524D-01,9.742D-01,9.966D-01,
+ &1.020D+00,1.044D+00,1.069D+00,1.094D+00,1.121D+00,
+ &1.149D+00,1.177D+00,1.207D+00,1.238D+00,1.271D+00,
+ &1.304D+00,1.339D+00,1.376D+00,1.414D+00,1.454D+00,
+ &1.496D+00,1.540D+00,1.586D+00,1.635D+00,1.686D+00/
+
+ DATA (FFZ(K,1),K=1,200 ) /
+ &1.895D+00,2.014D+00,2.137D+00,2.263D+00,2.393D+00,
+ &2.527D+00,2.665D+00,2.807D+00,2.953D+00,3.103D+00,
+ &3.257D+00,3.417D+00,3.580D+00,3.748D+00,3.921D+00,
+ &4.098D+00,4.281D+00,4.469D+00,4.663D+00,4.861D+00,
+ &5.065D+00,5.274D+00,5.489D+00,5.710D+00,5.937D+00,
+ &6.170D+00,6.409D+00,6.654D+00,6.906D+00,7.164D+00,
+ &7.430D+00,7.702D+00,7.981D+00,8.267D+00,8.561D+00,
+ &8.862D+00,9.171D+00,9.487D+00,9.811D+00,1.014D+01,
+ &1.048D+01,1.083D+01,1.119D+01,1.156D+01,1.193D+01,
+ &1.232D+01,1.271D+01,1.311D+01,1.352D+01,1.395D+01,
+ &1.438D+01,1.482D+01,1.527D+01,1.573D+01,1.621D+01,
+ &1.669D+01,1.718D+01,1.769D+01,1.821D+01,1.874D+01,
+ &1.928D+01,1.983D+01,2.040D+01,2.097D+01,2.156D+01,
+ &2.217D+01,2.278D+01,2.341D+01,2.406D+01,2.471D+01,
+ &2.539D+01,2.607D+01,2.677D+01,2.749D+01,2.822D+01,
+ &2.896D+01,2.973D+01,3.050D+01,3.130D+01,3.211D+01,
+ &3.293D+01,3.378D+01,3.464D+01,3.552D+01,3.642D+01,
+ &3.733D+01,3.827D+01,3.922D+01,4.020D+01,4.119D+01,
+ &4.220D+01,4.323D+01,4.429D+01,4.536D+01,4.646D+01,
+ &4.758D+01,4.872D+01,4.988D+01,5.106D+01,5.227D+01,
+ &5.350D+01,5.476D+01,5.604D+01,5.735D+01,5.868D+01,
+ &6.003D+01,6.142D+01,6.282D+01,6.426D+01,6.572D+01,
+ &6.721D+01,6.873D+01,7.028D+01,7.186D+01,7.346D+01,
+ &7.510D+01,7.677D+01,7.847D+01,8.020D+01,8.196D+01,
+ &8.375D+01,8.558D+01,8.744D+01,8.934D+01,9.127D+01,
+ &9.324D+01,9.524D+01,9.728D+01,9.936D+01,1.015D+02,
+ &1.036D+02,1.058D+02,1.080D+02,1.103D+02,1.126D+02,
+ &1.150D+02,1.174D+02,1.198D+02,1.223D+02,1.248D+02,
+ &1.274D+02,1.300D+02,1.327D+02,1.354D+02,1.381D+02,
+ &1.409D+02,1.438D+02,1.467D+02,1.496D+02,1.526D+02,
+ &1.557D+02,1.588D+02,1.619D+02,1.652D+02,1.684D+02,
+ &1.718D+02,1.751D+02,1.786D+02,1.821D+02,1.856D+02,
+ &1.892D+02,1.929D+02,1.967D+02,2.005D+02,2.043D+02,
+ &2.083D+02,2.122D+02,2.163D+02,2.204D+02,2.246D+02,
+ &2.289D+02,2.332D+02,2.376D+02,2.421D+02,2.467D+02,
+ &2.513D+02,2.560D+02,2.608D+02,2.656D+02,2.706D+02,
+ &2.756D+02,2.807D+02,2.859D+02,2.911D+02,2.965D+02,
+ &3.019D+02,3.074D+02,3.130D+02,3.187D+02,3.245D+02,
+ &3.304D+02,3.364D+02,3.425D+02,3.486D+02,3.549D+02,
+ &3.612D+02,3.677D+02,3.743D+02,3.809D+02,3.877D+02/
+
+ DATA (FFZ(K,2),K=1,200 ) /
+ &1.686D+00,1.738D+00,1.791D+00,1.844D+00,1.899D+00,
+ &1.955D+00,2.011D+00,2.069D+00,2.128D+00,2.188D+00,
+ &2.249D+00,2.311D+00,2.374D+00,2.438D+00,2.504D+00,
+ &2.570D+00,2.638D+00,2.708D+00,2.778D+00,2.850D+00,
+ &2.923D+00,2.997D+00,3.072D+00,3.149D+00,3.228D+00,
+ &3.307D+00,3.388D+00,3.471D+00,3.555D+00,3.640D+00,
+ &3.727D+00,3.815D+00,3.905D+00,3.997D+00,4.090D+00,
+ &4.184D+00,4.281D+00,4.378D+00,4.478D+00,4.579D+00,
+ &4.682D+00,4.787D+00,4.893D+00,5.002D+00,5.112D+00,
+ &5.224D+00,5.337D+00,5.453D+00,5.571D+00,5.690D+00,
+ &5.811D+00,5.935D+00,6.060D+00,6.188D+00,6.317D+00,
+ &6.449D+00,6.583D+00,6.719D+00,6.857D+00,6.997D+00,
+ &7.139D+00,7.284D+00,7.431D+00,7.580D+00,7.732D+00,
+ &7.886D+00,8.042D+00,8.201D+00,8.363D+00,8.526D+00,
+ &8.693D+00,8.862D+00,9.033D+00,9.207D+00,9.384D+00,
+ &9.563D+00,9.746D+00,9.930D+00,1.012D+01,1.031D+01,
+ &1.050D+01,1.070D+01,1.090D+01,1.110D+01,1.130D+01,
+ &1.151D+01,1.172D+01,1.194D+01,1.215D+01,1.237D+01,
+ &1.260D+01,1.283D+01,1.306D+01,1.329D+01,1.353D+01,
+ &1.377D+01,1.401D+01,1.426D+01,1.451D+01,1.476D+01,
+ &1.502D+01,1.528D+01,1.554D+01,1.581D+01,1.608D+01,
+ &1.636D+01,1.664D+01,1.692D+01,1.721D+01,1.750D+01,
+ &1.780D+01,1.810D+01,1.840D+01,1.871D+01,1.902D+01,
+ &1.934D+01,1.966D+01,1.998D+01,2.031D+01,2.065D+01,
+ &2.098D+01,2.133D+01,2.167D+01,2.203D+01,2.238D+01,
+ &2.274D+01,2.311D+01,2.348D+01,2.385D+01,2.423D+01,
+ &2.462D+01,2.501D+01,2.541D+01,2.581D+01,2.621D+01,
+ &2.662D+01,2.704D+01,2.746D+01,2.789D+01,2.832D+01,
+ &2.875D+01,2.920D+01,2.965D+01,3.010D+01,3.056D+01,
+ &3.103D+01,3.150D+01,3.198D+01,3.246D+01,3.295D+01,
+ &3.344D+01,3.395D+01,3.445D+01,3.497D+01,3.549D+01,
+ &3.601D+01,3.655D+01,3.709D+01,3.763D+01,3.819D+01,
+ &3.875D+01,3.931D+01,3.989D+01,4.047D+01,4.105D+01,
+ &4.165D+01,4.225D+01,4.286D+01,4.347D+01,4.410D+01,
+ &4.473D+01,4.537D+01,4.601D+01,4.666D+01,4.732D+01,
+ &4.799D+01,4.867D+01,4.935D+01,5.005D+01,5.075D+01,
+ &5.146D+01,5.217D+01,5.290D+01,5.363D+01,5.437D+01,
+ &5.512D+01,5.588D+01,5.665D+01,5.743D+01,5.821D+01,
+ &5.901D+01,5.981D+01,6.062D+01,6.145D+01,6.228D+01,
+ &6.312D+01,6.397D+01,6.483D+01,6.570D+01,6.658D+01/
+
+ DATA (XX(K,1),K=1,200 ) /
+ &8.000D-01,6.472D-01,5.944D-01,5.597D-01,5.335D-01,
+ &5.121D-01,4.941D-01,4.785D-01,4.647D-01,4.522D-01,
+ &4.409D-01,4.306D-01,4.210D-01,4.122D-01,4.039D-01,
+ &3.961D-01,3.887D-01,3.817D-01,3.751D-01,3.688D-01,
+ &3.628D-01,3.571D-01,3.516D-01,3.463D-01,3.413D-01,
+ &3.365D-01,3.318D-01,3.273D-01,3.230D-01,3.188D-01,
+ &3.147D-01,3.108D-01,3.070D-01,3.033D-01,2.998D-01,
+ &2.963D-01,2.929D-01,2.896D-01,2.864D-01,2.833D-01,
+ &2.802D-01,2.773D-01,2.744D-01,2.715D-01,2.688D-01,
+ &2.661D-01,2.634D-01,2.608D-01,2.583D-01,2.558D-01,
+ &2.534D-01,2.510D-01,2.487D-01,2.464D-01,2.442D-01,
+ &2.420D-01,2.398D-01,2.377D-01,2.356D-01,2.336D-01,
+ &2.316D-01,2.296D-01,2.277D-01,2.257D-01,2.239D-01,
+ &2.220D-01,2.202D-01,2.184D-01,2.167D-01,2.150D-01,
+ &2.132D-01,2.116D-01,2.099D-01,2.083D-01,2.067D-01,
+ &2.051D-01,2.036D-01,2.020D-01,2.005D-01,1.990D-01,
+ &1.976D-01,1.961D-01,1.947D-01,1.933D-01,1.919D-01,
+ &1.905D-01,1.891D-01,1.878D-01,1.865D-01,1.852D-01,
+ &1.839D-01,1.826D-01,1.814D-01,1.801D-01,1.789D-01,
+ &1.777D-01,1.765D-01,1.753D-01,1.741D-01,1.730D-01,
+ &1.718D-01,1.707D-01,1.696D-01,1.685D-01,1.674D-01,
+ &1.663D-01,1.653D-01,1.642D-01,1.632D-01,1.622D-01,
+ &1.611D-01,1.601D-01,1.591D-01,1.581D-01,1.572D-01,
+ &1.562D-01,1.552D-01,1.543D-01,1.534D-01,1.524D-01,
+ &1.515D-01,1.506D-01,1.497D-01,1.488D-01,1.479D-01,
+ &1.471D-01,1.462D-01,1.453D-01,1.445D-01,1.437D-01,
+ &1.428D-01,1.420D-01,1.412D-01,1.404D-01,1.396D-01,
+ &1.388D-01,1.380D-01,1.372D-01,1.365D-01,1.357D-01,
+ &1.349D-01,1.342D-01,1.335D-01,1.327D-01,1.320D-01,
+ &1.313D-01,1.306D-01,1.299D-01,1.292D-01,1.284D-01,
+ &1.278D-01,1.271D-01,1.264D-01,1.257D-01,1.251D-01,
+ &1.244D-01,1.237D-01,1.231D-01,1.224D-01,1.218D-01,
+ &1.212D-01,1.205D-01,1.199D-01,1.193D-01,1.187D-01,
+ &1.181D-01,1.175D-01,1.169D-01,1.163D-01,1.157D-01,
+ &1.151D-01,1.145D-01,1.139D-01,1.134D-01,1.128D-01,
+ &1.123D-01,1.117D-01,1.112D-01,1.106D-01,1.101D-01,
+ &1.095D-01,1.090D-01,1.085D-01,1.079D-01,1.074D-01,
+ &1.069D-01,1.064D-01,1.059D-01,1.054D-01,1.049D-01,
+ &1.044D-01,1.039D-01,1.034D-01,1.029D-01,1.024D-01,
+ &1.019D-01,1.014D-01,1.010D-01,1.005D-01,1.000D-01/
+
+ DATA (XX(K,2),K=1,200 ) /
+ &8.000D-01,7.632D-01,7.331D-01,7.073D-01,6.846D-01,
+ &6.643D-01,6.458D-01,6.289D-01,6.132D-01,5.986D-01,
+ &5.849D-01,5.721D-01,5.600D-01,5.485D-01,5.376D-01,
+ &5.272D-01,5.172D-01,5.077D-01,4.986D-01,4.899D-01,
+ &4.815D-01,4.734D-01,4.656D-01,4.581D-01,4.508D-01,
+ &4.438D-01,4.370D-01,4.304D-01,4.240D-01,4.178D-01,
+ &4.118D-01,4.059D-01,4.002D-01,3.947D-01,3.893D-01,
+ &3.840D-01,3.789D-01,3.739D-01,3.690D-01,3.643D-01,
+ &3.597D-01,3.551D-01,3.507D-01,3.464D-01,3.421D-01,
+ &3.380D-01,3.340D-01,3.300D-01,3.261D-01,3.223D-01,
+ &3.186D-01,3.150D-01,3.114D-01,3.079D-01,3.045D-01,
+ &3.011D-01,2.978D-01,2.945D-01,2.914D-01,2.883D-01,
+ &2.852D-01,2.822D-01,2.792D-01,2.763D-01,2.735D-01,
+ &2.707D-01,2.679D-01,2.652D-01,2.625D-01,2.599D-01,
+ &2.574D-01,2.548D-01,2.523D-01,2.499D-01,2.475D-01,
+ &2.451D-01,2.428D-01,2.405D-01,2.382D-01,2.360D-01,
+ &2.338D-01,2.316D-01,2.295D-01,2.274D-01,2.254D-01,
+ &2.233D-01,2.213D-01,2.193D-01,2.174D-01,2.155D-01,
+ &2.136D-01,2.117D-01,2.099D-01,2.081D-01,2.063D-01,
+ &2.045D-01,2.028D-01,2.011D-01,1.994D-01,1.977D-01,
+ &1.961D-01,1.944D-01,1.929D-01,1.913D-01,1.897D-01,
+ &1.882D-01,1.867D-01,1.851D-01,1.837D-01,1.822D-01,
+ &1.808D-01,1.793D-01,1.779D-01,1.765D-01,1.752D-01,
+ &1.738D-01,1.725D-01,1.711D-01,1.698D-01,1.686D-01,
+ &1.673D-01,1.660D-01,1.648D-01,1.635D-01,1.623D-01,
+ &1.611D-01,1.599D-01,1.588D-01,1.576D-01,1.564D-01,
+ &1.553D-01,1.542D-01,1.531D-01,1.520D-01,1.509D-01,
+ &1.498D-01,1.488D-01,1.477D-01,1.467D-01,1.457D-01,
+ &1.447D-01,1.437D-01,1.427D-01,1.417D-01,1.407D-01,
+ &1.398D-01,1.388D-01,1.379D-01,1.369D-01,1.360D-01,
+ &1.351D-01,1.342D-01,1.333D-01,1.324D-01,1.316D-01,
+ &1.307D-01,1.299D-01,1.290D-01,1.282D-01,1.273D-01,
+ &1.265D-01,1.257D-01,1.249D-01,1.241D-01,1.233D-01,
+ &1.225D-01,1.218D-01,1.210D-01,1.203D-01,1.195D-01,
+ &1.188D-01,1.180D-01,1.173D-01,1.166D-01,1.159D-01,
+ &1.152D-01,1.144D-01,1.138D-01,1.131D-01,1.124D-01,
+ &1.117D-01,1.110D-01,1.104D-01,1.097D-01,1.091D-01,
+ &1.084D-01,1.078D-01,1.072D-01,1.065D-01,1.059D-01,
+ &1.053D-01,1.047D-01,1.041D-01,1.035D-01,1.029D-01,
+ &1.023D-01,1.017D-01,1.012D-01,1.006D-01,1.000D-01/
+
+ DATA (ZZ(K,1),K=1,200 ) /
+ &-2.303D+00,-3.084D+00,-3.649D+00,-4.098D+00,
+ &-4.472D+00,-4.795D+00,-5.080D+00,-5.335D+00,
+ &-5.568D+00,-5.781D+00,-5.978D+00,-6.161D+00,
+ &-6.333D+00,-6.494D+00,-6.647D+00,-6.792D+00,
+ &-6.929D+00,-7.060D+00,-7.186D+00,-7.306D+00,
+ &-7.421D+00,-7.532D+00,-7.639D+00,-7.742D+00,
+ &-7.842D+00,-7.938D+00,-8.031D+00,-8.122D+00,
+ &-8.210D+00,-8.295D+00,-8.378D+00,-8.459D+00,
+ &-8.538D+00,-8.614D+00,-8.689D+00,-8.762D+00,
+ &-8.834D+00,-8.904D+00,-8.972D+00,-9.039D+00,
+ &-9.104D+00,-9.168D+00,-9.231D+00,-9.293D+00,
+ &-9.353D+00,-9.412D+00,-9.470D+00,-9.528D+00,
+ &-9.584D+00,-9.639D+00,-9.693D+00,-9.746D+00,
+ &-9.799D+00,-9.851D+00,-9.901D+00,-9.951D+00,
+ &-1.000D+01,-1.005D+01,-1.010D+01,-1.014D+01,
+ &-1.019D+01,-1.024D+01,-1.028D+01,-1.033D+01,
+ &-1.037D+01,-1.041D+01,-1.046D+01,-1.050D+01,
+ &-1.054D+01,-1.058D+01,-1.062D+01,-1.066D+01,
+ &-1.070D+01,-1.074D+01,-1.078D+01,-1.082D+01,
+ &-1.086D+01,-1.089D+01,-1.093D+01,-1.097D+01,
+ &-1.101D+01,-1.104D+01,-1.108D+01,-1.111D+01,
+ &-1.115D+01,-1.118D+01,-1.122D+01,-1.125D+01,
+ &-1.128D+01,-1.132D+01,-1.135D+01,-1.138D+01,
+ &-1.141D+01,-1.145D+01,-1.148D+01,-1.151D+01,
+ &-1.154D+01,-1.157D+01,-1.160D+01,-1.163D+01,
+ &-1.166D+01,-1.169D+01,-1.172D+01,-1.175D+01,
+ &-1.178D+01,-1.181D+01,-1.184D+01,-1.186D+01,
+ &-1.189D+01,-1.192D+01,-1.195D+01,-1.198D+01,
+ &-1.200D+01,-1.203D+01,-1.206D+01,-1.208D+01,
+ &-1.211D+01,-1.214D+01,-1.216D+01,-1.219D+01,
+ &-1.221D+01,-1.224D+01,-1.226D+01,-1.229D+01,
+ &-1.231D+01,-1.234D+01,-1.236D+01,-1.239D+01,
+ &-1.241D+01,-1.244D+01,-1.246D+01,-1.248D+01,
+ &-1.251D+01,-1.253D+01,-1.255D+01,-1.258D+01,
+ &-1.260D+01,-1.262D+01,-1.264D+01,-1.267D+01,
+ &-1.269D+01,-1.271D+01,-1.273D+01,-1.276D+01,
+ &-1.278D+01,-1.280D+01,-1.282D+01,-1.284D+01,
+ &-1.286D+01,-1.289D+01,-1.291D+01,-1.293D+01,
+ &-1.295D+01,-1.297D+01,-1.299D+01,-1.301D+01,
+ &-1.303D+01,-1.305D+01,-1.307D+01,-1.309D+01,
+ &-1.311D+01,-1.313D+01,-1.315D+01,-1.317D+01,
+ &-1.319D+01,-1.321D+01,-1.323D+01,-1.325D+01,
+ &-1.327D+01,-1.329D+01,-1.330D+01,-1.332D+01,
+ &-1.334D+01,-1.336D+01,-1.338D+01,-1.340D+01,
+ &-1.342D+01,-1.343D+01,-1.345D+01,-1.347D+01,
+ &-1.349D+01,-1.351D+01,-1.352D+01,-1.354D+01,
+ &-1.356D+01,-1.358D+01,-1.360D+01,-1.361D+01,
+ &-1.363D+01,-1.365D+01,-1.366D+01,-1.368D+01,
+ &-1.370D+01,-1.372D+01,-1.373D+01,-1.375D+01,
+ &-1.377D+01,-1.378D+01,-1.380D+01,-1.382D+01/
+
+ DATA (ZZ(K,2),K=1,200 ) /
+ &-2.303D+00,-2.512D+00,-2.700D+00,-2.871D+00,
+ &-3.029D+00,-3.175D+00,-3.310D+00,-3.438D+00,
+ &-3.557D+00,-3.670D+00,-3.778D+00,-3.880D+00,
+ &-3.977D+00,-4.070D+00,-4.159D+00,-4.245D+00,
+ &-4.328D+00,-4.407D+00,-4.484D+00,-4.558D+00,
+ &-4.630D+00,-4.699D+00,-4.767D+00,-4.832D+00,
+ &-4.896D+00,-4.958D+00,-5.019D+00,-5.078D+00,
+ &-5.135D+00,-5.191D+00,-5.246D+00,-5.300D+00,
+ &-5.352D+00,-5.403D+00,-5.453D+00,-5.503D+00,
+ &-5.551D+00,-5.598D+00,-5.645D+00,-5.690D+00,
+ &-5.735D+00,-5.779D+00,-5.822D+00,-5.864D+00,
+ &-5.906D+00,-5.947D+00,-5.988D+00,-6.027D+00,
+ &-6.067D+00,-6.105D+00,-6.143D+00,-6.181D+00,
+ &-6.217D+00,-6.254D+00,-6.290D+00,-6.325D+00,
+ &-6.360D+00,-6.394D+00,-6.428D+00,-6.462D+00,
+ &-6.495D+00,-6.528D+00,-6.560D+00,-6.592D+00,
+ &-6.624D+00,-6.655D+00,-6.686D+00,-6.716D+00,
+ &-6.746D+00,-6.776D+00,-6.805D+00,-6.835D+00,
+ &-6.863D+00,-6.892D+00,-6.920D+00,-6.948D+00,
+ &-6.976D+00,-7.003D+00,-7.030D+00,-7.057D+00,
+ &-7.084D+00,-7.110D+00,-7.136D+00,-7.162D+00,
+ &-7.188D+00,-7.213D+00,-7.238D+00,-7.263D+00,
+ &-7.288D+00,-7.312D+00,-7.336D+00,-7.360D+00,
+ &-7.384D+00,-7.408D+00,-7.431D+00,-7.455D+00,
+ &-7.478D+00,-7.501D+00,-7.523D+00,-7.546D+00,
+ &-7.568D+00,-7.590D+00,-7.612D+00,-7.634D+00,
+ &-7.656D+00,-7.677D+00,-7.698D+00,-7.720D+00,
+ &-7.741D+00,-7.761D+00,-7.782D+00,-7.803D+00,
+ &-7.823D+00,-7.843D+00,-7.863D+00,-7.883D+00,
+ &-7.903D+00,-7.923D+00,-7.943D+00,-7.962D+00,
+ &-7.981D+00,-8.001D+00,-8.020D+00,-8.039D+00,
+ &-8.057D+00,-8.076D+00,-8.095D+00,-8.113D+00,
+ &-8.132D+00,-8.150D+00,-8.168D+00,-8.186D+00,
+ &-8.204D+00,-8.222D+00,-8.239D+00,-8.257D+00,
+ &-8.274D+00,-8.292D+00,-8.309D+00,-8.326D+00,
+ &-8.343D+00,-8.360D+00,-8.377D+00,-8.394D+00,
+ &-8.411D+00,-8.427D+00,-8.444D+00,-8.460D+00,
+ &-8.476D+00,-8.493D+00,-8.509D+00,-8.525D+00,
+ &-8.541D+00,-8.557D+00,-8.572D+00,-8.588D+00,
+ &-8.604D+00,-8.619D+00,-8.635D+00,-8.650D+00,
+ &-8.666D+00,-8.681D+00,-8.696D+00,-8.711D+00,
+ &-8.726D+00,-8.741D+00,-8.756D+00,-8.771D+00,
+ &-8.786D+00,-8.800D+00,-8.815D+00,-8.829D+00,
+ &-8.844D+00,-8.858D+00,-8.872D+00,-8.887D+00,
+ &-8.901D+00,-8.915D+00,-8.929D+00,-8.943D+00,
+ &-8.957D+00,-8.971D+00,-8.985D+00,-8.998D+00,
+ &-9.012D+00,-9.026D+00,-9.039D+00,-9.053D+00,
+ &-9.066D+00,-9.080D+00,-9.093D+00,-9.106D+00,
+ &-9.119D+00,-9.133D+00,-9.146D+00,-9.159D+00,
+ &-9.172D+00,-9.185D+00,-9.197D+00,-9.210D+00/
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CHIDIS (KPARTin, IFL1, IFL2)
+
+C-----------------------------------------------------------------------
+C...Generate CHI (fraction of energy of a hadron carried by
+C. the valence quark, or diquark, as specified by IFL1)
+C. INPUT KPART = code of particle
+C. IFL1, IFL2 = codes of partons (3, 3bar of color)
+C.........................................................
+ IMPLICIT NONE
+c external types
+ INTEGER KPARTIN,IFL1,IFL2
+c COMMONs
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION CCHIK
+ COMMON /S_CPSPL/ CCHIK(4,99)
+
+ DOUBLE PRECISION STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+ COMMON /S_CUTOFF/ STR_mass_val, STR_mass_val_hyp, STR_mass_sea
+c internal types
+ DOUBLE PRECISION CUT,S_RNDM
+ INTEGER KPART,IFQ
+ SAVE
+
+ kpart=IABS(kpartin)
+ IFQ=IABS(IFL1)
+ IF (IFQ.GT.10) IFQ=IABS(IFL2)
+ CUT=2.D0*STR_mass_val/SQS
+c hyperon beam cut
+ IF(kpart.gt.14) CUT=2.D0*STR_mass_val_hyp/SQS
+100 CHIDIS=S_RNDM(0)**2
+ if (chidis.lt.cut) goto 100
+ if (chidis.gt.(1.D0-cut)) goto 100
+ IF((CHIDIS**2/(CHIDIS**2+CUT**2))**0.5D0
+ + *(1.D0-CHIDIS)**CCHIK(IFQ,KPART).LT.S_RNDM(1)) GOTO 100
+ CHIDIS = MAX(0.5D0*CUT,CHIDIS)
+ CHIDIS = MIN(1.D0-CUT,CHIDIS)
+c diquarks or charm quarks
+ IF (IABS(IFL1).GT.3) CHIDIS=1.D0-CHIDIS
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION QMASS(IFL)
+
+C-----------------------------------------------------------------------
+C...Return quark or diquark constituent masses
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION QMAS(4)
+ SAVE
+ DATA QMAS /0.325D0,0.325D0,0.5D0,1.5D0/
+
+ IFLA = IABS(IFL)
+ IFLA = MOD(IFLA,100)
+ IF (IFLA .LE. 4) THEN
+ QMASS = QMAS(IFLA)
+ ELSE
+ QMA = QMAS(IFLA/10)
+ QMB = QMAS(MOD(IFLA,10))
+ QMASS = QMA+QMB
+ ENDIF
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION XM2DIS(XM2MIN,XM2MAX,ALPHA)
+
+C-----------------------------------------------------------------------
+C function that samples mass**2 from (1/M**2)**alpha
+C with alpha <= 1
+C INPUT: Mmin**2 : minimal mass
+C Mmax**2 : maximal mass
+C alpha : slope \FR'14
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+c reduced alpha
+ ALPHArdc = 2.d0*(ALPHA-1.d0)
+ AMIN = LOG(XM2MIN)
+ AMAX = LOG(XM2MAX)
+ ADLT = AMAX-AMIN
+ IF(ABS(ALPHArdc).LT.1.d-3)THEN
+c alpha = 1
+ XRNDM = MAX(S_RNDM(0),1.D-10)
+ AX = AMIN+ADLT*XRNDM
+ XM2DIS = EXP(AX)
+ ELSEIF(ALPHArdc.LT.0.D0.and.ALPHA.gt.0.D0)THEN
+c 0 < alpha < 1
+ XRNDM = MAX(S_RNDM(0),1.D-10)
+c AX = AMAX-LOG(XRNDM)*ALPHArdc
+ DX = XM2MAX**(1.D0-ALPHA)*XRNDM +
+ + XM2MIN**(1.D0-ALPHA)*(1.D0-XRNDM)
+ AX = LOG(DX)/(1.D0-ALPHA)
+ XM2DIS = EXP(AX)
+ ELSEIF(ALPHArdc.GE.1.D0)THEN
+c alpha >= 1
+ ALPHAr = 1.D0-ALPHA
+ XMINA = XM2MIN**ALPHAr
+ XMAXA = XM2MAX**ALPHAr
+ XDLT = XMAXA-XMINA
+ XRNDM = MAX(S_RNDM(0),1.D-10)
+ Z = LOG(XMINA+XDLT*XRNDM)/ALPHAR
+ XM2DIS = EXP(Z)
+ ELSE
+ WRITE(6,*) 'M2DIS: undefined exponent in mass distribution!',
+ & ALPHA
+ XM2DIS = 0.D0
+ CALL SIB_REJECT('M2DIS ')
+ ENDIF
+ END
+C=======================================================================
+
+ SUBROUTINE EXCTDEC( IDX, LBAD)
+
+C-----------------------------------------------------------------------
+C routine to fragment an excited system with known flavor via
+C resonance decay
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+c external variables
+ INTEGER IDX,LBAD
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+
+ INTEGER LRNK
+ COMMON /SIB_RNK/ LRNK(8000)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c local variables
+ DOUBLE PRECISION P0,BE,PR1,PR2,PRH,GABE,P2,
+ & PAR2_def,PAR8_def,PAR24_def,DELTAE,PCXG,
+ & EMIN1,EMIN2,EMIN3,EMIN4,S_RNDM,GA,PTR,PTOT,P1TOT,PX,PY,
+ & COD,SID,COF,SIF,ANORF,BEP
+ DIMENSION P0(5),BE(3),PR1(5),PR2(5),PRH(5),GABE(4),
+ & P2(5)
+ INTEGER IPID,IR1DX,IFLR1,IR2DX,IFLR2,IRH,IRHPID,IR,
+ & KK,KD,IFAIL,N1,IFBAD,J,K,I
+ SAVE
+
+c LBAD = 1
+
+c initial parameters
+ PAR2_def = PAR(2) ! ud/s rate
+ PAR8_def = PAR(8) ! popcorn rate
+ PAR24_def = PAR(24) ! c/s rate
+ if(ndebug.gt.1)
+ & WRITE(LUN,*) ' EXCTDEC: IDX,IREJ',IDX,LBAD
+
+c read remnant 4momentum from stack
+ CALL RD_PRTN_4VEC(IDX,P0,IPID,IR1DX)
+ CALL RD_PRTN_4VEC(IR1DX,PR1,IFLR1,IR2DX)
+ CALL RD_PRTN_4VEC(IR2DX,PR2,IFLR2,IRH)
+ CALL RD_PRTN_4VEC(IRH,PRH,IRHPID,IR)
+ IPFLAG = IPID
+ IF(IDX.ne.IR)then
+ write(lun,*) ' EXCTDEC: reference loop broken!',IDX,IR
+ CALL SIB_REJECT('EXCTDEC ')
+ endif
+ IF(NDEBUG.GT.2)THEN
+ WRITE(LUN,*) ' EXCTDEC: P0:' , (P0(kk),kk=1,5)
+ WRITE(LUN,*) ' EXCTDEC: PR1:' , (PR1(kk),kk=1,5)
+ WRITE(LUN,*) ' EXCTDEC: PR2:' , (PR2(kk),kk=1,5)
+ WRITE(LUN,*) ' EXCTDEC: PH:' , (PRH(kk),kk=1,5)
+ ENDIF
+
+C identity of remnant
+c form hadron from flavors in remnant
+c (not preserving spin or isospin!)
+c CALL SIB_I4FLAV(iflr1,iflr2,Idm, KD )
+ KD = IRHPID
+
+c available kinetic energy
+ DELTAE = P0(5)-AM(ABS(KD))
+c fallback region: 0 < DELTAE < EMIN1
+ EMIN1 = PAR(76)
+c resonance region: EMIN1 < DELTAE < EMIN2
+ EMIN2 = PAR(77)
+c phasespace decay region: EMIN2 < DELTAE < EMIN3
+ EMIN3 = PAR(78)
+c string decay region: EMIN3 < DELTAE < EMIN4
+ EMIN4 = PAR(79)
+
+ IF(NDEBUG.gt.2)THEN
+ WRITE(LUN,*)
+ & ' EXCTDEC: MASS,IFL1,IFL2,PID',P0(5),IFLR1,IFLR2,KD
+ WRITE(LUN,*) ' EXCTDEC: DELTAE,EMIN1,EMIN2,EMIN3',
+ & DELTAE,EMIN1,EMIN2,EMIN3
+ ENDIF
+
+c strange quark rate
+ IF(IPAR(48).eq.1)THEN
+ PAR(2) = PAR(89)
+ ENDIF
+
+c charm quark rate
+ IF(IPAR(62).eq.1)THEN
+ PAR(24) = PAR(107)
+ ENDIF
+
+c popcorn rate in remnant
+ IF(IPAR(56).eq.1)THEN
+ PAR(8) = PAR(102)
+ ENDIF
+
+ IF(DELTAE.lt.EMIN2)THEN
+c beam or resonance region
+ IF(NDEBUG.gt.1) then
+ if(DELTAE.lt.EMIN1)then
+ WRITE(LUN,*)' EXCTDEC: fallback to beam..'
+ else
+ WRITE(LUN,*)' EXCTDEC: forming resonance..'
+ endif
+ endif
+ NP = NP + 1
+ LLIST(NP) = KD
+ NPORIG(NP) = IPFLAG
+ LRNK(NP) = 0
+ niorig(NP) = iiflag
+ DO kk=1,5
+ P(NP,KK) = P0(KK)
+ ENDDO
+ LBAD = 0
+ PAR(2) = PAR2_def
+ PAR(8) = PAR8_def
+ PAR(24) = PAR24_def
+ RETURN
+
+ ELSEIF(DELTAE.lt.EMIN3)THEN
+c phasespace decay region
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' EXCTDEC: phasespace decay ..'
+ IPFLAG = IPID/iabs(IPID) + ISIGN(1000,IPID)
+c set charge exchange probability,
+c i.e. prob for p* -> n + pip
+ PCXG = PAR(99)
+ CALL FIREBALL_4FLV(KD,P0,PCXG,IFAIL)
+ PAR(2) = PAR2_def
+ PAR(8) = PAR8_def
+ PAR(24) = PAR24_def
+ IF(IFAIL.eq.1) THEN
+ IF(ndebug.gt.0)
+ & WRITE(LUN,*) ' EXCTDEC: remnant frag. rejection!'
+ LBAD = 1
+ RETURN
+ ENDIF
+ LBAD = 0
+ RETURN
+
+c ELSEIF(DELTAE.lt.EMIN4)THEN
+ ELSE
+C string fragmentation region
+ IF(NDEBUG.gt.1) WRITE(LUN,*)' EXCTDEC: string decay ..'
+ N1 = NP+1
+ IPFLAG = IPFLAG + ISIGN(3000,IPID)
+c for meson remnant quark and anti-quark should be treated equally
+c therefor switch randomly
+ IF(IBAR(ABS(KD)).eq.0.and.S_RNDM(KD).lt.0.5D0)
+ & CALL ISWTCH_LMNTS(IFLR1,IFLR2)
+
+c turn remnant string around
+ IF(IPAR(23).eq.1)THEN
+ IF(S_RNDM(0).gt.PAR(39))
+ & CALL ISWTCH_LMNTS(IFLR1,IFLR2)
+ ENDIF
+
+ CALL STRING_FRAG_4FLV
+ + (P0(5), IFLR2, IFLR1, 0.D0,0.D0,0.D0,0.D0,IFBAD,1)
+ IF (IFBAD .EQ. 1)THEN
+ IF(ndebug.gt.0)
+ & WRITE(LUN,*) ' EXCTDEC: remnant frag. rejection!'
+ LBAD = 1
+ PAR(2) = PAR2_def
+ PAR(8) = PAR8_def
+ PAR(24) = PAR24_def
+ RETURN
+ ENDIF
+ DO J=1,3
+ BE(J)=P0(J)/P0(4)
+ GABE(J)=P0(J)/P0(5)
+ ENDDO
+ GA=P0(4)/P0(5)
+ GABE(4)=P0(4)/P0(5)
+C... rotate and boost string
+ IF(IPAR(38).eq.1.or.IPAR(38).eq.3)THEN
+c sample additional soft pt for remnant partons
+ CALL PTDIS_4FLV(0,PX,PY)
+ PTR = SQRT(PX**2+PY**2)
+ PTOT = SQRT(4.D0*PTR**2+P0(5)**2)*0.5D0
+c rotation factors
+ COD = 0.5D0*P0(5)/PTOT
+ SID = PTR/PTOT
+c COD= 1.D0/SQRT(1.D0+4.D0*PTR**2/P0(5))
+c SID= 2.D0*PTR/P0(5)*COD
+ COF=1.D0
+ SIF=0.D0
+ IF(PTOT*SID.GT.EPS5) THEN
+ COF=PX/(SID*PTOT)
+ SIF=PY/(SID*PTOT)
+ ANORF=DSQRT(COF*COF+SIF*SIF)
+ COF=COF/ANORF
+ SIF=SIF/ANORF
+ ENDIF
+ IF(ndebug.gt.3)THEN
+ write(lun,*)' EXCTDEC: rotation factors (cod,sid,cof,sif):',
+ & cod,sid,cof,sif
+ write(lun,*)' EXCTDEC: rotation angles (theta,phi):',
+ & ACOS(cod),ACOS(cof)
+ ENDIF
+c rotate string final state
+ DO K=N1,NP
+ CALL SIB_TRANI(P(K,1),P(k,2),P(k,3),cod,sid,cof,sif
+ & ,P2(1),P2(2),P2(3))
+ do j=1,3
+ P(K,j)=P2(j)
+ enddo
+ ENDDO
+c boost to hadron-hadron center-of-mass
+ IF(ndebug.gt.3)
+ & write(lun,*) ' EXCTDEC: boost to had-had (gabe,gam):',
+ & (gabe(j),j=1,4)
+ DO K=N1,NP
+ NPORIG(K) = IPFLAG
+ niorig(K) = iiflag
+ CALL SIB_ALTRA(gabe(4),gabe(1),gabe(2),
+ & gabe(3),P(k,1),p(k,2),p(k,3),p(k,4),
+ & P1TOT,p2(1),p2(2),p2(3),p2(4))
+ do j=1,4
+ P(K,j)=P2(j)
+ enddo
+ ENDDO
+ ELSEIF(IPAR(38).eq.2.or.IPAR(38).eq.0)THEN
+C... boost string
+ DO I=N1,NP
+ NPORIG(I) = IPFLAG
+ niorig(I) = iiflag
+ BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
+ DO J=1,3
+ P(I,J)=P(I,J)+GA*(GA*BEP/(1.D0+GA)+P(I,4))*BE(J)
+ ENDDO
+ P(I,4)=GA*(P(I,4)+BEP)
+ ENDDO
+ ENDIF
+ ENDIF
+ LBAD = 0
+ PAR(2) = PAR2_def
+ PAR(8) = PAR8_def
+ PAR(24) = PAR24_def
+ return
+ END
+C=======================================================================
+
+ SUBROUTINE PTDIS_4FLV (IFL,PX,PY)
+
+C-----------------------------------------------------------------------
+C...Generate pT
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ DOUBLE PRECISION PPT02
+ COMMON /S_CQDIS2/ PPT02(44)
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+
+ IF(IFL.eq.0)THEN
+c quark confinement pt
+ PPTT = PAR(110)
+ XM = 0.325D0
+ XM2 = XM**2
+ RNDM = MAX(EPS10,S_RNDM(IFL))
+ XMT = PPTT * LOG(RNDM) - XM
+ XMT2 = XMT**2
+ PT = SQRT(XMT2-XM2)
+ ELSE
+ IFLA = IABS(IFL)
+ IFLA = MOD(IFLA,100)
+ PPTT = PPT02(IFLA)
+c Gaussian distribution
+ PT = PPTT*SQRT(-LOG(MAX(EPS10,S_RNDM(IFL))))
+ IF (IPAR(3).GE.1) THEN
+ IF(MOD(IFLA,10).NE.0) THEN
+ XM = QMASS(IFL)
+ ELSE
+ XM = 0.5D0 ! pomeron mass
+ IF(IPAR(3).ge.6) XM = 0.D0
+ ENDIF
+c exponential transverse mass
+ XM2 = XM**2
+ RNDM = MAX(EPS10,S_RNDM(IFL))
+ XMT = PPTT * LOG(RNDM) - XM
+ XMT2 = XMT**2
+ PT = SQRT(XMT2-XM2)
+ ENDIF
+ ENDIF
+ PHI= TWOPI*S_RNDM(IFL)
+ PX=PT*COS(PHI)
+ PY=PT*SIN(PHI)
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE PTSETUP_4FLV(ECM)
+
+C-----------------------------------------------------------------------
+C moved from sib_ndiff to seperate subroutine
+c so that changes will affect diff. /FR'13
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+ DOUBLE PRECISION PPT02
+ COMMON /S_CQDIS2/ PPT02(44)
+ SAVE
+
+ SQS = ECM
+
+c NA22 piC retune
+ PTU=.3D0+.08D0*dlog10(sqs/30.D0)
+ PTS=.45D0+.08D0*dlog10(sqs/30.D0)
+ PTQQ=.6D0+.08D0*dlog10(sqs/30.D0)
+ PTPOM= .6D0+.08D0*dlog10(sqs/30.D0)
+ if ( IPAR(3).eq.1 ) then
+c pt0
+ ptu=.15D0+.007D0*dlog10(sqs/20.D0)**2
+ pts=.3D0+.007D0*dlog10(sqs/20.D0)**2
+ ptqq=.3D0+.03D0*dlog10(sqs/20.D0)**2
+ ptpom= .6D0+.08D0*dlog10(sqs/30.D0)
+ elseif ( IPAR(3).eq.2 ) then
+C pt1
+ ptu=.15D0+.007D0*dlog10(sqs/20.D0)**2
+ pts=.32D0+.007D0*dlog10(sqs/20.D0)**2
+ ptqq=.4D0+.007D0*dlog10(sqs/20.D0)**2
+ ptpom= .6D0+.08D0*dlog10(sqs/30.D0)
+c pt2
+ elseif ( IPAR(3).eq.3 ) then
+ ptu=.17D0+.007D0*dlog10(sqs/20.D0)**2
+ pts=.3D0+.007D0*dlog10(sqs/20.D0)**2
+ ptqq=.3D0+.03D0*dlog10(sqs/20.D0)**2
+ ptpom = .6D0+.08D0*dlog10(sqs/30.D0)
+ elseif ( IPAR(3).eq.5 ) then
+ PTU=.16D0+.007D0*dlog10(sqs/20.D0)**2
+ PTS=.28D0+.007D0*dlog10(sqs/20.D0)**2
+ PTQQ= .3D0+.03D0*dlog10(sqs/20.D0)**2
+ PTPOM = .23D0+.03D0*dlog10(sqs/20.D0)**2
+ elseif ( IPAR(3).eq.6 ) then
+ PTU=.16D0+.007D0*dlog10(sqs/20.D0)**2
+ PTS=.28D0+.007D0*dlog10(sqs/20.D0)**2
+ PTQQ= .3D0+.03D0*dlog10(sqs/20.D0)**2
+ PTPOM = .23D0+.03D0*dlog10(sqs/20.D0)**2
+ elseif ( IPAR(3).eq.7 ) then
+ PTU= PAR(46) + .007D0*dlog10(sqs/20.D0)**2
+ PTS= PAR(47) + .007D0*dlog10(sqs/20.D0)**2
+ PTQQ= PAR(48) + .03D0*dlog10(sqs/20.D0)**2
+ PTPOM = PAR(49) + .03D0*dlog10(sqs/20.D0)**2
+ elseif ( IPAR(3).eq.8 ) then
+ ASQS = MAX(log10(SQS/PAR(109)),0.D0)
+ PTU= PAR(46) + PAR(68)*ASQS**2
+ PTS= PAR(47) + PAR(70)*ASQS**2
+ PTQQ= PAR(48) + PAR(69)*ASQS**2
+ PTPOM = PAR(49) + PAR(51)*ASQS**2
+ PTSEA = PAR(67) + PAR(52)*ASQS**2
+ endif
+ PPT02 (1) = PTU
+ PPT02 (2) = PTU
+ PPT02 (3) = PTS
+c valence pt
+ PPT02 (10) = PTPOM
+ DO J=11,33
+ PPT02(J) = PTQQ
+ ENDDO
+c soft minijet pt
+ PPT02 (20) = PTSEA
+c sea quark pt
+ PPT02 (30) = PAR(132)
+c charm pt
+ ASQS = MAX(log10(SQS/30.D0),0.D0)
+ IF(IPAR(16).eq.8)THEN
+ PTCHM= PAR(147) + PAR(149)*ASQS
+ PTCHB= PAR(148) + PAR(149)*ASQS
+ ELSE
+c rc4a charm pt
+ PTCHM=0.308D0 + .165D0*ASQS
+ PTCHB=0.5D0 + .165D0*ASQS
+ ENDIF
+ PPT02(4) = PTCHM
+ PPT02(14) = PTCHB
+ PPT02(24) = PTCHB
+ DO J=34,44
+ PPT02(J) = PTCHB
+ ENDDO
+
+ IF(ndebug.gt.2)THEN
+ WRITE(LUN,*)' PTSETUP_4FLV: (sqs,(u,d),s,diq,pom,cm,cb)',sqs
+ + ,ppt02(1),ppt02(3),ppt02(11), ppt02(10),ppt02(4),ppt02(34)
+ ENDIF
+
+ RETURN
+ END
+C=======================================================================
+
+ INTEGER FUNCTION IMRG2HAD(IFLB1,IFLB2)
+
+C-----------------------------------------------------------------------
+C -----------------------------------------------------
+C function that merges two flavors into lightest hadron
+C -----------------------------------------------------
+ IMPLICIT NONE
+c flavor merging array
+ INTEGER KFLV
+ COMMON /S_KFLV/ KFLV(4,43)
+ INTEGER IFLB1,IFLB2,IFLA,IFLB,IFL1,IFL2
+ SAVE
+
+ IFLA = IFLB1
+ IFLB = IFLB2
+c order by flavor, meson: antiquark-quark, baryon: quark-diquark
+ IF(IFLB.lt.IFLA) CALL ISWTCH_LMNTS(ifla,iflb)
+c if antibaryon switch again..
+ IF(IFLB.lt.0) CALL ISWTCH_LMNTS(ifla,iflb)
+ IFL1 = IABS(IFLA)
+ IFL2 = IABS(IFLB)
+ IMRG2HAD = ISIGN(KFLV(IFL1,IFL2),IFLB)
+ END
+
+C=======================================================================
+
+ SUBROUTINE SAMPLE_SEA_TOT
+ & (KRMNT,KINT,NSEA,XGAM,XJET,STR_MASS,XSJ,XX)
+
+C-----------------------------------------------------------------------
+C input parameter: xgam,xjet,str_mass, Nsea,KINT,krmnt
+c outpt parameter: xsj,xx
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c include COMMON blocks
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c input/output type definitions
+ DOUBLE PRECISION XGAM,XJET,STR_MASS,XSEA,XX,XSJ
+ DIMENSION XX(2*NW_max+2)
+
+ INTEGER NSEA,KINT,KRMNT
+
+c local type definitions
+ DOUBLE PRECISION AC,GAMMAX,S_RNDM,XA,XREM,R,Z,Z1,Z2,XMINA
+ INTEGER j,jj,ilast
+ SAVE
+ DATA AC /-0.2761856692D0/ ! log(2) - gamma(Eulero)
+
+ GAMMAX = xgam
+ XMINA = 2.D0*STR_mass/SQS
+ IF(IPAR(73).eq.1.and.KINT.gt.1) GAMMAX = PAR(119)
+ IF(ndebug.gt.3) THEN
+ WRITE(LUN,*)' IMRG2HAD: called with ',
+ & '(KRMNT,KINT,NSEA,XGAM,XJET,STR_MASS):',
+ & KRMNT,KINT,NSEA,XGAM,XJET,STR_MASS
+
+ WRITE(LUN,*)' IMRG2HAD: XMIN,XMIN*N,XREM:',
+ & XMINA,NSEA*XMINA,1.D0-XJET
+ ENDIF
+c sample total fraction for sea partons..
+ Z1 = LOG(DBLE(NSEA))
+ 50 Z2 = LOG(0.5D0*SQS*(1.D0-XJET)/STR_MASS-2.D0)
+ R = S_RNDM(0)
+ Z=(Z1+AC)*(1.D0+R*(((Z2+AC)/(Z1+AC))**NSEA-1.D0))
+ & **(1.D0/DBLE(NSEA))-AC
+ XSEA = XMINA*EXP(Z)
+ IF(ndebug.gt.3) WRITE(LUN,*) ' total SEA fraction:' , xsea
+ IF ( (1.D0-XSEA)**GAMMAX .LT. S_RNDM(1)) GOTO 50
+c maximal fraction remaining for valence..
+ 60 XREM = XSEA - DBLE(Nsea)*XMINA
+ IF(ndebug.gt.3)
+ & WRITE(LUN,*) ' Xsea,xval,xjet:',
+ & xsea,1.D0-XSEA-XJET,xjet
+
+C... Split the energy of sea partons among the different partons
+ DO j=1,Nsea-1
+ jj = 2+j
+ IF(KRMNT.eq.0) jj = 4+j
+c fraction for first parton
+ XA = XREM*S_RNDM(J)
+c for interactions other than first decrease energy fraction
+c (beam side hadron can participate in multiple binary collisions)
+c IF(KINT.gt.1.and.j.gt.2*KRMNT) XA=SIGN(ABS(XA)**PAR(116),XA)
+ XX(jj) = XMINA + XA
+c new remainder
+ XREM = XREM - XA
+ IF(ndebug.gt.3) write(lun,*)' x1,j,rem,xa',xX(jj),jj,xrem,xa
+ ENDDO
+c last parton..
+ ilast = 2+Nsea
+ IF(KRMNT.eq.0) ilast = 4+Nsea
+ XX(ILAST) = XMINA + XREM
+
+c break symmetry between nucleon interactions
+c first interaction takes most energy
+ IF(KINT.gt.1.and.IPAR(71).eq.1)THEN
+ JJ = 3
+ IF(KRMNT.eq.0) JJ = 5
+ if(ndebug.gt.4) write(lun,*) ' x1+x2,p*xeq:',
+ & XX(JJ)+XX(JJ+1),PAR(117)*XSEA/KINT
+ IF(XX(JJ)+XX(JJ+1).lt.PAR(117)*XSEA/KINT) GOTO 60
+ ENDIF
+
+ XSJ = XSJ + XSEA
+ IF(ndebug.gt.3)THEN
+ write(lun,*)' x1,N,rem',xx(ilast),ilast,xrem
+ write(lun,*) ' xseajet',xsj
+ endif
+
+ END
+C-----------------------------------------------------------------------
+C
+C dummy subroutines, remove to link PDFLIB
+C
+C=======================================================================
+c
+c SUBROUTINE PDFSET(PARAM,VALUE)
+c
+c-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c DIMENSION PARAM(20),VALUE(20)
+c CHARACTER*20 PARAM
+c END
+c
+c=======================================================================
+c
+c SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+c
+c-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c END
+c
+c=======================================================================
+c
+c SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
+c
+c-----------------------------------------------------------------------
+c IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+c IMPLICIT INTEGER(I-N)
+c END
+c
+C-----------------------------------------------------------------------
+C
+C=======================================================================
+
+ SUBROUTINE SIB_NDIFF(K_beam, NW, Ecm, Irec, IREJ)
+
+C-----------------------------------------------------------------------
+C routine that samples and fragments a non-diffractive interaction
+C
+C 3 stages: 0: setup
+C 1: sampling of event structure (number of parton interactions)
+C (labeled as 2000)
+C 2: sampling of kinematics
+C (labeled as 3000)
+C 3: fragmentation
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ DOUBLE PRECISION ECM
+ INTEGER K_beam, NW, Irec, IREJ
+
+c COMMONs
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+C The final particle output is contained in COMMON /S_PLIST/
+C NP : number of final particles
+C P(1:NP, 1:5) : 4-momenta + masses of the final particles
+C LLIST (1:NP) : codes of final particles
+ DOUBLE PRECISION P
+ INTEGER NP,LLIST,NP_max
+ PARAMETER (NP_max=8000)
+ COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP
+
+ INTEGER NFORIG,NPORIG,NIORIG,IPFLAG,IIFLAG,KINT
+ COMMON /S_PARTO/ NFORIG(NP_max),NPORIG(NP_max),NIORIG(NP_max),
+ &IPFLAG,IIFLAG,KINT
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+ INTEGER NS_max, NH_max
+ PARAMETER (NS_max = 20, NH_max = 80)
+
+ INTEGER IBMRDX,ITGRDX,IHMJDX,ISMJDX,ICSTDX,IINTDX
+ COMMON /S_INDX/ IBMRDX(3),ITGRDX(NW_max,3),
+ & IHMJDX(NW_max*NH_max),IINTDX(NW_max),
+ & ISMJDX(NW_max*NS_max),ICSTDX(2*NW_max,3)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c internal type declarations
+ DOUBLE PRECISION X2JET,SQS_0,PZ,E2,PAWT,xnsof,xnjet,xjdif,x1jet,
+ & Esum,PXsum,PYsum,PZsum
+ DIMENSION X2JET(NW_max)
+ INTEGER LL,LXBAD,NP_0,NPP_0,NPP0_0,J,JJ,I,KBA,L,NPP_1,NPP0_1,
+ & IREFout,IREF,nj,ns,nv,II,Idm,LPID,NF,NPP,NPP0
+ DIMENSION LL(99)
+ SAVE
+ DATA LL /5*0,7*2,2*1,12*0,2,6*0,6*1,19*0,2,2,10*0,
+ & 2,2,0,2,2,11*0,1,1,1,9*0,1/
+
+
+C.. setup stage
+ IREJ = 1
+c default return point is kinematic sampling stage
+ LXBAD = 3
+
+c remember initial setup
+ NP_0 = NP
+ SQS_0 = SQS
+c remember position on parton stack
+ CALL GET_NPP(NPP_0,NPP0_0)
+
+c set interaction properties
+c IF(Irec.ne.1) CALL INI_EVENT(ECM,K_beam,Idm,Irec)
+
+ IF(ndebug.gt.0)then
+ IF(Irec.eq.0)THEN
+ WRITE(LUN,*)
+ & ' SIB_NDIFF: recursive call with (ecm,kb,kt,np,jdif):',
+ & ecm,k_beam,kt(1),(jdif(j),j=1,NW),NP
+ ELSE
+ WRITE(LUN,*)' SIB_NDIFF: regular call with (ECM,KB,NW,KT,',
+ & 'JDIF,NP):',ecm,k_beam,NW,(kt(ii),ii=1,NW),
+ & (jdif(j),j=1,NW),NP
+ ENDIF
+ ENDIF
+
+ 2000 CONTINUE
+
+c reset parton stack
+ CALL INI_PRTN_STCK(NPP_0,NPP0_0)
+
+C... sample multiple interaction configuration
+ KBA = IABS(K_beam)
+ L = LL(KBA)
+ DO I=1,NW
+ if(JDIF(I).eq.0) then
+ CALL CUT_PRO(L, SQS, PTmin, NNSOF(I), NNJET(I))
+ else
+ NNSOF(I) = 1
+ NNJET(I) = 0
+ endif
+c add incoming target particles
+ PZ = PAWT(SQS,AM(KBA),AM(KT(I)))
+ E2 = SQRT(PZ**2+AM2(KT(I)))
+ CALL ADD_PRTN(0.D0,0.D0,-PZ,E2,AM(KT(I)),KT(I),-2,0,IREFout)
+
+c add interactions
+ xjdif = dble(jdif(I))
+ xnjet = dble(nnjet(I))
+ xnsof = dble(nnsof(I))
+ CALL ADD_PRTN(xnsof,xnjet,xjdif,sqs,0.D0,I,-1,IREFout,IREF)
+c write parton stack index to interaction index
+ IINTDX(I) = IREF
+ ENDDO
+c remember state of parton stack
+ CALL GET_NPP(NPP_1,NPP0_1)
+
+C... kinematic sampling stage
+
+C... sample x values
+ ITRY(1) = 0
+ 3000 CONTINUE
+ ITRY(1) = ITRY(1)+1
+ IF(ITRY(1).GT.NREJ(1)) THEN
+c NCALL = NCALL + 1
+ GOTO 2000
+ ENDIF
+ NP = NP_0
+ CALL INI_PRTN_STCK(NPP_1,NPP0_1)
+
+ CALL SAMPLE_MINIJET(L,NW,NNJET,NNSOF,NJET,NSOF,x1jet,x2jet,lxbad)
+ IF(LXBAD.eq.3)THEN
+c reject kinematics
+ GOTO 3000
+ ELSEIF(LXBAD.eq.2)THEN
+c reject kinematics and event structure
+c NCALL = NCALL + 1
+ GOTO 2000
+ ELSEIF(LXBAD.eq.1)THEN
+c reject entire event
+ if(Ndebug.gt.0)
+ & WRITE(LUN,*)' SIB_NDIFF: minijet rejection (Ncall):',Ncall
+c restore initial state
+ NP = NP_0
+ CALL INI_PRTN_STCK(NPP_0,NPP0_0)
+ SQS = SQS_0
+ S = SQS*SQS
+ RETURN
+ ENDIF
+
+C... Prepare 2*NW valence/sea color strings and/or remnant.
+
+c default return point, jump back to sampling interaction structure
+c LXBAD = 2
+ CALl SAMPLE_RMNT(K_beam,NW,X1Jet,X2JET,Irec,LXBAD)
+ IF(LXBAD.eq.3)THEN
+c reject kinematics
+ GOTO 3000
+ ELSEIF(LXBAD.eq.2)THEN
+c reject kinematics and event structure
+c NCALL = NCALL + 1
+ GOTO 2000
+ ELSEIF(LXBAD.eq.1)THEN
+c reject entire event
+ if(Ndebug.gt.0)
+ & WRITE(LUN,*)' SIB_NDIFF: rmnt rejection (Ncall,NW):',Ncall,NW
+c restore initial state
+ NP = NP_0
+ CALL INI_PRTN_STCK(NPP_0,NPP0_0)
+ SQS = SQS_0
+ S = SQS*SQS
+ RETURN
+ ENDIF
+
+C Check parton final state..
+ CALL GET_NPP(NPP,NPP0)
+ CALL PPSUM(1,NPP,Esum,PXsum,PYsum,PZsum,NF)
+ IF(ABS(Esum/(0.5D0*Ecm*DBLE(NW+1))-1.D0).GT.EPS3)THEN
+ WRITE(LUN,*) ' SIB_NDIFF: energy not conserved! : ',Ncall
+ WRITE(LUN,*) ' sqs_inp = ', Ecm, ' sqs_out = ', Esum
+ CALL PRNT_PRTN_STCK
+ WRITE(LUN,*) ' SIB_NDIFF: event rejected! ',
+ & 'partons do not conserve energy'
+ WRITE(LUN,*)' (Ncall,NW,NPP,NJET,NSOF):',Ncall,NW,NPP,NJET,NSOF
+c CALL SIB_REJECT('SIB_NDIFF ')
+c restore initial state
+ NP = NP_0
+ CALL INI_PRTN_STCK(NPP_0,NPP0_0)
+ SQS = SQS_0
+ S = SQS*SQS
+ RETURN
+ ENDIF
+ IF(NDEBUG.gt.0) THEN
+ IF(NDEBUG.gt.1) CALL PRNT_PRTN_STCK
+ WRITE(LUN,*) ' SIB_NDIFF: entering fragmentation stage...'
+ ENDIF
+
+C... Fragmentation stage
+ nj = 0
+ ns = 0
+ nv = 0
+ II = NPP0_0+1
+ DO WHILE (II.gt.0)
+c default return point: reject event if fragmentation fails
+ LXBAD = 1
+c loop over level0 partons
+ CALL ITR_LVL0_PRTN(II,JJ,LPID)
+c read interaction
+ CALL RD_INT(jj,Idm,iiflag)
+
+C... Fragmentation of soft/hard sea color strings
+ IF(LPID.eq.100)THEN
+ nj = nj + 1
+ ipflag = 100
+ KINT = nj
+ CALL FRAG_MINIJET(jj,LXBAD)
+ IF(LXBAD.ne.0) RETURN
+
+ ELSEIF(LPID.eq.10)THEN
+ ns = ns + 1
+ ipflag = 10
+ KINT = ns
+ CALL FRAG_MINIJET(jj,LXBAD)
+ IF(LXBAD.ne.0) RETURN
+
+C... fragment 'valence' strings
+ ELSEIF(LPID.eq.1)THEN
+ nv = nv + 1
+ KINT = nv
+ ipflag = 1
+ CALL FRAG_VLNCE(jj,LXBAD)
+ IF(LXBAD.ne.0) RETURN
+
+C... fragment remnants
+ ELSEIF(IABS(LPID).eq.2)THEN
+ CALL EXCTDEC(JJ,LXBAD)
+ IF(LXBAD.ne.0) RETURN
+
+C... fragment incoherent diffraction
+ ELSEIF(LPID.eq.-10.or.LPID.eq.-20.or.LPID.eq.-30)THEN
+ CALL FRAG_INCHRNT_DIFF(jj,lxbad)
+ IF(LXBAD.ne.0) RETURN
+
+ ENDIF
+ ENDDO
+ IREJ = 0
+
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_RMNT(Kbeam,NW,X1JET,X2JET,Irec,LBAD)
+
+C-----------------------------------------------------------------------
+C routine to sample remnants
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+
+c external type declarations
+ DOUBLE PRECISION X1JET,X2JET
+ DIMENSION X2JET(NW_max)
+ INTEGER KBEAM,NW,IREC,LBAD
+
+C COMMONs
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+C parameters that represent: NW: max. number of wounded nucleons,
+C NS,NH: max. number of soft and hard interactions
+c PARAMETER (NW_max = 20)
+C The COMMON block /S_CHIST/ contains information about the
+C the structure of the generated event:
+C NWD = number of wounded nucleons
+C NJET = total number of hard interactions
+C NSOF = total number of soft interactions
+C NNSOF (1:NW) = number of soft pomeron cuts in each interaction
+C NNJET (1:NW) = number of minijets produced in each interaction
+C JDIF(1:NW) = diffraction code
+C 0 : non-diff,
+C 1 : beam-diff
+C 2 : target-diff
+C 3 : double-diff
+ INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+ INTEGER IRMNT,KRB,KRT
+ DOUBLE PRECISION XRMASS,XRMEX
+ COMMON /S_RMNT/ XRMASS(2),XRMEX(2),IRMNT(NW_max),KRB,KRT(NW_max)
+
+ INTEGER ICHP,ISTR,IBAR
+ COMMON /S_CHP/ ICHP(99), ISTR(99), IBAR(99)
+
+ INTEGER IISO,ISPN
+ COMMON /S_SPN/ IISO(99), ISPN(99)
+
+ INTEGER ICHM
+ COMMON /S_CHM/ ICHM(99)
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c internals
+ DOUBLE PRECISION PREM,PREM_NUC,R,R2,S_RNDM,FLVXCHG,ALPH
+ INTEGER ITGRMNT,IBMRMNT,I,j,jj,K,NPPLD,NPP0LD,IBMRMNT_OLD,
+ & IBAD,IKBAD,KBM
+ DIMENSION ITGRMNT(NW_max)
+ SAVE
+ DATA PREM /0.D0/ , PREM_NUC /0.D0/
+
+ IF(Ndebug.gt.1)
+ & WRITE(LUN,*)' SAMPLE_RMNT: called with (Kbeam,NW,X1JET,',
+ & 'X2JET,JDIF,Irec):',Kbeam,NW,X1JET,(X2JET(JJ),JJ=1,NW),
+ & (JDIF(JJ),JJ=1,NW),Irec
+
+ IF(Irec.eq.0.and.NW.ne.1)then
+ WRITE(LUN,*)' SAMPLE_RMNT: recursive call inconsistent!'
+ CALL SIB_REJECT('SAMPLE_RMNT ')
+ endif
+
+c default return point for remnant excitation routine:
+c beam and target sampling
+ IBAD = 1
+
+c set trial counter
+ ITRY(2) = 0
+c remember position on parton stack
+ CALL GET_NPP(NPPLD,NPP0LD)
+
+C... sample no. of remnants
+c ibmrmnt: 0,1..NW : number of excitations on beamside
+C itgrmnt: 0,1 : target side excitation
+
+c prob. of remnant excitation
+ IF(IPAR(78).ne.0)THEN
+ PREM = PAR(23)
+ PREM_NUC = PAR(23)
+ IF(IPAR(84).eq.2.and.IBAR(IABS(KBeam)).eq.0)
+ & PREM = PAR(140)
+ ENDIF
+
+c define Prem as probablility for remnant survival
+c switch to sampling of remnant de-excitation
+ IF(IPAR(79).ne.0) PREM = 1.D0-PREM
+
+c prob. of remnant excitation target side
+ IF(IPAR(79).ne.0) PREM_NUC = 1.D0-PAR(23)
+ IF(IPAR(63).eq.1) PREM_NUC = PREM_NUC/dble(NW)
+
+c turn of remnant for Nw>1
+ IF(IPAR(77).eq.1)THEN
+c only beamside
+ IF(NW.gt.1) PREM = 0
+ ELSEIF(IPAR(77).eq.2)THEN
+c target and beam-side
+ IF(NW.gt.1) then
+ PREM = 0.D0
+ PREM_NUC = 0.D0
+ endif
+ ELSE
+ CONTINUE
+ ENDIF
+
+C... remnant mass dis. exponents
+ XRMEX(1) = PAR(98) ! baryons
+ IF(IPAR(84).gt.0)THEN
+ XRMEX(2) = PAR(141) ! mesons
+ else
+ XRMEX(2) = PAR(98) ! mesons same as baryons
+ endif
+
+ IBMRMNT = 0
+ DO K=1, NW
+c additionally penalize remnant survival for multiple nucleon interactions
+ IF(IPAR(79).eq.2.and.K.gt.1) PREM=1.D0-PAR(23)*PAR(128)
+c penalize remnant survival for multiple parton interactions
+ IF(IPAR(80).ne.0) THEN
+c multiple interaction penalty for remnant survival, individual interaction
+ ALPH = 1.D0+PAR(129)*DBLE(NNSOF(K)+NNJET(K)-1)
+ PREM = 1.D0-(1.D0-PREM)**ALPH
+ PREM_NUC = 1.D0-(1.D0-PREM_NUC)**ALPH
+ ENDIF
+ IF(JDIF(K).eq.0)THEN
+ R = S_RNDM(k)
+ R2 = S_RNDM(0)
+ IF(R.LT.PREM) IBMRMNT = IBMRMNT + 1
+c no target side excitation if recursive call (irec=0)!
+ IF(R2.LT.PREM_NUC*Irec) THEN
+ ITGRMNT(K) = 1
+ ELSE
+ ITGRMNT(K) = 0
+ ENDIF
+ ELSE
+ ITGRMNT(K) = 0
+ ENDIF
+ IF(Ndebug.gt.1)
+ & WRITE(LUN,'(2X,A,1X,I2,1X,F5.3,1X,I2,1X,I2,1X,I2,1X,I2)')
+ & 'SAMPLE_RMNT: (JW,PREM,NS,NH,IBMRMNT,LTGRMNT):',
+ & K,PREM,NNSOF(k),NNJET(k),IBMRMNT,ITGRMNT(k)
+ ENDDO
+ IF(IPAR(79).ne.0)THEN
+c Prem was redefined as probablility for remnant destruction
+c therefore invert configuration..
+ DO K=1, NW
+ IF(JDIF(K).eq.0)THEN
+ ITGRMNT(K)=IABS(ITGRMNT(K)-1)
+ ENDIF
+ ENDDO
+c multiple de-excitations not possible..
+ IBMRMNT=MIN(IBMRMNT,1)
+ IBMRMNT=IABS(IBMRMNT-1)*Irec
+ ENDIF
+ IF(Ndebug.gt.1)
+ & WRITE(LUN,*)
+ & ' SAMPLE_RMNT: remnant sampling (PREM,NW,LBMRMNT,LTGRMNT): ',
+ & PREM,NW,IBMRMNT,(ITGRMNT(j),j=1,NW)
+
+ IBMRMNT_OLD = IBMRMNT
+
+C... Sample flavor and momentum fractions
+ 20 ITRY(2) = ITRY(2) + 1
+c reset parton stack
+ CALL INI_PRTN_STCK(NPPLD,NPP0LD)
+ IBMRMNT = IBMRMNT_OLD
+
+c retry without counting
+c 22 CONTINUE
+ IF(ITRY(2).gt.NREJ(2))THEN
+ LBAD = 2
+ IF(ndebug.gt.1)then
+ WRITE(LUN,*)' SAMPLE_RMNT: number of trials exceeded'
+ WRITE(LUN,*)' resample minijets...(IREJ,NW,NCALL)',
+ & LBAD, NW, NCALL
+ endif
+c raise event call counter
+c NCALL = NCALL + 1
+ RETURN
+ ENDIF
+
+ Kbm = Kbeam
+
+C.. sample central strings and remnant flavor
+ flvXchg = PAR(80) ! prob. of flv exchange between strgs and rmnt
+c remnant and sea on beam side
+ CALL SAMPLE_BEAM(Kbm,NW,flvXchg,IBMRMNT,X1JET,IKBAD)
+ IF(IKBAD.eq.1)THEN
+c resample minijets event
+ LBAD = 3
+ RETURN
+ ELSEIF(IKBAD.eq.2)THEN
+c too many partons, reject NW, i.e. entire event
+ LBAD = 1
+ RETURN
+ ENDIF
+
+c remnants and sea on target side
+ CALL SAMPLE_TARGET(NW,flvXchg,ITGRMNT,X2JET,Irec,IKBAD)
+ IF(IKBAD.eq.1)THEN
+c resample minijets event
+ LBAD = 3
+ RETURN
+ ELSEIF(IKBAD.eq.2)THEN
+c too many partons, reject NW, i.e. entire event
+ LBAD = 1
+ RETURN
+ ENDIF
+
+C... sample remnant excitation masses and add to parton stack
+c beam-side (one remnant, formed by several interactions)
+c target-side (possibly NW remnants)
+
+ DO I=1,NW
+c default return point
+ IBAD = 1
+ IF(IPAR(78).EQ.1)THEN
+c$$$ write(lun,*)
+c$$$ & ' SIB_RMNT: multiple excitation model',
+c$$$ & ' not implemented yet!'
+c$$$ stop
+c model where beam side remnant can receive mass from multiple target nucleons
+ IF(IBMRMNT.gt.0)THEN
+c beam side remnant excited
+ if(ITGRMNT(I).eq.0)then
+ CALL EXCT_RMNT(I,1,IBAD)
+ else
+ CALL EXCT_RMNT(I,3,IBAD)
+ endif
+ IBMRMNT = IBMRMNT - 1
+ ELSE
+c beam side remnant not excited
+ if(ITGRMNT(I).ne.0)then
+ CALL EXCT_RMNT(I,2,IBAD)
+ else
+ CALL EXCT_RMNT(I,0,IBAD)
+ endif
+ ENDIF
+
+ ELSEIF(IPAR(78).eq.2)then
+ IF(IBMRMNT.gt.0)then
+c beam side remnant excited, only once!
+ IF(ITGRMNT(I).eq.0)then
+ CALL EXCT_RMNT(I,1,IBAD)
+ else
+ CALL EXCT_RMNT(I,3,IBAD)
+ endif
+ IBMRMNT = 0
+ ELSE
+c beam side remnant not excited
+ IF(ITGRMNT(I).ne.0)then
+ CALL EXCT_RMNT(I,2,IBAD)
+ else
+ CALL EXCT_RMNT(I,0,IBAD)
+ endif
+ ENDIF
+ ELSE
+c no remnant model
+ CALL EXCT_RMNT(I,0,IBAD)
+ ENDIF
+c catch remant excitation exception, redo sea kinematics..
+ IF(IBAD.eq.1) GOTO 20
+c catch severe exception, resample minijet kinematics..
+ IF(IBAD.eq.2) THEN
+ LBAD = 3
+ RETURN ! resample event
+ ENDIF
+ ENDDO
+ LBAD = 0
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_HADCSL(L,ECM,SIGTOT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+C-----------------------------------------------------------------------
+C low-energy cross section parametrizations (target always proton)
+C
+C input: L beam particle: (1 - proton,
+C 2 - pion,
+C 3 - kaon)
+C target is always proton
+C ECM c.m. energy (GeV)
+C
+C output: SIGTOT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGDIF diffractive cross section (sd-1,sd-2,dd, mb)
+C SLOPE forward elastic slope (GeV**-2)
+C RHO real/imaginary part of elastic amplitude
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION SIGDIF(3)
+
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ SAVE
+
+C proton-proton cross section as reference
+ CALL SIB_HADCS1(1,ECM,SIGTOT,SIGEL,SIGINEL,SLOPE,RHO)
+
+C parametrization for diffraction
+ Xi_min = 1.5D0/(ECM*ECM)
+ Xi_max = PAR(13)
+ SIGeff = SIGEL
+ CALL SIB_HADCS2(ECM,Xi_min,Xi_max,SIGeff,SIGDIF)
+
+ if(L.eq.1) return
+
+C regge motivated rescaling of diffraction dissociation
+ sigtot_pp = SIGTOT
+ sigel_pp = SIGEL
+ slope_pp = SLOPE
+ CALL SIB_HADCS1(L,ECM,SIGTOT,SIGEL,SIGINEL,SLOPE,RHO)
+ SIGDIF(1) = slope_pp/SLOPE*SIGTOT/sigtot_pp*SIGDIF(1)
+ SIGDIF(2) = slope_pp/SLOPE*SIGEL/sigel_pp*SIGDIF(2)
+ SIGDIF(3) = SIGTOT/sigtot_pp*SIGDIF(3)
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_HADCS1(L,ECM,SIGTOT,SIGEL,SIGINEL,SLOPE,RHO)
+
+C-----------------------------------------------------------------------
+C low-energy cross section parametrizations
+C
+C input: L beam particle: (1 - proton,
+C 2 - pion,
+C 3 - kaon)
+C target is always proton
+C ECM c.m. energy (GeV)
+C
+C output: SIGTOT total cross section (mb)
+C SIGEL elastic cross section (mb)
+C SIGDIF diffractive cross section (sd-1,sd-2,dd, mb)
+C SLOPE forward elastic slope (GeV**-2)
+C RHO real/imaginary part of elastic amplitude
+C
+C comments:
+C - low-energy data interpolation uses PDG fits from 1992
+C - slopes from ???, new fit to pp data
+C - high-energy extrapolation by Donnachie-Landshoff like fit made
+C by PDG 1996
+C - analytic extension of amplitude to calculate rho
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+ DIMENSION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
+ SAVE
+
+ DATA TPDG92 /
+ & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
+ & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
+ & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
+ & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
+ & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
+ & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
+ & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
+ & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
+ & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
+ & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
+ & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
+ & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
+
+ DATA TPDG96 /
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,-21.05D0,0.46D0,0.9D0,
+ & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
+ & 77.15D0,21.05D0,0.46D0,0.9D0,
+ & 10.D0, 13.70D0,0.079D0,0.25D0,0.D0,
+ & 31.85D0,-4.05D0,0.45D0,0.9D0,
+ & 10.D0, 13.70D0,0.079D0,0.25D0,0.D0,
+ & 31.85D0,4.05D0,0.45D0,0.9D0,
+ & 10.D0, 12.20D0,0.079D0,0.25D0,0.D0,
+ & 17.35D0,-9.05D0,0.50D0,0.9D0,
+ & 10.D0, 12.20D0,0.079D0,0.25D0,0.D0,
+ & 17.35D0,9.05D0,0.50D0,0.9D0 /
+
+ DATA BURQ83 /
+ & 8.557D0, 0.00D0, 0.574D0,
+ & 11.13D0, 7.23D0, 0.30D0,
+ & 9.11D0, -0.73D0, 0.28D0,
+ & 9.11D0, 0.65D0, 0.28D0,
+ & 8.55D0, -5.98D0, 0.28D0,
+ & 8.55D0, 1.60D0, 0.28D0 /
+
+c DATA XMA / 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
+ DATA GEV2MB /0.389365D0/
+ DATA INIT/0/
+
+ IF(INIT.EQ.0) THEN
+c use the internal masses
+ XMA(1) = AM(13) ! proton
+ XMA(2) = AM(14) ! neutron
+ XMA(3) = AM(7) ! pi+
+ XMA(4) = AM(8) ! pi-
+ XMA(5) = AM(9) ! K+
+ XMA(6) = AM(10) ! K-
+ INIT = 1
+ ENDIF
+
+C find index
+ IF (L.eq.1) THEN
+ K = 1 ! p p
+ ELSEIF(L.eq.2) THEN
+ K = 3 ! pi+ p
+* K = 4 ! pi- p
+ ELSEIF(L.eq.3) THEN
+ K = 5 ! K+ p
+* K = 6 ! K- p
+ ELSE
+ GOTO 100
+ ENDIF
+
+C calculate lab momentum
+ SS = ECM**2
+ E1 = (SS-XMA(1)**2-XMA(K)**2)/(2.D0*XMA(1))
+ PL = dSQRT((E1-XMA(K))*(E1+XMA(K)))
+ PLL = dLOG(PL)
+
+C check against lower limit
+ IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
+
+ XP = TPDG96(2,K)*SS**TPDG96(3,K)
+ YP = TPDG96(6,K)/SS**TPDG96(8,K)
+ YM = TPDG96(7,K)/SS**TPDG96(8,K)
+
+ PHR = dTAN(PI/2.D0*(1.D0-TPDG96(8,K)))
+ PHP = dTAN(PI/2.D0*(1.D0+TPDG96(3,K)))
+ RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
+
+ SLOPE = BURQ83(1,K)+BURQ83(2,K)/dSQRT(PL)+BURQ83(3,K)*PLL
+
+C select energy range and interpolation method
+ IF(PL.LT.TPDG96(1,K)) THEN
+ SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
+ SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
+ & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
+ SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
+ & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
+ SIGTO2 = YP+YM+XP
+ SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ X2 = dLOG(PL/TPDG96(1,K))/dLOG(TPDG92(2,1,K)/TPDG96(1,K))
+ X1 = 1.D0 - X2
+ SIGTOT = SIGTO2*X2 + SIGTO1*X1
+ SIGEL = SIGEL2*X2 + SIGEL1*X1
+ ELSE
+ SIGTOT = YP+YM+XP
+ SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
+ ENDIF
+ SIGINEL = SIGTOT-SIGEL
+
+ RETURN
+
+ 100 CONTINUE
+ WRITE(LUN,'(1X,2A,2I7)') ' SIB_HADCS1: ',
+ & 'invalid beam particle: ',L
+ RETURN
+
+ 200 CONTINUE
+ WRITE(LUN,'(1X,2A,1P,E12.4)') ' SIB_HADCS1: ',
+ & 'energy too small (Ecm): ',ECM
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_HADCS2(SQS,Xi_min,Xi_max,SIGeff,SIGDIF)
+
+C-----------------------------------------------------------------------
+C cross section for diffraction dissociation
+C
+C - single diffraction dissociation:
+C Goulianos' parametrization (Ref: PL B358 (1995) 379)
+C - double diffration dissociation: simple scaling model using
+C single diff. cross section
+C
+C in addition rescaling for different particles is applied using
+C internal rescaling tables (not implemented yet)
+C
+C input: SQS c.m. energy (GeV)
+C Xi_min min. diff mass (squared) = Xi_min*SQS**2
+C Xi_max max. diff mass (squared) = Xi_max*SQS**2
+C SIGeff effective cross section for DD scaling
+C
+C output: sig_sd1 cross section for diss. of particle 1 (mb)
+C sig_sd2 cross section for diss. of particle 2 (mb)
+C sig_dd cross section for diss. of both particles
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DIMENSION SIGDIF(3)
+ DIMENSION Xpos1(96),Xwgh1(96),Xpos2(96),Xwgh2(96)
+ DOUBLE PRECISION xil,xiu,tl,tu
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+C model parameters
+ DATA delta / 0.104D0 /
+ DATA alphap / 0.25D0 /
+ DATA beta0 / 6.56D0 /
+ DATA gpom0 / 1.21D0 /
+ DATA xm_p / 0.938D0 /
+ DATA x_rad2 / 0.71D0 /
+
+C integration precision
+ DATA Ngau1 / 32 /
+ DATA Ngau2 / 32 /
+
+ DATA GEV2MB /0.389365D0/
+
+ SIGDIF(1) = 0.D0
+ SIGDIF(2) = 0.D0
+ SIGDIF(3) = 0.D0
+
+ XIL = dLOG(Xi_min)
+ XIU = dLOG(Xi_max)
+
+ if(XIL.ge.XIU) return
+
+ SS = SQS*SQS
+ xm4_p2 = 4.D0*xm_p**2
+ fac = beta0**2/(16.D0*PI)
+
+ t1 = -5.D0
+ t2 = 0.D0
+ tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C flux renormalization and cross section for pp/ppbar case
+
+ Xnorm = 0.D0
+
+ xil = dlog(1.5D0/SS)
+ xiu = dlog(0.1D0)
+
+ IF(xiu.LE.xil) goto 1000
+
+ CALL SIB_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
+ CALL SIB_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
+
+ do i1=1,Ngau1
+
+ xi = dexp(xpos1(i1))
+ w_xi = Xwgh1(i1)
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ Xnorm = Xnorm
+ & + f2_t*xi**(2.D0-2.D0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ Xnorm = Xnorm*fac
+
+ 1000 continue
+
+ XIL = dLOG(Xi_min)
+ XIU = dLOG(Xi_max)
+
+ T1 = -5.D0
+ T2 = 0.D0
+
+ TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
+ TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
+
+C single diffraction diss. cross section
+
+ CSdiff = 0.D0
+
+ CALL SIB_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
+ CALL SIB_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
+
+ do i1=1,Ngau1
+
+ xi = dexp(xpos1(i1))
+ w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
+
+ do i2=1,Ngau2
+
+ tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
+
+ alpha_t = 1.D0+delta+alphap*tt
+ f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
+
+ CSdiff = CSdiff
+ & + f2_t*xi**(2.D0-2.D0*alpha_t)*Xwgh2(i2)*w_xi
+
+ enddo
+ enddo
+
+ CSdiff = CSdiff*fac*GEV2MB/MAX(1.D0,Xnorm)
+
+* write(LUN,'(1x,1p,4e14.3)')
+* & sqrt(SS),Xnorm,2.d0*CSdiff*MAX(1.d0,Xnorm),2.d0*CSdiff
+
+ SIGDIF(1) = CSdiff
+ SIGDIF(2) = CSdiff
+
+C double diff. dissociation from simple probability consideration
+* Pdiff = 0.5d0-sqrt(0.25d0-CSdiff/SIGeff)
+ Pdiff = CSdiff/SIGeff
+ SIGDIF(3) = Pdiff*Pdiff*SIGeff
+
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_GAUSET(AX,BX,NX,Z,W)
+
+C-----------------------------------------------------------------------
+C
+C N-point gauss zeros and weights for the interval (AX,BX) are
+C stored in arrays Z and W respectively.
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ COMMON /GQCOM/A(273),X(273),KTAB(96)
+ DIMENSION Z(NX),W(NX)
+ SAVE
+ DATA INIT/0/
+C
+ ALPHA=0.5D0*(BX+AX)
+ BETA=0.5D0*(BX-AX)
+ N=NX
+*
+* the N=1 case:
+ IF(N.NE.1) GO TO 1
+ Z(1)=ALPHA
+ W(1)=BX-AX
+ RETURN
+*
+* the Gauss cases:
+ 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
+ IF(N.EQ.20) GO TO 2
+ IF(N.EQ.24) GO TO 2
+ IF(N.EQ.32) GO TO 2
+ IF(N.EQ.40) GO TO 2
+ IF(N.EQ.48) GO TO 2
+ IF(N.EQ.64) GO TO 2
+ IF(N.EQ.80) GO TO 2
+ IF(N.EQ.96) GO TO 2
+*
+* the extended Gauss cases:
+ IF((N/96)*96.EQ.N) GO TO 3
+*
+C jump to center of intervall intrgration:
+ GO TO 100
+*
+C get Gauss point array
+*
+ 2 CALL PO106BD
+C -print out message
+* IF(INIT.LE.20)THEN
+* INIT=init+1
+* WRITE (6,*) ' initialization of Gauss int. N=',N
+* ENDIF
+C extract real points
+ K=KTAB(N)
+ M=N/2
+ DO 21 J=1,M
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+C store them backward
+ Z(J)=ALPHA-DELTA
+ W(J)=WTEMP
+C store them forward
+ JP=N+1-J
+ Z(JP)=ALPHA+DELTA
+ W(JP)=WTEMP
+ 21 CONTINUE
+C store central point (odd N)
+ IF((N-M-M).EQ.0) RETURN
+ Z(M+1)=ALPHA
+ JMID=K+M
+ W(M+1)=BETA*A(JMID)
+ RETURN
+C
+C get ND96 times chained 96 Gauss point array
+C
+ 3 CALL PO106BD
+C print out message
+ IF(INIT.LE.20)THEN
+ INIT=init+1
+ WRITE (6,*) ' initialization of extended Gauss int. N=',N
+ ENDIF
+C -extract real points
+ K=KTAB(96)
+ ND96=N/96
+ DO 31 J=1,48
+C extract values from big array
+ JTAB=K-1+J
+ WTEMP=BETA*A(JTAB)
+ DELTA=BETA*X(JTAB)
+ WTeMP=WTEMP/ND96
+ DeLTA=DELTA/ND96
+ DO 32 JD96=0,ND96-1
+ ZCNTR= (ALPHA-BETA)+ BETA*DBLE(2*JD96+1)/DBLE(ND96)
+C store them backward
+ Z(J+JD96*96)=ZCNTR-DELTA
+ W(J+JD96*96)=WTEMP
+C store them forward
+ JP=96+1-J
+ Z(JP+JD96*96)=ZCNTR+DELTA
+ W(JP+JD96*96)=WTEMP
+ 32 CONTINUE
+ 31 CONTINUE
+ RETURN
+*
+C the center of intervall cases:
+ 100 CONTINUE
+C print out message
+ IF(INIT.LE.20)THEN
+ INIT=init+1
+ WRITE (6,*) ' init. of center of intervall int. N=',N
+ ENDIF
+C put in constant weight and equally spaced central points
+ N=IABS(N)
+ DO 111 IN=1,N
+ WIN=(BX-AX)/DBLE(N)
+ Z(IN)=AX + (DBLE(IN)-.5D0)*WIN
+ 111 W(IN)=WIN
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE PO106BD
+
+C-----------------------------------------------------------------------
+C
+C store big arrays needed for Gauss integral, CERNLIB D106BD
+C (arrays A,X,ITAB copied on B,Y,LTAB)
+C
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+C
+ COMMON /GQCOM/ B(273),Y(273),LTAB(96)
+ DIMENSION A(273),X(273),KTAB(96)
+ SAVE
+C
+C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
+ DATA KTAB(2)/1/
+ DATA KTAB(3)/2/
+ DATA KTAB(4)/4/
+ DATA KTAB(5)/6/
+ DATA KTAB(6)/9/
+ DATA KTAB(7)/12/
+ DATA KTAB(8)/16/
+ DATA KTAB(9)/20/
+ DATA KTAB(10)/25/
+ DATA KTAB(11)/30/
+ DATA KTAB(12)/36/
+ DATA KTAB(13)/42/
+ DATA KTAB(14)/49/
+ DATA KTAB(15)/56/
+ DATA KTAB(16)/64/
+ DATA KTAB(20)/72/
+ DATA KTAB(24)/82/
+ DATA KTAB(28)/82/
+ DATA KTAB(32)/94/
+ DATA KTAB(36)/94/
+ DATA KTAB(40)/110/
+ DATA KTAB(44)/110/
+ DATA KTAB(48)/130/
+ DATA KTAB(52)/130/
+ DATA KTAB(56)/130/
+ DATA KTAB(60)/130/
+ DATA KTAB(64)/154/
+ DATA KTAB(68)/154/
+ DATA KTAB(72)/154/
+ DATA KTAB(76)/154/
+ DATA KTAB(80)/186/
+ DATA KTAB(84)/186/
+ DATA KTAB(88)/186/
+ DATA KTAB(92)/186/
+ DATA KTAB(96)/226/
+C
+C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
+C
+C-----N=2
+ DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
+C-----N=3
+ DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
+ DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
+C-----N=4
+ DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
+ DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
+C-----N=5
+ DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
+ DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
+ DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
+C-----N=6
+ DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
+ DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
+ DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
+C-----N=7
+ DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
+ DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
+ DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
+ DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
+C-----N=8
+ DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
+ DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
+ DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
+ DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
+C-----N=9
+ DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
+ DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
+ DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
+ DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
+ DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
+C-----N=10
+ DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
+ DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
+ DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
+ DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
+ DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
+C-----N=11
+ DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
+ DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
+ DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
+ DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
+ DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
+ DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
+C-----N=12
+ DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
+ DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
+ DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
+ DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
+ DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
+ DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
+C-----N=13
+ DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
+ DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
+ DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
+ DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
+ DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
+ DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
+ DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
+C-----N=14
+ DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
+ DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
+ DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
+ DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
+ DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
+ DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
+ DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
+C-----N=15
+ DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
+ DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
+ DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
+ DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
+ DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
+ DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
+ DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
+ DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
+C-----N=16
+ DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
+ DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
+ DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
+ DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
+ DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
+ DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
+ DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
+ DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
+C-----N=20
+ DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
+ DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
+ DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
+ DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
+ DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
+ DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
+ DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
+ DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
+ DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
+ DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
+C-----N=24
+ DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
+ DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
+ DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
+ DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
+ DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
+ DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
+ DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
+ DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
+ DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
+ DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
+ DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
+ DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
+C-----N=32
+ DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
+ DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
+ DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
+ DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
+ DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
+ DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
+ DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
+ DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
+ DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
+ DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
+ DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
+ DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
+ DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
+ DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
+ DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
+ DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
+C-----N=40
+ DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
+ DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
+ DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
+ DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
+ DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
+ DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
+ DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
+ DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
+ DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
+ DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
+ DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
+ DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
+ DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
+ DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
+ DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
+ DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
+ DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
+ DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
+ DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
+ DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
+C-----N=48
+ DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
+ DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
+ DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
+ DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
+ DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
+ DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
+ DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
+ DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
+ DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
+ DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
+ DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
+ DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
+ DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
+ DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
+ DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
+ DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
+ DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
+ DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
+ DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
+ DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
+ DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
+ DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
+ DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
+ DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
+C-----N=64
+ DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
+ DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
+ DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
+ DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
+ DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
+ DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
+ DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
+ DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
+ DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
+ DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
+ DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
+ DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
+ DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
+ DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
+ DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
+ DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
+ DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
+ DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
+ DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
+ DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
+ DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
+ DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
+ DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
+ DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
+ DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
+ DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
+ DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
+ DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
+ DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
+ DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
+ DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
+ DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
+C-----N=80
+ DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
+ DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
+ DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
+ DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
+ DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
+ DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
+ DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
+ DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
+ DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
+ DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
+ DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
+ DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
+ DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
+ DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
+ DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
+ DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
+ DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
+ DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
+ DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
+ DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
+ DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
+ DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
+ DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
+ DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
+ DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
+ DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
+ DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
+ DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
+ DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
+ DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
+ DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
+ DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
+ DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
+ DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
+ DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
+ DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
+ DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
+ DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
+ DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
+ DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
+C-----N=96
+ DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
+ DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
+ DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
+ DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
+ DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
+ DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
+ DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
+ DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
+ DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
+ DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
+ DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
+ DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
+ DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
+ DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
+ DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
+ DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
+ DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
+ DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
+ DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
+ DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
+ DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
+ DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
+ DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
+ DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
+ DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
+ DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
+ DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
+ DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
+ DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
+ DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
+ DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
+ DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
+ DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
+ DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
+ DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
+ DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
+ DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
+ DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
+ DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
+ DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
+ DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
+ DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
+ DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
+ DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
+ DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
+ DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
+ DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
+ DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
+ DATA IBD/0/
+
+ IF(IBD.NE.0) RETURN
+ IBD=1
+ DO 10 I=1,273
+ B(I) = A(I)
+10 Y(I) = X(I)
+ DO 20 I=1,96
+20 LTAB(I) = KTAB(I)
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SIB_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
+
+C-----------------------------------------------------------------------
+C
+C arbitrary Lorentz transformation
+C
+C Input: GA : gamma factor
+C BG? : components of gamma * beta
+C PC?,EC : components of initial 4 vector
+C
+C Output: P?,E : components of 4vector in final frame
+C P : 3-norm in final frame, a.k.a momentum
+C
+C PHO_ALTRA taken from PHOJET /FR'14
+C*********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ DOUBLE PRECISION P,E
+ SAVE
+
+c consistency check: (gamma*beta)**2 = gamma**2 - 1
+ BETGAM2 = BGX**2+BGY**2+BGZ**2
+ xtst = 1.D0-BETGAM2/GA**2 - 1.D0/GA**2
+ IF(abs(xtst).gt.1.D-5) THEN
+ WRITE(LUN,*) ' SIB_ALTRA: transf. inconsistent!'
+ WRITE(LUN,*) ' SIB_ALTRA: input (GA,GABE):',GA,BGX,BGY,BGZ
+ ENDIF
+ IF(GA.LT.1.D0) THEN
+ WRITE(LUN,*) ' SIB_ALTRA: you are joking right? GAMMA=',GA
+ CALL SIB_REJECT('SIB_ALTRA ')
+ ENDIF
+ EP=PCX*BGX+PCY*BGY+PCZ*BGZ
+ PE=EP/(GA+1.D0)+EC
+ PX=PCX+BGX*PE
+ PY=PCY+BGY*PE
+ PZ=PCZ+BGZ*PE
+ P=DSQRT(PX*PX+PY*PY+PZ*PZ)
+ E=GA*EC+EP
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+
+C-----------------------------------------------------------------------
+C
+C rotation of coordinate frame (1) de rotation around y axis
+C (2) fe rotation around z axis
+C (inverse rotation to SIB_TRANI)
+C
+C Input: ?0 : vector components in initial frame
+C C? : cosine of rotation angle
+C S? : sine of rotation angle
+C DE : angle of rotation around y axis
+C (polar angle in spherical coord.)
+C FE : angle of rotation around z axis
+C (azimuthal angle in spherical coord.)
+C
+C Output: X,Y,Z: components of vector in rotated frame
+C
+C PHO_TRANS taken from PHOJET \FR'14
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
+ Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
+ Z=-SDE *XO +CDE *ZO
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
+
+C-----------------------------------------------------------------------
+C
+C rotation of coordinate frame (1) -fe rotation around z axis
+C (2) -de rotation around y axis
+C (inverse rotation to SIB_TRANS)
+C
+C Input: ?0 : vector components in initial frame
+C C? : cosine of rotation angle
+C S? : sine of rotation angle
+C DE : angle of rotation around y axis
+C (polar angle in spherical coord.)
+C FE : angle of rotation around z axis
+C (azimuthal angle in spherical coord.)
+C
+C Output: X,Y,Z: components of vector in rotated frame
+C
+C PHO_TRANS taken from PHOJET \FR'14
+C**********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
+ Y=-SFE *XO+CFE* YO
+ Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIROBO( NBEG, NEND, THE, PHI, DBEX, DBEY, DBEZ)
+
+C-----------------------------------------------------------------------
+C THIS IS A SLIGHTLY ALTERED VERSION OF "LUROBO" [JETSET63.PYTHIA] *
+C SET TO WORK IN THE SIBYL ENVIROMENT. THE TRANSFORMATION IS PERFORMED *
+C ON PARTICLES NUMBER FROM NBEG TO NEND. COMMON BLOCKS CHANGED. *
+C TSS, Oct '87 *
+C modification use directly BETA in double precision in input (PL) *
+C **********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /S_PLIST/ P(8000,5), LLIST(8000), NP
+ DIMENSION ROT(3,3),PV(3),DP(4)
+ SAVE
+
+ IF(THE**2+PHI**2 .LE. 1.D-20) GO TO 131
+C...ROTATE (TYPICALLY FROM Z AXIS TO DIRECTION THETA,PHI)
+ ROT(1,1)=dCOS(THE)*dCOS(PHI)
+ ROT(1,2)=-dSIN(PHI)
+ ROT(1,3)=dSIN(THE)*dCOS(PHI)
+ ROT(2,1)=dCOS(THE)*dSIN(PHI)
+ ROT(2,2)=dCOS(PHI)
+ ROT(2,3)=dSIN(THE)*dSIN(PHI)
+ ROT(3,1)=-dSIN(THE)
+ ROT(3,2)=0.D0
+ ROT(3,3)=dCOS(THE)
+ DO 120 I=NBEG,NEND
+ DO 100 J=1,3
+ 100 PV(J)=P(I,J)
+ DO 110 J=1,3
+ 110 P(I,J)=ROT(J,1)*PV(1)+ROT(J,2)*PV(2)+ROT(J,3)*PV(3)
+ 120 CONTINUE
+ 131 IF(DBEX**2+DBEY**2+DBEZ**2 .LE. 1.D-20) GO TO 151
+C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA)
+ DGA=1.D0/DSQRT(1D0-DBEX**2-DBEY**2-DBEZ**2)
+ DO 140 I=NBEG, NEND
+ DO 130 J=1,4
+ 130 DP(J)=P(I,J)
+ DBEP=DBEX*DP(1)+DBEY*DP(2)+DBEZ*DP(3)
+ DGABEP=DGA*(DGA*DBEP/(1.D0+DGA)+DP(4))
+ P(I,1)=DP(1)+DGABEP*DBEX
+ P(I,2)=DP(2)+DGABEP*DBEY
+ P(I,3)=DP(3)+DGABEP*DBEZ
+ P(I,4)=DGA*(DP(4)+DBEP)
+ 140 CONTINUE
+ 151 RETURN
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE ISWTCH_LMNTS(ia,ib)
+
+C-----------------------------------------------------------------------
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ itmp = ia
+ ia = ib
+ ib = itmp
+ end
+C=======================================================================
+
+ SUBROUTINE SWTCH_LMNTS(a,b)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ tmp = a
+ a = b
+ b = tmp
+ end
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION PAWT(A,B,C)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+ SAVE
+
+C... c.m.s. Momentum in two particle decays
+ PAWT = SQRT((A**2-(B+C)**2+EPS10)*(A**2-(B-C)**2))/(2.D0*A)
+ END
+
+C=======================================================================
+
+ SUBROUTINE HSPLI (KF,KP1,KP2)
+
+C-----------------------------------------------------------------------
+C...This subroutine splits one hadron of code KF
+C. into 2 partons of code KP1 and KP2
+C. KP1 refers to a color triplet [q or (qq)bar]
+C. KP2 to a a color anti-triplet [qbar or (qq)]
+C. allowed inputs:
+C. KF = 6:14 pi0,pi+-,k+-,k0L,k0s, p,n
+C. = -13,-14 pbar,nbar
+C. = 34:39 Sig+, Sig0, Sig-, Xi0, Xi-, Lam0
+C. = 49: Omega-
+C. \FR'16
+C------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ INTEGER KF,KP1,KP2
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+
+c internal types
+ INTEGER KPP
+ DOUBLE PRECISION R,XBUG,S_RNDM
+ SAVE
+
+ IF(IABS(KF).eq.6.or.IABS(KF).eq.27)THEN ! pi0, rho0
+ R = S_RNDM(0)
+ XBUG = 0.D0
+ IF(IPAR(19).eq.1) XBUG = 0.5D0
+ IF (R.LE.XBUG) THEN
+ KP1 = 1
+ KP2 = -1
+ ELSE
+ KP1 = 2
+ KP2 = -2
+ ENDIF
+
+ ELSEIF(IABS(KF).eq.7)THEN ! pi+
+ KP1 = 1
+ KP2 = -2
+
+ ELSEIF(IABS(KF).eq.8)THEN ! pi-
+ KP1 = 2
+ KP2 = -1
+
+ ELSEIF(IABS(KF).eq.9)THEN ! K+
+ KP1 = 1
+ KP2 = -3
+ ELSEIF(IABS(KF).eq.10)THEN ! K-
+ KP1 = 3
+ KP2 = -1
+ ELSEIF(IABS(KF).eq.11.or.IABS(KF).eq.12)THEN ! K0S/K0L
+ KP1 = 2
+ KP2 = -3
+ IF (S_RNDM(1).GT. 0.5D0) THEN
+ KP1 = 3
+ KP2 = -2
+ ENDIF
+ ELSEIF(IABS(KF).eq.21)THEN ! K0
+ KP1 = 2
+ KP2 = -3
+ ELSEIF(IABS(KF).eq.22)THEN ! K0bar
+ KP1 = 3
+ KP2 = -2
+ ELSEIF(IABS(KF).eq.33)THEN ! phi
+ KP1 = 3
+ KP2 = -3
+ ELSEIF(IABS(KF).eq.13.or.IABS(KF).eq.41)THEN ! p/pbar,delta+
+ R = PAR(53)*S_RNDM(KF)
+ IF (R .LT.3.D0) THEN
+ KP1 = 1
+ KP2 = 12
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 1
+ KP2 = 21
+ ELSE
+ KP1 = 2
+ KP2 = 11
+ ENDIF
+ ELSEIF(IABS(KF).eq.14.or.IABS(KF).eq.42)THEN ! n/nbar,delta0
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 2
+ KP2 = 12
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 2
+ KP2 = 21
+ ELSE
+ KP1 = 1
+ KP2 = 22
+ ENDIF
+ ELSEIF(IABS(KF).eq.40)THEN ! delta++
+ KP1 = 1
+ KP2 = 11
+ ELSEIF(IABS(KF).eq.43)THEN ! delta-
+ KP1 = 2
+ KP2 = 22
+ ELSEIF(IABS(KF).eq.34)THEN !Sigma+
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 3
+ KP2 = 11
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 1
+ KP2 = 31
+ ELSE
+ KP1 = 1
+ KP2 = 13
+ ENDIF
+ ELSEIF(IABS(KF).eq.35.or.IABS(KF).eq.39)THEN !Sigma0/Lambda0
+c all configurations equally likely --> Knuth shuffle
+c setup quarks: u,d,s
+ CALL SHFFL_QRKS(1,2,3,KP1,KP2)
+
+ ELSEIF(IABS(KF).eq.36)THEN !Sigma-
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 3
+ KP2 = 22
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 2
+ KP2 = 32
+ ELSE
+ KP1 = 2
+ KP2 = 23
+ ENDIF
+ ELSEIF(IABS(KF).eq.37)THEN !Xi0
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 1
+ KP2 = 33
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 3
+ KP2 = 13
+ ELSE
+ KP1 = 1
+ KP2 = 33
+ ENDIF
+ ELSEIF(IABS(KF).eq.38)THEN !Xi-
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 2
+ KP2 = 33
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 3
+ KP2 = 23
+ ELSE
+ KP1 = 2
+ KP2 = 33
+ ENDIF
+ ELSEIF(IABS(KF).eq.49)THEN ! Omega-
+ KP1 = 3
+ KP2 = 33
+
+ ELSEIF(IABS(KF).eq.59)THEN ! D+
+ KP1 = 4
+ KP2 = -2
+
+ ELSEIF(IABS(KF).eq.60)THEN ! D-
+ KP1 = 2
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.71)THEN ! D0
+ KP1 = 4
+ KP2 = -1
+
+ ELSEIF(IABS(KF).eq.72)THEN ! D0bar
+ KP1 = 1
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.73)THEN ! eta_c
+ KP1 = 4
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.74)THEN ! Ds+
+ KP1 = 4
+ KP2 = -3
+
+ ELSEIF(IABS(KF).eq.75)THEN ! Ds-
+ KP1 = 3
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.76)THEN ! Ds*+
+ KP1 = 4
+ KP2 = -3
+
+ ELSEIF(IABS(KF).eq.77)THEN ! Ds*-
+ KP1 = 3
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.78)THEN ! D*+
+ KP1 = 4
+ KP2 = -2
+
+ ELSEIF(IABS(KF).eq.79)THEN ! D*-
+ KP1 = 2
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.80)THEN ! D*0
+ KP1 = 4
+ KP2 = -1
+
+ ELSEIF(IABS(KF).eq.81)THEN ! D*0bar
+ KP1 = 1
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.83)THEN ! J/psi
+ KP1 = 4
+ KP2 = -4
+
+ ELSEIF(IABS(KF).eq.84)THEN ! Sigma_c++
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 4
+ KP2 = 11
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 1
+ KP2 = 41
+ ELSE
+ KP1 = 1
+ KP2 = 14
+ ENDIF
+
+ ELSEIF(IABS(KF).eq.85.or.IABS(KF).eq.89)THEN ! Sigma_c+ / Lambda_c+
+c setup quarks: u,d,c
+ CALL SHFFL_QRKS(1,2,4,KP1,KP2)
+
+ ELSEIF(IABS(KF).eq.86)THEN ! Sigma_c0
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 4
+ KP2 = 22
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 2
+ KP2 = 42
+ ELSE
+ KP1 = 2
+ KP2 = 24
+ ENDIF
+
+ ELSEIF(IABS(KF).eq.87)THEN ! Xi_c+
+c setup quarks: u,s,c
+ CALL SHFFL_QRKS(1,3,4,KP1,KP2)
+
+ ELSEIF(IABS(KF).eq.88)THEN ! Xi_c0
+ CALL SHFFL_QRKS(2,3,4,KP1,KP2)
+
+ ELSEIF(IABS(KF).eq.99)THEN ! Omega_c0
+ R = 6.D0*S_RNDM(0)
+ IF (R .LT.3.D0) THEN
+ KP1 = 4
+ KP2 = 33
+ ELSEIF (R .LT. 4.D0) THEN
+ KP1 = 3
+ KP2 = 43
+ ELSE
+ KP1 = 3
+ KP2 = 34
+ ENDIF
+
+ ELSE
+C... Test for good input
+ WRITE(LUN,*)
+ & ' HSPLI : Routine entered with illegal particle code ',KF
+ CALL SIB_REJECT('HSPLI ')
+ ENDIF
+
+C if anti-baryon, invert valences
+ IF (KF .LT. 0) THEN
+ KPP = KP1
+ KP1 = -KP2
+ KP2 = -KPP
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SHFFL_QRKS(IQF1,IQF2,IQF3,KF1,KF2)
+
+C-----------------------------------------------------------------------
+c routine to shuffle 3 quark flavors
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER IQF1,IQF2,IQF3,KF1,KF2
+ INTEGER KPL,JJ,II,IFL
+ DOUBLE PRECISION S_RNDM
+ DIMENSION KPL(3)
+c quark flavors to shuffle
+ KPL(1) = IQF1
+ KPL(2) = IQF2
+ KPL(3) = IQF3
+c Knuth shuffle..
+ DO II=3,2,-1
+ JJ=1+INT(II*S_RNDM(II))
+ IFL=KPL(jj)
+ KPL(jj)=KPL(ii)
+ KPL(ii)=IFL
+ ENDDO
+ KF1=KPL(1)
+ KF2=KPL(2)*10+KPL(3)
+ END
+
+C.=========================================================================
+C. Library of programs for the generation of nucleus-nucleus interactions
+C. and the study of nucleus-induced cosmic ray showers
+C.
+C. September 2001 changes in FPNI, and SIGMA_INI,
+C. new SIGMA_PP, SIGMA_PPI, SIGMA_KP (R. Engel)
+C.
+C. may 1996 small bug corrected by Dieter Heck in NUC_CONF
+C.
+C. march 1996 small modification to the superposition code
+C.
+C. February 1996 change to FPNI to give an interaction length
+C. also at very low energy
+C.
+C. Version 1.01 september 1995
+C. (small corrections P.L.)
+C. the random number generator is called as S_RNDM(0)
+C. ------------------------------------------------------
+C. Version 1.00 April 1992
+C.
+C. Authors:
+C.
+C. J. Engel
+C. T.K Gaisser
+C. P.Lipari
+C. T. Stanev
+C.
+C. This set of routines when used in the simulation of cosmic ray
+C. showers have only three "contact points" with the "external world"
+C.
+C. (i) SUBROUTINE NUC_NUC_INI
+C. (no calling arguments)
+C. to be called once during general initialization
+C. (ii) SUBROUTINE HEAVY (IA, E0)
+C. where IA (integer) is the mass number of the projectile
+C. nucleus and E0 (TeV) is the energy per nucleon
+C. The output (positions of first interaction for the IA
+C. nucleons of the projectile) is contained in the common block:
+C. COMMON /C1STNC/ XX0(60),XX(60),YY(60),AX(60),AY(60)
+C. In detail:
+C. XX0(j) (g cm-2) = position of interaction
+C. XX(j) (mm) x-distance from shower axis
+C. YY(j) (mm) y-distance from shower axis
+C. AX(j) (radiants) Theta_x with respect to original direction
+C. AY(j) (radiants) Theta_y with respect to original direction
+C.
+C. (iii) FUNCTION FPNI (E,L)
+C. Interaction length in air.
+C. E (TeV) is the energy of the particle, L is the particle
+C. code (NOTE: "Sibyll" codes are used : L =1-18)
+C. WANRNING : The nucleus-nucleus cross section
+C. tabulated in the program are "matched" to the p-Air
+C. cross section calculated with this FUNCTION, in other words
+C. they are both calculated with the same input pp cross section
+C==========================================================================
+
+ SUBROUTINE NUC_NUC_INI
+
+C-----------------------------------------------------------------------
+C...Initialization for the generation of nucleus-nucleus interactions
+C. INPUT : E0 (TeV) Energy per nucleon of the beam nucleus
+C........................................................................
+ SAVE
+
+ CALL NUC_GEOM_INI ! nucleus profiles
+ CALL SIGMA_INI ! initialize pp cross sections
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE FRAGM1 (IA,NW, NF, IAF)
+
+C-----------------------------------------------------------------------
+C...Nuclear Fragmentation
+C. total dissolution of nucleus
+C.......................................................................
+ SAVE
+
+ DIMENSION IAF(60)
+ NF = IA-NW
+ DO J=1,NF
+ IAF(J) = 1
+ ENDDO
+ RETURN
+ END
+C->
+C=======================================================================
+
+ SUBROUTINE FRAGM2 (IA,NW, NF, IAF)
+
+C-----------------------------------------------------------------------
+C...Nuclear Fragmentation
+C. Spectator in one single fragment
+C.......................................................................
+ SAVE
+
+ DIMENSION IAF(60)
+ IF (IA-NW .GT. 0) THEN
+ NF = 1
+ IAF(1) = IA-NW
+ ELSE
+ NF = 0
+ ENDIF
+ RETURN
+ END
+
+C-----------------------------------------------------------------------
+C...Code of fragmentation of spectator nucleons
+C. based on Jon Engel abrasion-ablation algorithms
+C=======================================================================
+
+ BLOCK DATA FRAG_DATA
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+C...Data for the fragmentation of nucleus projectiles
+ COMMON /FRAGMOD/A(10,10,20),AE(10,10,20),ERES(10,10),NFLAGG(10,10)
+ SAVE
+ DATA (NFLAGG(I, 1),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NFLAGG(I, 2),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NFLAGG(I, 3),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NFLAGG(I, 4),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NFLAGG(I, 5),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+ DATA (NFLAGG(I, 6),I=1,10) /
+ + 0, 0, 0, 0, 0, 0, 0, 1, 1, 1 /
+ DATA (NFLAGG(I, 7),I=1,10) /
+ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
+ DATA (NFLAGG(I, 8),I=1,10) /
+ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
+ DATA (NFLAGG(I, 9),I=1,10) /
+ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
+ DATA (NFLAGG(I,10),I=1,10) /
+ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
+ DATA (A(I, 1, 1),I=1,10) /
+ + .438D-01,.172D0 ,.283D0 ,.511D0 ,.715D0 ,.920D0 ,1.19D0 ,
+ + 1.37D0 ,1.65D0 ,2.14D0 /
+ DATA (A(I, 1, 2),I=1,10) /
+ + .147D-01,.249D-01,.439D-01,.592D-01,.776D-01,.886D-01,.108D0 ,
+ + .117D0 ,.126D0 ,.128D0 /
+ DATA (A(I, 1, 3),I=1,10) /
+ + .216D-02,.627D-02,.834D-02,.108D-01,.144D-01,.152D-01,.196D-01,
+ + .200D-01,.210D-01,.224D-01 /
+ DATA (A(I, 1, 4),I=1,10) /
+ + .593D-01,.653D-01,.116D0 ,.145D0 ,.184D0 ,.204D0 ,.234D0 ,
+ + .257D0 ,.271D0 ,.248D0 /
+ DATA (A(I, 1, 5),I=1,10) /
+ + .000D+00,.918D-02,.362D-02,.805D-02,.436D-02,.728D-02,.466D-02,
+ + .707D-02,.932D-02,.130D-01 /
+ DATA (A(I, 1, 6),I=1,10) /
+ + .000D+00,.180D-02,.247D-02,.208D-02,.224D-02,.214D-02,.226D-02,
+ + .233D-02,.230D-02,.194D-02 /
+ DATA (A(I, 1, 7),I=1,10) /
+ + .000D+00,.106D-02,.703D-03,.687D-03,.739D-03,.674D-03,.819D-03,
+ + .768D-03,.756D-03,.720D-03 /
+ DATA (A(I, 1, 8),I=1,10) /
+ + .000D+00,.000D+00,.188D-02,.130D-02,.138D-02,.117D-02,.124D-02,
+ + .119D-02,.111D-02,.829D-03 /
+ DATA (A(I, 1, 9),I=1,10) /
+ + .000D+00,.000D+00,.302D-03,.258D-03,.249D-03,.208D-03,.248D-03,
+ + .222D-03,.210D-03,.187D-03 /
+ DATA (A(I, 1,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.235D-03,.222D-03,.172D-03,.181D-03,
+ + .166D-03,.152D-03,.124D-03 /
+ DATA (A(I, 1,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.238D-03,.179D-03,.145D-03,.156D-03,
+ + .138D-03,.129D-03,.111D-03 /
+ DATA (A(I, 1,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.368D-03,.400D-03,.255D-03,.262D-03,
+ + .221D-03,.182D-03,.112D-03 /
+ DATA (A(I, 1,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.753D-04,.712D-04,.527D-04,
+ + .537D-04,.538D-04,.487D-04 /
+ DATA (A(I, 1,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.103D-03,.589D-04,.578D-04,
+ + .468D-04,.385D-04,.269D-04 /
+ DATA (A(I, 1,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.444D-04,.372D-04,
+ + .318D-04,.284D-04,.218D-04 /
+ DATA (A(I, 1,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.487D-04,.473D-04,
+ + .338D-04,.243D-04,.122D-04 /
+ DATA (A(I, 1,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.121D-04,.117D-04,
+ + .932D-05,.792D-05,.583D-05 /
+ DATA (A(I, 1,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.147D-04,
+ + .101D-04,.756D-05,.496D-05 /
+ DATA (A(I, 1,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.755D-05,
+ + .612D-05,.505D-05,.341D-05 /
+ DATA (A(I, 1,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .630D-05,.444D-05,.282D-05 /
+ DATA (A(I, 2, 1),I=1,10) /
+ + .269D0 ,.510D0 ,.738D0 ,1.12D0 ,1.46D0 ,1.83D0 ,2.22D0 ,
+ + 2.57D0 ,3.00D0 ,3.67D0 /
+ DATA (A(I, 2, 2),I=1,10) /
+ + .121D0 ,.133D0 ,.190D0 ,.234D0 ,.293D0 ,.332D0 ,.395D0 ,
+ + .431D0 ,.468D0 ,.502D0 /
+ DATA (A(I, 2, 3),I=1,10) /
+ + .227D-01,.374D-01,.474D-01,.578D-01,.722D-01,.794D-01,.960D-01,
+ + .102D0 ,.110D0 ,.120D0 /
+ DATA (A(I, 2, 4),I=1,10) /
+ + .287D0 ,.196D0 ,.270D0 ,.314D0 ,.373D0 ,.408D0 ,.462D0 ,
+ + .498D0 ,.529D0 ,.523D0 /
+ DATA (A(I, 2, 5),I=1,10) /
+ + .000D+00,.433D-01,.218D-01,.384D-01,.263D-01,.385D-01,.298D-01,
+ + .405D-01,.504D-01,.671D-01 /
+ DATA (A(I, 2, 6),I=1,10) /
+ + .000D+00,.151D-01,.177D-01,.159D-01,.173D-01,.173D-01,.187D-01,
+ + .196D-01,.201D-01,.191D-01 /
+ DATA (A(I, 2, 7),I=1,10) /
+ + .000D+00,.457D-02,.607D-02,.610D-02,.677D-02,.670D-02,.784D-02,
+ + .787D-02,.806D-02,.803D-02 /
+ DATA (A(I, 2, 8),I=1,10) /
+ + .000D+00,.000D+00,.702D-02,.536D-02,.558D-02,.510D-02,.554D-02,
+ + .546D-02,.538D-02,.489D-02 /
+ DATA (A(I, 2, 9),I=1,10) /
+ + .000D+00,.000D+00,.190D-02,.199D-02,.205D-02,.191D-02,.221D-02,
+ + .214D-02,.213D-02,.204D-02 /
+ DATA (A(I, 2,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.226D-02,.219D-02,.195D-02,.208D-02,
+ + .204D-02,.203D-02,.194D-02 /
+ DATA (A(I, 2,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.213D-02,.195D-02,.175D-02,.191D-02,
+ + .183D-02,.179D-02,.166D-02 /
+ DATA (A(I, 2,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.588D-03,.186D-02,.137D-02,.141D-02,
+ + .128D-02,.117D-02,.947D-03 /
+ DATA (A(I, 2,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.554D-03,.562D-03,.454D-03,
+ + .485D-03,.505D-03,.509D-03 /
+ DATA (A(I, 2,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.490D-03,.533D-03,.531D-03,
+ + .476D-03,.437D-03,.369D-03 /
+ DATA (A(I, 2,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.427D-03,.382D-03,
+ + .358D-03,.340D-03,.294D-03 /
+ DATA (A(I, 2,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.239D-03,.298D-03,
+ + .238D-03,.196D-03,.134D-03 /
+ DATA (A(I, 2,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.299D-04,.893D-04,
+ + .796D-04,.744D-04,.683D-04 /
+ DATA (A(I, 2,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.127D-03,
+ + .107D-03,.916D-04,.720D-04 /
+ DATA (A(I, 2,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.397D-04,
+ + .630D-04,.565D-04,.461D-04 /
+ DATA (A(I, 2,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .511D-04,.459D-04,.402D-04 /
+ DATA (A(I, 3, 1),I=1,10) /
+ + .708D0 ,1.02D0 ,1.41D0 ,1.91D0 ,2.42D0 ,3.00D0 ,3.53D0 ,
+ + 4.09D0 ,4.71D0 ,5.57D0 /
+ DATA (A(I, 3, 2),I=1,10) /
+ + .397D0 ,.410D0 ,.539D0 ,.648D0 ,.795D0 ,.910D0 ,1.06D0 ,
+ + 1.17D0 ,1.29D0 ,1.42D0 /
+ DATA (A(I, 3, 3),I=1,10) /
+ + .845D-01,.122D0 ,.157D0 ,.190D0 ,.232D0 ,.262D0 ,.307D0 ,
+ + .335D0 ,.366D0 ,.402D0 /
+ DATA (A(I, 3, 4),I=1,10) /
+ + .210D0 ,.379D0 ,.450D0 ,.490D0 ,.574D0 ,.636D0 ,.709D0 ,
+ + .769D0 ,.820D0 ,.849D0 /
+ DATA (A(I, 3, 5),I=1,10) /
+ + .000D+00,.102D0 ,.675D-01,.104D0 ,.858D-01,.115D0 ,.102D0 ,
+ + .129D0 ,.154D0 ,.194D0 /
+ DATA (A(I, 3, 6),I=1,10) /
+ + .000D+00,.392D-01,.615D-01,.593D-01,.649D-01,.674D-01,.735D-01,
+ + .779D-01,.817D-01,.828D-01 /
+ DATA (A(I, 3, 7),I=1,10) /
+ + .000D+00,.539D-02,.222D-01,.238D-01,.269D-01,.280D-01,.320D-01,
+ + .334D-01,.350D-01,.361D-01 /
+ DATA (A(I, 3, 8),I=1,10) /
+ + .000D+00,.000D+00,.838D-02,.130D-01,.133D-01,.131D-01,.141D-01,
+ + .144D-01,.149D-01,.152D-01 /
+ DATA (A(I, 3, 9),I=1,10) /
+ + .000D+00,.000D+00,.228D-02,.647D-02,.688D-02,.687D-02,.772D-02,
+ + .786D-02,.811D-02,.824D-02 /
+ DATA (A(I, 3,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.664D-02,.828D-02,.802D-02,.845D-02,
+ + .869D-02,.902D-02,.930D-02 /
+ DATA (A(I, 3,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.338D-02,.735D-02,.710D-02,.767D-02,
+ + .767D-02,.776D-02,.756D-02 /
+ DATA (A(I, 3,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.280D-03,.262D-02,.349D-02,.342D-02,
+ + .322D-02,.312D-02,.291D-02 /
+ DATA (A(I, 3,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.618D-03,.161D-02,.138D-02,
+ + .148D-02,.155D-02,.166D-02 /
+ DATA (A(I, 3,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.313D-03,.128D-02,.161D-02,
+ + .150D-02,.144D-02,.134D-02 /
+ DATA (A(I, 3,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.645D-03,.118D-02,
+ + .115D-02,.111D-02,.103D-02 /
+ DATA (A(I, 3,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.117D-03,.497D-03,
+ + .581D-03,.501D-03,.401D-03 /
+ DATA (A(I, 3,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.115D-04,.997D-04,
+ + .202D-03,.203D-03,.206D-03 /
+ DATA (A(I, 3,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.877D-04,
+ + .242D-03,.263D-03,.226D-03 /
+ DATA (A(I, 3,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.158D-04,
+ + .881D-04,.152D-03,.136D-03 /
+ DATA (A(I, 3,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .358D-04,.997D-04,.117D-03 /
+ DATA (A(I, 4, 1),I=1,10) /
+ + .945D0 ,1.29D0 ,1.40D0 ,1.98D0 ,2.73D0 ,3.17D0 ,3.77D0 ,
+ + 4.29D0 ,4.78D0 ,5.54D0 /
+ DATA (A(I, 4, 2),I=1,10) /
+ + .581D0 ,.599D0 ,.645D0 ,.839D0 ,1.10D0 ,1.25D0 ,1.47D0 ,
+ + 1.64D0 ,1.78D0 ,1.99D0 /
+ DATA (A(I, 4, 3),I=1,10) /
+ + .127D0 ,.182D0 ,.202D0 ,.264D0 ,.344D0 ,.387D0 ,.455D0 ,
+ + .504D0 ,.549D0 ,.611D0 /
+ DATA (A(I, 4, 4),I=1,10) /
+ + .183D0 ,.464D0 ,.351D0 ,.444D0 ,.642D0 ,.659D0 ,.772D0 ,
+ + .830D0 ,.882D0 ,.930D0 /
+ DATA (A(I, 4, 5),I=1,10) /
+ + .000D+00,.122D0 ,.803D-01,.136D0 ,.134D0 ,.173D0 ,.164D0 ,
+ + .203D0 ,.239D0 ,.300D0 /
+ DATA (A(I, 4, 6),I=1,10) /
+ + .000D+00,.393D-01,.766D-01,.872D-01,.108D0 ,.111D0 ,.123D0 ,
+ + .132D0 ,.139D0 ,.145D0 /
+ DATA (A(I, 4, 7),I=1,10) /
+ + .000D+00,.416D-02,.289D-01,.360D-01,.454D-01,.477D-01,.549D-01,
+ + .583D-01,.618D-01,.654D-01 /
+ DATA (A(I, 4, 8),I=1,10) /
+ + .000D+00,.000D+00,.761D-02,.157D-01,.214D-01,.205D-01,.233D-01,
+ + .241D-01,.255D-01,.271D-01 /
+ DATA (A(I, 4, 9),I=1,10) /
+ + .000D+00,.000D+00,.238D-02,.803D-02,.123D-01,.123D-01,.140D-01,
+ + .145D-01,.153D-01,.160D-01 /
+ DATA (A(I, 4,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.695D-02,.150D-01,.154D-01,.166D-01,
+ + .172D-01,.181D-01,.192D-01 /
+ DATA (A(I, 4,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.355D-02,.104D-01,.143D-01,.156D-01,
+ + .158D-01,.164D-01,.165D-01 /
+ DATA (A(I, 4,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.112D-03,.276D-02,.568D-02,.736D-02,
+ + .684D-02,.691D-02,.661D-02 /
+ DATA (A(I, 4,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.740D-03,.222D-02,.339D-02,
+ + .352D-02,.382D-02,.409D-02 /
+ DATA (A(I, 4,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.369D-03,.160D-02,.322D-02,
+ + .375D-02,.375D-02,.355D-02 /
+ DATA (A(I, 4,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.750D-03,.190D-02,
+ + .298D-02,.319D-02,.299D-02 /
+ DATA (A(I, 4,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.260D-03,.673D-03,
+ + .117D-02,.156D-02,.126D-02 /
+ DATA (A(I, 4,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.283D-05,.131D-03,
+ + .363D-03,.618D-03,.690D-03 /
+ DATA (A(I, 4,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.205D-03,
+ + .378D-03,.709D-03,.844D-03 /
+ DATA (A(I, 4,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.654D-05,
+ + .150D-03,.341D-03,.527D-03 /
+ DATA (A(I, 4,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .957D-04,.197D-03,.406D-03 /
+ DATA (A(I, 5, 1),I=1,10) /
+ + 1.16D0 ,1.70D0 ,2.19D0 ,2.79D0 ,3.33D0 ,3.90D0 ,4.49D0 ,
+ + 5.07D0 ,5.66D0 ,6.38D0 /
+ DATA (A(I, 5, 2),I=1,10) /
+ + .779D0 ,.899D0 ,1.09D0 ,1.28D0 ,1.51D0 ,1.71D0 ,1.96D0 ,
+ + 2.18D0 ,2.39D0 ,2.62D0 /
+ DATA (A(I, 5, 3),I=1,10) /
+ + .167D0 ,.263D0 ,.334D0 ,.408D0 ,.482D0 ,.548D0 ,.632D0 ,
+ + .700D0 ,.767D0 ,.840D0 /
+ DATA (A(I, 5, 4),I=1,10) /
+ + .203D0 ,.565D0 ,.845D0 ,.867D0 ,.906D0 ,.961D0 ,1.08D0 ,
+ + 1.13D0 ,1.21D0 ,1.25D0 /
+ DATA (A(I, 5, 5),I=1,10) /
+ + .000D+00,.129D0 ,.152D0 ,.237D0 ,.208D0 ,.268D0 ,.258D0 ,
+ + .312D0 ,.368D0 ,.450D0 /
+ DATA (A(I, 5, 6),I=1,10) /
+ + .000D+00,.460D-01,.126D0 ,.174D0 ,.182D0 ,.188D0 ,.208D0 ,
+ + .219D0 ,.233D0 ,.239D0 /
+ DATA (A(I, 5, 7),I=1,10) /
+ + .000D+00,.289D-02,.380D-01,.611D-01,.788D-01,.845D-01,.974D-01,
+ + .103D0 ,.111D0 ,.117D0 /
+ DATA (A(I, 5, 8),I=1,10) /
+ + .000D+00,.000D+00,.137D-01,.223D-01,.374D-01,.436D-01,.488D-01,
+ + .488D-01,.524D-01,.547D-01 /
+ DATA (A(I, 5, 9),I=1,10) /
+ + .000D+00,.000D+00,.162D-02,.114D-01,.198D-01,.263D-01,.315D-01,
+ + .323D-01,.348D-01,.364D-01 /
+ DATA (A(I, 5,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.149D-01,.240D-01,.320D-01,.428D-01,
+ + .436D-01,.469D-01,.493D-01 /
+ DATA (A(I, 5,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.562D-02,.194D-01,.290D-01,.408D-01,
+ + .460D-01,.492D-01,.500D-01 /
+ DATA (A(I, 5,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.476D-04,.106D-01,.134D-01,.191D-01,
+ + .227D-01,.264D-01,.253D-01 /
+ DATA (A(I, 5,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.281D-02,.679D-02,.879D-02,
+ + .123D-01,.165D-01,.190D-01 /
+ DATA (A(I, 5,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.542D-04,.847D-02,.125D-01,
+ + .144D-01,.173D-01,.192D-01 /
+ DATA (A(I, 5,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.652D-02,.982D-02,
+ + .129D-01,.159D-01,.192D-01 /
+ DATA (A(I, 5,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.109D-03,.688D-02,
+ + .751D-02,.845D-02,.905D-02 /
+ DATA (A(I, 5,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.823D-06,.237D-02,
+ + .318D-02,.446D-02,.569D-02 /
+ DATA (A(I, 5,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.604D-03,
+ + .610D-02,.673D-02,.827D-02 /
+ DATA (A(I, 5,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.716D-06,
+ + .412D-02,.519D-02,.617D-02 /
+ DATA (A(I, 5,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .710D-03,.543D-02,.674D-02 /
+ DATA (A(I, 6, 1),I=1,10) /
+ + 1.36D0 ,2.08D0 ,2.67D0 ,3.30D0 ,3.94D0 ,4.62D0 ,5.18D0 ,
+ + 3.60D0 ,3.64D0 ,3.95D0 /
+ DATA (A(I, 6, 2),I=1,10) /
+ + 1.07D0 ,1.33D0 ,1.58D0 ,1.82D0 ,2.10D0 ,2.44D0 ,2.74D0 ,
+ + 1.78D0 ,1.73D0 ,1.80D0 /
+ DATA (A(I, 6, 3),I=1,10) /
+ + .158D0 ,.276D0 ,.402D0 ,.506D0 ,.609D0 ,.700D0 ,.802D0 ,
+ + .638D0 ,.629D0 ,.658D0 /
+ DATA (A(I, 6, 4),I=1,10) /
+ + .308D0 ,.739D0 ,1.02D0 ,1.12D0 ,1.26D0 ,1.35D0 ,1.57D0 ,
+ + 1.94D0 ,1.71D0 ,1.55D0 /
+ DATA (A(I, 6, 5),I=1,10) /
+ + .000D+00,.217D0 ,.183D0 ,.324D0 ,.276D0 ,.395D0 ,.393D0 ,
+ + .558D0 ,.602D0 ,.681D0 /
+ DATA (A(I, 6, 6),I=1,10) /
+ + .000D+00,.658D-01,.251D0 ,.267D0 ,.299D0 ,.326D0 ,.386D0 ,
+ + .452D0 ,.475D0 ,.409D0 /
+ DATA (A(I, 6, 7),I=1,10) /
+ + .000D+00,.198D-02,.774D-01,.136D0 ,.149D0 ,.164D0 ,.187D0 ,
+ + .210D0 ,.238D0 ,.256D0 /
+ DATA (A(I, 6, 8),I=1,10) /
+ + .000D+00,.000D+00,.290D-01,.122D0 ,.139D0 ,.128D0 ,.129D0 ,
+ + .137D0 ,.147D0 ,.167D0 /
+ DATA (A(I, 6, 9),I=1,10) /
+ + .000D+00,.000D+00,.699D-03,.617D-01,.750D-01,.801D-01,.905D-01,
+ + .974D-01,.105D0 ,.122D0 /
+ DATA (A(I, 6,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.310D-01,.112D0 ,.127D0 ,.140D0 ,
+ + .143D0 ,.155D0 ,.176D0 /
+ DATA (A(I, 6,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.277D-02,.889D-01,.143D0 ,.150D0 ,
+ + .175D0 ,.184D0 ,.208D0 /
+ DATA (A(I, 6,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.202D-04,.343D-01,.959D-01,.109D0 ,
+ + .115D0 ,.112D0 ,.116D0 /
+ DATA (A(I, 6,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.186D-02,.435D-01,.512D-01,
+ + .744D-01,.856D-01,.103D0 /
+ DATA (A(I, 6,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.144D-04,.427D-01,.786D-01,
+ + .911D-01,.993D-01,.108D0 /
+ DATA (A(I, 6,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.466D-02,.518D-01,
+ + .848D-01,.109D0 ,.119D0 /
+ DATA (A(I, 6,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.655D-05,.330D-01,
+ + .586D-01,.617D-01,.594D-01 /
+ DATA (A(I, 6,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.228D-06,.328D-02,
+ + .190D-01,.301D-01,.454D-01 /
+ DATA (A(I, 6,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.218D-04,
+ + .272D-01,.501D-01,.707D-01 /
+ DATA (A(I, 6,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.146D-06,
+ + .441D-02,.378D-01,.556D-01 /
+ DATA (A(I, 6,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .160D-03,.204D-01,.679D-01 /
+ DATA (A(I, 7, 1),I=1,10) /
+ + .522D0 ,.862D0 ,1.14D0 ,1.40D0 ,1.70D0 ,1.94D0 ,2.26D0 ,
+ + 2.48D0 ,2.72D0 ,3.95D0 /
+ DATA (A(I, 7, 2),I=1,10) /
+ + .314D0 ,.450D0 ,.588D0 ,.692D0 ,.834D0 ,.936D0 ,1.09D0 ,
+ + 1.18D0 ,1.28D0 ,1.80D0 /
+ DATA (A(I, 7, 3),I=1,10) /
+ + .814D-01,.147D0 ,.189D0 ,.226D0 ,.272D0 ,.302D0 ,.351D0 ,
+ + .378D0 ,.406D0 ,.658D0 /
+ DATA (A(I, 7, 4),I=1,10) /
+ + .252D0 ,.864D0 ,1.01D0 ,.851D0 ,.837D0 ,.774D0 ,.763D0 ,
+ + .757D0 ,.748D0 ,1.55D0 /
+ DATA (A(I, 7, 5),I=1,10) /
+ + .000D+00,.225D0 ,.180D0 ,.276D0 ,.193D0 ,.240D0 ,.190D0 ,
+ + .228D0 ,.259D0 ,.681D0 /
+ DATA (A(I, 7, 6),I=1,10) /
+ + .000D+00,.485D-01,.272D0 ,.273D0 ,.253D0 ,.216D0 ,.206D0 ,
+ + .197D0 ,.191D0 ,.409D0 /
+ DATA (A(I, 7, 7),I=1,10) /
+ + .000D+00,.137D-02,.752D-01,.137D0 ,.152D0 ,.134D0 ,.125D0 ,
+ + .119D0 ,.116D0 ,.256D0 /
+ DATA (A(I, 7, 8),I=1,10) /
+ + .000D+00,.000D+00,.220D-01,.155D0 ,.175D0 ,.155D0 ,.116D0 ,
+ + .977D-01,.858D-01,.167D0 /
+ DATA (A(I, 7, 9),I=1,10) /
+ + .000D+00,.000D+00,.326D-03,.695D-01,.881D-01,.106D0 ,.897D-01,
+ + .782D-01,.706D-01,.122D0 /
+ DATA (A(I, 7,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.261D-01,.124D0 ,.131D0 ,.156D0 ,
+ + .141D0 ,.121D0 ,.176D0 /
+ DATA (A(I, 7,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.785D-03,.864D-01,.130D0 ,.170D0 ,
+ + .182D0 ,.172D0 ,.208 /
+ DATA (A(I, 7,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.896D-05,.225D-01,.105D0 ,.126D0 ,
+ + .126D0 ,.135D0 ,.116D0 /
+ DATA (A(I, 7,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.542D-03,.427D-01,.553D-01,
+ + .744D-01,.980D-01,.103D0 /
+ DATA (A(I, 7,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.515D-05,.377D-01,.831D-01,
+ + .985D-01,.104D0 ,.108D0 /
+ DATA (A(I, 7,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.285D-02,.495D-01,
+ + .871D-01,.106D0 ,.119D0 /
+ DATA (A(I, 7,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.110D-05,.284D-01,
+ + .588D-01,.657D-01,.594D-01 /
+ DATA (A(I, 7,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.722D-07,.176D-02,
+ + .170D-01,.305D-01,.454D-01 /
+ DATA (A(I, 7,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.148D-05,
+ + .213D-01,.492D-01,.707D-01 /
+ DATA (A(I, 7,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.323D-07,
+ + .722D-02,.359D-01,.556D-01 /
+ DATA (A(I, 7,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .461D-05,.155D-01,.679D-01 /
+ DATA (A(I, 8, 1),I=1,10) /
+ + .630D0 ,.974D0 ,1.29D0 ,1.58D0 ,1.89D0 ,2.16D0 ,2.49D0 ,
+ + 2.75D0 ,3.02D0 ,3.95D0 /
+ DATA (A(I, 8, 2),I=1,10) /
+ + .328D0 ,.459D0 ,.613D0 ,.735D0 ,.879D0 ,.994D0 ,1.15D0 ,
+ + 1.27D0 ,1.38D0 ,1.80D0 /
+ DATA (A(I, 8, 3),I=1,10) /
+ + .748D-01,.121D0 ,.164D0 ,.197D0 ,.235D0 ,.265D0 ,.310D0 ,
+ + .339D0 ,.370D0 ,.658D0 /
+ DATA (A(I, 8, 4),I=1,10) /
+ + .194D0 ,.211D0 ,.337D0 ,.344D0 ,.339D0 ,.351D0 ,.390 ,
+ + .419D0 ,.442D0 ,1.55D0 /
+ DATA (A(I, 8, 5),I=1,10) /
+ + .000D+00,.869D-01,.725D-01,.113D0 ,.810D-01,.106D0 ,.951D-01,
+ + .120D0 ,.143D0 ,.681D0 /
+ DATA (A(I, 8, 6),I=1,10) /
+ + .000D+00,.288D-01,.102D0 ,.922D-01,.857D-01,.845D-01,.932D-01,
+ + .983D-01,.102D0 ,.409D0 /
+ DATA (A(I, 8, 7),I=1,10) /
+ + .000D+00,.668D-03,.533D-01,.575D-01,.493D-01,.482D-01,.539D-01,
+ + .558D-01,.582D-01,.256D0 /
+ DATA (A(I, 8, 8),I=1,10) /
+ + .000D+00,.000D+00,.205D-01,.808D-01,.510D-01,.409D-01,.406D-01,
+ + .394D-01,.389D-01,.167D0 /
+ DATA (A(I, 8, 9),I=1,10) /
+ + .000D+00,.000D+00,.999D-04,.647D-01,.385D-01,.325D-01,.325D-01,
+ + .316D-01,.314D-01,.122D0 /
+ DATA (A(I, 8,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.169D-01,.834D-01,.611D-01,.565D-01,
+ + .533D-01,.519D-01,.176D0 /
+ DATA (A(I, 8,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.107D-03,.769D-01,.922D-01,.805D-01,
+ + .745D-01,.711D-01,.208D0 /
+ DATA (A(I, 8,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.180D-05,.143D-01,.983D-01,.775D-01,
+ + .627D-01,.541D-01,.116D0 /
+ DATA (A(I, 8,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.157D-04,.346D-01,.507D-01,
+ + .479D-01,.455D-01,.103D0 /
+ DATA (A(I, 8,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.752D-06,.248D-01,.721D-01,
+ + .728D-01,.611D-01,.108D0 /
+ DATA (A(I, 8,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.686D-04,.356D-01,
+ + .731D-01,.791D-01,.119D0 /
+ DATA (A(I, 8,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.838D-07,.151D-01,
+ + .470D-01,.567D-01,.594D-01 /
+ DATA (A(I, 8,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.759D-08,.400D-04,
+ + .193D-01,.313D-01,.454D-01 /
+ DATA (A(I, 8,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.385D-07,
+ + .921D-02,.353D-01,.707D-01 /
+ DATA (A(I, 8,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.219D-08,
+ + .348D-03,.226D-01,.556D-01 /
+ DATA (A(I, 8,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .212D-07,.149D-01,.679D-01 /
+ DATA (A(I, 9, 1),I=1,10) /
+ + .736D0 ,1.13D0 ,1.49D0 ,1.82D0 ,2.20D0 ,2.49D0 ,2.86D0 ,
+ + 3.17D0 ,3.49D0 ,3.95D0 /
+ DATA (A(I, 9, 2),I=1,10) /
+ + .339D0 ,.492D0 ,.658D0 ,.789D0 ,.958D0 ,1.08D0 ,1.25D0 ,
+ + 1.37D0 ,1.50D0 ,1.80D0 /
+ DATA (A(I, 9, 3),I=1,10) /
+ + .680D-01,.110D0 ,.150D0 ,.180D0 ,.222D0 ,.247D0 ,.289 ,
+ + .318D0 ,.349D0 ,.658D0 /
+ DATA (A(I, 9, 4),I=1,10) /
+ + .110D0 ,.104D0 ,.157D0 ,.156D0 ,.210D0 ,.205D0 ,.246D0 ,
+ + .274D0 ,.300D0 ,1.55D0 /
+ DATA (A(I, 9, 5),I=1,10) /
+ + .000D+00,.379D-01,.347D-01,.477D-01,.486D-01,.576D-01,.569D-01,
+ + .732D-01,.893D-01,.681D0 /
+ DATA (A(I, 9, 6),I=1,10) /
+ + .000D+00,.223D-01,.354D-01,.312D-01,.436D-01,.400D-01,.489D-01,
+ + .548D-01,.600D-01,.409D0 /
+ DATA (A(I, 9, 7),I=1,10) /
+ + .000D+00,.338D-03,.149D-01,.142D-01,.215D-01,.188D-01,.248D-01,
+ + .278D-01,.307D-01,.256D0 /
+ DATA (A(I, 9, 8),I=1,10) /
+ + .000D+00,.000D+00,.553D-02,.862D-02,.150D-01,.106D-01,.145D-01,
+ + .165D-01,.181D-01,.167D0 /
+ DATA (A(I, 9, 9),I=1,10) /
+ + .000D+00,.000D+00,.375D-04,.641D-02,.111D-01,.792D-02,.112D-01,
+ + .127D-01,.140D-01,.122D0 /
+ DATA (A(I, 9,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.112D-01,.200D-01,.127D-01,.176D-01,
+ + .200D-01,.220D-01,.176D0 /
+ DATA (A(I, 9,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.244D-04,.261D-01,.162D-01,.232D-01,
+ + .263D-01,.287D-01,.208D0 /
+ DATA (A(I, 9,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.455D-06,.635D-02,.121D-01,.186D-01,
+ + .201D-01,.207D-01,.116D0 /
+ DATA (A(I, 9,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.146D-05,.922D-02,.116D-01,
+ + .145D-01,.165D-01,.103D0 /
+ DATA (A(I, 9,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.135D-06,.128D-01,.202D-01,
+ + .215D-01,.220D-01,.108D0 /
+ DATA (A(I, 9,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.237D-05,.229D-01,
+ + .259D-01,.271D-01,.119D0 /
+ DATA (A(I, 9,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.100D-07,.534D-02,
+ + .210D-01,.193D-01,.594D-01 /
+ DATA (A(I, 9,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.915D-09,.847D-06,
+ + .119D-01,.125D-01,.454D-01 /
+ DATA (A(I, 9,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.298D-08,
+ + .101D-01,.242D-01,.707D-01 /
+ DATA (A(I, 9,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.196D-09,
+ + .243D-05,.234D-01,.556D-01 /
+ DATA (A(I, 9,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .575D-09,.364D-02,.679D-01 /
+ DATA (A(I,10, 1),I=1,10) /
+ + .959D0 ,1.46D0 ,1.92D0 ,2.34D0 ,2.80D0 ,3.24D0 ,3.64D0 ,
+ + 4.05D0 ,4.48D0 ,3.95D0 /
+ DATA (A(I,10, 2),I=1,10) /
+ + .343D0 ,.516D0 ,.692D0 ,.836D0 ,1.01D0 ,1.16D0 ,1.31D0 ,
+ + 1.46D0 ,1.61D0 ,1.80D0 /
+ DATA (A(I,10, 3),I=1,10) /
+ + .512D-01,.837D-01,.115D0 ,.138D0 ,.169D0 ,.195D0 ,.220D0 ,
+ + .245D0 ,.270D0 ,.658D0 /
+ DATA (A(I,10, 4),I=1,10) /
+ + .274D-01,.361D-01,.510D-01,.562D-01,.703D-01,.828D-01,.877D-01,
+ + .996D-01,.111D0 ,1.55D0 /
+ DATA (A(I,10, 5),I=1,10) /
+ + .000D+00,.850D-02,.875D-02,.118D-01,.124D-01,.170D-01,.154D-01,
+ + .194D-01,.237D-01,.681D0 /
+ DATA (A(I,10, 6),I=1,10) /
+ + .000D+00,.345D-02,.519D-02,.533D-02,.691D-02,.842D-02,.844D-02,
+ + .987D-02,.113D-01,.409D0 /
+ DATA (A(I,10, 7),I=1,10) /
+ + .000D+00,.722D-04,.130D-02,.135D-02,.189D-02,.240D-02,.235D-02,
+ + .281D-02,.331D-02,.256D0 /
+ DATA (A(I,10, 8),I=1,10) /
+ + .000D+00,.000D+00,.283D-03,.272D-03,.394D-03,.557D-03,.480D-03,
+ + .616D-03,.775D-03,.167D0 /
+ DATA (A(I,10, 9),I=1,10) /
+ + .000D+00,.000D+00,.457D-05,.122D-03,.192D-03,.275D-03,.225D-03,
+ + .292D-03,.373D-03,.122D0 /
+ DATA (A(I,10,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.119D-03,.185D-03,.278D-03,.201D-03,
+ + .274D-03,.364D-03,.176D0 /
+ DATA (A(I,10,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.140D-05,.129D-03,.200D-03,.137D-03,
+ + .188D-03,.252D-03,.208D0 /
+ DATA (A(I,10,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.207D-07,.307D-04,.518D-04,.278D-04,
+ + .421D-04,.608D-04,.116D0 /
+ DATA (A(I,10,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.306D-07,.252D-04,.111D-04,
+ + .188D-04,.295D-04,.103D0 /
+ DATA (A(I,10,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.321D-08,.220D-04,.104D-04,
+ + .162D-04,.243D-04,.108D0 /
+ DATA (A(I,10,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.770D-08,.632D-05,
+ + .105D-04,.162D-04,.119D0 /
+ DATA (A(I,10,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.117D-09,.199D-05,
+ + .321D-05,.492D-05,.594D-01 /
+ DATA (A(I,10,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.888E-11,.323D-09,
+ + .106D-05,.192D-05,.454D-01 /
+ DATA (A(I,10,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.174E-10,
+ + .131D-05,.218D-05,.707D-01 /
+ DATA (A(I,10,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.994E-12,
+ + .233D-09,.104D-05,.556D-01 /
+ DATA (A(I,10,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + .144E-11,.724D-06,.679D-01 /
+ DATA (AE(I, 1, 1),I=1,10) /
+ + 7.27D0 ,6.29D0 ,7.76D0 ,6.70D0 ,8.17D0 ,7.34D0 ,8.70D0 ,
+ + 8.02D0 ,7.37D0 ,6.18D0 /
+ DATA (AE(I, 1, 2),I=1,10) /
+ + 7.41D0 ,7.52D0 ,8.14D0 ,8.20D0 ,8.96D0 ,9.05D0 ,9.96D0 ,
+ + 10.0D0 ,10.1D0 ,9.86D0 /
+ DATA (AE(I, 1, 3),I=1,10) /
+ + 7.72D0 ,7.69D0 ,9.17D0 ,8.99D0 ,10.6D0 ,10.5D0 ,12.1D0 ,
+ + 12.1D0 ,12.0D0 ,11.5D0 /
+ DATA (AE(I, 1, 4),I=1,10) /
+ + 7.90D0 ,8.48D0 ,9.50D0 ,9.94D0 ,10.8D0 ,11.4D0 ,12.2D0 ,
+ + 12.8D0 ,13.3D0 ,13.8D0 /
+ DATA (AE(I, 1, 5),I=1,10) /
+ + .000D+00,8.52D0 ,9.59D0 ,10.1D0 ,11.1D0 ,11.8D0 ,12.7D0 ,
+ + 13.3D0 ,13.8D0 ,14.4D0 /
+ DATA (AE(I, 1, 6),I=1,10) /
+ + .000D+00,9.00D0 ,10.7D0 ,11.7D0 ,13.2D0 ,14.2D0 ,15.6D0 ,
+ + 16.5D0 ,17.3D0 ,18.0D0 /
+ DATA (AE(I, 1, 7),I=1,10) /
+ + .000D+00,9.01D0 ,11.1D0 ,11.9D0 ,14.3D0 ,15.0D0 ,17.4D0 ,
+ + 18.0D0 ,18.6D0 ,18.8D0 /
+ DATA (AE(I, 1, 8),I=1,10) /
+ + .000D+00,.000D+00,11.2D0 ,12.4D0 ,14.5D0 ,15.7D0 ,17.6D0 ,
+ + 18.8D0 ,19.9D0 ,20.9D0 /
+ DATA (AE(I, 1, 9),I=1,10) /
+ + .000D+00,.000D+00,11.4D0 ,12.7D0 ,15.5D0 ,16.6D0 ,19.3D0 ,
+ + 20.2D0 ,21.1D0 ,21.7D0 /
+ DATA (AE(I, 1,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,13.2D0 ,15.8D0 ,17.3D0 ,19.9D0 ,
+ + 21.2D0 ,22.4D0 ,23.2D0 /
+ DATA (AE(I, 1,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,13.2D0 ,16.3D0 ,17.8D0 ,20.8D0 ,
+ + 22.1D0 ,23.3D0 ,24.2D0 /
+ DATA (AE(I, 1,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,13.4D0 ,16.2D0 ,18.2D0 ,21.0D0 ,
+ + 22.8D0 ,24.4D0 ,25.9D0 /
+ DATA (AE(I, 1,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,16.5D0 ,18.4D0 ,21.6D0 ,
+ + 23.2D0 ,24.8D0 ,26.2D0 /
+ DATA (AE(I, 1,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,16.7D0 ,19.0D0 ,22.3D0 ,
+ + 24.3D0 ,26.1D0 ,27.4D0 /
+ DATA (AE(I, 1,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,19.1D0 ,22.8D0 ,
+ + 24.7D0 ,26.6D0 ,28.2D0 /
+ DATA (AE(I, 1,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,19.2D0 ,23.0D0 ,
+ + 25.3D0 ,27.5D0 ,29.5D0 /
+ DATA (AE(I, 1,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,19.6D0 ,23.3D0 ,
+ + 25.6D0 ,27.8D0 ,29.6D0 /
+ DATA (AE(I, 1,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,23.6D0 ,
+ + 26.2D0 ,28.5D0 ,30.4D0 /
+ DATA (AE(I, 1,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,23.7D0 ,
+ + 26.3D0 ,28.8D0 ,31.0D0 /
+ DATA (AE(I, 1,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 26.5D0 ,29.2D0 ,31.5D0 /
+ DATA (AE(I, 2, 1),I=1,10) /
+ + 8.74D0 ,8.16D0 ,9.25D0 ,8.45D0 ,9.46D0 ,8.90D0 ,9.83D0 ,
+ + 9.38D0 ,8.96D0 ,8.15D0 /
+ DATA (AE(I, 2, 2),I=1,10) /
+ + 8.96D0 ,9.30D0 ,9.95D0 ,10.0D0 ,10.8D0 ,10.9D0 ,11.7D0 ,
+ + 11.8D0 ,11.9D0 ,11.8D0 /
+ DATA (AE(I, 2, 3),I=1,10) /
+ + 9.44D0 ,9.66D0 ,11.0D0 ,11.0D0 ,12.3D0 ,12.5D0 ,13.7D0 ,
+ + 13.9D0 ,14.0D0 ,13.8D0 /
+ DATA (AE(I, 2, 4),I=1,10) /
+ + 8.86D0 ,9.81D0 ,10.8D0 ,11.2D0 ,12.0D0 ,12.6D0 ,13.4D0 ,
+ + 14.0D0 ,14.5D0 ,15.1D0 /
+ DATA (AE(I, 2, 5),I=1,10) /
+ + .000D+00,10.2D0 ,11.4D0 ,12.0D0 ,12.9D0 ,13.6D0 ,14.5D0 ,
+ + 15.1D0 ,15.7D0 ,16.3D0 /
+ DATA (AE(I, 2, 6),I=1,10) /
+ + .000D+00,10.7D0 ,12.5D0 ,13.5D0 ,15.1D0 ,16.0D0 ,17.5D0 ,
+ + 18.3D0 ,19.2D0 ,19.9D0 /
+ DATA (AE(I, 2, 7),I=1,10) /
+ + .000D+00,11.5D0 ,12.9D0 ,13.9D0 ,16.1D0 ,17.0D0 ,19.1D0 ,
+ + 19.8D0 ,20.6D0 ,21.0D0 /
+ DATA (AE(I, 2, 8),I=1,10) /
+ + .000D+00,.000D+00,12.4D0 ,13.8D0 ,15.9D0 ,17.2D0 ,19.1D0 ,
+ + 20.3D0 ,21.4D0 ,22.3D0 /
+ DATA (AE(I, 2, 9),I=1,10) /
+ + .000D+00,.000D+00,13.4D0 ,14.5D0 ,17.1D0 ,18.3D0 ,20.9D0 ,
+ + 21.9D0 ,23.0D0 ,23.7D0 /
+ DATA (AE(I, 2,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,14.9D0 ,17.5D0 ,19.1D0 ,21.6D0 ,
+ + 22.9D0 ,24.1D0 ,25.0D0 /
+ DATA (AE(I, 2,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,15.0D0 ,18.0D0 ,19.6D0 ,22.4D0 ,
+ + 23.8D0 ,25.2D0 ,26.2D0 /
+ DATA (AE(I, 2,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,16.2D0 ,17.3D0 ,19.4D0 ,22.2D0 ,
+ + 24.0D0 ,25.7D0 ,27.2D0 /
+ DATA (AE(I, 2,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,17.8D0 ,19.8D0 ,22.9D0 ,
+ + 24.6D0 ,26.2D0 ,27.7D0 /
+ DATA (AE(I, 2,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,19.1D0 ,20.4D0 ,23.7D0 ,
+ + 25.7D0 ,27.6D0 ,29.1D0 /
+ DATA (AE(I, 2,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,20.5D0 ,24.1D0 ,
+ + 26.1D0 ,28.1D0 ,29.9D0 /
+ DATA (AE(I, 2,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,20.9D0 ,23.9D0 ,
+ + 26.4D0 ,28.7D0 ,30.7D0 /
+ DATA (AE(I, 2,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,22.4D0 ,24.2D0 ,
+ + 26.7D0 ,29.0D0 ,30.9D0 /
+ DATA (AE(I, 2,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,24.8D0 ,
+ + 27.3D0 ,29.7D0 ,31.8D0 /
+ DATA (AE(I, 2,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,26.1D0 ,
+ + 27.3D0 ,29.9D0 ,32.3D0 /
+ DATA (AE(I, 2,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 27.4D0 ,30.1D0 ,32.6D0 /
+ DATA (AE(I, 3, 1),I=1,10) /
+ + 11.0D0 ,11.0D0 ,11.7D0 ,11.3D0 ,11.9D0 ,11.4D0 ,12.1D0 ,
+ + 11.7D0 ,11.5D0 ,11.0D0 /
+ DATA (AE(I, 3, 2),I=1,10) /
+ + 11.2D0 ,12.0D0 ,12.7D0 ,12.9D0 ,13.6D0 ,13.7D0 ,14.4D0 ,
+ + 14.6D0 ,14.7D0 ,14.6D0 /
+ DATA (AE(I, 3, 3),I=1,10) /
+ + 12.1D0 ,12.6D0 ,13.7D0 ,13.9D0 ,15.0D0 ,15.2D0 ,16.3D0 ,
+ + 16.5D0 ,16.7D0 ,16.7D0 /
+ DATA (AE(I, 3, 4),I=1,10) /
+ + 12.6D0 ,11.3D0 ,12.4D0 ,13.0D0 ,13.8D0 ,14.2D0 ,15.0D0 ,
+ + 15.6D0 ,16.1D0 ,16.6D0 /
+ DATA (AE(I, 3, 5),I=1,10) /
+ + .000D+00,12.6D0 ,13.7D0 ,14.4D0 ,15.3D0 ,16.0D0 ,16.8D0 ,
+ + 17.5D0 ,18.1D0 ,18.6D0 /
+ DATA (AE(I, 3, 6),I=1,10) /
+ + .000D+00,14.0D0 ,14.6D0 ,15.8D0 ,17.4D0 ,18.4D0 ,19.8D0 ,
+ + 20.6D0 ,21.5D0 ,22.2D0 /
+ DATA (AE(I, 3, 7),I=1,10) /
+ + .000D+00,16.0D0 ,15.2D0 ,16.3D0 ,18.3D0 ,19.3D0 ,21.1D0 ,
+ + 22.0D0 ,22.8D0 ,23.5D0 /
+ DATA (AE(I, 3, 8),I=1,10) /
+ + .000D+00,.000D+00,15.6D0 ,15.1D0 ,17.2D0 ,18.6D0 ,20.6D0 ,
+ + 21.8D0 ,22.9D0 ,23.8D0 /
+ DATA (AE(I, 3, 9),I=1,10) /
+ + .000D+00,.000D+00,17.8D0 ,16.3D0 ,18.8D0 ,20.1D0 ,22.5D0 ,
+ + 23.6D0 ,24.7D0 ,25.6D0 /
+ DATA (AE(I, 3,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,17.5D0 ,19.0D0 ,20.7D0 ,23.1D0 ,
+ + 24.5D0 ,25.8D0 ,26.8D0 /
+ DATA (AE(I, 3,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,19.2D0 ,19.4D0 ,21.1D0 ,23.8D0 ,
+ + 25.4D0 ,26.8D0 ,28.0D0 /
+ DATA (AE(I, 3,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,20.7D0 ,19.6D0 ,19.7D0 ,22.4D0 ,
+ + 24.4D0 ,26.2D0 ,27.9D0 /
+ DATA (AE(I, 3,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,21.6D0 ,20.4D0 ,23.2D0 ,
+ + 25.1D0 ,26.9D0 ,28.5D0 /
+ DATA (AE(I, 3,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,23.5D0 ,22.0D0 ,23.8D0 ,
+ + 26.1D0 ,28.1D0 ,29.9D0 /
+ DATA (AE(I, 3,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,23.7D0 ,24.2D0 ,
+ + 26.3D0 ,28.5D0 ,30.4D0 /
+ DATA (AE(I, 3,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,25.4D0 ,24.8D0 ,
+ + 25.6D0 ,28.1D0 ,30.5D0 /
+ DATA (AE(I, 3,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,26.9D0 ,26.8D0 ,
+ + 26.1D0 ,28.4D0 ,30.8D0 /
+ DATA (AE(I, 3,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,28.8D0 ,
+ + 27.6D0 ,29.0D0 ,31.5D0 /
+ DATA (AE(I, 3,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,30.5D0 ,
+ + 29.2D0 ,28.9D0 ,31.5D0 /
+ DATA (AE(I, 3,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 31.0D0 ,30.0D0 ,31.7D0 /
+ DATA (AE(I, 4, 1),I=1,10) /
+ + 13.0D0 ,13.2D0 ,14.8D0 ,14.2D0 ,14.2D0 ,14.1D0 ,14.5D0 ,
+ + 14.4D0 ,14.3D0 ,14.0D0 /
+ DATA (AE(I, 4, 2),I=1,10) /
+ + 13.5D0 ,14.5D0 ,16.1D0 ,15.9D0 ,16.0D0 ,16.3D0 ,16.8D0 ,
+ + 17.0D0 ,17.1D0 ,17.2D0 /
+ DATA (AE(I, 4, 3),I=1,10) /
+ + 14.9D0 ,15.3D0 ,17.2D0 ,17.1D0 ,17.5D0 ,17.8D0 ,18.6D0 ,
+ + 18.9D0 ,19.1D0 ,19.3D0 /
+ DATA (AE(I, 4, 4),I=1,10) /
+ + 15.1D0 ,13.5D0 ,16.4D0 ,16.7D0 ,16.4D0 ,17.3D0 ,17.8D0 ,
+ + 18.5D0 ,19.0D0 ,19.6D0 /
+ DATA (AE(I, 4, 5),I=1,10) /
+ + .000D+00,15.6D0 ,17.5D0 ,17.7D0 ,17.8D0 ,18.6D0 ,19.2D0 ,
+ + 19.9D0 ,20.3D0 ,21.1D0 /
+ DATA (AE(I, 4, 6),I=1,10) /
+ + .000D+00,18.0D0 ,18.4D0 ,19.2D0 ,19.8D0 ,20.9D0 ,22.0D0 ,
+ + 23.1D0 ,23.6D0 ,24.7D0 /
+ DATA (AE(I, 4, 7),I=1,10) /
+ + .000D+00,27.4D0 ,19.1D0 ,19.8D0 ,20.7D0 ,21.8D0 ,23.2D0 ,
+ + 24.4D0 ,24.9D0 ,25.9D0 /
+ DATA (AE(I, 4, 8),I=1,10) /
+ + .000D+00,.000D+00,18.9D0 ,18.9D0 ,19.3D0 ,21.1D0 ,22.5D0 ,
+ + 24.0D0 ,24.7D0 ,26.0D0 /
+ DATA (AE(I, 4, 9),I=1,10) /
+ + .000D+00,.000D+00,21.1D0 ,19.7D0 ,20.7D0 ,22.3D0 ,24.0D0 ,
+ + 25.6D0 ,26.3D0 ,27.7D0 /
+ DATA (AE(I, 4,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,21.0D0 ,21.1D0 ,22.9D0 ,24.6D0 ,
+ + 26.5D0 ,27.3D0 ,29.0D0 /
+ DATA (AE(I, 4,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,21.3D0 ,22.4D0 ,23.1D0 ,25.0D0 ,
+ + 27.1D0 ,27.9D0 ,29.8D0 /
+ DATA (AE(I, 4,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,36.6D0 ,21.5D0 ,22.2D0 ,23.1D0 ,
+ + 25.6D0 ,26.8D0 ,29.1D0 /
+ DATA (AE(I, 4,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,22.9D0 ,23.1D0 ,23.7D0 ,
+ + 26.2D0 ,27.3D0 ,29.6D0 /
+ DATA (AE(I, 4,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,30.5D0 ,23.6D0 ,25.0D0 ,
+ + 26.9D0 ,28.2D0 ,30.7D0 /
+ DATA (AE(I, 4,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,25.4D0 ,26.2D0 ,
+ + 27.2D0 ,28.3D0 ,31.0D0 /
+ DATA (AE(I, 4,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,24.5D0 ,25.9D0 ,
+ + 27.4D0 ,27.6D0 ,30.7D0 /
+ DATA (AE(I, 4,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,43.3D0 ,28.4D0 ,
+ + 27.5D0 ,27.9D0 ,30.9D0 /
+ DATA (AE(I, 4,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,27.2D0 ,
+ + 29.1D0 ,29.0D0 ,31.4D0 /
+ DATA (AE(I, 4,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,51.3D0 ,
+ + 30.6D0 ,29.5D0 ,31.4D0 /
+ DATA (AE(I, 4,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 28.8D0 ,30.6D0 ,32.4D0 /
+ DATA (AE(I, 5, 1),I=1,10) /
+ + 15.0D0 ,14.9D0 ,15.5D0 ,15.4D0 ,15.9D0 ,15.8D0 ,16.2D0 ,
+ + 16.2D0 ,16.1D0 ,15.9D0 /
+ DATA (AE(I, 5, 2),I=1,10) /
+ + 15.4D0 ,16.1D0 ,17.0D0 ,17.4D0 ,18.0D0 ,18.2D0 ,18.7D0 ,
+ + 18.9D0 ,19.0D0 ,19.1D0 /
+ DATA (AE(I, 5, 3),I=1,10) /
+ + 17.1D0 ,17.2D0 ,18.3D0 ,18.7D0 ,19.3D0 ,19.6D0 ,20.3D0 ,
+ + 20.6D0 ,20.8D0 ,20.9D0 /
+ DATA (AE(I, 5, 4),I=1,10) /
+ + 14.7D0 ,14.8D0 ,15.0D0 ,16.0D0 ,17.0D0 ,17.7D0 ,18.1D0 ,
+ + 19.0D0 ,19.4D0 ,20.0D0 /
+ DATA (AE(I, 5, 5),I=1,10) /
+ + .000D+00,16.7D0 ,17.6D0 ,18.1D0 ,18.6D0 ,19.2D0 ,19.7D0 ,
+ + 20.4D0 ,20.8D0 ,21.2D0 /
+ DATA (AE(I, 5, 6),I=1,10) /
+ + .000D+00,17.8D0 ,18.2D0 ,19.2D0 ,20.0D0 ,21.0D0 ,21.9D0 ,
+ + 23.0D0 ,23.6D0 ,24.3D0 /
+ DATA (AE(I, 5, 7),I=1,10) /
+ + .000D+00,35.2D0 ,18.9D0 ,20.3D0 ,20.6D0 ,21.5D0 ,22.6D0 ,
+ + 23.7D0 ,24.2D0 ,24.7D0 /
+ DATA (AE(I, 5, 8),I=1,10) /
+ + .000D+00,.000D+00,16.4D0 ,18.9D0 ,18.8D0 ,19.6D0 ,20.7D0 ,
+ + 22.3D0 ,23.1D0 ,23.9D0 /
+ DATA (AE(I, 5, 9),I=1,10) /
+ + .000D+00,.000D+00,33.9D0 ,19.8D0 ,20.3D0 ,20.7D0 ,21.9D0 ,
+ + 23.4D0 ,24.1D0 ,24.8D0 /
+ DATA (AE(I, 5,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,18.0D0 ,20.0D0 ,21.4D0 ,22.0D0 ,
+ + 23.8D0 ,24.6D0 ,25.4D0 /
+ DATA (AE(I, 5,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,26.4D0 ,20.4D0 ,21.2D0 ,22.3D0 ,
+ + 23.8D0 ,24.7D0 ,25.5D0 /
+ DATA (AE(I, 5,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,41.7D0 ,18.2D0 ,19.8D0 ,21.1D0 ,
+ + 22.6D0 ,23.4D0 ,24.6D0 /
+ DATA (AE(I, 5,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,22.5D0 ,20.0D0 ,21.7D0 ,
+ + 22.8D0 ,23.7D0 ,24.7D0 /
+ DATA (AE(I, 5,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,54.1D0 ,19.9D0 ,21.9D0 ,
+ + 23.2D0 ,24.3D0 ,25.3D0 /
+ DATA (AE(I, 5,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,21.2D0 ,22.2D0 ,
+ + 23.6D0 ,24.9D0 ,25.5D0 /
+ DATA (AE(I, 5,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,44.9D0 ,21.9D0 ,
+ + 23.8D0 ,25.2D0 ,25.6D0 /
+ DATA (AE(I, 5,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,47.8D0 ,22.7D0 ,
+ + 23.8D0 ,24.9D0 ,26.3D0 /
+ DATA (AE(I, 5,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,35.5D0 ,
+ + 23.9D0 ,25.9D0 ,26.6D0 /
+ DATA (AE(I, 5,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,64.3D0 ,
+ + 24.1D0 ,25.7D0 ,27.1D0 /
+ DATA (AE(I, 5,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 34.0D0 ,25.7D0 ,27.7D0 /
+ DATA (AE(I, 6, 1),I=1,10) /
+ + 16.6D0 ,16.5D0 ,16.8D0 ,16.7D0 ,17.0D0 ,16.5D0 ,16.7D0 ,
+ + 18.3D0 ,18.9D0 ,19.0D0 /
+ DATA (AE(I, 6, 2),I=1,10) /
+ + 16.2D0 ,16.6D0 ,17.2D0 ,17.4D0 ,17.9D0 ,17.4D0 ,17.7D0 ,
+ + 20.7D0 ,22.0D0 ,22.6D0 /
+ DATA (AE(I, 6, 3),I=1,10) /
+ + 18.9D0 ,18.7D0 ,18.8D0 ,18.6D0 ,18.9D0 ,18.6D0 ,18.9D0 ,
+ + 21.0D0 ,22.3D0 ,22.9D0 /
+ DATA (AE(I, 6, 4),I=1,10) /
+ + 18.3D0 ,12.7D0 ,14.2D0 ,15.0D0 ,15.7D0 ,16.1D0 ,16.3D0 ,
+ + 16.5D0 ,17.9D0 ,19.0D0 /
+ DATA (AE(I, 6, 5),I=1,10) /
+ + .000D+00,15.7D0 ,15.1D0 ,15.3D0 ,16.5D0 ,16.4D0 ,16.4D0 ,
+ + 17.0D0 ,18.3D0 ,19.4D0 /
+ DATA (AE(I, 6, 6),I=1,10) /
+ + .000D+00,22.9D0 ,14.9D0 ,15.2D0 ,16.2D0 ,16.9D0 ,17.4D0 ,
+ + 18.2D0 ,19.5D0 ,21.1D0 /
+ DATA (AE(I, 6, 7),I=1,10) /
+ + .000D+00,40.7D0 ,18.4D0 ,15.9D0 ,17.1D0 ,17.7D0 ,18.9D0 ,
+ + 19.5D0 ,20.3D0 ,21.1D0 /
+ DATA (AE(I, 6, 8),I=1,10) /
+ + .000D+00,.000D+00,23.3D0 ,16.2D0 ,16.3D0 ,17.3D0 ,18.7D0 ,
+ + 19.5D0 ,20.3D0 ,21.1D0 /
+ DATA (AE(I, 6, 9),I=1,10) /
+ + .000D+00,.000D+00,49.2D0 ,19.0D0 ,19.1D0 ,19.4D0 ,20.2D0 ,
+ + 20.8D0 ,21.6D0 ,22.0D0 /
+ DATA (AE(I, 6,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,27.2D0 ,21.2D0 ,20.8D0 ,21.4D0 ,
+ + 22.3D0 ,22.8D0 ,23.3D0 /
+ DATA (AE(I, 6,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,45.6D0 ,25.0D0 ,22.8D0 ,23.9D0 ,
+ + 23.6D0 ,24.3D0 ,24.4D0 /
+ DATA (AE(I, 6,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,45.8D0 ,29.7D0 ,25.1D0 ,25.3D0 ,
+ + 25.3D0 ,26.0D0 ,26.3D0 /
+ DATA (AE(I, 6,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,42.7D0 ,29.0D0 ,28.0D0 ,
+ + 27.0D0 ,27.2D0 ,27.6D0 /
+ DATA (AE(I, 6,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,62.0D0 ,32.0D0 ,30.0D0 ,
+ + 29.8D0 ,29.5D0 ,29.6D0 /
+ DATA (AE(I, 6,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,44.5D0 ,34.4D0 ,
+ + 32.7D0 ,31.5D0 ,31.8D0 /
+ DATA (AE(I, 6,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,75.6D0 ,37.1D0 ,
+ + 34.6D0 ,34.4D0 ,34.4D0 /
+ DATA (AE(I, 6,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,51.2D0 ,45.2D0 ,
+ + 39.0D0 ,37.5D0 ,36.4D0 /
+ DATA (AE(I, 6,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,74.9D0 ,
+ + 42.3D0 ,39.9D0 ,38.3D0 /
+ DATA (AE(I, 6,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,69.5D0 ,
+ + 50.7D0 ,42.3D0 ,41.4D0 /
+ DATA (AE(I, 6,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 66.3D0 ,48.0D0 ,43.4D0 /
+ DATA (AE(I, 7, 1),I=1,10) /
+ + 27.0D0 ,25.8D0 ,26.3D0 ,26.2D0 ,26.7D0 ,26.7D0 ,27.1D0 ,
+ + 27.1D0 ,27.2D0 ,19.0D0 /
+ DATA (AE(I, 7, 2),I=1,10) /
+ + 29.1D0 ,28.9D0 ,29.7D0 ,30.3D0 ,31.0D0 ,31.4D0 ,32.0D0 ,
+ + 32.3D0 ,32.7D0 ,22.6D0 /
+ DATA (AE(I, 7, 3),I=1,10) /
+ + 31.6D0 ,29.7D0 ,30.9D0 ,31.4D0 ,32.5D0 ,33.1D0 ,34.0D0 ,
+ + 34.6D0 ,35.1D0 ,22.9D0 /
+ DATA (AE(I, 7, 4),I=1,10) /
+ + 27.4D0 ,19.9D0 ,20.8D0 ,22.8D0 ,24.6D0 ,26.4D0 ,28.2D0 ,
+ + 29.6D0 ,30.8D0 ,19.0D0 /
+ DATA (AE(I, 7, 5),I=1,10) /
+ + .000D+00,24.6D0 ,24.1D0 ,25.0D0 ,27.2D0 ,28.7D0 ,30.7D0 ,
+ + 31.8D0 ,32.9D0 ,19.4D0 /
+ DATA (AE(I, 7, 6),I=1,10) /
+ + .000D+00,35.6D0 ,25.2D0 ,25.6D0 ,27.9D0 ,30.4D0 ,32.7D0 ,
+ + 34.6D0 ,36.3D0 ,21.1D0 /
+ DATA (AE(I, 7, 7),I=1,10) /
+ + .000D+00,45.4D0 ,30.9D0 ,28.2D0 ,29.0D0 ,31.2D0 ,34.0D0 ,
+ + 35.8D0 ,37.4D0 ,21.1D0 /
+ DATA (AE(I, 7, 8),I=1,10) /
+ + .000D+00,.000D+00,38.2D0 ,29.6D0 ,29.4D0 ,30.3D0 ,33.2D0 ,
+ + 35.5D0 ,37.6D0 ,21.1D0 /
+ DATA (AE(I, 7, 9),I=1,10) /
+ + .000D+00,.000D+00,59.3D0 ,34.5D0 ,33.7D0 ,32.9D0 ,35.4D0 ,
+ + 37.6D0 ,39.6D0 ,22.0D0 /
+ DATA (AE(I, 7,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,44.5D0 ,37.8D0 ,37.5D0 ,37.2D0 ,
+ + 39.0D0 ,41.4D0 ,23.3D0 /
+ DATA (AE(I, 7,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,67.0D0 ,43.6D0 ,42.0D0 ,40.8D0 ,
+ + 41.4D0 ,43.0D0 ,24.4D0 /
+ DATA (AE(I, 7,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,49.9D0 ,50.9D0 ,44.6D0 ,43.9D0 ,
+ + 44.2D0 ,44.2D0 ,26.3D0 /
+ DATA (AE(I, 7,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,67.2D0 ,50.5D0 ,48.7D0 ,
+ + 48.1D0 ,47.2D0 ,27.6D0 /
+ DATA (AE(I, 7,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,68.1D0 ,55.2D0 ,52.3D0 ,
+ + 51.5D0 ,51.6D0 ,29.6D0 /
+ DATA (AE(I, 7,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,68.7D0 ,58.6D0 ,
+ + 56.5D0 ,55.7D0 ,31.8D0 /
+ DATA (AE(I, 7,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,89.3D0 ,62.9D0 ,
+ + 60.0D0 ,59.1D0 ,34.4D0 /
+ DATA (AE(I, 7,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,56.0D0 ,72.9D0 ,
+ + 66.3D0 ,64.2D0 ,36.4D0 /
+ DATA (AE(I, 7,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,105.D0 ,
+ + 71.3D0 ,68.3D0 ,38.3D0 /
+ DATA (AE(I, 7,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,73.4D0 ,
+ + 76.8D0 ,72.4D0 ,41.4D0 /
+ DATA (AE(I, 7,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 107.D0 ,79.9D0 ,43.4D0 /
+ DATA (AE(I, 8, 1),I=1,10) /
+ + 35.5D0 ,35.3D0 ,35.7D0 ,35.7D0 ,36.3D0 ,36.3D0 ,36.7D0 ,
+ + 36.7D0 ,36.7D0 ,19.0D0 /
+ DATA (AE(I, 8, 2),I=1,10) /
+ + 40.6D0 ,41.4D0 ,41.9D0 ,42.3D0 ,43.2D0 ,43.5D0 ,44.0D0 ,
+ + 44.3D0 ,44.5D0 ,22.6D0 /
+ DATA (AE(I, 8, 3),I=1,10) /
+ + 45.4D0 ,45.7D0 ,46.4D0 ,47.0D0 ,48.1D0 ,48.7D0 ,49.4D0 ,
+ + 49.8D0 ,50.2D0 ,22.9D0 /
+ DATA (AE(I, 8, 4),I=1,10) /
+ + 43.9D0 ,44.3D0 ,43.4D0 ,45.1D0 ,47.3D0 ,48.7D0 ,49.6D0 ,
+ + 50.5D0 ,51.3D0 ,19.0D0 /
+ DATA (AE(I, 8, 5),I=1,10) /
+ + .000D+00,49.3D0 ,49.6D0 ,50.5D0 ,53.2D0 ,54.2D0 ,55.4D0 ,
+ + 56.1D0 ,56.8D0 ,19.4D0 /
+ DATA (AE(I, 8, 6),I=1,10) /
+ + .000D+00,59.1D0 ,53.0D0 ,55.4D0 ,58.0D0 ,60.0D0 ,61.2D0 ,
+ + 62.5D0 ,63.6D0 ,21.1D0 /
+ DATA (AE(I, 8, 7),I=1,10) /
+ + .000D+00,54.5D0 ,57.1D0 ,59.2D0 ,62.3D0 ,64.4D0 ,66.0D0 ,
+ + 67.3D0 ,68.5D0 ,21.1D0 /
+ DATA (AE(I, 8, 8),I=1,10) /
+ + .000D+00,.000D+00,65.9D0 ,62.1D0 ,65.1D0 ,67.6D0 ,69.4D0 ,
+ + 71.1D0 ,72.6D0 ,21.1D0 /
+ DATA (AE(I, 8, 9),I=1,10) /
+ + .000D+00,.000D+00,72.2D0 ,67.1D0 ,70.5D0 ,73.1D0 ,75.1D0 ,
+ + 76.8D0 ,78.4D0 ,22.0D0 /
+ DATA (AE(I, 8,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,80.1D0 ,75.0D0 ,78.0D0 ,80.0D0 ,
+ + 82.1D0 ,83.9D0 ,23.3D0 /
+ DATA (AE(I, 8,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,94.5D0 ,82.2D0 ,82.8D0 ,85.1D0 ,
+ + 87.3D0 ,89.2D0 ,24.4D0 /
+ DATA (AE(I, 8,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,56.8D0 ,92.5D0 ,87.2D0 ,89.4D0 ,
+ + 91.9D0 ,94.1D0 ,26.3D0 /
+ DATA (AE(I, 8,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,116.D0 ,96.2D0 ,94.4D0 ,
+ + 97.0D0 ,99.2D0 ,27.6D0 /
+ DATA (AE(I, 8,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,78.1D0 ,104.D0 ,102.D0 ,
+ + 102.D0 ,105.D0 ,29.6D0 /
+ DATA (AE(I, 8,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,128.D0 ,111.D0 ,
+ + 109.D0 ,110.D0 ,31.8D0 /
+ DATA (AE(I, 8,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,104.D0 ,118.D0 ,
+ + 117.D0 ,115.D0 ,34.4D0 /
+ DATA (AE(I, 8,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,64.4D0 ,138.D0 ,
+ + 124.D0 ,122.D0 ,36.4D0 /
+ DATA (AE(I, 8,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,133.D0 ,
+ + 133.D0 ,132.D0 ,38.3D0 /
+ DATA (AE(I, 8,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,83.6D0 ,
+ + 146.D0 ,139.D0 ,41.4D0 /
+ DATA (AE(I, 8,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 166.D0 ,147.D0 ,43.4D0 /
+ DATA (AE(I, 9, 1),I=1,10) /
+ + 43.3D0 ,43.2D0 ,43.6D0 ,43.8D0 ,44.1D0 ,44.3D0 ,44.7D0 ,
+ + 44.8D0 ,44.8D0 ,19.0D0 /
+ DATA (AE(I, 9, 2),I=1,10) /
+ + 50.9D0 ,51.4D0 ,52.0D0 ,52.6D0 ,53.1D0 ,53.6D0 ,54.2D0 ,
+ + 54.5D0 ,54.7D0 ,22.6D0 /
+ DATA (AE(I, 9, 3),I=1,10) /
+ + 58.0D0 ,58.4D0 ,59.3D0 ,60.1D0 ,60.7D0 ,61.5D0 ,62.3D0 ,
+ + 62.7D0 ,63.1D0 ,22.9D0 /
+ DATA (AE(I, 9, 4),I=1,10) /
+ + 62.0D0 ,63.9D0 ,63.7D0 ,65.7D0 ,65.5D0 ,67.5D0 ,68.2D0 ,
+ + 68.9D0 ,69.7D0 ,19.0D0 /
+ DATA (AE(I, 9, 5),I=1,10) /
+ + .000D+00,72.2D0 ,72.5D0 ,74.2D0 ,74.2D0 ,76.1D0 ,77.0D0 ,
+ + 77.8D0 ,78.6D0 ,19.4D0 /
+ DATA (AE(I, 9, 6),I=1,10) /
+ + .000D+00,80.4D0 ,80.5D0 ,83.1D0 ,83.0D0 ,85.5D0 ,86.8D0 ,
+ + 88.1D0 ,89.2D0 ,21.1D0 /
+ DATA (AE(I, 9, 7),I=1,10) /
+ + .000D+00,63.4D0 ,88.5D0 ,91.3D0 ,91.1D0 ,94.0D0 ,95.8D0 ,
+ + 97.3D0 ,98.6D0 ,21.1D0 /
+ DATA (AE(I, 9, 8),I=1,10) /
+ + .000D+00,.000D+00,98.8D0 ,98.6D0 ,97.8D0 ,102.D0 ,104.D0 ,
+ + 106.D0 ,108.D0 ,21.1D0 /
+ DATA (AE(I, 9, 9),I=1,10) /
+ + .000D+00,.000D+00,84.1D0 ,107.D0 ,107.D0 ,111.D0 ,113.D0 ,
+ + 116.D0 ,117.D0 ,22.0D0 /
+ DATA (AE(I, 9,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,116.D0 ,115.D0 ,119.D0 ,122.D0 ,
+ + 125.D0 ,127.D0 ,23.3D0 /
+ DATA (AE(I, 9,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,111.D0 ,123.D0 ,127.D0 ,131.D0 ,
+ + 134.D0 ,137.D0 ,24.4D0 /
+ DATA (AE(I, 9,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,65.6D0 ,136.D0 ,135.D0 ,140.D0 ,
+ + 143.D0 ,146.D0 ,26.3D0 /
+ DATA (AE(I, 9,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,146.D0 ,144.D0 ,149.D0 ,
+ + 152.D0 ,155.D0 ,27.6D0 /
+ DATA (AE(I, 9,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,88.7D0 ,152.D0 ,158.D0 ,
+ + 162.D0 ,165.D0 ,29.6D0 /
+ DATA (AE(I, 9,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,181.D0 ,167.D0 ,
+ + 171.D0 ,174.D0 ,31.8D0 /
+ DATA (AE(I, 9,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,117.D0 ,174.D0 ,
+ + 180.D0 ,183.D0 ,34.4D0 /
+ DATA (AE(I, 9,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,72.0D0 ,201.D0 ,
+ + 189.D0 ,192.D0 ,36.4D0 /
+ DATA (AE(I, 9,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,151.D0 ,
+ + 198.D0 ,201.D0 ,38.3D0 /
+ DATA (AE(I, 9,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,95.2D0 ,
+ + 220.D0 ,210.D0 ,41.4D0 /
+ DATA (AE(I, 9,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 192.D0 ,217.D0 ,43.4D0 /
+ DATA (AE(I,10, 1),I=1,10) /
+ + 62.1D0 ,62.1D0 ,62.6D0 ,62.9D0 ,63.3D0 ,63.3D0 ,64.0D0 ,
+ + 64.0D0 ,64.0D0 ,19.0D0 /
+ DATA (AE(I,10, 2),I=1,10) /
+ + 75.1D0 ,75.4D0 ,76.3D0 ,76.8D0 ,77.6D0 ,77.9D0 ,78.8D0 ,
+ + 79.0D0 ,79.3D0 ,22.6D0 /
+ DATA (AE(I,10, 3),I=1,10) /
+ + 87.5D0 ,88.3D0 ,89.4D0 ,90.2D0 ,91.3D0 ,91.9D0 ,93.0D0 ,
+ + 93.5D0 ,93.9D0 ,22.9D0 /
+ DATA (AE(I,10, 4),I=1,10) /
+ + 104.D0 ,104.D0 ,105.D0 ,106.D0 ,107.D0 ,108.D0 ,109.D0 ,
+ + 110.D0 ,110.D0 ,19.0D0 /
+ DATA (AE(I,10, 5),I=1,10) /
+ + .000D+00,122.D0 ,122.D0 ,123.D0 ,124.D0 ,125.D0 ,126.D0 ,
+ + 127.D0 ,128.D0 ,19.4D0 /
+ DATA (AE(I,10, 6),I=1,10) /
+ + .000D+00,138.D0 ,139.D0 ,140.D0 ,142.D0 ,143.D0 ,144.D0 ,
+ + 146.D0 ,147.D0 ,21.1D0 /
+ DATA (AE(I,10, 7),I=1,10) /
+ + .000D+00,85.3D0 ,158.D0 ,159.D0 ,161.D0 ,162.D0 ,164.D0 ,
+ + 166.D0 ,167.D0 ,21.1D0 /
+ DATA (AE(I,10, 8),I=1,10) /
+ + .000D+00,.000D+00,176.D0 ,177.D0 ,179.D0 ,181.D0 ,183.D0 ,
+ + 184.D0 ,186.D0 ,21.1D0 /
+ DATA (AE(I,10, 9),I=1,10) /
+ + .000D+00,.000D+00,114.D0 ,199.D0 ,201.D0 ,202.D0 ,205.D0 ,
+ + 206.D0 ,207.D0 ,22.0D0 /
+ DATA (AE(I,10,10),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,218.D0 ,219.D0 ,220.D0 ,224.D0 ,
+ + 225.D0 ,226.D0 ,23.3D0 /
+ DATA (AE(I,10,11),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,150.D0 ,238.D0 ,238.D0 ,243.D0 ,
+ + 244.D0 ,245.D0 ,24.4D0 /
+ DATA (AE(I,10,12),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,85.8D0 ,255.D0 ,255.D0 ,261.D0 ,
+ + 262.D0 ,263.D0 ,26.3D0 /
+ DATA (AE(I,10,13),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,195.D0 ,272.D0 ,279.D0 ,
+ + 279.D0 ,280.D0 ,27.6D0 /
+ DATA (AE(I,10,14),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,115.D0 ,290.D0 ,296.D0 ,
+ + 297.D0 ,298.D0 ,29.6D0 /
+ DATA (AE(I,10,15),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,263.D0 ,313.D0 ,
+ + 314.D0 ,315.D0 ,31.8D0 /
+ DATA (AE(I,10,16),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,150.D0 ,330.D0 ,
+ + 331.D0 ,332.D0 ,34.4D0 /
+ DATA (AE(I,10,17),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,90.0D0 ,319.D0 ,
+ + 349.D0 ,349.D0 ,36.4D0 /
+ DATA (AE(I,10,18),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,196.D0 ,
+ + 366.D0 ,367.D0 ,38.3D0 /
+ DATA (AE(I,10,19),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,122.D0 ,
+ + 387.D0 ,384.D0 ,41.4D0 /
+ DATA (AE(I,10,20),I=1,10) /
+ + .000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,.000D+00,
+ + 247.D0 ,401.D0 ,43.4D0 /
+ DATA (ERES(I, 1),I=1,10) / 10*0.D0/
+ DATA (ERES(I, 2),I=1,10) / 10*0.D0/
+ DATA (ERES(I, 3),I=1,10) / 10*0.D0/
+ DATA (ERES(I, 4),I=1,10) / 10*0.D0/
+ DATA (ERES(I, 5),I=1,10) / 10*0.D0/
+ DATA (ERES(I, 6),I=1,10) /
+ + 0.000D0, 0.000D0, 0.000D0, 0.000D0, 0.000D0, 0.000D0, 0.000D0,
+ + 2.780D0, 2.880D0, 2.890D0 /
+ DATA (ERES(I, 7),I=1,10) /
+ + 1.500D0, 2.460D0, 2.510D0, 2.610D0, 2.700D0, 2.920D0, 3.070D0,
+ + 3.200D0, 3.330D0, 2.890D0 /
+ DATA (ERES(I, 8),I=1,10) /
+ + 4.470D0, 4.350D0, 4.390D0, 4.550D0, 4.660D0, 4.890D0, 4.980D0,
+ + 5.100D0, 5.220D0, 2.890D0 /
+ DATA (ERES(I, 9),I=1,10) /
+ + 7.480D0, 7.380D0, 7.370D0, 7.480D0, 7.510D0, 7.630D0, 7.660D0,
+ + 7.750D0, 7.820D0, 2.890D0 /
+ DATA (ERES(I,10),I=1,10) /
+ + 15.270D0,15.190D0,15.200D0,15.370D0,15.380D0,15.430D0,15.540D0,
+ + 15.590D0,15.630D0, 2.890D0 /
+ END
+C->
+C=======================================================================
+
+ SUBROUTINE FRAGM (IAT,IAP, NW,B, NF, IAF)
+
+C-----------------------------------------------------------------------
+C...Nuclear Fragmentation, Abrasion-ablation model,
+C...Based on Jon Engel's routines ABRABL
+C...This most recent version adds for all prefragment
+C...masses > 10 the model calculation for the fragment
+C...mass distribution and the energy carried by the fragment
+C...of W. Friedmann
+C...The average values are used to implement the model
+C...in the montecarlo fashion / TSS, Dec '91
+C.
+C. INPUT: IAP = mass of incident nucleus
+C. IAT = mass of target nucleus
+C. NW = number of wounded nucleons in the beam nucleus
+C. B = impact parameter in the interaction
+C.
+C. OUTPUT : NF = number of fragments of the spectator nucleus
+C. IAF(1:NF) = mass number of each fragment
+C. PF(3,60) in common block /FRAGMENTS/ contains
+C. the three momentum components (MeV/c) of each
+C. fragment in the projectile frame
+C..............................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /FRAGMENTS/ PPP(3,60)
+ COMMON /FRAGMOD/A(10,10,20),AE(10,10,20),ERES(10,10),NFLAGG(10,10)
+ DIMENSION IAF(60)
+ DIMENSION AA(10), EAA(10)
+ SAVE
+ EXTERNAL GASDEV
+ DATA AA/10.D0,15.D0,20.D0,25.D0,30.D0,35.D0,40.D0,45.D0,50.D0,
+ $ 56.D0/
+ DATA EAA/1.D0,2.D0,4.D0,6.D0,8.D0,10.D0,12.D0,16.D0,20.D0,30.D0/
+
+ AP=IAP
+ AT=IAT
+ NPF = IAP - NW
+ IF (NPF .EQ. 0) THEN
+ NF = 0
+ RETURN
+ ENDIF
+
+ EB = ESTAR(AP,AT, B)
+ EBP = ESTARP (NPF, NW)
+C CONTRIBUTION TO E* FROM ENERGY DEPOSITED BY SECONDARIES
+ EB = EB + EBP
+C TOTAL E* IS THE SUM OF THE TWO COMPONENTS
+
+C.....Prefragment transverse momentum (MeV/nucleon)...
+ FK = FERMK(AP)
+C FERMI MOMENTUM OF THE PROJECTILE NUCLEUS
+ IF (NW .LT. IAP) THEN
+ SIG = FK*DSQRT(NW*NPF/(AP-1.D0))/3.162D0
+C GAUSSIAN SIGMA IN ALL THREE DIRECTION
+ ELSE
+ SIG = FK/3.162D0
+C THIS IS NOT CORRECT, TOO LARGE !!!!!!!!!!!!!!
+ ENDIF
+ PPFX = SIG*GASDEV(0)/NPF
+ PPFY = SIG*GASDEV(1)/NPF
+C THREE MOMENTUM COMPONENTS PER NUCLEON FOR THE PREFRAGMENT
+
+C.............Crude model for small prefragment mass .......
+ IF (NPF .LT. 10) THEN
+ CALL EVAP(NPF, EB, EPS, NNUC, NALP)
+C EPS IS THE KINETIC ENERGY CARRIED BY THE EVAPORATED NUCLEONS
+ ETOT = 938.D0 + EPS
+ PP = SQRT((ETOT*ETOT - 8.79844D5)/3.D0)
+C AVERAGE MOMENTUM OF EVAPORATED NUCLEONS IN EACH DIRECTION
+ NUC = NPF - NNUC - 4*NALP
+ NF = 0
+ IF (NUC .GT. 0) THEN
+ NF = NF + 1
+ IAF(NF) = NUC
+ PPP(1,NF) = NUC*PPFX
+ PPP(2,NF) = NUC*PPFY
+ ENDIF
+ IF (NALP .NE. 0) THEN
+ DO I=1,NALP
+ NF = NF + 1
+ IAF(NF) = 4
+ CALL SINCO(S1,C1)
+ CALL SINCO(S2,C2)
+ PXE = 4.D0*PP*S1*S2
+ PYE = 4.D0*PP*S1*C2
+ PPP(1,NF) = 4.D0*PPFX + PXE
+ PPP(2,NF) = 4.D0*PPFY + PYE
+ PPP(1,1) = PPP(1,1) - PXE
+ PPP(2,1) = PPP(2,1) - PYE
+ ENDDO
+ ENDIF
+ IF (NNUC .NE. 0) THEN
+ DO I=1,NNUC
+ NF = NF + 1
+ IAF(NF) = 1
+ CALL SINCO(S1,C1)
+ CALL SINCO(S2,C2)
+ PXE = PP*S1*S2
+ PYE = PP*S1*C2
+ PPP(1,NF) = 4.D0*PPFX + PXE
+ PPP(2,NF) = 4.D0*PPFY + PYE
+ PPP(1,1) = PPP(1,1) - PXE
+ PPP(2,1) = PPP(2,1) - PYE
+ ENDDO
+ ENDIF
+ RETURN
+ ENDIF
+
+C.........More refined model calculation .............
+ JA = NPF/5 -1
+ IF (JA .LT. 10) THEN
+ IF ((NPF - AA(JA)) .GT. (AA(JA+1)-NPF)) JA = JA + 1
+ ENDIF
+ ARAT = DBLE(NPF)/AA(JA)
+ DO J=1,10
+ IF (EB .LT. EAA(J)) GO TO 29
+ ENDDO
+ JE = 10
+ GO TO 39
+ 29 JE = J
+ 39 IF (JE .GT. 1 .AND. JE .NE. 10) THEN
+ IF ((EB - EAA(J-1)) .LT. (EAA(J)-EB)) JE = J - 1
+ ENDIF
+ ERAT = EB/EAA(JE)
+ IF (EB .LT. 1.D0) THEN
+ ERAT = EB
+ ENDIF
+C INTERPOLATE BETWEEN EB=0. (NOTHING HAPPENS) AND EB = 1. MeV
+ IF (JA .EQ. 10 .AND. JE .GT. 6) THEN
+ WRITE(*,*)' JA=',JA,', JE=',JE
+ ENDIF
+ 43 ESUM = 0.D0
+ NSUM = 0
+ JF = 0
+ DO J=20,1,-1
+ FR = A(JA, JE, J)*ARAT*ERAT
+ N1 = INT(1.D0 + FR)
+ FR1 = FR/DBLE(N1)
+ DO K=1, N1
+ IF (S_RNDM(0) .LT. FR1) THEN
+ JF = JF + 1
+ IAF(JF) = J
+ NSUM = NSUM + J
+ EKIN = ERAT*AE(JA,JE, J)
+ IF (EKIN .GT. 0.D0) THEN
+ ESUM = ESUM + EKIN
+ ETOT = 938.D0*IAF(JF) + EKIN
+ PP = DSQRT(2.D0*(ETOT*ETOT - IAF(JF)**2*8.79844D5)/3.D0)
+ CALL SINCO(S1,C1)
+ CALL SINCO(S2,C2)
+ PPP(1,JF) = PP*S1*S2 + IAF(JF)*PPFX
+ PPP(2,JF) = PP*S1*C2 + IAF(JF)*PPFY
+ ENDIF
+ IF (NSUM .GT. NPF) THEN
+C WRITE(*,*)' WARNING, NSUM=', NSUM,', NPF=',NPF
+C WRITE(*,*)' ARAT =', ARAT
+ GO TO 43
+ ELSE
+ IF (NSUM .EQ. NPF) THEN
+ GO TO 44
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ IF (NFLAGG(JA,JE) .EQ. 0) THEN
+C 'THE RESIDUE' IS A NUCLEAR FRAGMENT
+ JF = JF + 1
+ IAF(JF) = NPF - NSUM
+ F1 = NPF*EB - ESUM
+ IF (F1 .LT. 0.D0) F1 = 0.D0
+C GIVE THE REST OF EB TO THE FRAGMENT
+ EKIN = F1
+ IF (EKIN .GT. 0.D0) THEN
+ ETOT = 938.D0*IAF(JF) + EKIN
+ PP = DSQRT(2.D0*(ETOT*ETOT - IAF(JF)**2*8.79844D5)/3.D0)
+ CALL SINCO(S1,C1)
+ CALL SINCO(S2,C2)
+ PPP(1,JF) = PP*S1*S2 + IAF(JF)*PPFX
+ PPP(2,JF) = PP*S1*C2 + IAF(JF)*PPFY
+ ENDIF
+ ELSE
+C 'THE RESIDUE' CONSISTS OF SPECTATOR NUCLEONS
+ N1 = NPF - NSUM
+ DO K=1,N1
+ JF = JF + 1
+ IAF(JF) = 1
+ EKIN = ERAT*ERES(JA,JE)
+ IF (EKIN .GT. 0.D0) THEN
+ ETOT = 938.D0*IAF(JF) + EKIN
+ PP = DSQRT(2.D0*(ETOT*ETOT - IAF(JF)**2*8.79844D5)/3.D0)
+ CALL SINCO(S1,C1)
+ CALL SINCO(S2,C2)
+ PPP(1,JF) = PP*S1*S2 + PPFX
+ PPP(2,JF) = PP*S1*C2 + PPFY
+ ENDIF
+ ENDDO
+ ENDIF
+ 44 NF = JF
+ RETURN
+ END
+C->
+C=======================================================================
+
+ FUNCTION ESTARP (NPF, NW)
+
+C-----------------------------------------------------------------------
+C CONTRIBUTION TO E* FROM ENERGY DEPOSITED BY SECONDARIES
+C VERY NAIVE VERSION INCORPORATING HUEFFNER'S IDEAS
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ APF = NPF
+ F1 = 15.3D0/APF**0.666666666D0
+C AVERAGE KINETIC ENERGY/NUCLEON IN PREFRAGMENT (MeV)
+C PER PATHLENGTH EQUAL TO THE PREFRAGMENT RADIUS
+ ESTARP = 0.D0
+ DO I=1,NW
+ IF (S_RNDM(0) .GT. 0.5D0) THEN
+ F2 = F1*RDIS(0)
+ ESTARP = ESTARP + F2
+ ENDIF
+ ENDDO
+C SAMPLE RANDOMLY PER WOUNDED NUCLEON, x NW
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION RDIS(Idum)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ dimension probr(20)
+ SAVE
+ data probr/
+ * 0.10000D0, 0.15748D0, 0.21778D0, 0.28605D0, 0.36060D0,
+ * 0.43815D0, 0.51892D0, 0.60631D0, 0.70002D0, 0.79325D0,
+ * 0.88863D0, 0.98686D0, 1.10129D0, 1.21202D0, 1.32932D0,
+ * 1.44890D0, 1.57048D0, 1.70139D0, 1.83417D0, 2.00000D0/
+
+ rdis = idum
+ nr = INT(20.D0*S_RNDM(0) + 1.D0)
+ if (nr .eq. 1) then
+ f1 = 0.D0
+ else
+ f1 = probr(nr-1)
+ endif
+ dr = probr(nr) - f1
+ rdis = f1 + dr*S_RNDM(1)
+ return
+ end
+
+C=======================================================================
+
+ FUNCTION ESTAR(ap,at,b)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ SAVE
+
+c real*4 ap,at,b,estar
+ sigma=4.5D0 !total n-n cross section in fm**2
+ rt=.82d0*at**.33333333D0 !target radius
+ rp=.82d0*ap**.33333333D0 !projectile radius
+ alpha=rt**2/rp**2
+ beta=b**2/rt**2
+ f=at*sigma/(PI*rt**2)
+ alf = log(f)
+ alalf = log(alpha)
+ gfac=0.d0
+ gfac1=0.d0
+ s1=0.D0
+ s2=0.D0
+ s3=0.D0
+ ii=1
+ do n=0,10 ! This limit may not need to be so high.
+ if(n.ge.2) then
+ gfac1=gfac
+ gfac=gfac+log(float(n))
+ endif
+ g0=n*alf -n*beta*alpha/(n+alpha)+alalf
+ g1=g0-log(alpha+n)-gfac
+ g2=(n+2)*log(f)-(n+2)*beta*alpha/(n+2+alpha)
+ > +log(n+2+alpha+beta*alpha**2)-3.d0*log(n+2.d0+alpha)-gfac
+ g3=g0-2.d0*log(n+alpha)-gfac1
+ ii=-ii
+ s1=s1+ii*exp(g1)
+ s2=s2+ii*exp(g2)
+ if(n.ge.1) s3=s3+ii*exp(g3)
+ enddo
+
+ pb=s1
+ e1b=197.D0**2/(2.D0*938.d0*rp**2*pb) *s2
+c a=b*(s3/pb-1)
+c a=-b*s3/pb
+c e2b=-.5* 938. * (41./(ap**.333))**2 * a**2 /(197.**2)
+c estar=e1b+e2b
+ estar = e1b
+ return
+ end
+C=======================================================================
+
+ SUBROUTINE EVAP(npf,eb,eps,nnuc,nalp)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ eps=7.5D0+sqrt(8.D0*eb)
+ n=min(npf*int(eb/eps),npf)
+ nalp=n/5
+ nnuc=n-4*nalp
+ return
+ end
+C->
+C=======================================================================
+
+ FUNCTION FERMK(A)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION AA(6), FK(6)
+ SAVE
+ DATA AA/4.D0, 6.D0, 12.D0, 24.D0, 40.D0, 57.D0/
+ DATA FK/130.D0,169.D0,221.D0,235.D0,251.D0,260.D0/
+
+ DO I=2,4
+ IF (A .LT. AA(I)) GO TO 25
+ ENDDO
+ I = 5
+ 25 F11 = AA(I-1)
+ F12 = AA(I)
+ F13 = AA(I+1)
+ F21 = FK(I-1)
+ F22 = FK(I)
+ F23 = FK(I+1)
+ FERMK = QUAD_INT(A,F11,F12,F13, F21,F22,F23)
+ RETURN
+ END
+
+C*=======================================================================
+C. Multiple interaction structure
+C========================================================================
+
+ SUBROUTINE INT_NUC (IA, IB, SIG0, SIGEL)
+
+C-----------------------------------------------------------------------
+C...Compute with a montecarlo code the "multiple interaction structure"
+C. of a nucleus-nucleus interaction
+C.
+C. INPUT : IA = mass of target nucleus
+C. IB = mass of projectile nucleus
+C. SIG0 (mbarn) = inelastic pp cross section
+C. SIGEL(mbarn) = elastic pp cross section
+C.
+C. OUTPUT : in common block /CNUCMS/
+C. B = impact parameter (fm)
+C. BMAX = maximum impact parameter for generation
+C. NTRY = number of "trials" before one interaction
+C. NA = number of wounded nucleons in A
+C. NB = " " " in B
+C. NI = number of nucleon-nucleon inelastic interactions
+C. NAEL = number of elastically scattered nucleons in A
+C. NBEL = " " " " in B
+C. JJA(J) [J=1:IA] = number of inelastic interactions
+C. of J-th nucleon of nucleus A
+C. JJB(J) [J=1:IB] = number of inelastic interactions
+C. of J-th nucleon of nucleus B
+C. JJAEL(J) [J=1:IA] = number of elastic interactions
+C. of J-th nucleon of nucleus A
+C. JJBEL(J) [J=1:IB] = number of elastic interactions
+C. of J-th nucleon of nucleus B
+C. JJINT(J,K) [J=1:NB, K=1:NA] (0 = no interaction)
+C. (1 = interaction )
+C. between nucleon J of A and K of B
+C-----------------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (IAMAX=56)
+ COMMON /CNUCMS/ B, BMAX, NTRY, NA, NB, NI, NAEL, NBEL
+ + ,JJA(IAMAX), JJB(IAMAX), JJINT(IAMAX,IAMAX)
+ + ,JJAEL(IAMAX), JJBEL(IAMAX)
+ DIMENSION XA(IAMAX), YA(IAMAX), XB(IAMAX), YB(IAMAX)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ SIGT = SIG0 + SIGEL
+ R2 = 0.1D0 * SIG0/PI
+ R2T = 0.1D0 * SIGT/PI
+ BMAX = 15.D0 ! fm
+ NTRY = 0
+ CALL NUC_CONF (IA, XA, YA)
+ CALL NUC_CONF (IB, XB, YB)
+ NI = 0
+ NIEL = 0
+ DO JA=1,IA
+ JJA(JA) = 0
+ JJAEL(JA) = 0
+ ENDDO
+ DO JB=1,IB
+ JJB(JB) = 0
+ JJBEL(JB) = 0
+ DO JA=1,IA
+ JJINT(JB,JA) = 0
+ ENDDO
+ ENDDO
+1000 B = BMAX*SQRT(S_RNDM(0))
+ PHI = TWOPI*S_RNDM(1)
+ BX = B*COS(PHI)
+ BY = B*SIN(PHI)
+ NTRY = NTRY+1
+ DO JA=1,IA
+ DO JB=1,IB
+ S = (XA(JA)-XB(JB)-BX)**2 + (YA(JA)-YB(JB)-BY)**2
+ IF (S .LT. R2) THEN
+ NI = NI + 1
+ JJA(JA) = JJA(JA)+1
+ JJB(JB) = JJB(JB)+1
+ JJINT(JB,JA) = 1
+ ELSE IF (S .LT. R2T) THEN
+ NIEL = NIEL + 1
+ JJAEL(JA) = JJAEL(JA)+1
+ JJBEL(JB) = JJBEL(JB)+1
+ ENDIF
+ ENDDO
+ ENDDO
+ IF (NI + NIEL .EQ. 0) GOTO 1000
+ NA = 0
+ NB = 0
+ NAEL = 0
+ NBEL = 0
+ DO JA=1,IA
+ IF (JJA(JA) .GT. 0) THEN
+ NA = NA + 1
+ ELSE
+ IF (JJAEL(JA) .GT. 0) NAEL = NAEL+1
+ ENDIF
+ ENDDO
+ DO JB=1,IB
+ IF (JJB(JB) .GT. 0) THEN
+ NB = NB + 1
+ ELSE
+ IF (JJBEL(JB) .GT. 0) NBEL = NBEL+1
+ ENDIF
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE NUC_CONF (IA, XX, YY)
+
+C-----------------------------------------------------------------------
+C...This routine generates the configuration of a nucleus
+C. need an initialization call to NUC_GEOM_INI
+C.
+C. INPUT : IA = mass number of the nucleus
+C. OUTPUT : XX(1:IA), YY(1:IA) (fm) = position in impact parameter
+C. space of the IA nucleons
+C...................................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (IAMAX=56)
+ DIMENSION XX(IAMAX), YY(IAMAX)
+ PARAMETER (NB=401)
+ COMMON /CPROFA/ ZMIN, DZ, BBZ(NB,IAMAX)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ DO J=1,IA
+ Z = S_RNDM(J)
+ JZ = INT((Z-ZMIN)/DZ)+1
+ JZ = MIN(JZ,400)
+ T = (Z-ZMIN)/DZ - DBLE(JZ-1)
+ B = BBZ(JZ,IA)*(1.D0-T) + BBZ(JZ+1,IA)*T
+ PHI = TWOPI*S_RNDM(J+1)
+ XX(J) = B*COS(PHI)
+ YY(J) = B*SIN(PHI)
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE NUC_GEOM_INI
+
+C-----------------------------------------------------------------------
+C...Initialize all nucleus profiles
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (NB=401)
+ PARAMETER (IAMAX=56)
+ COMMON /CPROF/ DB, BMAX, BB(NB), TB(NB), A
+ COMMON /CPROFA/ ZMIN, DZ, BBZ(NB,IAMAX)
+ DIMENSION FFB(NB), GGB(NB)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ CALL SHELL_INI
+ CALL WOOD_SAXON_INI
+ DO IA= 2,IAMAX
+ JA = IA
+ CALL NUC_PROFIL(JA)
+ DO K=1,NB
+ FFB(K) = BB(K)*TB(K) * TWOPI
+ ENDDO
+ GGB(1) = 0.D0
+ GGB(NB) = 1.D0
+ DO K=2,NB-1
+ GGB(K) = GGB(K-1) + FFB(K-1)*DB
+ ENDDO
+ CALL INVERT_ARRAY(GGB,0.D0,DB,NB, BBZ(1,IA), ZMIN, DZ)
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE NUC_PROFIL (JA)
+
+C-----------------------------------------------------------------------
+C...Compute the profile function T(b)
+C. normalised as INT[d2b T(b) = 1]
+C. INPUT : JA = integer mass number of nucleus
+C...............................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ PARAMETER (NB=401)
+ EXTERNAL DENSA
+ DOUBLE PRECISION DENSA
+ COMMON /CC01/ B
+ COMMON /CCDA/ JJA
+ COMMON /CPROF/ DB, BMAX, BB(NB), TB(NB), A
+ SAVE
+
+ BMAX = 7.5D0
+ DB = BMAX/DBLE(NB-1)
+ JJA = JA
+ A = JA
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ BB(JB) = B
+ IF (JA .LE. 18) THEN
+ TB(JB) = PROFNUC (B, JA)
+ ELSE
+ TB(JB) = 2.D0*GAUSS (DENSA,0.D0,BMAX)
+ ENDIF
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE NUC1_PROFIL (AA)
+
+C-----------------------------------------------------------------------
+C...Compute the profile function T(b)
+C. normalised as INT[d2b T(b) = 1]
+C. INPUT : AA = mass number of nucleus
+C...............................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (NB=401)
+ EXTERNAL DENSA
+ DOUBLE PRECISION DENSA
+ COMMON /CC01/ B
+ COMMON /CPROF/ DB, BMAX, BB(NB), TB(NB), A
+ SAVE
+
+ A = AA
+ IA1 = INT(AA)
+ IA2 = IA1 + 1
+ U = AA - DBLE(IA1)
+ BMAX = 7.5D0
+ DB = BMAX/DBLE(NB-1)
+ DO JB=1,NB
+ B = DB*DBLE(JB-1)
+ BB(JB) = B
+ IF (A .LE. 18.D0) THEN
+ T1 = PROFNUC (B, IA1)
+ T2 = PROFNUC (B, IA2)
+ ELSE
+ JJA = IA1
+ T1 = 2.D0*GAUSS (DENSA,0.D0,BMAX)
+ JJA = IA2
+ T2 = 2.D0*GAUSS (DENSA,0.D0,BMAX)
+ ENDIF
+ TB(JB) = (1.D0-U)*T1 + U*T2
+ ENDDO
+ RETURN
+ END
+
+C*======================================================================
+C. Code about nuclear densities
+C=======================================================================
+
+ FUNCTION DENS_NUC (R, JA)
+
+C-----------------------------------------------------------------------
+C....Nuclear density (normalised to 1)
+C. for a nucleus of mass number JA
+C. INPUT R = radial coordinate (fm)
+C. JA = integer mass number
+C. OUTPUT (fm**-3)
+C--------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CWOOD/ RR0(19:56), AA0(19:56), CC0(19:56)
+ SAVE
+
+ IF (JA .GT. 18) THEN
+ DENS_NUC = WOOD_SAXON(R,JA)
+ ELSE IF (JA .NE. 4) THEN
+ DENS_NUC = HELIUM(R)
+ ELSE
+ DENS_NUC = SHELL(R,JA)
+ ENDIF
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION WOOD_SAXON (R, JA)
+
+C-----------------------------------------------------------------------
+C....Wood-Saxon nuclear density (normalised to 1)
+C. for a nucleus of mass number A.
+C. INPUT R = (fm)
+C. JA = mass number
+C. OUTPUT (fm**-3)
+C------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CWOOD/ RR0(19:56), AA0(19:56), CC0(19:56)
+ SAVE
+
+ WOOD_SAXON = CC0(JA)/(1.D0+EXP((R-RR0(JA))/AA0(JA)))
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION HELIUM (R)
+
+C-----------------------------------------------------------------------
+C... Helium density from Barrett and Jackson
+C. INPUT R = r coordinate (fm)
+C. OUTPUT (fm**-3)
+C........................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+ DATA R0 /0.964D0/, CA /0.322D0/ ! fm
+ DATA W /0.517D0/, CC /5.993224D-02/
+
+ HELIUM = CC*(1.D0+W*(R/R0)**2)/(1.D0 + EXP((R-R0)/CA))
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION SHELL (R,JA)
+
+C-----------------------------------------------------------------------
+C...Density in the shell model
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CSHELL/ RR0(18), RR02(18)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ R0 = RR0(JA)
+ C1 = MIN(1.D0,4.D0/DBLE(JA))
+ CS = 1.D0/(R0**3 * PI**1.5D0)
+ CP = 2.D0*CS/3.D0
+ FS = EXP(-(R/R0)**2)
+ FP = (R/R0)**2 * FS
+ SHELL = C1*CS*FS + (1.D0-C1)*CP*FP
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION PROFNUC (B, JA)
+
+C-----------------------------------------------------------------------
+C...This function return
+C. the profile T(b) for a nucleus of mass number A
+C. INPUT B = impact parameter (GeV**-1)
+C. JA = integer mass number
+C. OUTPUT (fm**-2)
+C.
+C. The density of the nucleus is the `shell model density'
+C. the parameter r0 must beinitialized in the common block
+C.............................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CSHELL/ RR0(18), RR02(18)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ B2 = B*B
+ ARG = B2/RR02(JA)
+ TS = EXP(-ARG)
+ TP = TS*(2.D0*B2+RR02(JA))/(3.D0*RR02(JA))
+ CS = MIN(1.D0,4.D0/DBLE(JA))
+ PROFNUC = (CS*TS + (1.D0-CS)*TP)/(PI*RR02(JA))
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SHELL_INI
+
+C-----------------------------------------------------------------------
+C...Initialize the parameter of the shell model
+C. for the nuclei with 6 < A < 18
+C..............................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /CSHELL/ RR0(18), RR02(18)
+ DIMENSION RR(18)
+ SAVE
+C...Data on Sqrt[<r**2>] in fermi
+ DATA RR /0.81D0, 2.095D0, 1.88D0, 1.674D0, -1.D0,
+ + 2.56D0, 2.41D0, -1.D0, 2.519D0, 2.45D0,
+ + 2.37D0, 2.460D0, 2.440D0, 2.54D0, 2.58D0,
+ + 2.718D0,2.662D0, 2.789D0/
+
+ DO JA=1,18
+ A = DBLE(JA)
+ RMED = RR(JA)
+ IF (RMED .LE. 0.D0) RMED = 0.5D0*(RR(JA-1) + RR(JA+1))
+ C = MAX(1.5D0,(5.D0/2.D0 - 4.D0/A) )
+ R0 = RMED/SQRT(C)
+ RR0 (JA) = R0
+ RR02(JA) = R0*R0
+ ENDDO
+ RETURN
+ END
+C->
+C=======================================================================
+
+ SUBROUTINE WOOD_SAXON_INI
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CWOOD/ RR0(19:56), AA0(19:56), CC0(19:56)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+C...Wood-Saxon parameters from table 6.2 of Barrett and Jackson
+ RR0 (19) = 2.59D0
+ AA0 (19) = 0.564D0
+ RR0 (20) = 2.74D0
+ AA0 (20) = 0.569D0
+ RR0 (22) = 2.782D0
+ AA0 (22) = 0.549D0
+ RR0 (24) = 2.99D0
+ AA0 (24) = 0.548D0
+ RR0 (27) = 2.84D0
+ AA0 (27) = 0.569D0
+ RR0 (28) = 3.14D0
+ AA0 (28) = 0.537D0
+ RR0 (29) = 3.77D0
+ AA0 (29) = 0.52D0
+ RR0 (48) = 3.912D0
+ AA0 (48) = 0.5234D0
+ RR0 (56) = 3.98D0
+ AA0 (56) = 0.569D0
+ DO J=19, 56
+ IF (RR0(J) .LE. 0.D0) THEN
+ RR0(J) = 1.05D0*DBLE(J)**0.333333333333D0
+ AA0(J) = 0.545D0
+ ENDIF
+ CC0(J)=3.D0/(4.D0*PI*RR0(J)**3)/(1.D0+((AA0(J)*PI)/RR0(J))**2)
+ ENDDO
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION DENSA (Z)
+
+C-----------------------------------------------------------------------
+C....Woods Saxon nuclear density (normalised to 1)
+C. for a nucleus of mass number A.
+C. INPUT z = z coordinate (fm)
+C. JA = integer mass number
+C. B (in common /CC01/) impact parameter (fm)
+C. OUTPUT (fm**-3)
+C--------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CC01/ B
+ COMMON /CCDA/ JA
+ COMMON /CWOOD/ RR0(19:56), AA0(19:56), CC0(19:56)
+ SAVE
+
+ R = SQRT (Z*Z + B*B)
+ DENSA = CC0(JA)/(1.D0+EXP((R-RR0(JA))/AA0(JA)))
+ RETURN
+ END
+
+C*=====================================================================
+C. Cross sections
+C======================================================================
+
+ SUBROUTINE SIGMA_AIR (IB,SIG0,SIGEL,KINT,
+ + SIGMA,DSIGMA,SIGQE,DSIGQE)
+
+C-----------------------------------------------------------------------
+C...Compute with a montecarlo method the "production"
+C. and "quasi-elastic" cross section for
+C. a nucleus-air interaction
+C.
+C. INPUT : IB = mass of projectile nucleus
+C. SIG0 (mbarn) = inelastic pp cross section
+C. KINT = number of interactions to generate
+C. OUTPUT : SIGMA (mbarn) = "production" cross section
+C. DSIGMA " = error
+C. SIGQE " = "quasi-elastic" cross section
+C. DSIGQE " = error
+C. additional output is in the common block /CPROBAB/
+C..........................................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (IAMAX=56)
+ PARAMETER (IAMAX2=3136) ! IAMAX*IAMAX
+ COMMON /CPROBAB/ PROBA(IAMAX), DPROBA(IAMAX),
+ + PROBB(IAMAX), DPROBB(IAMAX), PROBI(IAMAX2), DPROBI(IAMAX2),
+ + P1AEL(0:IAMAX),DP1AEL(0:IAMAX),P1BEL(0:IAMAX), DP1BEL(0:IAMAX),
+ + P2AEL(0:IAMAX),DP2AEL(0:IAMAX),P2BEL(0:IAMAX), DP2BEL(0:IAMAX)
+ COMMON /CNUCMS/ B, BMAX, NTRY, NA, NB, NI, NAEL, NBEL
+ + ,JJA(IAMAX), JJB(IAMAX), JJINT(IAMAX,IAMAX)
+ + ,JJAEL(IAMAX), JJBEL(IAMAX)
+ DIMENSION MMA(0:IAMAX), MMB(0:IAMAX), MMI(0:IAMAX2)
+ DIMENSION M1AEL(0:IAMAX), M1BEL(0:IAMAX)
+ DIMENSION M2AEL(0:IAMAX), M2BEL(0:IAMAX)
+ DOUBLE PRECISION FOX
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+ DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air
+
+ R2 = 0.1D0 * SIG0/PI
+ BMAX = 15.D0 ! fm
+ SIGMA0 = PI*BMAX*BMAX*10. ! mbarn
+ IA = 16
+ DO J=1,IA
+ MMA(J) = 0
+ M1AEL(J) = 0
+ M2AEL(J) = 0
+ ENDDO
+ DO J=1,IB
+ MMB(J) = 0
+ M1BEL(J) = 0
+ M2BEL(J) = 0
+ ENDDO
+ DO J=1,IA*IB
+ MMI(J) = 0
+ ENDDO
+ NN = 0
+ M = 0
+ DO KK=1,KINT
+c select target IA from air composition
+ R = S_RNDM(KK)
+ IA = 14
+ IF (R .LT. FOX) IA = 16
+
+ CALL INT_NUC (IA, IB, SIG0, SIGEL)
+ NN = NN + NTRY
+ MMI(NI) = MMI(NI) + 1
+ MMA(NA) = MMA(NA)+1
+ MMB(NB) = MMB(NB)+1
+ IF (NI .GT. 0) THEN
+ M = M+1
+ M1AEL(NAEL) = M1AEL(NAEL)+1
+ M1BEL(NBEL) = M1BEL(NBEL)+1
+ ELSE
+ M2AEL(NAEL) = M2AEL(NAEL)+1
+ M2BEL(NBEL) = M2BEL(NBEL)+1
+ ENDIF
+ ENDDO
+ MQE = KINT - M
+ SIGMA = SIGMA0 * DBLE(M)/DBLE(NN)
+ DSIGMA = SIGMA0 * SQRT(DBLE(M))/DBLE(NN)
+ SIGQE = SIGMA0 * DBLE(MQE)/DBLE(NN)
+ DSIGQE = SIGMA0 * SQRT(DBLE(MQE))/DBLE(NN)
+ DO J=1,IA
+ PROBA(J) = DBLE(MMA(J))/DBLE(M)
+ DPROBA(J) = SQRT(DBLE(MMA(J)))/DBLE(M)
+ ENDDO
+ DO J=1,IB
+ PROBB(J) = DBLE(MMB(J))/DBLE(M)
+ DPROBB(J) = SQRT(DBLE(MMB(J)))/DBLE(M)
+ ENDDO
+ DO J=1,IA*IB
+ PROBI(J) = DBLE(MMI(J))/DBLE(M)
+ DPROBI(J) = SQRT(DBLE(MMI(J)))/DBLE(M)
+ ENDDO
+ DO J=0,IA
+ P1AEL(J) = DBLE(M1AEL(J))/DBLE(M)
+ DP1AEL(J) = SQRT(DBLE(M1AEL(J)))/DBLE(M)
+ P2AEL(J) = DBLE(M2AEL(J))/DBLE(MQE)
+ DP2AEL(J) = SQRT(DBLE(M2AEL(J)))/DBLE(MQE)
+ ENDDO
+ DO J=0,IB
+ P1BEL(J) = DBLE(M1BEL(J))/DBLE(M)
+ DP1BEL(J) = SQRT(DBLE(M1BEL(J)))/DBLE(M)
+ P2BEL(J) = DBLE(M2BEL(J))/DBLE(MQE)
+ DP2BEL(J) = SQRT(DBLE(M2BEL(J)))/DBLE(MQE)
+ ENDDO
+ RETURN
+ END
+C->
+C=======================================================================
+
+ SUBROUTINE SIGMA_MC (IA,IB,SIG0,SIGEL,KINT,
+ + SIGMA,DSIGMA,SIGQE,DSIGQE)
+
+C-----------------------------------------------------------------------
+C...Compute with a montecarlo method the "production"
+C. and "quasi-elastic" cross section for
+C. a nucleus-nucleus interaction
+C.
+C. INPUT : IA = mass of target nucleus
+C. IB = mass of projectile nucleus
+C. SIG0 (mbarn) = inelastic pp cross section
+C. KINT = number of interactions to generate
+C. OUTPUT : SIGMA (mbarn) = "production" cross section
+C. DSIGMA " = error
+C. SIGQE " = "quasi-elastic" cross section
+C. DSIGQE " = error
+C. additional output is in the common block /CPROBAB/
+C. Prob(n_A), Prob(n_B), Prob(n_int)
+C..........................................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (IAMAX=56)
+ PARAMETER (IAMAX2=3136) ! IAMAX*IAMAX
+ COMMON /CPROBAB/ PROBA(IAMAX), DPROBA(IAMAX),
+ + PROBB(IAMAX), DPROBB(IAMAX), PROBI(IAMAX2), DPROBI(IAMAX2),
+ + P1AEL(0:IAMAX),DP1AEL(0:IAMAX),P1BEL(0:IAMAX), DP1BEL(0:IAMAX),
+ + P2AEL(0:IAMAX),DP2AEL(0:IAMAX),P2BEL(0:IAMAX), DP2BEL(0:IAMAX)
+ COMMON /CNUCMS/ B, BMAX, NTRY, NA, NB, NI, NAEL, NBEL
+ + ,JJA(IAMAX), JJB(IAMAX), JJINT(IAMAX,IAMAX)
+ + ,JJAEL(IAMAX), JJBEL(IAMAX)
+ DIMENSION MMA(0:IAMAX), MMB(0:IAMAX), MMI(0:IAMAX2)
+ DIMENSION M1AEL(0:IAMAX), M1BEL(0:IAMAX)
+ DIMENSION M2AEL(0:IAMAX), M2BEL(0:IAMAX)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ R2 = 0.1D0 * SIG0/PI
+ BMAX = 15.D0 ! fm
+ SIGMA0 = PI*BMAX*BMAX*10.D0 ! mbarn
+ DO J=1,IA
+ MMA(J) = 0
+ M1AEL(J) = 0
+ M2AEL(J) = 0
+ ENDDO
+ DO J=1,IB
+ MMB(J) = 0
+ M1BEL(J) = 0
+ M2BEL(J) = 0
+ ENDDO
+ DO J=1,IA*IB
+ MMI(J) = 0
+ ENDDO
+ NN = 0
+ M = 0
+ DO KK=1,KINT
+ CALL INT_NUC (IA, IB, SIG0, SIGEL)
+ NN = NN + NTRY
+ MMI(NI) = MMI(NI) + 1
+ MMA(NA) = MMA(NA)+1
+ MMB(NB) = MMB(NB)+1
+ IF (NI .GT. 0) THEN
+ M = M+1
+ M1AEL(NAEL) = M1AEL(NAEL)+1
+ M1BEL(NBEL) = M1BEL(NBEL)+1
+ ELSE
+ M2AEL(NAEL) = M2AEL(NAEL)+1
+ M2BEL(NBEL) = M2BEL(NBEL)+1
+ ENDIF
+ ENDDO
+ MQE = KINT - M
+ SIGMA = SIGMA0 * DBLE(M)/DBLE(NN)
+ DSIGMA = SIGMA0 * SQRT(DBLE(M))/DBLE(NN)
+ SIGQE = SIGMA0 * DBLE(MQE)/DBLE(NN)
+ DSIGQE = SIGMA0 * SQRT(DBLE(MQE))/DBLE(NN)
+ DO J=1,IA
+ PROBA(J) = DBLE(MMA(J))/DBLE(M)
+ DPROBA(J) = SQRT(DBLE(MMA(J)))/DBLE(M)
+ ENDDO
+ DO J=1,IB
+ PROBB(J) = DBLE(MMB(J))/DBLE(M)
+ DPROBB(J) = SQRT(DBLE(MMB(J)))/DBLE(M)
+ ENDDO
+ DO J=1,IA*IB
+ PROBI(J) = DBLE(MMI(J))/DBLE(M)
+ DPROBI(J) = SQRT(DBLE(MMI(J)))/DBLE(M)
+ ENDDO
+ DO J=0,IA
+ P1AEL(J) = DBLE(M1AEL(J))/DBLE(M)
+ DP1AEL(J) = SQRT(DBLE(M1AEL(J)))/DBLE(M)
+ P2AEL(J) = DBLE(M2AEL(J))/DBLE(MQE)
+ DP2AEL(J) = SQRT(DBLE(M2AEL(J)))/DBLE(MQE)
+ ENDDO
+ DO J=0,IB
+ P1BEL(J) = DBLE(M1BEL(J))/DBLE(M)
+ DP1BEL(J) = SQRT(DBLE(M1BEL(J)))/DBLE(M)
+ P2BEL(J) = DBLE(M2BEL(J))/DBLE(MQE)
+ DP2BEL(J) = SQRT(DBLE(M2BEL(J)))/DBLE(MQE)
+ ENDDO
+ RETURN
+ END
+
+C*=============================================================
+C. Cross sections
+C*=============================================================
+
+C Glauber h-air cross section calculation moved to inelScreen src file..
+
+C-----------------------------------------------------------------------
+C. Fit of Block and Cahn to pp and pbar-p cross sections
+C-----------------------------------------------------------------------
+C=======================================================================
+
+ SUBROUTINE BLOCK(SQS,SIG1,SIG2,SLOP1,SLOP2,
+ + RHO1,RHO2,SIGEL1,SIGEL2)
+
+C-----------------------------------------------------------------------
+C...p-p and pbar-p cross sections
+C. Parametrization of Block and Cahn
+C
+C. INPUT : SQS (GeV) = c.m. energy
+C.
+C. OUPUT : SIG1 (mbarn) = pp total cross section
+C. SLOP1 (GeV**2) = slope of elastic scattering
+C. RHO1 = Real/Imaginary part of the amplitude
+C. for forward elastic scattering (pp)
+C. SIGEL1 (mbarn) = pp elastic scattering cross section
+C. [1 -> 2 : pp -> pbar p]
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ S = SQS*SQS
+ CALL FPLUS (S, FR, FI)
+ CALL FMINUS (S, GR, GI)
+ SIG1 = FI-GI
+ SIG2 = FI+GI
+ RHO1 = (FR-GR)/(FI-GI)
+ RHO2 = (FR+GR)/(FI+GI)
+ CALL SSLOPE (S, BP, BM)
+ SLOP1 = BP - GI/FI*(BM-BP)
+ SLOP2 = BP + GI/FI*(BM-BP)
+ SIGEL1 = SIG1**2*(1.D0+RHO1**2)/(16.D0*PI*SLOP1)/CMBARN
+ SIGEL2 = SIG2**2*(1.D0+RHO2**2)/(16.D0*PI*SLOP2)/CMBARN
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE FPLUS (S, FR, FI)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /BLOCKC/ AA, BETA, S0, CC, AMU, DD, ALPHA, A0
+ COMPLEX*16 Z1, Z2, Z3
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ F1 = LOG(S/S0)
+ Z1 = DCMPLX(F1,-PI/2.D0)
+ Z1 = Z1*Z1
+ Z2 = 1.D0 + A0*Z1
+ Z3 = Z1/Z2
+ F2 = CC*S**(AMU-1.D0)
+ F3 = 0.5D0*PI*(1.-AMU)
+ FI = AA + F2*COS(F3) + BETA*DREAL(Z3)
+ FR = -BETA*DIMAG(Z3)+F2*SIN(F3)
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE FMINUS (S, FR, FI)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /BLOCKC/ AA, BETA, S0, CC, AMU, DD, ALPHA, A0
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ F1 = S**(ALPHA-1.D0)
+ F2 = 0.5D0*PI*(1.D0-ALPHA)
+ FR = -DD*F1*COS(F2)
+ FI = -DD*F1*SIN(F2)
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE SSLOPE (S, BP, BM)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /BLOCKD/ CP, DP, EP, CM, DM
+ SAVE
+
+ AL = LOG(S)
+ BP = CP + DP*AL + EP*AL*AL
+ BM = CM + DM*AL
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE BLOCK_INI
+
+C-----------------------------------------------------------------------
+C...Parameters of fit IFIT=1 of Block and Cahn
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /BLOCKC/ AA, BETA, S0, CC, AMU, DD, ALPHA, A0
+ COMMON /BLOCKD/ CP, DP, EP, CM, DM
+ SAVE
+
+ AA = 41.74D0
+ BETA = 0.66D0
+ S0 = 338.5D0
+ CC = 0.D0
+ AMU = 0.D0
+ DD = -39.37D0
+ ALPHA = 0.48D0
+ A0 = 0.D0
+ CP = 10.90D0
+ DP = -0.08D0
+ EP = 0.043D0
+ CM = 23.27D0
+ DM = 0.93D0
+ RETURN
+ END
+
+C*=============================================================
+C. Nucleus-nucleus cross sections
+C=======================================================================
+
+ SUBROUTINE SIGNUC_INI (IA,E0)
+
+C-----------------------------------------------------------------------
+C...This subroutine receives in INPUT E0 (TeV)
+C. energy per nucleon and computes the cross sections
+C. and interactions lengths for all nuclei
+C. with A between 2 and IA
+C. The output is contained in common block /CLENNN/
+C.
+C. Attention: the tabulated cross sections are obtained with
+C. new p-p cross sections as used in SIBYLL 2x,
+C. in addition field dimensions changed (RE 04/2000)
+C.
+C........................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CLENNN/ SSIGNUC(60), ALNUC(60)
+ DIMENSION SIGMA(6,56), SIGQE(6,56)
+ DIMENSION AA(6)
+ SAVE
+ DATA NE /6/, AMIN /1.D0/, DA /1.D0/
+ DATA AA /1.D0,2.D0,3.D0,4.D0,5.D0,6.D0/
+ DATA AVOG /6.0221367D-04/
+ DATA ATARGET /14.514D0/ ! effective masss of air
+C...Data on `inelastic-production' nucleus-air cross section
+ DATA (SIGMA(J, 2),J=1,6) /
+ &3.842D+02,4.287D+02,4.940D+02,5.887D+02,6.922D+02,7.767D+02/
+ DATA (SIGMA(J, 3),J=1,6) /
+ &4.601D+02,5.149D+02,5.595D+02,6.663D+02,7.641D+02,8.446D+02/
+ DATA (SIGMA(J, 4),J=1,6) /
+ &4.881D+02,5.373D+02,6.005D+02,6.895D+02,7.716D+02,8.967D+02/
+ DATA (SIGMA(J, 5),J=1,6) /
+ &5.874D+02,6.176D+02,7.181D+02,7.993D+02,9.089D+02,1.031D+03/
+ DATA (SIGMA(J, 6),J=1,6) /
+ &7.054D+02,7.399D+02,8.388D+02,9.463D+02,1.080D+03,1.197D+03/
+ DATA (SIGMA(J, 7),J=1,6) /
+ &7.192D+02,7.611D+02,8.449D+02,9.539D+02,1.061D+03,1.176D+03/
+ DATA (SIGMA(J, 8),J=1,6) /
+ &7.550D+02,7.975D+02,9.153D+02,9.944D+02,1.126D+03,1.236D+03/
+ DATA (SIGMA(J, 9),J=1,6) /
+ &7.929D+02,8.392D+02,9.265D+02,1.059D+03,1.167D+03,1.262D+03/
+ DATA (SIGMA(J, 10),J=1,6) /
+ &8.157D+02,8.644D+02,9.512D+02,1.058D+03,1.182D+03,1.298D+03/
+ DATA (SIGMA(J, 11),J=1,6) /
+ &8.039D+02,8.587D+02,9.534D+02,1.055D+03,1.182D+03,1.298D+03/
+ DATA (SIGMA(J, 12),J=1,6) /
+ &8.515D+02,8.957D+02,9.869D+02,1.122D+03,1.253D+03,1.366D+03/
+ DATA (SIGMA(J, 13),J=1,6) /
+ &8.769D+02,9.100D+02,1.018D+03,1.119D+03,1.252D+03,1.341D+03/
+ DATA (SIGMA(J, 14),J=1,6) /
+ &9.058D+02,9.532D+02,1.057D+03,1.171D+03,1.302D+03,1.391D+03/
+ DATA (SIGMA(J, 15),J=1,6) /
+ &9.555D+02,9.799D+02,1.098D+03,1.201D+03,1.342D+03,1.444D+03/
+ DATA (SIGMA(J, 16),J=1,6) /
+ &1.009D+03,1.058D+03,1.149D+03,1.290D+03,1.414D+03,1.520D+03/
+ DATA (SIGMA(J, 17),J=1,6) /
+ &9.907D+02,1.045D+03,1.166D+03,1.290D+03,1.384D+03,1.516D+03/
+ DATA (SIGMA(J, 18),J=1,6) /
+ &1.036D+03,1.121D+03,1.198D+03,1.328D+03,1.470D+03,1.592D+03/
+ DATA (SIGMA(J, 19),J=1,6) /
+ &1.083D+03,1.162D+03,1.250D+03,1.371D+03,1.516D+03,1.661D+03/
+ DATA (SIGMA(J, 20),J=1,6) /
+ &1.146D+03,1.215D+03,1.295D+03,1.443D+03,1.544D+03,1.744D+03/
+ DATA (SIGMA(J, 21),J=1,6) /
+ &1.158D+03,1.234D+03,1.292D+03,1.467D+03,1.618D+03,1.750D+03/
+ DATA (SIGMA(J, 22),J=1,6) /
+ &1.153D+03,1.205D+03,1.329D+03,1.451D+03,1.596D+03,1.734D+03/
+ DATA (SIGMA(J, 23),J=1,6) /
+ &1.210D+03,1.274D+03,1.356D+03,1.493D+03,1.655D+03,1.803D+03/
+ DATA (SIGMA(J, 24),J=1,6) /
+ &1.212D+03,1.273D+03,1.398D+03,1.489D+03,1.641D+03,1.800D+03/
+ DATA (SIGMA(J, 25),J=1,6) /
+ &1.236D+03,1.315D+03,1.423D+03,1.561D+03,1.669D+03,1.855D+03/
+ DATA (SIGMA(J, 26),J=1,6) /
+ &1.279D+03,1.345D+03,1.431D+03,1.595D+03,1.734D+03,1.889D+03/
+ DATA (SIGMA(J, 27),J=1,6) /
+ &1.228D+03,1.304D+03,1.438D+03,1.546D+03,1.714D+03,1.836D+03/
+ DATA (SIGMA(J, 28),J=1,6) /
+ &1.289D+03,1.370D+03,1.451D+03,1.597D+03,1.754D+03,1.913D+03/
+ DATA (SIGMA(J, 29),J=1,6) /
+ &1.411D+03,1.469D+03,1.613D+03,1.777D+03,1.910D+03,2.075D+03/
+ DATA (SIGMA(J, 30),J=1,6) /
+ &1.347D+03,1.401D+03,1.498D+03,1.642D+03,1.816D+03,1.975D+03/
+ DATA (SIGMA(J, 31),J=1,6) /
+ &1.359D+03,1.448D+03,1.551D+03,1.694D+03,1.858D+03,2.007D+03/
+ DATA (SIGMA(J, 32),J=1,6) /
+ &1.358D+03,1.460D+03,1.559D+03,1.698D+03,1.842D+03,1.974D+03/
+ DATA (SIGMA(J, 33),J=1,6) /
+ &1.418D+03,1.448D+03,1.578D+03,1.727D+03,1.872D+03,2.047D+03/
+ DATA (SIGMA(J, 34),J=1,6) /
+ &1.433D+03,1.466D+03,1.605D+03,1.738D+03,1.892D+03,2.019D+03/
+ DATA (SIGMA(J, 35),J=1,6) /
+ &1.430D+03,1.511D+03,1.602D+03,1.752D+03,1.935D+03,2.060D+03/
+ DATA (SIGMA(J, 36),J=1,6) /
+ &1.462D+03,1.499D+03,1.653D+03,1.805D+03,1.920D+03,2.057D+03/
+ DATA (SIGMA(J, 37),J=1,6) /
+ &1.470D+03,1.520D+03,1.656D+03,1.818D+03,1.946D+03,2.131D+03/
+ DATA (SIGMA(J, 38),J=1,6) /
+ &1.470D+03,1.542D+03,1.691D+03,1.800D+03,1.968D+03,2.133D+03/
+ DATA (SIGMA(J, 39),J=1,6) /
+ &1.495D+03,1.588D+03,1.676D+03,1.834D+03,1.969D+03,2.163D+03/
+ DATA (SIGMA(J, 40),J=1,6) /
+ &1.525D+03,1.551D+03,1.722D+03,1.833D+03,2.020D+03,2.192D+03/
+ DATA (SIGMA(J, 41),J=1,6) /
+ &1.526D+03,1.615D+03,1.709D+03,1.899D+03,2.040D+03,2.181D+03/
+ DATA (SIGMA(J, 42),J=1,6) /
+ &1.510D+03,1.567D+03,1.716D+03,1.892D+03,2.056D+03,2.197D+03/
+ DATA (SIGMA(J, 43),J=1,6) /
+ &1.557D+03,1.658D+03,1.776D+03,1.898D+03,2.092D+03,2.200D+03/
+ DATA (SIGMA(J, 44),J=1,6) /
+ &1.556D+03,1.645D+03,1.752D+03,1.920D+03,2.091D+03,2.243D+03/
+ DATA (SIGMA(J, 45),J=1,6) /
+ &1.583D+03,1.663D+03,1.798D+03,1.940D+03,2.051D+03,2.263D+03/
+ DATA (SIGMA(J, 46),J=1,6) /
+ &1.599D+03,1.642D+03,1.799D+03,1.941D+03,2.107D+03,2.268D+03/
+ DATA (SIGMA(J, 47),J=1,6) /
+ &1.611D+03,1.692D+03,1.811D+03,1.956D+03,2.107D+03,2.264D+03/
+ DATA (SIGMA(J, 48),J=1,6) /
+ &1.625D+03,1.706D+03,1.819D+03,1.986D+03,2.139D+03,2.354D+03/
+ DATA (SIGMA(J, 49),J=1,6) /
+ &1.666D+03,1.737D+03,1.854D+03,1.971D+03,2.160D+03,2.318D+03/
+ DATA (SIGMA(J, 50),J=1,6) /
+ &1.648D+03,1.747D+03,1.856D+03,2.023D+03,2.181D+03,2.352D+03/
+ DATA (SIGMA(J, 51),J=1,6) /
+ &1.653D+03,1.763D+03,1.868D+03,2.015D+03,2.203D+03,2.386D+03/
+ DATA (SIGMA(J, 52),J=1,6) /
+ &1.690D+03,1.720D+03,1.902D+03,2.027D+03,2.189D+03,2.357D+03/
+ DATA (SIGMA(J, 53),J=1,6) /
+ &1.690D+03,1.750D+03,1.921D+03,2.059D+03,2.208D+03,2.417D+03/
+ DATA (SIGMA(J, 54),J=1,6) /
+ &1.705D+03,1.781D+03,1.911D+03,2.073D+03,2.242D+03,2.411D+03/
+ DATA (SIGMA(J, 55),J=1,6) /
+ &1.714D+03,1.806D+03,1.896D+03,2.100D+03,2.253D+03,2.411D+03/
+ DATA (SIGMA(J, 56),J=1,6) /
+ &1.774D+03,1.813D+03,1.954D+03,2.098D+03,2.280D+03,2.482D+03/
+
+ DATA (SIGQE(J, 2),J=1,6) /
+ &4.141D+01,3.708D+01,5.428D+01,8.696D+01,1.403D+02,1.885D+02/
+ DATA (SIGQE(J, 3),J=1,6) /
+ &4.357D+01,3.894D+01,5.177D+01,9.675D+01,1.447D+02,2.029D+02/
+ DATA (SIGQE(J, 4),J=1,6) /
+ &4.123D+01,3.933D+01,6.070D+01,9.482D+01,1.474D+02,2.023D+02/
+ DATA (SIGQE(J, 5),J=1,6) /
+ &4.681D+01,4.287D+01,6.381D+01,1.050D+02,1.519D+02,2.198D+02/
+ DATA (SIGQE(J, 6),J=1,6) /
+ &5.407D+01,5.195D+01,6.723D+01,1.108D+02,1.750D+02,2.368D+02/
+ DATA (SIGQE(J, 7),J=1,6) /
+ &4.975D+01,4.936D+01,6.880D+01,1.162D+02,1.689D+02,2.329D+02/
+ DATA (SIGQE(J, 8),J=1,6) /
+ &5.361D+01,5.027D+01,6.858D+01,1.177D+02,1.759D+02,2.412D+02/
+ DATA (SIGQE(J, 9),J=1,6) /
+ &4.980D+01,5.063D+01,7.210D+01,1.196D+02,1.806D+02,2.299D+02/
+ DATA (SIGQE(J, 10),J=1,6) /
+ &5.170D+01,5.070D+01,7.105D+01,1.182D+02,1.679D+02,2.411D+02/
+ DATA (SIGQE(J, 11),J=1,6) /
+ &4.950D+01,4.950D+01,7.286D+01,1.137D+02,1.769D+02,2.477D+02/
+ DATA (SIGQE(J, 12),J=1,6) /
+ &5.262D+01,5.133D+01,7.110D+01,1.204D+02,1.789D+02,2.501D+02/
+ DATA (SIGQE(J, 13),J=1,6) /
+ &5.320D+01,5.378D+01,6.847D+01,1.200D+02,1.805D+02,2.442D+02/
+ DATA (SIGQE(J, 14),J=1,6) /
+ &5.638D+01,5.271D+01,6.985D+01,1.209D+02,1.867D+02,2.610D+02/
+ DATA (SIGQE(J, 15),J=1,6) /
+ &5.294D+01,5.353D+01,7.435D+01,1.211D+02,1.899D+02,2.612D+02/
+ DATA (SIGQE(J, 16),J=1,6) /
+ &5.668D+01,5.254D+01,7.557D+01,1.269D+02,1.917D+02,2.707D+02/
+ DATA (SIGQE(J, 17),J=1,6) /
+ &5.456D+01,5.721D+01,7.481D+01,1.208D+02,1.859D+02,2.658D+02/
+ DATA (SIGQE(J, 18),J=1,6) /
+ &5.901D+01,5.382D+01,7.591D+01,1.246D+02,1.872D+02,2.874D+02/
+ DATA (SIGQE(J, 19),J=1,6) /
+ &6.328D+01,6.116D+01,8.451D+01,1.318D+02,2.088D+02,2.749D+02/
+ DATA (SIGQE(J, 20),J=1,6) /
+ &5.779D+01,5.924D+01,8.382D+01,1.370D+02,2.062D+02,2.837D+02/
+ DATA (SIGQE(J, 21),J=1,6) /
+ &7.155D+01,5.732D+01,8.231D+01,1.363D+02,2.047D+02,2.820D+02/
+ DATA (SIGQE(J, 22),J=1,6) /
+ &6.699D+01,5.651D+01,8.511D+01,1.477D+02,2.031D+02,2.921D+02/
+ DATA (SIGQE(J, 23),J=1,6) /
+ &6.179D+01,6.269D+01,9.395D+01,1.437D+02,2.195D+02,2.964D+02/
+ DATA (SIGQE(J, 24),J=1,6) /
+ &6.784D+01,6.028D+01,8.622D+01,1.279D+02,2.214D+02,2.867D+02/
+ DATA (SIGQE(J, 25),J=1,6) /
+ &6.589D+01,5.795D+01,8.890D+01,1.385D+02,2.055D+02,2.988D+02/
+ DATA (SIGQE(J, 26),J=1,6) /
+ &6.364D+01,6.325D+01,8.942D+01,1.421D+02,2.128D+02,3.083D+02/
+ DATA (SIGQE(J, 27),J=1,6) /
+ &6.449D+01,6.664D+01,8.986D+01,1.453D+02,2.140D+02,2.932D+02/
+ DATA (SIGQE(J, 28),J=1,6) /
+ &7.284D+01,6.139D+01,8.867D+01,1.425D+02,2.179D+02,2.978D+02/
+ DATA (SIGQE(J, 29),J=1,6) /
+ &7.221D+01,7.085D+01,9.079D+01,1.482D+02,2.277D+02,2.913D+02/
+ DATA (SIGQE(J, 30),J=1,6) /
+ &6.928D+01,6.294D+01,8.935D+01,1.463D+02,2.265D+02,2.834D+02/
+ DATA (SIGQE(J, 31),J=1,6) /
+ &6.611D+01,6.586D+01,9.133D+01,1.461D+02,2.201D+02,2.959D+02/
+ DATA (SIGQE(J, 32),J=1,6) /
+ &6.401D+01,6.177D+01,8.971D+01,1.480D+02,2.155D+02,3.152D+02/
+ DATA (SIGQE(J, 33),J=1,6) /
+ &7.057D+01,6.918D+01,8.410D+01,1.465D+02,2.288D+02,3.088D+02/
+ DATA (SIGQE(J, 34),J=1,6) /
+ &6.453D+01,7.020D+01,9.272D+01,1.517D+02,2.189D+02,2.999D+02/
+ DATA (SIGQE(J, 35),J=1,6) /
+ &6.741D+01,6.295D+01,9.323D+01,1.536D+02,2.190D+02,2.930D+02/
+ DATA (SIGQE(J, 36),J=1,6) /
+ &6.807D+01,7.046D+01,1.025D+02,1.565D+02,2.315D+02,3.090D+02/
+ DATA (SIGQE(J, 37),J=1,6) /
+ &8.082D+01,6.565D+01,9.160D+01,1.572D+02,2.229D+02,3.125D+02/
+ DATA (SIGQE(J, 38),J=1,6) /
+ &6.494D+01,6.964D+01,9.089D+01,1.653D+02,2.336D+02,3.120D+02/
+ DATA (SIGQE(J, 39),J=1,6) /
+ &6.833D+01,6.860D+01,8.933D+01,1.601D+02,2.261D+02,3.167D+02/
+ DATA (SIGQE(J, 40),J=1,6) /
+ &7.021D+01,6.866D+01,8.437D+01,1.588D+02,2.249D+02,2.941D+02/
+ DATA (SIGQE(J, 41),J=1,6) /
+ &7.122D+01,6.205D+01,9.545D+01,1.582D+02,2.335D+02,3.395D+02/
+ DATA (SIGQE(J, 42),J=1,6) /
+ &7.265D+01,6.936D+01,9.486D+01,1.505D+02,2.379D+02,3.248D+02/
+ DATA (SIGQE(J, 43),J=1,6) /
+ &7.048D+01,7.539D+01,9.192D+01,1.566D+02,2.532D+02,3.182D+02/
+ DATA (SIGQE(J, 44),J=1,6) /
+ &6.650D+01,7.139D+01,9.862D+01,1.602D+02,2.289D+02,3.077D+02/
+ DATA (SIGQE(J, 45),J=1,6) /
+ &7.511D+01,6.893D+01,9.245D+01,1.641D+02,2.519D+02,3.381D+02/
+ DATA (SIGQE(J, 46),J=1,6) /
+ &6.437D+01,6.894D+01,8.697D+01,1.544D+02,2.391D+02,3.213D+02/
+ DATA (SIGQE(J, 47),J=1,6) /
+ &7.980D+01,6.958D+01,1.022D+02,1.609D+02,2.408D+02,3.246D+02/
+ DATA (SIGQE(J, 48),J=1,6) /
+ &7.265D+01,7.313D+01,8.989D+01,1.578D+02,2.387D+02,3.235D+02/
+ DATA (SIGQE(J, 49),J=1,6) /
+ &6.959D+01,6.337D+01,9.084D+01,1.656D+02,2.331D+02,3.226D+02/
+ DATA (SIGQE(J, 50),J=1,6) /
+ &7.371D+01,6.807D+01,9.726D+01,1.535D+02,2.445D+02,3.189D+02/
+ DATA (SIGQE(J, 51),J=1,6) /
+ &7.882D+01,6.680D+01,9.377D+01,1.629D+02,2.448D+02,3.297D+02/
+ DATA (SIGQE(J, 52),J=1,6) /
+ &7.223D+01,6.794D+01,9.925D+01,1.738D+02,2.446D+02,3.162D+02/
+ DATA (SIGQE(J, 53),J=1,6) /
+ &7.703D+01,6.971D+01,9.601D+01,1.595D+02,2.484D+02,3.265D+02/
+ DATA (SIGQE(J, 54),J=1,6) /
+ &7.549D+01,7.459D+01,8.984D+01,1.645D+02,2.348D+02,3.201D+02/
+ DATA (SIGQE(J, 55),J=1,6) /
+ &7.891D+01,6.840D+01,1.017D+02,1.698D+02,2.501D+02,3.429D+02/
+ DATA (SIGQE(J, 56),J=1,6) /
+ &7.545D+01,6.673D+01,1.057D+02,1.684D+02,2.424D+02,3.181D+02/
+
+ ASQS = 0.5D0*LOG10(1.876D+03*E0)
+ JE = MIN(INT((ASQS-AMIN)/DA)+1,NE-2)
+ DO JA=2,IA
+ ABEAM = DBLE(JA)
+ S1 = QUAD_INT(ASQS, AA(JE),AA(JE+1),AA(JE+2),
+ + SIGMA(JE,JA),SIGMA(JE+1,JA),SIGMA(JE+2,JA))
+ S2 = QUAD_INT(ASQS, AA(JE),AA(JE+1),AA(JE+2),
+ + SIGQE(JE,JA),SIGQE(JE+1,JA),SIGQE(JE+2,JA))
+ SSIGNUC(JA) = S1 + S2
+ ALNUC(JA) = ATARGET/(AVOG*SSIGNUC(JA))
+ ENDDO
+ ALNUC(1) = FPNI(E0, 13)
+ SSIGNUC(1) = ATARGET/(AVOG*ALNUC(1))
+
+ RETURN
+ END
+
+
+C*=======================================================================
+C. General utilities
+C=======================================================================
+
+ FUNCTION QUAD_INT (R,X0,X1,X2,V0,V1,V2)
+
+C-----------------------------------------------------------------------
+C...Quadratic interpolation
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ SAVE
+
+ R0=R-X0
+ R1=R-X1
+ R2=R-X2
+ S0=X0-X1
+ S1=X0-X2
+ S2=X1-X2
+ QUAD_INT = V0*R1*R2/(S0*S1)-V1*R0*R2/(S0*S2)+V2*R0*R1/(S1*S2)
+ RETURN
+ END
+C=======================================================================
+
+ FUNCTION GAUSS (FUN, A,B)
+
+C-----------------------------------------------------------------------
+C...Returns the 8 points Gauss-Legendre integral
+C. of function FUN from A to B
+C...........................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION X(8), W(8)
+ SAVE
+ DATA X/.0950125098D0, .2816035507D0, .4580167776D0, .6178762444D0,
+ 1 .7554044083D0, .8656312023D0, .9445750230D0, .9894009349D0/
+ DATA W/.1894506104D0, .1826034150D0, .1691565193D0, .1495959888D0,
+ 1 .1246289712D0, .0951585116D0, .0622535239D0, .0271524594D0/
+
+ XM = 0.5D0*(B+A)
+ XR = 0.5D0*(B-A)
+ SS = 0.D0
+ DO J=1,8
+ DX = XR*X(J)
+ SS = SS + W(J) * (FUN(XM+DX) + FUN(XM-DX))
+ ENDDO
+ GAUSS = XR*SS
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE INVERT_ARRAY (yy, xmin, dx, n, xnew, ymin, dy)
+
+C-----------------------------------------------------------------------
+C.. This subroutine receives one array
+C of n y values in input yy(1:n)
+C that correspond to equispaced values of x_j = xmin + dx*(j-1)
+C
+C and "reverse" the array returning an array of x values
+C xnew (1:n) that corresponds to equispaced values of y
+C The relation is assumed monotonous but can be
+C increasing or decreasing
+C..............................................................
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ dimension yy(n), xnew (n)
+ SAVE
+
+ ymin = yy(1)
+ ymax = yy(n)
+ dy = (ymax - ymin)/float(n-1)
+ xnew (1) = xmin
+ xnew (n) = xmin + dx*float(n-1)
+ k0 = 1
+ do j=2,n-1
+ y = ymin + float(j-1)*dy
+ do k=k0,n
+ if((yy(k) .gt. y) .eqv. (yy(n) .gt. yy(1))) goto 100
+ enddo
+100 y2 = yy(k)
+ y1 = yy(k-1)
+ k0 = k-1
+ x1 = xmin + dx*float(k-2)
+ x2 = x1+dx
+ xnew (j) = x1 + dx* (y-y1)/(y2-y1)
+ enddo
+ return
+ end
+C->
+C=======================================================================
+
+ SUBROUTINE SINCO(S,C)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+ F = TWOPI*S_RNDM(0)
+ C = COS (F)
+ S = SIN (F)
+ RETURN
+ END
+
+C***********************************************************************
+C. Cross sections for cascade calculations (FPNI)
+C=======================================================================
+
+ SUBROUTINE SIGMA_PP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+C...p-p cross sections
+C.
+C. this routine serves the purpose to calculate cascades with different
+C. cross sections
+C.
+C. INPUT: E0 = Laboratory Energy (TeV)
+C.
+C. OUTPUT: SIGT = total cross section
+C. SIGEL = elastic cross section
+C. SIGINEL = inelastic cross section
+C. SLOPE = slope of elastic scattering (GeV**-2)
+C. RHO = Imaginary/Real part of forward elastic amplitude
+C.
+C. (old cross section tables end at 10^6 GeV)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION SSIG0(51)
+ DIMENSION SIGDIF(3)
+ COMMON /CSPA/ ICSPA2(3)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+C...p-p inelastic cross sections (mbarn)
+ DATA (SSIG0(J),J=1,51) /
+ + 32.05D0, 32.06D0, 32.08D0, 32.13D0, 32.22D0, 32.36D0,
+ + 32.56D0, 32.85D0, 33.24D0, 33.75D0, 34.37D0, 35.14D0,
+ + 36.05D0, 37.12D0, 38.37D0, 39.78D0, 41.36D0, 43.13D0,
+ + 45.07D0, 47.18D0, 49.47D0, 51.91D0, 54.54D0, 57.28D0,
+ + 60.15D0, 63.15D0, 66.28D0, 69.48D0, 72.80D0, 76.22D0,
+ + 79.71D0, 83.27D0, 86.87D0, 90.55D0, 94.26D0, 98.05D0,
+ + 101.89D0, 105.75D0, 109.71D0, 113.65D0, 117.60D0, 121.55D0,
+ + 125.53D0, 129.56D0, 133.60D0, 137.70D0, 141.77D0, 145.84D0,
+ + 149.92D0, 154.02D0, 158.15D0/
+
+ ICSPA = ICSPA2(1)
+
+ SQS = SQRT(2000.D0*0.938D0*E0)
+
+* pre-LHC SIBYLL2.1 model
+
+ IF(ICSPA.EQ.-2) THEN
+
+ CALL SIB_SIGMA_EXT(3,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO)
+
+* old standard NUCLIB/SIBYLL model
+
+ ELSE IF(ICSPA.EQ.-1) THEN
+
+ AL = LOG10(SQS)
+ if(AL.le.1.D0) then
+ SIGINEL = SSIG0(1)
+ else
+ J1 = INT((AL - 1.D0)*10.D0) + 1
+ J1 = min(J1,50)
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGINEL = SSIG0(J1)*(1.D0-T) + SSIG0(J1+1)*T
+ endif
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+ SIGT = SIGINEL/(1.D0-R)
+ SIGEL = SIGINEL*R/(1.D0-R)
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO1**2) /CMBARN
+
+* cross section as calculated in SIBYLL
+
+ ELSE IF(ICSPA.EQ.0) THEN
+
+ CALL SIB_SIGMA_HP(1,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+* Donnachie-Landshoff (sig-tot)
+
+ ELSE IF(ICSPA.EQ.1) THEN
+
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,
+ + SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO**2) /CMBARN
+
+* Donnachie-Landshoff (sig-tot and sig-el)
+
+ ELSE IF(ICSPA.EQ.2) THEN
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
+ IMODEL = 1
+ IF(IMODEL.EQ.1) THEN
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+2.D0*ALPHAP*LOG(S)
+ ELSE IF(IMODEL.EQ.2) THEN
+ ALPHAP = 0.3D0
+ SLOPE = 8.D0+2.D0*ALPHAP*LOG(S)
+ ENDIF
+ SIGEL = SIGT**2/(16.D0*PI*SLOPE*CMBARN)
+ SIGINEL = SIGT-SIGEL
+ RHO = 0.D0
+
+* geometrical scaling with Donnachie-Landshoff sig-tot
+
+ ELSE IF(ICSPA.EQ.3) THEN
+
+ R = 0.17D0
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
+
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(16.D0*PI*SIGEL)/CMBARN
+ RHO = 0.D0
+
+c ICSPA=4 reserved for CONEX_EXTENSION
+c ELSE IF(ICSPA.EQ.4) THEN
+
+* cross section from 2014 Review of Particle Physics
+
+ ELSE IF(ICSPA.EQ.5) THEN
+
+c elastic slope not included in fit
+c taking slope parameterization from sigma_pp Donnie.-Landshoff
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+4.D0*ALPHAP*LOG(SQS)
+
+ CALL SIG_RPP2014(1,1,SQS,SLOPE,SIGT,SIGEL,SIGINEL,RHO)
+
+ ENDIF
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIGMA_PIP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+C...pi-p cross sections
+C.
+C. this routine serves the purpose to calculate cascades with different
+C. cross sections
+C.
+C. INPUT: E0 = Laboratory Energy (TeV)
+C.
+C. OUTPUT: SIGT = total cross section
+C. SIGEL = elastic cross section
+C. SIGINEL = inelastic cross section
+C. SLOPE = slope of elastic scattering (GeV**-2)
+C. RHO = Imaginary/Real part of forward elastic amplitude
+C.
+C. (old cross section tables end at 10^6 GeV)
+C-----------------------------------------------------------------------
+Cf2py double precision,intent(in) :: e0
+Cf2py double precision,intent(out) :: sigt, sigel, siginel, slope, rho
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION SSIG0(51)
+ DIMENSION SIGDIF(3)
+ COMMON /CSPA/ ICSPA2(3)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+C...pi-p inelastic cross sections (mbarn)
+ DATA (SSIG0(J),J=1,51) /
+ + 20.76D0, 20.78D0, 20.81D0, 20.88D0, 20.98D0, 21.13D0,
+ + 21.33D0, 21.61D0, 21.96D0, 22.39D0, 22.92D0, 23.56D0,
+ + 24.31D0, 25.18D0, 26.18D0, 27.32D0, 28.60D0, 30.04D0,
+ + 31.64D0, 33.40D0, 35.34D0, 37.43D0, 39.72D0, 42.16D0,
+ + 44.77D0, 47.56D0, 50.53D0, 53.66D0, 56.99D0, 60.50D0,
+ + 64.17D0, 68.03D0, 72.05D0, 76.27D0, 80.67D0, 85.27D0,
+ + 90.08D0, 95.04D0, 100.27D0, 105.65D0, 111.21D0, 116.94D0,
+ + 122.87D0, 129.03D0, 135.37D0, 141.93D0, 148.62D0, 155.49D0,
+ + 162.48D0, 169.60D0, 176.94D0/
+
+ ICSPA = ICSPA2(2)
+
+ SQS = SQRT(2000.D0*0.938D0*E0)
+
+* pre-LHC SIBYLL2.1 model
+
+ IF(ICSPA.EQ.-2) THEN
+
+ CALL SIB_SIGMA_EXT(2,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO)
+
+* old standard NUCLIB/SIBYLL model
+
+ ELSE IF(ICSPA.EQ.-1) THEN
+
+ AL = LOG10(SQS)
+ if(AL.le.1.D0) then
+ SIGINEL = SSIG0(1)
+ else
+ J1 = INT((AL - 1.D0)*10.D0) + 1
+ J1 = min(J1,50)
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGINEL = SSIG0(J1)*(1.D0-T) + SSIG0(J1+1)*T
+ endif
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+ SIGT = SIGINEL/(1.D0-R)
+ SIGEL = SIGINEL*R/(1.D0-R)
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO1**2) /CMBARN
+
+* cross section as calculated in SIBYLL
+
+ ELSE IF(ICSPA.EQ.0) THEN
+
+ CALL SIB_SIGMA_HP(2,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+* Donnachie-Landshoff (sig-tot)
+
+ ELSE IF(ICSPA.EQ.1) THEN
+
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,
+ + SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 13.63D0*S**DELDL+(36.02D0+27.56D0)/2.D0*S**EPSDL
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO**2) /CMBARN
+
+* Donnachie-Landshoff (sig-tot and sig-el)
+
+ ELSE IF(ICSPA.EQ.2) THEN
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 13.63D0*S**DELDL+(36.02D0+27.56D0)/2.D0*S**EPSDL
+ IMODEL = 1
+ IF(IMODEL.EQ.1) THEN
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+2.D0*ALPHAP*LOG(S)
+ ELSE IF(IMODEL.EQ.2) THEN
+ ALPHAP = 0.3D0
+ SLOPE = 8.D0+2.D0*ALPHAP*LOG(S)
+ ENDIF
+ SIGEL = SIGT**2/(16.D0*PI*SLOPE*CMBARN)
+ SIGINEL = SIGT-SIGEL
+ RHO = 0.
+
+* geometrical scaling with Donnachie-Landshoff sig-tot
+
+ ELSE IF(ICSPA.EQ.3) THEN
+
+ R = 0.17D0
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 13.63D0*S**DELDL+(36.02D0+27.56D0)/2.D0*S**EPSDL
+
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(16.D0*PI*SIGEL)/CMBARN
+ RHO = 0.D0
+
+c ICSPA=4 reserved for CONEX_EXTENSION
+c ELSE IF(ICSPA.EQ.4) THEN
+
+* cross section from 2014 Review of Particle Physics
+
+ ELSE IF(ICSPA.EQ.5) THEN
+
+c elastic slope not included in fit
+c taking slope parameterization from sigma_pp Donnie.-Landshoff
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+4.D0*ALPHAP*LOG(SQS)
+
+ CALL SIG_RPP2014(2,1,SQS,SLOPE,SIGT,SIGEL,SIGINEL,RHO)
+
+ ENDIF
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIGMA_KP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+
+C-----------------------------------------------------------------------
+C...K-p cross sections
+C.
+C. this routine serves the purpose to calculate cascades with different
+C. cross sections
+C.
+C. if old cross sections are selected then sigma_pi = sigma_K
+C.
+C. INPUT: E0 = Laboratory Energy (TeV)
+C.
+C. OUTPUT: SIGT = total cross section
+C. SIGEL = elastic cross section
+C. SIGINEL = inelastic cross section
+C. SLOPE = slope of elastic scattering (GeV**-2)
+C. RHO = Imaginary/Real part of forward elastic amplitude
+C.
+C. (old cross section tables end at 10^6 GeV)
+C-----------------------------------------------------------------------
+Cf2py double precision,intent(in) :: e0
+Cf2py double precision,intent(out) :: sigt, sigel, siginel, slope, rho
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ DIMENSION SSIG0(51)
+ DIMENSION SIGDIF(3)
+ COMMON /CSPA/ ICSPA2(3)
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+ SAVE
+
+C...pi-p inelastic cross sections (mbarn)
+ DATA (SSIG0(J),J=1,51) /
+ + 20.76D0, 20.78D0, 20.81D0, 20.88D0, 20.98D0, 21.13D0,
+ + 21.33D0, 21.61D0, 21.96D0, 22.39D0, 22.92D0, 23.56D0,
+ + 24.31D0, 25.18D0, 26.18D0, 27.32D0, 28.60D0, 30.04D0,
+ + 31.64D0, 33.40D0, 35.34D0, 37.43D0, 39.72D0, 42.16D0,
+ + 44.77D0, 47.56D0, 50.53D0, 53.66D0, 56.99D0, 60.50D0,
+ + 64.17D0, 68.03D0, 72.05D0, 76.27D0, 80.67D0, 85.27D0,
+ + 90.08D0, 95.04D0, 100.27D0, 105.65D0, 111.21D0, 116.94D0,
+ + 122.87D0, 129.03D0, 135.37D0, 141.93D0, 148.62D0, 155.49D0,
+ + 162.48D0, 169.60D0, 176.94D0/
+
+ ICSPA = ICSPA2(3)
+
+ SQS = SQRT(2000.D0*0.938D0*E0)
+
+* pre-LHC SIBYLL2.1 model
+
+ IF(ICSPA.EQ.-2) THEN
+
+ CALL SIB_SIGMA_EXT(3,SQS,SIGT,SIGEL,SIGINEL,SLOPE,RHO)
+
+* old standard NUCLIB/SIBYLL model
+
+ ELSE IF(ICSPA.EQ.-1) THEN
+
+ AL = LOG10(SQS)
+ if(AL.le.1.D0) then
+ SIGINEL = SSIG0(1)
+ else
+ J1 = INT((AL - 1.D0)*10.D0) + 1
+ J1 = min(J1,50)
+ T = (AL-1.D0)*10.D0 - DBLE(J1-1)
+ SIGINEL = SSIG0(J1)*(1.D0-T) + SSIG0(J1+1)*T
+ endif
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+ SIGT = SIGINEL/(1.D0-R)
+ SIGEL = SIGINEL*R/(1.D0-R)
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO1**2) /CMBARN
+
+* cross section as calculated in SIBYLL
+
+ ELSE IF(ICSPA.EQ.0) THEN
+
+ CALL SIB_SIGMA_HP(3,SQS,SIGT,SIGEL,SIGINEL,SIGDIF,SLOPE,RHO)
+
+* Donnachie-Landshoff (sig-tot)
+
+ ELSE IF(ICSPA.EQ.1) THEN
+
+ CALL BLOCK(SQS,SIGT1,SIGT2,SLOP1,SLOP2,RHO1,RHO2,
+ + SIGEL1,SIGEL2)
+ R = SIGEL1/SIGT1
+ RHO = RHO1
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 11.82D0*S**DELDL+(26.36D0+ 8.15D0)/2.D0*S**EPSDL
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(SIGEL * 16.D0*PI) * (1.D0+RHO**2) /CMBARN
+
+* Donnachie-Landshoff (sig-tot and sig-el)
+
+ ELSE IF(ICSPA.EQ.2) THEN
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 11.82D0*S**DELDL+(26.36D0+ 8.15D0)/2.D0*S**EPSDL
+ IMODEL = 1
+ IF(IMODEL.EQ.1) THEN
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+2.D0*ALPHAP*LOG(S)
+ ELSE IF(IMODEL.EQ.2) THEN
+ ALPHAP = 0.3D0
+ SLOPE = 8.D0+2.D0*ALPHAP*LOG(S)
+ ENDIF
+ SIGEL = SIGT**2/(16.D0*PI*SLOPE*CMBARN)
+ SIGINEL = SIGT-SIGEL
+ RHO = 0.D0
+
+* geometrical scaling with Donnachie-Landshoff sig-tot
+
+ ELSE IF(ICSPA.EQ.3) THEN
+
+ R = 0.17D0
+
+ DELDL = 0.0808D0
+ EPSDL = -0.4525D0
+ S = SQS*SQS
+ SIGT = 11.82D0*S**DELDL+(26.36D0+ 8.15D0)/2.D0*S**EPSDL
+
+ SIGEL = R*SIGT
+ SIGINEL = SIGT-SIGEL
+ SLOPE = SIGT**2/(16.D0*PI*SIGEL)/CMBARN
+ RHO = 0.D0
+
+c ICSPA=4 reserved for CONEX_EXTENSION
+c ELSE IF(ICSPA.EQ.4) THEN
+
+
+* cross section from 2014 Review of Particle Physics
+
+ ELSE IF(ICSPA.EQ.5) THEN
+
+c elastic slope not included in fit
+c taking slope parameterization from sigma_pp Donnie.-Landshoff
+ ALPHAP = 0.25D0
+ SLOPE = 8.5D0+4.D0*ALPHAP*LOG(SQS)
+
+ CALL SIG_RPP2014(3,1,SQS,SLOPE,SIGT,SIGEL,SIGINEL,RHO)
+
+ ENDIF
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIGMA_INI
+
+C-----------------------------------------------------------------------
+C. Initialize the cross section and interaction lengths in air
+C. cross section model can be chosen, per particle, by setting ICSPA2()
+C. default is Sibyll cross section (0,0,0)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+ COMMON /CSAIR/ ASQSMIN, ASQSMAX, DASQS,
+ & SSIG0(61,3),SSIGA(61,3),ALINT(61,3),NSQS
+
+ COMMON /CSPA/ ICSPA2(3)
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ SAVE
+ DATA ICSPA2 /0,0,0/
+ DATA AVOG /6.0221367D-04/
+ DATA ATARGET /14.514D0/ ! effective masss of air
+
+ IF(NDEBUG.gt.0)
+ & write(lun,*) ' SIGMA_INI: using cross section model no.',
+ & (ICSPA2(i),i=1,3)
+
+ CALL BLOCK_INI
+
+C...Loop on c.m. energy
+ NSQS = 61
+ SQSMIN = 10.D0
+ SQSMAX = 1.d+07
+ ASQSMIN = LOG10(SQSMIN)
+ ASQSMAX = LOG10(SQSMAX)
+ DASQS = (ASQSMAX-ASQSMIN)/DBLE(NSQS-1)
+ DO J=1,NSQS
+ ASQS = ASQSMIN + DASQS*DBLE(J-1)
+ SQS = 10.D0**ASQS
+ E0 = SQS*SQS/(2.D0*0.938D0) * 1.D-03 ! TeV
+C...p-air
+ CALL SIGMA_PP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+C using parametrization by Goulianos for diff. cross section
+c (depends on elastic cross section)
+c used to determine coupling to intermediate resonances in Glauber calc (ALAM)
+c assumed to be universal, i.e. same coupling used for proton, pion and kaons
+ CALL SIB_HADCS1(1,SQS,SIGT1,SIGEL1,SIGINEL1,SLOPE1,RHO1)
+ SIGEFF = 0.68D0*(1.D0+36.D0/SQS**2)
+ & *LOG(0.6D0+0.02D0/1.5D0*SQS**2)
+ SIGEFF = MAX(0.D0,SIGEFF)
+ ALAM = sqrt(SIGEFF/SIGEL1)
+ SSIGSD = 2.D0 * SIGEFF
+ CALL SIG_H_AIR (SIGT, SLOPE, RHO, ALAM,
+ & SSIGT, SSIGEL, SSIGQE, SIGSD, SIGQSD )
+ SSIGA(J,1) = SSIGT-SSIGQE ! had-air production cross section
+ SSIG0(J,1) = SIGINEL ! had-nucleon inel. cross section
+ ALINT(J,1) = 1.D0/(AVOG*SSIGA(J,1)/ATARGET) ! interaction length in air
+C...pi-air
+ CALL SIGMA_PIP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+ CALL SIG_H_AIR (SIGT, SLOPE, RHO, ALAM,
+ & SSIGT, SSIGEL, SSIGQE, SIGSD, SIGQSD )
+ SSIGA(J,2) = SSIGT-SSIGQE
+ SSIG0(J,2) = SIGINEL
+ ALINT(J,2) = 1.D0/(AVOG*SSIGA(J,2)/ATARGET)
+C...K-air
+ CALL SIGMA_KP (E0, SIGT, SIGEL, SIGINEL, SLOPE, RHO)
+ CALL SIG_H_AIR (SIGT, SLOPE, RHO, ALAM,
+ & SSIGT, SSIGEL, SSIGQE, SIGSD, SIGQSD )
+ SSIGA(J,3) = SSIGT-SSIGQE
+ SSIG0(J,3) = SIGINEL
+ ALINT(J,3) = 1.D0/(AVOG*SSIGA(J,3)/ATARGET)
+ ENDDO
+
+ if (ndebug .gt. 0 ) THEN
+ WRITE(LUN,'(1X,A)')
+ & ' SIGMA_INI: NUCLIB interaction lengths [g/cm**2]'
+ WRITE(LUN,'(1X,A)')
+ & ' sqs, p-air, pi-air, K-air'
+ DO J=1,NSQS
+ SQS = 10.D0**(ASQSMIN + DASQS*DBLE(J-1))
+ WRITE(LUN,'(1X,1P,4E12.3)')
+ & SQS,ALINT(J,1),ALINT(J,2),ALINT(J,3)
+ ENDDO
+ endif
+
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION FPNI (E,Linp)
+
+C-----------------------------------------------------------------------
+C...This function returns the interaction length
+C. of an hadronic particle travelling in air
+C.
+C. INPUT: E (TeV) particle energy
+C. Linp particle code
+C. OUTPUT: FPNI (g cm-2)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /CSAIR/ ASQSMIN, ASQSMAX, DASQS,
+ & SSIG0(61,3),SSIGA(61,3),ALINT(61,3),NSQS
+
+ DIMENSION KK(6:14)
+ SAVE
+ DATA KK /3*2, 4*3, 2*1/
+
+ SQS = SQRT(2000.D0*E*0.937D0) ! GeV
+ AL = LOG10 (SQS)
+ L = abs(Linp)
+ IF (AL .LE. ASQSMIN) THEN
+ FPNI = ALINT(1,KK(L))
+ ELSE
+ T = (AL-ASQSMIN)/DASQS
+ J = INT(T)
+ J = MIN(J,NSQS-2)
+ T = T-DBLE(J)
+ FPNI = ((1.D0-T)*ALINT(J+1,KK(L)) + T*ALINT(J+2,KK(L)))
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ FUNCTION FSIGHAIR (E,Linp)
+
+C-----------------------------------------------------------------------
+C...This function returns the production cross section
+C. of an hadronic particle with air calculated in NUCLIB (SIGMA_INI)
+C.
+C. INPUT: E (TeV) particle energy
+C. Linp particle code
+C. OUTPUT: SIG_PROD (mb)
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ COMMON /CSAIR/ ASQSMIN, ASQSMAX, DASQS,
+ & SSIG0(61,3),SSIGA(61,3),ALINT(61,3),NSQS
+
+ DIMENSION KK(6:14)
+ SAVE
+ DATA KK /3*2, 4*3, 2*1/
+
+ SQS = SQRT(2000.D0*E*0.937D0) ! GeV
+ AL = LOG10 (SQS)
+ L = abs(Linp)
+ IF (AL .LE. ASQSMIN) THEN
+ FSIGHAIR = SSIGA(1,KK(L))
+ ELSE
+ T = (AL-ASQSMIN)/DASQS
+ J = INT(T)
+ J = MIN(J,NSQS-2)
+ T = T-DBLE(J)
+ FSIGHAIR = ((1.D0-T)*SSIGA(J+1,KK(L)) + T*SSIGA(J+2,KK(L)))
+ ENDIF
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE INT_LEN_INI
+
+C-----------------------------------------------------------------------
+C...Initialize the interaction lengths from NUCLIB
+C-----------------------------------------------------------------------
+ SAVE
+
+ CALL NUC_GEOM_INI ! nucleus profiles
+ CALL SIGMA_INI ! initialize cross sections
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE TRANSFONSHELL(ECM,XM1in,XM2in,XMAX,IMOD,P1,P2,LBAD)
+
+C-----------------------------------------------------------------------
+C samples 2 --> 2 scattering that puts a particle on its mass shell
+C
+C particle1 is along +z, always receives mass
+C particle2 is along -z, mass only sampled if both aquire mass
+C
+C DEPENDS: slope-parameter in s_difmass
+C
+C INPUT: ECM : center-of-mass energy of scattering particles
+C M1in : mass of first particle
+C M2in : mass of second particle
+C XMAX : maximal mass that can be obtained
+C IMOD : remnant or diffraction mode
+C
+C OUTPUT: P1,P2 : final state 4vectors in two-particle c.m. \FR'14
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+c external types
+ DOUBLE PRECISION ECM,XM1in,XM2in,XMAX,P1,P2
+ DIMENSION P1(5),P2(5)
+ INTEGER IMOD,LBAD
+
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NIPAR_max,NPAR_max
+ PARAMETER (NPAR_max=200,NIPAR_max=100)
+ DOUBLE PRECISION PAR
+ INTEGER IPAR
+ COMMON /S_CFLAFR/ PAR(NPAR_max), IPAR(NIPAR_max)
+ INTEGER ITRY, NREJ
+ COMMON /S_CNT/ ITRY(20), NREJ(20)
+ DOUBLE PRECISION AM,AM2
+ COMMON /S_MASS1/ AM(99), AM2(99)
+
+c internal types
+ DOUBLE PRECISION XMB2,XMT2,AXMX,S,X1,X2,ALX,SLOP0,SLOPE,DB,
+ & T,PTS,PZB2,PZT2,PT,PHI,XMB,XMT,S_RNDM,PTSWTCH
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+ DOUBLE PRECISION SLOP0_0,ASLOP,BSLOP
+ INTEGER II
+ SAVE
+ DATA SLOP0_0 /6.5D0/ ! b (slope_ for Mx**2 > 5 GeV**2
+ DATA ASLOP /31.10362D0/ ! fit to the slope parameter.
+ DATA BSLOP /-15.29012D0/
+
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*) ' TRANSFONSHELL: called with (Ecm,M1,M2,XMAX):',
+ & ECM,XM1in,XM2in,XMAX
+
+ XMB2 = XM1in**2
+ XMT2 = XM2in**2
+
+ AXMX = LOG(XMAX)
+
+ ITRY(6) = 0
+ LBAD = 1
+
+C remnant pt parameters
+c distribution is: exp(-slope*t)
+c slope = aslop + bslop * log(Mx**2)
+c (by default same as in diff.
+c scale with paramterers 90 and 91)
+
+c diff. pt paramters
+ ASLOP = PAR(133)
+ BSLOP = PAR(134)
+ SLOP0_0 = PAR(135)
+
+ S = ECM*ECM
+ X1 = 1.D0-(XMT2-XMB2)/S
+ X2 = 2.D0-X1
+ IF(X2.LT.EPS5) RETURN
+
+ 60 ITRY(6) = ITRY(6) + 1
+ IF(ITRY(6).GT.NREJ(6)) RETURN
+c sample transverse momentum
+ ALX = LOG(MAX(XMT2,XMB2))
+c set slope of pt distribution
+ IF(IMOD.eq.0)THEN
+c diffraction dissociation
+ SLOP0 = SLOP0_0*PAR(93)
+ SLOPE = MAX(SLOP0,ASLOP+BSLOP*ALX)
+ PTSWTCH = 1.D0
+
+ ELSEIF(IMOD.eq.1)THEN
+c remnant excitation
+ IF(IPAR(57).eq.0)THEN
+ ALX = ALX-LOG(AM2(13))
+ SLOP0 = PAR(92)
+ DB = (SLOP0-PAR(90))/AXMX
+ SLOPE = MAX(SLOP0,PAR(90)+DB*PAR(91)*ALX)
+ ELSE
+ ALX = ALX-LOG(AM2(13))
+ SLOP0 = PAR(92)
+ SLOPE = MAX(SLOP0,PAR(90)+PAR(91)*ALX)
+ ENDIF
+ PTSWTCH = 1.D0
+
+ ELSEIF(IMOD.eq.3)THEN
+c no pt
+ PTSWTCH = 0.D0
+ SLOPE = 1.D0
+ ENDIF
+ IF(ndebug.gt.3)
+ & WRITE(LUN,*) ' TRANSFONSHELL: (SLOP0,SLOPE,log(M**2)):',
+ & SLOP0,SLOPE,ALX
+ T = -DLOG(MAX(EPS10,S_RNDM(0)))/SLOPE
+ PTS = T*X1*PTSWTCH
+ PZB2 = S*0.5D0*0.5D0*X1*X1-XMB2-PTS
+ PZT2 = S*0.5D0*0.5D0*X2*X2-XMT2-PTS
+ IF(NDEBUG.gt.3)
+ & WRITE(LUN,*) ' TRANSFONSHELL: (PTS,PZB2,PZT2):',PTS,PZB2,PZT2
+c IF (ABS(PZB2)-PZT2.GT.EPS10) GOTO 60
+ IF (PZB2.lt.0.D0.or.PZT2.LT.0.D0) GOTO 60
+ PT = DSQRT(PTS)
+ PHI = TWOPI*S_RNDM(1)
+ XMB = sqrt(XMB2)
+ XMT = sqrt(XMT2)
+ P2(4) = 0.5D0*ECM*X2
+ P2(3) = -DSQRT(PZT2)
+ P2(1) = PT*dCOS(PHI)
+ P2(2) = PT*dSIN(PHI)
+ P2(5) = XMT
+
+ P1(4) = 0.5D0*ECM*X1
+ P1(3) = DSQRT(PZB2)
+ do ii = 1,2
+ P1(ii) = -P2(ii)
+ enddo
+ P1(5) = XMB
+ IF(NDEBUG.gt.3) THEN
+ WRITE(LUN,*) ' TRANSFONSHELL: (P1):',(p1(ii),ii=1,5)
+ WRITE(LUN,*) ' TRANSFONSHELL: (P2):',(p2(ii),ii=1,5)
+ ENDIF
+ LBAD = 0
+ END
+C=======================================================================
+
+ SUBROUTINE SAMPLE_SEA (ALPHA,ASUP,XMASS,XMAX,X1,X2,PT)
+
+C-----------------------------------------------------------------------
+C. Routine that samples the kinematical variables of a sea quark pair.
+C. INPUT: STR_mass_min : minimal string mass ** 2 = x1 * x2 * s
+C. ASUP : large x suppression exponent
+C. OUTPUT: X1, X2, PT (GeV) /FR'14
+C-----------------------------------------------------------------------
+Cf2py double precision, intent(in) :: ALPHA,ASUP,XMASS,XMAX
+Cf2py double precision, intent(out) :: X1,X2,PT
+ IMPLICIT NONE
+
+c include COMMONs
+ INTEGER NCALL, NDEBUG, LUN
+ COMMON /S_DEBUG/ NCALL, NDEBUG, LUN
+ INTEGER NW_max
+ PARAMETER (NW_max = 20)
+C--------------------------------------------------------------------
+C SIBYLL common blocks containing event information \FR'14
+C--------------------------------------------------------------------
+
+C EVENT INFO COMMON
+C contains overall interaction properties, like
+C SQS : center-of-mass energy
+C S : " " squared
+C PTmin : low pt cut of QCD cross section,
+C i.e. minimal pt of hard minijets
+C Xmin : low-x bound for PDFs,
+C i.e. minimal momentum fraction of hard partons
+C Zmin : logarithm of that
+C KB : PID of beam hadron
+C KT() : PID of target
+C IAT : mass number of target
+ DOUBLE PRECISION SQS,S,PTmin,XMIN,ZMIN
+ INTEGER KB,IAT,KT
+ COMMON /S_RUN/ SQS, S, PTmin, XMIN, ZMIN, KB, KT(NW_max), IAT
+
+C--------------------------------------------------------------------
+C SIBYLL utility common blocks containing constants \FR'14
+C--------------------------------------------------------------------
+ DOUBLE PRECISION EPS3,EPS5,EPS8,EPS10
+ COMMON /SIB_EPS/ EPS3,EPS5,EPS8,EPS10
+
+ DOUBLE PRECISION PI,TWOPI,CMBARN
+ COMMON /SIB_CST/ PI,TWOPI,CMBARN
+
+ DOUBLE PRECISION FACN
+ DIMENSION FACN(3:10)
+ COMMON /SIB_FAC/ FACN
+
+c external type declarations
+ DOUBLE PRECISION ALPHA,ASUP,XMASS,XMAX,X1,X2,PT
+
+c internal types
+ DOUBLE PRECISION XMINA,XM2DIS,XR,SLOPE,S_RNDM,XRNDM
+ SAVE
+
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_SEA: alpha,asup,qmass,xmax',
+ & ALPHA,ASUP,XMASS,XMAX
+
+c min. momentum fraction for massive quarks
+c i.e. sample from 1/(x+x_min)
+ XMINA = 2.D0*XMASS/SQS
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_SEA: xmina:',XMINA
+c exponent of large x suppression: (1-x)**b, b=0 or b>1
+ IF(ABS(ASUP).lt.EPS3)THEN
+c b = 0 , no suppression, sample bare 1/(x+xmin)
+ X1 = XM2DIS(XMINA,XMAX,ALPHA) ! ~(1/x)**alpha
+ X2 = XM2DIS(XMINA,XMAX,ALPHA) ! ~(1/x)**alpha
+
+ ELSEIF(ASUP.ge.EPS3)THEN
+c b >= 1 , sample bare (1-x)**b/(x+xmin)
+ SLOPE = MAX(ASUP,EPS3)
+c quark
+ 100 X1 = XM2DIS(XMINA,XMAX,ALPHA) ! ~(1/x)**alpha
+ XR = LOG(1.D0-X1)-LOG(1.D0-XMINA)
+ XRNDM = S_RNDM(1)
+ IF(ndebug.gt.4)
+ & write(lun,*) ' X1,XR,SLOPE*XR:',X1,XR,SLOPE*XR
+ if(SLOPE*XR.le.LOG(max(XRNDM,eps10))) goto 100
+
+c anti-quark
+ 200 X2 = XM2DIS(XMINA,XMAX,ALPHA) ! ~(1/x)**alpha
+ XR = log(1.D0-X2)-log(1.D0-XMINA)
+ XRNDM = S_RNDM(2)
+ IF(ndebug.gt.4)
+ & write(lun,*) ' X2,XR,SLOPE*XR,XRNDM:',
+ & X2,XR,SLOPE*XR,XRNDM
+ if(SLOPE*XR.le.log(max(XRNDM,eps10))) goto 200
+ ELSE
+ WRITE(LUN,*) ' SAMPLE_SEA: suppression exponent out of range.'
+ WRITE(LUN,*) ' SAMPLE_SEA: ASUP:',ASUP
+ STOP
+ ENDIF
+
+c sample pt
+c not yet implemented... to avoid problem with virtual partons
+ pt = 0.D0
+ IF(ndebug.gt.3)
+ & write(lun,*) ' SAMPLE_SEA: X1,X2,PT:',X1,X2,PT
+
+ END
+C**********************************************
+C
+C contains the src for pion and proton pdf
+C parametrizations according to GRV
+C ( see function head for refs. )
+C
+C 1 pion pdf
+C 2 proton pdf GRV98LO
+C
+C**********************************************
+
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+* *
+* G R V - P I O N - P A R A M E T R I Z A T I O N S *
+* *
+* FOR A DETAILED EXPLANATION SEE : *
+* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
+* *
+* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
+* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
+* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
+* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
+* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
+* *
+* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
+* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
+* *
+* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
+* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
+* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
+* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
+* *
+* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
+* *
+* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C=======================================================================
+
+ SUBROUTINE DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.25D0
+ LAM2 = 0.232D0 * 0.232D0
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.519D0 + 0.180D0 * S - 0.011D0 * S2
+ AKV = 0.499D0 - 0.027D0 * S
+ AGV = 0.381D0 - 0.419D0 * S
+ DV = 0.367D0 + 0.563D0 * S
+ VAP = DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 0.599D0
+ BEG = 1.263D0
+ AKG = 0.482D0 + 0.341D0 * DS
+ BKG = 0.0D0
+ AGG = 0.678D0 + 0.877D0 * S - 0.175D0 * S2
+ BGG = 0.338D0 - 1.597D0 * S
+ CG = 0.0D0 - 0.233D0 * S + 0.406D0 * S2
+ DG = 0.390D0 + 1.053D0 * S
+ EG = 0.618D0 + 2.070D0 * S
+ ESG = 3.676D0
+ GLP =DORFGP(X, S, ALG, BEG, AKG, BKG, AGG, BGG, CG, DG, EG, ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0D0
+ ALS = 0.55D0
+ BES = 0.56D0
+ AKS = 2.538D0 - 0.763D0 * S
+ AGS = -0.748D0
+ BS = 0.313D0 + 0.935D0 * S
+ DS = 3.359D0
+ EST = 4.433D0 + 1.301D0 * S
+ ESS = 9.30D0 - 0.887D0 * S
+ QBP = DORFQP (X, S, SL, ALS, BES, AKS, AGS, BS, DS, EST, ESS)
+C...X * CBAR = X * C :
+ SC = 0.888D0
+ ALC = 1.02D0
+ BEC = 0.39D0
+ AKC = 0.0D0
+ AGC = 0.0D0
+ BC = 1.008D0
+ DC = 1.208D0 + 0.771D0 * S
+ EC = 4.40D0 + 1.493D0 * S
+ ESC = 2.032D0 + 1.901D0 * S
+ CBP = DORFQP (X, S, SC, ALC, BEC, AKC, AGC, BC, DC, EC, ESC)
+C...X * BBAR = X * B :
+ SBO = 1.351D0
+ ALB = 1.03D0
+ BEB = 0.39D0
+ AKB = 0.0D0
+ AGB = 0.0D0
+ BBO = 0.0D0
+ DB = 0.697D0 + 0.855D0 * S
+ EB = 4.51D0 + 1.490D0 * S
+ ESB = 3.056D0 + 1.694D0 * S
+ BBP = DORFQP (X, S, SBO, ALB, BEB, AKB, AGB, BBO, DB, EB, ESB)
+ RETURN
+ END
+C
+C=======================================================================
+
+ SUBROUTINE DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ MU2 = 0.3D0
+ LAM2 = 0.248D0 * 0.248D0
+ S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
+ DS = SQRT (S)
+ S2 = S * S
+C...X * VALENCE :
+ NV = 0.456D0 + 0.150D0 * DS + 0.112D0 * S - 0.019D0 * S2
+ AKV = 0.505D0 - 0.033D0 * S
+ AGV = 0.748D0 - 0.669D0 * DS - 0.133D0 * S
+ DV = 0.365D0 + 0.197D0 * DS + 0.394D0 * S
+ VAP = DORFVP (X, NV, AKV, AGV, DV)
+C...X * GLUON :
+ ALG = 1.096D0
+ BEG = 1.371D0
+ AKG = 0.437D0 - 0.689D0 * DS
+ BKG = -0.631D0
+ AGG = 1.324D0 - 0.441D0 * DS - 0.130D0 * S
+ BGG = -0.955D0 + 0.259D0 * S
+ CG = 1.075D0 - 0.302D0 * S
+ DG = 1.158D0 + 1.229D0 * S
+ EG = 0.0D0 + 2.510D0 * S
+ ESG = 2.604D0 + 0.165D0 * S
+ GLP =DORFGP(X, S, ALG, BEG, AKG, BKG, AGG, BGG, CG, DG, EG, ESG)
+C...X * QBAR (SU(3)-SYMMETRIC SEA) :
+ SL = 0.0D0
+ ALS = 0.85D0
+ BES = 0.96D0
+ AKS = -0.350D0 + 0.806D0 * S
+ AGS = -1.663D0
+ BS = 3.148D0
+ DS = 2.273D0 + 1.438D0 * S
+ EST = 3.214D0 + 1.545D0 * S
+ ESS = 1.341D0 + 1.938D0 * S
+ QBP = DORFQP (X, S, SL, ALS, BES, AKS, AGS, BS, DS, EST, ESS)
+C...X * CBAR = X * C :
+ SC = 0.820D0
+ ALC = 0.98D0
+ BEC = 0.0D0
+ AKC = 0.0D0 - 0.457D0 * S
+ AGC = 0.0D0
+ BC = -1.00D0 + 1.40 D0* S
+ DC = 1.318D0 + 0.584D0 * S
+ EC = 4.45D0 + 1.235D0 * S
+ ESC = 1.496D0 + 1.010D0 * S
+ CBP = DORFQP (X, S, SC, ALC, BEC, AKC, AGC, BC, DC, EC, ESC)
+C...X * BBAR = X * B :
+ SBO = 1.297D0
+ ALB = 0.99D0
+ BEB = 0.0D0
+ AKB = 0.0D0 - 0.172D0 * S
+ AGB = 0.0D0
+ BBO = 0.0D0
+ DB = 1.447D0 + 0.485D0 * S
+ EB = 4.79D0 + 1.164D0 * S
+ ESB = 1.724D0 + 2.121D0 * S
+ BBP = DORFQP (X, S, SBO, ALB, BEB, AKB, AGB, BBO, DB, EB, ESB)
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION DORFVP (X, N, AK, AG, D)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ DORFVP = N * X**AK * (1.D0+ AG*DX) * (1.D0- X)**D
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION DORFGP (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1.D0/X)
+ DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.D0- X)**D
+ RETURN
+ END
+C
+C=======================================================================
+
+ FUNCTION DORFQP (X, S, ST, AL, BE, AK, AG, B, D, E, ES)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1./X)
+ IF (S .LE. ST) THEN
+ DORFQP = 0.0D0
+ ELSE
+ DORFQP = (S-ST)**AL / LX**AK * (1.D0+AG*DX+B*X) * (1.D0- X)**D
+ 1 * EXP(-E + SQRT(ES * S**BE * LX))
+ END IF
+ RETURN
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIB_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
+
+C-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A - Z)
+ SAVE
+
+ DX = SQRT (X)
+ LX = LOG (1.D0/X)
+ IF (S .LE. ST) THEN
+ SIB_DOR92FS = 0.D0
+ ELSE
+ SIB_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
+ 1 * EXP (-E + SQRT (ES * S**BE * LX))
+ END IF
+
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION SIB_DBFINT(NARG,ARG,NA,ENT,TABLE)
+
+C-----------------------------------------------------------------------
+C
+C routine based on CERN library E104
+C
+C multi-dimensional interpolation routine, needed for PHOJET
+C internal cross section tables and several PDF sets (GRV98 and AGL)
+C
+C changed to avoid recursive function calls (R.Engel, 09/98)
+C
+C***********************************************************************
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ INTEGER NA(NARG), INDE(32)
+ DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
+ SAVE
+
+
+ DBFINT = 0.D0
+ SIB_DBFINT = 0.D0
+ IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
+
+ LMAX = 0
+ ISTEP = 1
+ KNOTS = 1
+ INDE(1) = 1
+ WEIGHT(1) = 1.D0
+ DO 100 N = 1, NARG
+ X = ARG(N)
+ NDIM = NA(N)
+ LOCA = LMAX
+ LMIN = LMAX + 1
+ LMAX = LMAX + NDIM
+ IF(NDIM .GT. 2) GOTO 10
+ IF(NDIM .EQ. 1) GOTO 100
+ H = X - ENT(LMIN)
+ IF(ABS(H) .LT. 0.D-8) GOTO 90
+ ISHIFT = ISTEP
+ IF(ABS(X-ENT(LMIN+1)) .LT. 0.D-8) GOTO 21
+ ISHIFT = 0
+ ETA = H / (ENT(LMIN+1) - ENT(LMIN))
+ GOTO 30
+ 10 LOCB = LMAX + 1
+ 11 LOCC = (LOCA+LOCB) / 2
+ IF(X-ENT(LOCC)) 12, 20, 13
+ 12 LOCB = LOCC
+ GOTO 14
+ 13 LOCA = LOCC
+ 14 IF(LOCB-LOCA .GT. 1) GOTO 11
+ LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
+ ISHIFT = (LOCA - LMIN) * ISTEP
+ ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
+ GOTO 30
+ 20 ISHIFT = (LOCC - LMIN) * ISTEP
+ 21 DO 22 K = 1, KNOTS
+ INDE(K) = INDE(K) + ISHIFT
+ 22 CONTINUE
+ GOTO 90
+ 30 DO 31 K = 1, KNOTS
+ INDE(K) = INDE(K) + ISHIFT
+ INDE(K+KNOTS) = INDE(K) + ISTEP
+ WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
+ WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
+ 31 CONTINUE
+ KNOTS = 2*KNOTS
+ 90 ISTEP = ISTEP * NDIM
+ 100 CONTINUE
+ DO 200 K = 1, KNOTS
+ I = INDE(K)
+ DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
+ 200 CONTINUE
+
+ SIB_DBFINT = DBFINT
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE SIB_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
+
+C-----------------------------------------------------------------------
+C***********************************************************************
+C
+C GRV98 parton densities, leading order set
+C
+C For a detailed explanation see
+C M. Glueck, E. Reya, A. Vogt :
+C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
+C (To appear in Eur. Phys. J. C)
+C
+C interpolation routine based on the original GRV98PA routine,
+C adapted to define interpolation table as DATA statements
+C
+C (R.Engel, 09/98)
+C
+C
+C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
+C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
+C
+C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
+C DS = d(bar), SS = s = s(bar), GL = gluon.
+C Always x times the distribution is returned.
+C
+C******************************************************i****************
+ IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+ IMPLICIT INTEGER(I-N)
+
+ PARAMETER (NX=68, NQ=27, NARG=2)
+ DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
+ 1 XSF(NX,NQ), XGF(NX,NQ),
+ 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
+
+ DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
+ & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
+
+ EQUIVALENCE (XUVF(1,1),XUVF_L(1))
+ EQUIVALENCE (XDVF(1,1),XDVF_L(1))
+ EQUIVALENCE (XDEF(1,1),XDEF_L(1))
+ EQUIVALENCE (XUDF(1,1),XUDF_L(1))
+ EQUIVALENCE (XSF(1,1),XSF_L(1))
+ EQUIVALENCE (XGF(1,1),XGF_L(1))
+ SAVE
+
+ DATA (ARRF(K),K= 1, 95) /
+ & -2.0723D+01,-2.0135D+01,-1.9560D+01,-1.8983D+01,-1.8421D+01,
+ & -1.7833D+01,-1.7258D+01,-1.6680D+01,-1.6118D+01,-1.5530D+01,
+ & -1.4955D+01,-1.4378D+01,-1.3816D+01,-1.3479D+01,-1.3122D+01,
+ & -1.2717D+01,-1.2311D+01,-1.1913D+01,-1.1513D+01,-1.1176D+01,
+ & -1.0820D+01,-1.0414D+01,-1.0009D+01,-9.6108D+00,-9.2103D+00,
+ & -8.8739D+00,-8.5172D+00,-8.1117D+00,-7.7063D+00,-7.3082D+00,
+ & -6.9078D+00,-6.5713D+00,-6.2146D+00,-5.8091D+00,-5.4037D+00,
+ & -5.0056D+00,-4.6052D+00,-4.2687D+00,-3.9120D+00,-3.5066D+00,
+ & -3.1011D+00,-2.8134D+00,-2.5257D+00,-2.3026D+00,-2.0794D+00,
+ & -1.8971D+00,-1.7430D+00,-1.6094D+00,-1.4917D+00,-1.3863D+00,
+ & -1.2910D+00,-1.2040D+00,-1.1239D+00,-1.0498D+00,-9.8083D-01,
+ & -9.1629D-01,-7.9851D-01,-6.9315D-01,-5.9784D-01,-5.1083D-01,
+ & -4.3078D-01,-3.5667D-01,-2.8768D-01,-2.2314D-01,-1.6252D-01,
+ & -1.0536D-01,-5.1293D-02, 0.0000D+00,-2.2314D-01, 0.0000D+00,
+ & 2.6236D-01, 5.8779D-01, 9.9325D-01, 1.3863D+00, 1.8563D+00,
+ & 2.3026D+00, 2.7726D+00, 3.2189D+00, 3.6889D+00, 4.1589D+00,
+ & 4.6052D+00, 5.1930D+00, 5.7683D+00, 6.3456D+00, 6.9078D+00,
+ & 7.4955D+00, 8.0709D+00, 8.6482D+00, 9.2103D+00, 9.9988D+00,
+ & 1.0736D+01, 1.1513D+01, 1.2301D+01, 1.3039D+01, 1.3816D+01/
+ DATA (XUVF_L(K),K= 1, 114) /
+ &2.3186D+00,2.2915D+00,2.2645D+00,2.2385D+00,2.2140D+00,2.1876D+00,
+ &2.1623D+00,2.1366D+00,2.1121D+00,2.0862D+00,2.0612D+00,2.0358D+00,
+ &2.0110D+00,1.9963D+00,1.9806D+00,1.9624D+00,1.9446D+00,1.9263D+00,
+ &1.9072D+00,1.8904D+00,1.8724D+00,1.8515D+00,1.8294D+00,1.8085D+00,
+ &1.7865D+00,1.7680D+00,1.7483D+00,1.7249D+00,1.6993D+00,1.6715D+00,
+ &1.6385D+00,1.6141D+00,1.5884D+00,1.5597D+00,1.5337D+00,1.5121D+00,
+ &1.4985D+00,1.4980D+00,1.5116D+00,1.5555D+00,1.6432D+00,1.7434D+00,
+ &1.8861D+00,2.0327D+00,2.2174D+00,2.4015D+00,2.5849D+00,2.7671D+00,
+ &2.9488D+00,3.1308D+00,3.3142D+00,3.4998D+00,3.6885D+00,3.8826D+00,
+ &4.0815D+00,4.2069D+00,4.5481D+00,4.8830D+00,5.2116D+00,5.5351D+00,
+ &5.8553D+00,6.1665D+00,6.4745D+00,6.7767D+00,7.0735D+00,7.3628D+00,
+ &7.6283D+00,0.0000D+00,2.3948D+00,2.3665D+00,2.3388D+00,2.3126D+00,
+ &2.2860D+00,2.2592D+00,2.2327D+00,2.2065D+00,2.1810D+00,2.1541D+00,
+ &2.1284D+00,2.1020D+00,2.0760D+00,2.0605D+00,2.0443D+00,2.0259D+00,
+ &2.0068D+00,1.9873D+00,1.9676D+00,1.9500D+00,1.9312D+00,1.9081D+00,
+ &1.8860D+00,1.8635D+00,1.8406D+00,1.8221D+00,1.8007D+00,1.7764D+00,
+ &1.7489D+00,1.7195D+00,1.6855D+00,1.6600D+00,1.6332D+00,1.6031D+00,
+ &1.5760D+00,1.5532D+00,1.5397D+00,1.5376D+00,1.5507D+00,1.5929D+00,
+ &1.6784D+00,1.7759D+00,1.9129D+00,2.0531D+00,2.2292D+00,2.4032D+00/
+ DATA (XUVF_L(K),K= 115, 228) /
+ &2.5752D+00,2.7449D+00,2.9135D+00,3.0810D+00,3.2491D+00,3.4183D+00,
+ &3.5898D+00,3.7650D+00,3.9437D+00,4.0443D+00,4.3402D+00,4.6262D+00,
+ &4.9009D+00,5.1640D+00,5.4156D+00,5.6530D+00,5.8759D+00,6.0779D+00,
+ &6.2540D+00,6.3836D+00,6.4062D+00,0.0000D+00,2.4808D+00,2.4513D+00,
+ &2.4236D+00,2.3948D+00,2.3680D+00,2.3397D+00,2.3127D+00,2.2853D+00,
+ &2.2585D+00,2.2307D+00,2.2026D+00,2.1762D+00,2.1490D+00,2.1332D+00,
+ &2.1164D+00,2.0964D+00,2.0766D+00,2.0565D+00,2.0353D+00,2.0171D+00,
+ &1.9969D+00,1.9738D+00,1.9501D+00,1.9258D+00,1.9026D+00,1.8821D+00,
+ &1.8594D+00,1.8330D+00,1.8046D+00,1.7734D+00,1.7378D+00,1.7112D+00,
+ &1.6829D+00,1.6514D+00,1.6228D+00,1.5994D+00,1.5840D+00,1.5808D+00,
+ &1.5927D+00,1.6334D+00,1.7157D+00,1.8093D+00,1.9406D+00,2.0735D+00,
+ &2.2394D+00,2.4019D+00,2.5615D+00,2.7178D+00,2.8718D+00,3.0246D+00,
+ &3.1766D+00,3.3284D+00,3.4820D+00,3.6370D+00,3.7952D+00,3.8716D+00,
+ &4.1225D+00,4.3580D+00,4.5798D+00,4.7847D+00,4.9730D+00,5.1395D+00,
+ &5.2832D+00,5.3945D+00,5.4634D+00,5.4612D+00,5.2940D+00,0.0000D+00,
+ &2.5823D+00,2.5527D+00,2.5226D+00,2.4928D+00,2.4650D+00,2.4358D+00,
+ &2.4071D+00,2.3783D+00,2.3505D+00,2.3212D+00,2.2928D+00,2.2636D+00,
+ &2.2360D+00,2.2185D+00,2.2005D+00,2.1801D+00,2.1591D+00,2.1376D+00,
+ &2.1153D+00,2.0960D+00,2.0747D+00,2.0505D+00,2.0247D+00,1.9991D+00/
+ DATA (XUVF_L(K),K= 229, 342) /
+ &1.9746D+00,1.9523D+00,1.9287D+00,1.9000D+00,1.8693D+00,1.8361D+00,
+ &1.7994D+00,1.7711D+00,1.7409D+00,1.7076D+00,1.6772D+00,1.6517D+00,
+ &1.6345D+00,1.6302D+00,1.6408D+00,1.6789D+00,1.7574D+00,1.8457D+00,
+ &1.9692D+00,2.0939D+00,2.2474D+00,2.3969D+00,2.5419D+00,2.6837D+00,
+ &2.8216D+00,2.9573D+00,3.0915D+00,3.2246D+00,3.3583D+00,3.4917D+00,
+ &3.6273D+00,3.6791D+00,3.8823D+00,4.0673D+00,4.2350D+00,4.3813D+00,
+ &4.5072D+00,4.6083D+00,4.6757D+00,4.7055D+00,4.6825D+00,4.5674D+00,
+ &4.2566D+00,0.0000D+00,2.7025D+00,2.6705D+00,2.6393D+00,2.6093D+00,
+ &2.5790D+00,2.5484D+00,2.5184D+00,2.4880D+00,2.4590D+00,2.4277D+00,
+ &2.3971D+00,2.3669D+00,2.3380D+00,2.3200D+00,2.3002D+00,2.2782D+00,
+ &2.2557D+00,2.2331D+00,2.2092D+00,2.1887D+00,2.1660D+00,2.1400D+00,
+ &2.1126D+00,2.0859D+00,2.0586D+00,2.0351D+00,2.0094D+00,1.9786D+00,
+ &1.9453D+00,1.9096D+00,1.8707D+00,1.8406D+00,1.8084D+00,1.7728D+00,
+ &1.7392D+00,1.7128D+00,1.6933D+00,1.6875D+00,1.6949D+00,1.7295D+00,
+ &1.8023D+00,1.8845D+00,1.9991D+00,2.1134D+00,2.2525D+00,2.3868D+00,
+ &2.5160D+00,2.6405D+00,2.7609D+00,2.8781D+00,2.9929D+00,3.1059D+00,
+ &3.2180D+00,3.3292D+00,3.4407D+00,3.4675D+00,3.6225D+00,3.7573D+00,
+ &3.8710D+00,3.9617D+00,4.0270D+00,4.0642D+00,4.0675D+00,4.0263D+00,
+ &3.9240D+00,3.7262D+00,3.3217D+00,0.0000D+00,2.8135D+00,2.7813D+00/
+ DATA (XUVF_L(K),K= 343, 456) /
+ &2.7489D+00,2.7166D+00,2.6850D+00,2.6527D+00,2.6212D+00,2.5898D+00,
+ &2.5592D+00,2.5267D+00,2.4943D+00,2.4636D+00,2.4320D+00,2.4129D+00,
+ &2.3929D+00,2.3695D+00,2.3453D+00,2.3211D+00,2.2959D+00,2.2740D+00,
+ &2.2496D+00,2.2221D+00,2.1931D+00,2.1653D+00,2.1356D+00,2.1112D+00,
+ &2.0830D+00,2.0503D+00,2.0147D+00,1.9766D+00,1.9361D+00,1.9037D+00,
+ &1.8696D+00,1.8318D+00,1.7966D+00,1.7677D+00,1.7459D+00,1.7378D+00,
+ &1.7430D+00,1.7738D+00,1.8407D+00,1.9169D+00,2.0223D+00,2.1273D+00,
+ &2.2537D+00,2.3742D+00,2.4892D+00,2.5990D+00,2.7043D+00,2.8056D+00,
+ &2.9038D+00,3.0000D+00,3.0936D+00,3.1864D+00,3.2782D+00,3.2867D+00,
+ &3.4021D+00,3.4971D+00,3.5691D+00,3.6188D+00,3.6422D+00,3.6335D+00,
+ &3.5908D+00,3.5036D+00,3.3552D+00,3.1085D+00,2.6634D+00,0.0000D+00,
+ &2.9406D+00,2.9062D+00,2.8726D+00,2.8385D+00,2.8060D+00,2.7720D+00,
+ &2.7392D+00,2.7058D+00,2.6734D+00,2.6399D+00,2.6057D+00,2.5722D+00,
+ &2.5390D+00,2.5194D+00,2.4975D+00,2.4728D+00,2.4471D+00,2.4216D+00,
+ &2.3945D+00,2.3712D+00,2.3458D+00,2.3152D+00,2.2856D+00,2.2545D+00,
+ &2.2237D+00,2.1966D+00,2.1672D+00,2.1312D+00,2.0926D+00,2.0521D+00,
+ &2.0093D+00,1.9748D+00,1.9384D+00,1.8975D+00,1.8601D+00,1.8275D+00,
+ &1.8036D+00,1.7924D+00,1.7948D+00,1.8206D+00,1.8808D+00,1.9499D+00,
+ &2.0450D+00,2.1390D+00,2.2512D+00,2.3570D+00,2.4564D+00,2.5501D+00/
+ DATA (XUVF_L(K),K= 457, 570) /
+ &2.6391D+00,2.7240D+00,2.8053D+00,2.8834D+00,2.9590D+00,3.0326D+00,
+ &3.1042D+00,3.0942D+00,3.1727D+00,3.2289D+00,3.2628D+00,3.2739D+00,
+ &3.2574D+00,3.2103D+00,3.1297D+00,3.0047D+00,2.8211D+00,2.5467D+00,
+ &2.0897D+00,0.0000D+00,3.0557D+00,3.0193D+00,2.9840D+00,2.9497D+00,
+ &2.9150D+00,2.8801D+00,2.8454D+00,2.8109D+00,2.7771D+00,2.7412D+00,
+ &2.7065D+00,2.6716D+00,2.6360D+00,2.6149D+00,2.5923D+00,2.5663D+00,
+ &2.5395D+00,2.5120D+00,2.4834D+00,2.4589D+00,2.4330D+00,2.4011D+00,
+ &2.3676D+00,2.3363D+00,2.3027D+00,2.2736D+00,2.2422D+00,2.2040D+00,
+ &2.1629D+00,2.1194D+00,2.0750D+00,2.0384D+00,1.9996D+00,1.9565D+00,
+ &1.9160D+00,1.8811D+00,1.8541D+00,1.8409D+00,1.8399D+00,1.8611D+00,
+ &1.9143D+00,1.9764D+00,2.0622D+00,2.1459D+00,2.2457D+00,2.3385D+00,
+ &2.4249D+00,2.5051D+00,2.5806D+00,2.6515D+00,2.7182D+00,2.7823D+00,
+ &2.8427D+00,2.9008D+00,2.9564D+00,2.9332D+00,2.9828D+00,3.0094D+00,
+ &3.0142D+00,2.9955D+00,2.9537D+00,2.8796D+00,2.7735D+00,2.6260D+00,
+ &2.4242D+00,2.1388D+00,1.6900D+00,0.0000D+00,3.1718D+00,3.1348D+00,
+ &3.0971D+00,3.0610D+00,3.0260D+00,2.9896D+00,2.9533D+00,2.9173D+00,
+ &2.8818D+00,2.8449D+00,2.8072D+00,2.7709D+00,2.7340D+00,2.7121D+00,
+ &2.6877D+00,2.6605D+00,2.6319D+00,2.6032D+00,2.5732D+00,2.5471D+00,
+ &2.5180D+00,2.4851D+00,2.4511D+00,2.4170D+00,2.3817D+00,2.3505D+00/
+ DATA (XUVF_L(K),K= 571, 684) /
+ &2.3172D+00,2.2762D+00,2.2328D+00,2.1868D+00,2.1400D+00,2.1012D+00,
+ &2.0601D+00,2.0136D+00,1.9704D+00,1.9335D+00,1.9035D+00,1.8868D+00,
+ &1.8827D+00,1.8990D+00,1.9452D+00,2.0005D+00,2.0763D+00,2.1507D+00,
+ &2.2377D+00,2.3179D+00,2.3917D+00,2.4592D+00,2.5218D+00,2.5799D+00,
+ &2.6336D+00,2.6843D+00,2.7314D+00,2.7753D+00,2.8166D+00,2.7824D+00,
+ &2.8054D+00,2.8081D+00,2.7893D+00,2.7474D+00,2.6818D+00,2.5888D+00,
+ &2.4646D+00,2.3032D+00,2.0902D+00,1.8025D+00,1.3740D+00,0.0000D+00,
+ &3.2793D+00,3.2385D+00,3.2014D+00,3.1643D+00,3.1270D+00,3.0888D+00,
+ &3.0517D+00,3.0141D+00,2.9773D+00,2.9392D+00,2.9009D+00,2.8610D+00,
+ &2.8230D+00,2.8000D+00,2.7754D+00,2.7459D+00,2.7163D+00,2.6858D+00,
+ &2.6545D+00,2.6270D+00,2.5962D+00,2.5617D+00,2.5271D+00,2.4903D+00,
+ &2.4527D+00,2.4207D+00,2.3851D+00,2.3421D+00,2.2960D+00,2.2476D+00,
+ &2.1987D+00,2.1578D+00,2.1146D+00,2.0670D+00,2.0202D+00,1.9796D+00,
+ &1.9468D+00,1.9282D+00,1.9203D+00,1.9319D+00,1.9712D+00,2.0197D+00,
+ &2.0872D+00,2.1524D+00,2.2288D+00,2.2981D+00,2.3606D+00,2.4177D+00,
+ &2.4692D+00,2.5159D+00,2.5591D+00,2.5981D+00,2.6339D+00,2.6669D+00,
+ &2.6962D+00,2.6528D+00,2.6566D+00,2.6395D+00,2.6028D+00,2.5437D+00,
+ &2.4622D+00,2.3555D+00,2.2200D+00,2.0488D+00,1.8335D+00,1.5506D+00,
+ &1.1442D+00,0.0000D+00,3.3868D+00,3.3470D+00,3.3075D+00,3.2689D+00/
+ DATA (XUVF_L(K),K= 685, 798) /
+ &3.2300D+00,3.1909D+00,3.1517D+00,3.1129D+00,3.0747D+00,3.0335D+00,
+ &2.9946D+00,2.9537D+00,2.9140D+00,2.8896D+00,2.8638D+00,2.8337D+00,
+ &2.8021D+00,2.7705D+00,2.7373D+00,2.7075D+00,2.6767D+00,2.6403D+00,
+ &2.6031D+00,2.5649D+00,2.5258D+00,2.4917D+00,2.4537D+00,2.4080D+00,
+ &2.3597D+00,2.3091D+00,2.2580D+00,2.2150D+00,2.1692D+00,2.1186D+00,
+ &2.0701D+00,2.0257D+00,1.9901D+00,1.9679D+00,1.9571D+00,1.9629D+00,
+ &1.9955D+00,2.0378D+00,2.0963D+00,2.1529D+00,2.2178D+00,2.2766D+00,
+ &2.3287D+00,2.3749D+00,2.4162D+00,2.4529D+00,2.4850D+00,2.5140D+00,
+ &2.5392D+00,2.5617D+00,2.5798D+00,2.5298D+00,2.5151D+00,2.4811D+00,
+ &2.4282D+00,2.3561D+00,2.2611D+00,2.1439D+00,2.0005D+00,1.8252D+00,
+ &1.6091D+00,1.3345D+00,9.5375D-01,0.0000D+00,3.4912D+00,3.4507D+00,
+ &3.4100D+00,3.3696D+00,3.3310D+00,3.2893D+00,3.2496D+00,3.2088D+00,
+ &3.1686D+00,3.1278D+00,3.0865D+00,3.0438D+00,3.0020D+00,2.9766D+00,
+ &2.9494D+00,2.9180D+00,2.8850D+00,2.8520D+00,2.8174D+00,2.7877D+00,
+ &2.7550D+00,2.7169D+00,2.6762D+00,2.6369D+00,2.5958D+00,2.5594D+00,
+ &2.5195D+00,2.4721D+00,2.4211D+00,2.3680D+00,2.3145D+00,2.2695D+00,
+ &2.2214D+00,2.1684D+00,2.1154D+00,2.0706D+00,2.0303D+00,2.0058D+00,
+ &1.9909D+00,1.9920D+00,2.0177D+00,2.0531D+00,2.1031D+00,2.1511D+00,
+ &2.2060D+00,2.2548D+00,2.2972D+00,2.3339D+00,2.3655D+00,2.3927D+00/
+ DATA (XUVF_L(K),K= 799, 912) /
+ &2.4159D+00,2.4357D+00,2.4520D+00,2.4644D+00,2.4735D+00,2.4171D+00,
+ &2.3878D+00,2.3397D+00,2.2743D+00,2.1907D+00,2.0861D+00,1.9611D+00,
+ &1.8128D+00,1.6351D+00,1.4227D+00,1.1584D+00,8.0371D-01,0.0000D+00,
+ &3.5892D+00,3.5473D+00,3.5055D+00,3.4637D+00,3.4230D+00,3.3809D+00,
+ &3.3396D+00,3.2976D+00,3.2571D+00,3.2126D+00,3.1696D+00,3.1272D+00,
+ &3.0840D+00,3.0569D+00,3.0286D+00,2.9959D+00,2.9619D+00,2.9273D+00,
+ &2.8910D+00,2.8598D+00,2.8266D+00,2.7863D+00,2.7448D+00,2.7029D+00,
+ &2.6598D+00,2.6219D+00,2.5804D+00,2.5305D+00,2.4773D+00,2.4214D+00,
+ &2.3662D+00,2.3191D+00,2.2698D+00,2.2126D+00,2.1577D+00,2.1092D+00,
+ &2.0674D+00,2.0393D+00,2.0210D+00,2.0173D+00,2.0367D+00,2.0654D+00,
+ &2.1076D+00,2.1485D+00,2.1942D+00,2.2338D+00,2.2678D+00,2.2959D+00,
+ &2.3193D+00,2.3386D+00,2.3539D+00,2.3660D+00,2.3738D+00,2.3789D+00,
+ &2.3799D+00,2.3197D+00,2.2776D+00,2.2186D+00,2.1426D+00,2.0495D+00,
+ &1.9397D+00,1.8097D+00,1.6583D+00,1.4814D+00,1.2736D+00,1.0200D+00,
+ &6.8880D-01,0.0000D+00,3.7157D+00,3.6699D+00,3.6275D+00,3.5842D+00,
+ &3.5420D+00,3.4972D+00,3.4542D+00,3.4107D+00,3.3678D+00,3.3234D+00,
+ &3.2774D+00,3.2332D+00,3.1870D+00,3.1600D+00,3.1297D+00,3.0952D+00,
+ &3.0595D+00,3.0231D+00,2.9850D+00,2.9534D+00,2.9160D+00,2.8740D+00,
+ &2.8312D+00,2.7872D+00,2.7408D+00,2.7014D+00,2.6568D+00,2.6045D+00/
+ DATA (XUVF_L(K),K= 913, 1026) /
+ &2.5481D+00,2.4895D+00,2.4315D+00,2.3817D+00,2.3283D+00,2.2697D+00,
+ &2.2106D+00,2.1591D+00,2.1128D+00,2.0807D+00,2.0578D+00,2.0477D+00,
+ &2.0583D+00,2.0796D+00,2.1122D+00,2.1433D+00,2.1777D+00,2.2069D+00,
+ &2.2299D+00,2.2483D+00,2.2618D+00,2.2718D+00,2.2778D+00,2.2803D+00,
+ &2.2797D+00,2.2749D+00,2.2668D+00,2.2019D+00,2.1468D+00,2.0761D+00,
+ &1.9902D+00,1.8883D+00,1.7711D+00,1.6370D+00,1.4847D+00,1.3103D+00,
+ &1.1091D+00,8.7047D-01,5.6856D-01,0.0000D+00,3.8327D+00,3.7877D+00,
+ &3.7424D+00,3.6981D+00,3.6540D+00,3.6083D+00,3.5637D+00,3.5184D+00,
+ &3.4753D+00,3.4271D+00,3.3800D+00,3.3325D+00,3.2860D+00,3.2564D+00,
+ &3.2258D+00,3.1893D+00,3.1519D+00,3.1135D+00,3.0738D+00,3.0389D+00,
+ &3.0010D+00,2.9580D+00,2.9118D+00,2.8654D+00,2.8178D+00,2.7758D+00,
+ &2.7289D+00,2.6738D+00,2.6146D+00,2.5530D+00,2.4924D+00,2.4399D+00,
+ &2.3845D+00,2.3213D+00,2.2605D+00,2.2040D+00,2.1540D+00,2.1186D+00,
+ &2.0908D+00,2.0749D+00,2.0772D+00,2.0914D+00,2.1145D+00,2.1368D+00,
+ &2.1613D+00,2.1804D+00,2.1941D+00,2.2037D+00,2.2088D+00,2.2101D+00,
+ &2.2083D+00,2.2031D+00,2.1942D+00,2.1826D+00,2.1665D+00,2.0987D+00,
+ &2.0321D+00,1.9516D+00,1.8571D+00,1.7497D+00,1.6281D+00,1.4923D+00,
+ &1.3406D+00,1.1697D+00,9.7635D-01,7.5209D-01,4.7638D-01,0.0000D+00,
+ &3.9497D+00,3.9009D+00,3.8555D+00,3.8080D+00,3.7630D+00,3.7163D+00/
+ DATA (XUVF_L(K),K= 1027, 1140) /
+ &3.6699D+00,3.6231D+00,3.5765D+00,3.5285D+00,3.4807D+00,3.4305D+00,
+ &3.3810D+00,3.3511D+00,3.3185D+00,3.2805D+00,3.2414D+00,3.2016D+00,
+ &3.1598D+00,3.1244D+00,3.0837D+00,3.0383D+00,2.9908D+00,2.9424D+00,
+ &2.8919D+00,2.8477D+00,2.7990D+00,2.7403D+00,2.6784D+00,2.6142D+00,
+ &2.5507D+00,2.4960D+00,2.4362D+00,2.3710D+00,2.3058D+00,2.2463D+00,
+ &2.1931D+00,2.1539D+00,2.1216D+00,2.0996D+00,2.0940D+00,2.1012D+00,
+ &2.1154D+00,2.1294D+00,2.1444D+00,2.1543D+00,2.1597D+00,2.1610D+00,
+ &2.1585D+00,2.1523D+00,2.1432D+00,2.1307D+00,2.1155D+00,2.0964D+00,
+ &2.0742D+00,2.0035D+00,1.9273D+00,1.8396D+00,1.7387D+00,1.6273D+00,
+ &1.5032D+00,1.3665D+00,1.2164D+00,1.0501D+00,8.6515D-01,6.5470D-01,
+ &4.0284D-01,0.0000D+00,4.0572D+00,4.0093D+00,3.9616D+00,3.9140D+00,
+ &3.8670D+00,3.8185D+00,3.7706D+00,3.7224D+00,3.6746D+00,3.6251D+00,
+ &3.5744D+00,3.5233D+00,3.4720D+00,3.4406D+00,3.4062D+00,3.3671D+00,
+ &3.3263D+00,3.2847D+00,3.2414D+00,3.2046D+00,3.1620D+00,3.1150D+00,
+ &3.0653D+00,3.0145D+00,2.9619D+00,2.9153D+00,2.8641D+00,2.8032D+00,
+ &2.7388D+00,2.6715D+00,2.6056D+00,2.5481D+00,2.4880D+00,2.4171D+00,
+ &2.3496D+00,2.2862D+00,2.2282D+00,2.1865D+00,2.1502D+00,2.1217D+00,
+ &2.1086D+00,2.1086D+00,2.1149D+00,2.1216D+00,2.1275D+00,2.1295D+00,
+ &2.1273D+00,2.1212D+00,2.1119D+00,2.0992D+00,2.0837D+00,2.0653D+00/
+ DATA (XUVF_L(K),K= 1141, 1254) /
+ &2.0442D+00,2.0194D+00,1.9912D+00,1.9193D+00,1.8359D+00,1.7412D+00,
+ &1.6366D+00,1.5214D+00,1.3956D+00,1.2594D+00,1.1115D+00,9.5033D-01,
+ &7.7356D-01,5.7585D-01,3.4506D-01,0.0000D+00,4.1710D+00,4.1201D+00,
+ &4.0712D+00,4.0213D+00,3.9730D+00,3.9228D+00,3.8734D+00,3.8233D+00,
+ &3.7726D+00,3.7217D+00,3.6699D+00,3.6160D+00,3.5640D+00,3.5311D+00,
+ &3.4960D+00,3.4549D+00,3.4121D+00,3.3689D+00,3.3237D+00,3.2848D+00,
+ &3.2425D+00,3.1917D+00,3.1399D+00,3.0866D+00,3.0319D+00,2.9838D+00,
+ &2.9306D+00,2.8668D+00,2.7992D+00,2.7291D+00,2.6605D+00,2.6007D+00,
+ &2.5375D+00,2.4631D+00,2.3919D+00,2.3261D+00,2.2643D+00,2.2183D+00,
+ &2.1772D+00,2.1426D+00,2.1222D+00,2.1155D+00,2.1135D+00,2.1130D+00,
+ &2.1102D+00,2.1039D+00,2.0941D+00,2.0815D+00,2.0652D+00,2.0466D+00,
+ &2.0251D+00,2.0014D+00,1.9746D+00,1.9450D+00,1.9116D+00,1.8381D+00,
+ &1.7481D+00,1.6484D+00,1.5404D+00,1.4225D+00,1.2963D+00,1.1611D+00,
+ &1.0161D+00,8.6047D-01,6.9193D-01,5.0691D-01,2.9581D-01,0.0000D+00,
+ &4.2754D+00,4.2238D+00,4.1737D+00,4.1233D+00,4.0740D+00,4.0219D+00,
+ &3.9713D+00,3.9196D+00,3.8675D+00,3.8160D+00,3.7618D+00,3.7060D+00,
+ &3.6510D+00,3.6173D+00,3.5808D+00,3.5380D+00,3.4941D+00,3.4493D+00,
+ &3.4027D+00,3.3623D+00,3.3163D+00,3.2647D+00,3.2114D+00,3.1563D+00,
+ &3.0989D+00,3.0489D+00,2.9929D+00,2.9263D+00,2.8563D+00,2.7837D+00/
+ DATA (XUVF_L(K),K= 1255, 1368) /
+ &2.7122D+00,2.6501D+00,2.5825D+00,2.5073D+00,2.4327D+00,2.3623D+00,
+ &2.2962D+00,2.2474D+00,2.2020D+00,2.1616D+00,2.1335D+00,2.1209D+00,
+ &2.1113D+00,2.1034D+00,2.0929D+00,2.0795D+00,2.0634D+00,2.0439D+00,
+ &2.0222D+00,1.9982D+00,1.9716D+00,1.9428D+00,1.9113D+00,1.8773D+00,
+ &1.8394D+00,1.7649D+00,1.6692D+00,1.5658D+00,1.4547D+00,1.3360D+00,
+ &1.2095D+00,1.0761D+00,9.3485D-01,7.8430D-01,6.2380D-01,4.5010D-01,
+ &2.5625D-01,0.0000D+00,4.3798D+00,4.3275D+00,4.2762D+00,4.2239D+00,
+ &4.1730D+00,4.1196D+00,4.0674D+00,4.0143D+00,3.9623D+00,3.9056D+00,
+ &3.8502D+00,3.7935D+00,3.7370D+00,3.7018D+00,3.6642D+00,3.6200D+00,
+ &3.5742D+00,3.5277D+00,3.4786D+00,3.4371D+00,3.3901D+00,3.3359D+00,
+ &3.2800D+00,3.2235D+00,3.1639D+00,3.1115D+00,3.0537D+00,2.9847D+00,
+ &2.9116D+00,2.8364D+00,2.7623D+00,2.6973D+00,2.6275D+00,2.5497D+00,
+ &2.4705D+00,2.3972D+00,2.3281D+00,2.2747D+00,2.2253D+00,2.1793D+00,
+ &2.1444D+00,2.1253D+00,2.1081D+00,2.0939D+00,2.0755D+00,2.0555D+00,
+ &2.0332D+00,2.0081D+00,1.9814D+00,1.9522D+00,1.9205D+00,1.8875D+00,
+ &1.8520D+00,1.8139D+00,1.7725D+00,1.6968D+00,1.5976D+00,1.4911D+00,
+ &1.3772D+00,1.2577D+00,1.1320D+00,1.0005D+00,8.6242D-01,7.1750D-01,
+ &5.6466D-01,4.0150D-01,2.2333D-01,0.0000D+00,4.4809D+00,4.4265D+00,
+ &4.3735D+00,4.3193D+00,4.2670D+00,4.2128D+00,4.1585D+00,4.1039D+00/
+ DATA (XUVF_L(K),K= 1369, 1482) /
+ &4.0509D+00,3.9928D+00,3.9351D+00,3.8769D+00,3.8180D+00,3.7821D+00,
+ &3.7434D+00,3.6974D+00,3.6501D+00,3.6019D+00,3.5513D+00,3.5093D+00,
+ &3.4594D+00,3.4035D+00,3.3456D+00,3.2870D+00,3.2250D+00,3.1715D+00,
+ &3.1110D+00,3.0396D+00,2.9639D+00,2.8863D+00,2.8096D+00,2.7429D+00,
+ &2.6702D+00,2.5884D+00,2.5068D+00,2.4296D+00,2.3560D+00,2.3003D+00,
+ &2.2464D+00,2.1951D+00,2.1530D+00,2.1283D+00,2.1045D+00,2.0843D+00,
+ &2.0591D+00,2.0328D+00,2.0047D+00,1.9749D+00,1.9429D+00,1.9096D+00,
+ &1.8740D+00,1.8369D+00,1.7978D+00,1.7560D+00,1.7116D+00,1.6360D+00,
+ &1.5322D+00,1.4233D+00,1.3084D+00,1.1885D+00,1.0637D+00,9.3449D-01,
+ &7.9961D-01,6.6020D-01,5.1453D-01,3.6103D-01,1.9641D-01,0.0000D+00,
+ &4.6169D+00,4.5608D+00,4.5060D+00,4.4504D+00,4.3960D+00,4.3395D+00,
+ &4.2837D+00,4.2262D+00,4.1710D+00,4.1106D+00,4.0517D+00,3.9908D+00,
+ &3.9300D+00,3.8920D+00,3.8509D+00,3.8030D+00,3.7538D+00,3.7035D+00,
+ &3.6494D+00,3.6055D+00,3.5556D+00,3.4966D+00,3.4351D+00,3.3738D+00,
+ &3.3090D+00,3.2518D+00,3.1888D+00,3.1141D+00,3.0348D+00,2.9533D+00,
+ &2.8730D+00,2.8020D+00,2.7264D+00,2.6400D+00,2.5551D+00,2.4732D+00,
+ &2.3941D+00,2.3329D+00,2.2742D+00,2.2147D+00,2.1644D+00,2.1317D+00,
+ &2.0986D+00,2.0700D+00,2.0363D+00,2.0021D+00,1.9668D+00,1.9299D+00,
+ &1.8922D+00,1.8532D+00,1.8125D+00,1.7704D+00,1.7270D+00,1.6809D+00/
+ DATA (XUVF_L(K),K= 1483, 1596) /
+ &1.6327D+00,1.5570D+00,1.4497D+00,1.3373D+00,1.2215D+00,1.1020D+00,
+ &9.7897D-01,8.5304D-01,7.2349D-01,5.9074D-01,4.5411D-01,3.1307D-01,
+ &1.6547D-01,0.0000D+00,4.7403D+00,4.6834D+00,4.6262D+00,4.5696D+00,
+ &4.5140D+00,4.4557D+00,4.3978D+00,4.3393D+00,4.2817D+00,4.2191D+00,
+ &4.1578D+00,4.0941D+00,4.0310D+00,3.9917D+00,3.9492D+00,3.8995D+00,
+ &3.8481D+00,3.7958D+00,3.7411D+00,3.6937D+00,3.6405D+00,3.5806D+00,
+ &3.5171D+00,3.4520D+00,3.3840D+00,3.3254D+00,3.2596D+00,3.1812D+00,
+ &3.0985D+00,3.0137D+00,2.9301D+00,2.8556D+00,2.7782D+00,2.6879D+00,
+ &2.5974D+00,2.5119D+00,2.4281D+00,2.3629D+00,2.2982D+00,2.2324D+00,
+ &2.1730D+00,2.1332D+00,2.0922D+00,2.0570D+00,2.0152D+00,1.9739D+00,
+ &1.9323D+00,1.8902D+00,1.8474D+00,1.8039D+00,1.7589D+00,1.7129D+00,
+ &1.6654D+00,1.6163D+00,1.5652D+00,1.4896D+00,1.3789D+00,1.2649D+00,
+ &1.1487D+00,1.0300D+00,9.0896D-01,7.8619D-01,6.6149D-01,5.3498D-01,
+ &4.0654D-01,2.7586D-01,1.4208D-01,0.0000D+00,4.8699D+00,4.8107D+00,
+ &4.7518D+00,4.6928D+00,4.6350D+00,4.5750D+00,4.5152D+00,4.4524D+00,
+ &4.3956D+00,4.3299D+00,4.2674D+00,4.2014D+00,4.1350D+00,4.0939D+00,
+ &4.0503D+00,3.9982D+00,3.9448D+00,3.8905D+00,3.8328D+00,3.7846D+00,
+ &3.7300D+00,3.6664D+00,3.5991D+00,3.5326D+00,3.4620D+00,3.3998D+00,
+ &3.3311D+00,3.2494D+00,3.1632D+00,3.0752D+00,2.9881D+00,2.9120D+00/
+ DATA (XUVF_L(K),K= 1597, 1710) /
+ &2.8299D+00,2.7339D+00,2.6398D+00,2.5493D+00,2.4611D+00,2.3911D+00,
+ &2.3215D+00,2.2482D+00,2.1812D+00,2.1342D+00,2.0854D+00,2.0427D+00,
+ &1.9932D+00,1.9453D+00,1.8978D+00,1.8504D+00,1.8030D+00,1.7545D+00,
+ &1.7059D+00,1.6565D+00,1.6056D+00,1.5535D+00,1.4989D+00,1.4245D+00,
+ &1.3108D+00,1.1959D+00,1.0798D+00,9.6219D-01,8.4358D-01,7.2422D-01,
+ &6.0451D-01,4.8425D-01,3.6380D-01,2.4286D-01,1.2189D-01,0.0000D+00,
+ &4.9964D+00,4.9356D+00,4.8755D+00,4.8147D+00,4.7550D+00,4.6935D+00,
+ &4.6315D+00,4.5697D+00,4.5062D+00,4.4406D+00,4.3752D+00,4.3061D+00,
+ &4.2380D+00,4.1962D+00,4.1500D+00,4.0963D+00,4.0405D+00,3.9832D+00,
+ &3.9245D+00,3.8728D+00,3.8172D+00,3.7504D+00,3.6811D+00,3.6108D+00,
+ &3.5381D+00,3.4734D+00,3.4018D+00,3.3164D+00,3.2269D+00,3.1352D+00,
+ &3.0446D+00,2.9657D+00,2.8794D+00,2.7800D+00,2.6821D+00,2.5867D+00,
+ &2.4930D+00,2.4184D+00,2.3433D+00,2.2634D+00,2.1877D+00,2.1342D+00,
+ &2.0772D+00,2.0279D+00,1.9713D+00,1.9172D+00,1.8642D+00,1.8120D+00,
+ &1.7600D+00,1.7076D+00,1.6553D+00,1.6027D+00,1.5491D+00,1.4938D+00,
+ &1.4374D+00,1.3637D+00,1.2481D+00,1.1325D+00,1.0166D+00,9.0047D-01,
+ &7.8428D-01,6.6889D-01,5.5381D-01,4.3953D-01,3.2652D-01,2.1461D-01,
+ &1.0498D-01,0.0000D+00,5.1134D+00,5.0511D+00,4.9886D+00,4.9273D+00,
+ &4.8660D+00,4.8016D+00,4.7382D+00,4.6744D+00,4.6106D+00,4.5420D+00/
+ DATA (XUVF_L(K),K= 1711, 1824) /
+ &4.4742D+00,4.4028D+00,4.3320D+00,4.2892D+00,4.2413D+00,4.1858D+00,
+ &4.1281D+00,4.0682D+00,4.0067D+00,3.9556D+00,3.8955D+00,3.8271D+00,
+ &3.7556D+00,3.6829D+00,3.6071D+00,3.5401D+00,3.4662D+00,3.3777D+00,
+ &3.2849D+00,3.1898D+00,3.0960D+00,3.0140D+00,2.9244D+00,2.8224D+00,
+ &2.7183D+00,2.6191D+00,2.5219D+00,2.4431D+00,2.3628D+00,2.2767D+00,
+ &2.1931D+00,2.1332D+00,2.0695D+00,2.0145D+00,1.9514D+00,1.8920D+00,
+ &1.8340D+00,1.7775D+00,1.7215D+00,1.6664D+00,1.6108D+00,1.5553D+00,
+ &1.4995D+00,1.4421D+00,1.3839D+00,1.3103D+00,1.1944D+00,1.0782D+00,
+ &9.6271D-01,8.4822D-01,7.3481D-01,6.2240D-01,5.1184D-01,4.0291D-01,
+ &2.9618D-01,1.9206D-01,9.1846D-02,0.0000D+00,5.2367D+00,5.1713D+00,
+ &5.1071D+00,5.0425D+00,4.9800D+00,4.9141D+00,4.8489D+00,4.7833D+00,
+ &4.7181D+00,4.6457D+00,4.5768D+00,4.5034D+00,4.4300D+00,4.3847D+00,
+ &4.3353D+00,4.2782D+00,4.2182D+00,4.1570D+00,4.0921D+00,4.0385D+00,
+ &3.9782D+00,3.9074D+00,3.8331D+00,3.7575D+00,3.6781D+00,3.6086D+00,
+ &3.5313D+00,3.4401D+00,3.3439D+00,3.2455D+00,3.1483D+00,3.0623D+00,
+ &2.9694D+00,2.8629D+00,2.7561D+00,2.6527D+00,2.5508D+00,2.4669D+00,
+ &2.3816D+00,2.2887D+00,2.1979D+00,2.1317D+00,2.0613D+00,2.0002D+00,
+ &1.9307D+00,1.8659D+00,1.8033D+00,1.7426D+00,1.6834D+00,1.6247D+00,
+ &1.5668D+00,1.5085D+00,1.4504D+00,1.3916D+00,1.3311D+00,1.2591D+00/
+ DATA (XUVF_L(K),K= 1825, 1836) /
+ &1.1415D+00,1.0256D+00,9.1107D-01,7.9840D-01,6.8736D-01,5.7902D-01,
+ &4.7260D-01,3.6895D-01,2.6838D-01,1.7161D-01,8.0264D-02,0.0000D+00/
+ DATA (XDVF_L(K),K= 1, 114) /
+ &1.4230D+00,1.4064D+00,1.3903D+00,1.3749D+00,1.3590D+00,1.3424D+00,
+ &1.3271D+00,1.3114D+00,1.2962D+00,1.2803D+00,1.2647D+00,1.2492D+00,
+ &1.2340D+00,1.2246D+00,1.2155D+00,1.2044D+00,1.1927D+00,1.1814D+00,
+ &1.1695D+00,1.1589D+00,1.1479D+00,1.1347D+00,1.1214D+00,1.1080D+00,
+ &1.0944D+00,1.0824D+00,1.0700D+00,1.0544D+00,1.0371D+00,1.0188D+00,
+ &9.9884D-01,9.8287D-01,9.6563D-01,9.4645D-01,9.2847D-01,9.1313D-01,
+ &9.0246D-01,8.9955D-01,9.0461D-01,9.2737D-01,9.7648D-01,1.0343D+00,
+ &1.1168D+00,1.2030D+00,1.3129D+00,1.4240D+00,1.5357D+00,1.6492D+00,
+ &1.7643D+00,1.8818D+00,2.0016D+00,2.1253D+00,2.2535D+00,2.3853D+00,
+ &2.5225D+00,2.5620D+00,2.7906D+00,3.0230D+00,3.2574D+00,3.4983D+00,
+ &3.7459D+00,4.0062D+00,4.2803D+00,4.5790D+00,4.9150D+00,5.3263D+00,
+ &5.9228D+00,0.0000D+00,1.4698D+00,1.4526D+00,1.4360D+00,1.4199D+00,
+ &1.4030D+00,1.3864D+00,1.3702D+00,1.3542D+00,1.3386D+00,1.3221D+00,
+ &1.3059D+00,1.2896D+00,1.2740D+00,1.2644D+00,1.2544D+00,1.2425D+00,
+ &1.2309D+00,1.2185D+00,1.2061D+00,1.1953D+00,1.1836D+00,1.1697D+00,
+ &1.1558D+00,1.1417D+00,1.1275D+00,1.1154D+00,1.1011D+00,1.0844D+00,
+ &1.0663D+00,1.0471D+00,1.0261D+00,1.0092D+00,9.9133D-01,9.7103D-01,
+ &9.5184D-01,9.3560D-01,9.2380D-01,9.1922D-01,9.2378D-01,9.4563D-01,
+ &9.9235D-01,1.0474D+00,1.1262D+00,1.2078D+00,1.3110D+00,1.4146D+00/
+ DATA (XDVF_L(K),K= 115, 228) /
+ &1.5192D+00,1.6241D+00,1.7298D+00,1.8375D+00,1.9471D+00,2.0592D+00,
+ &2.1741D+00,2.2925D+00,2.4144D+00,2.4425D+00,2.6407D+00,2.8375D+00,
+ &3.0361D+00,3.2345D+00,3.4343D+00,3.6388D+00,3.8488D+00,4.0682D+00,
+ &4.3043D+00,4.5737D+00,4.9280D+00,0.0000D+00,1.5226D+00,1.5047D+00,
+ &1.4874D+00,1.4702D+00,1.4530D+00,1.4363D+00,1.4193D+00,1.4023D+00,
+ &1.3860D+00,1.3690D+00,1.3520D+00,1.3351D+00,1.3190D+00,1.3083D+00,
+ &1.2983D+00,1.2858D+00,1.2733D+00,1.2606D+00,1.2476D+00,1.2362D+00,
+ &1.2237D+00,1.2092D+00,1.1943D+00,1.1795D+00,1.1645D+00,1.1509D+00,
+ &1.1365D+00,1.1185D+00,1.0994D+00,1.0784D+00,1.0566D+00,1.0388D+00,
+ &1.0195D+00,9.9801D-01,9.7765D-01,9.6019D-01,9.4712D-01,9.4158D-01,
+ &9.4524D-01,9.6454D-01,1.0088D+00,1.0604D+00,1.1346D+00,1.2112D+00,
+ &1.3076D+00,1.4038D+00,1.4995D+00,1.5957D+00,1.6918D+00,1.7888D+00,
+ &1.8877D+00,1.9877D+00,2.0896D+00,2.1940D+00,2.2999D+00,2.3168D+00,
+ &2.4844D+00,2.6497D+00,2.8098D+00,2.9678D+00,3.1219D+00,3.2743D+00,
+ &3.4260D+00,3.5742D+00,3.7237D+00,3.8717D+00,4.0300D+00,0.0000D+00,
+ &1.5849D+00,1.5662D+00,1.5482D+00,1.5298D+00,1.5130D+00,1.4944D+00,
+ &1.4769D+00,1.4593D+00,1.4423D+00,1.4243D+00,1.4066D+00,1.3894D+00,
+ &1.3720D+00,1.3607D+00,1.3499D+00,1.3366D+00,1.3237D+00,1.3101D+00,
+ &1.2963D+00,1.2840D+00,1.2709D+00,1.2553D+00,1.2396D+00,1.2232D+00/
+ DATA (XDVF_L(K),K= 229, 342) /
+ &1.2075D+00,1.1932D+00,1.1776D+00,1.1584D+00,1.1377D+00,1.1152D+00,
+ &1.0922D+00,1.0729D+00,1.0524D+00,1.0294D+00,1.0074D+00,9.8843D-01,
+ &9.7377D-01,9.6751D-01,9.6901D-01,9.8606D-01,1.0264D+00,1.0745D+00,
+ &1.1435D+00,1.2136D+00,1.3018D+00,1.3894D+00,1.4758D+00,1.5619D+00,
+ &1.6474D+00,1.7332D+00,1.8194D+00,1.9063D+00,1.9941D+00,2.0832D+00,
+ &2.1725D+00,2.1789D+00,2.3166D+00,2.4460D+00,2.5708D+00,2.6884D+00,
+ &2.7987D+00,2.9025D+00,2.9974D+00,3.0823D+00,3.1538D+00,3.2013D+00,
+ &3.2043D+00,0.0000D+00,1.6586D+00,1.6391D+00,1.6202D+00,1.6014D+00,
+ &1.5830D+00,1.5638D+00,1.5457D+00,1.5267D+00,1.5087D+00,1.4899D+00,
+ &1.4711D+00,1.4517D+00,1.4340D+00,1.4224D+00,1.4107D+00,1.3972D+00,
+ &1.3827D+00,1.3684D+00,1.3535D+00,1.3404D+00,1.3263D+00,1.3096D+00,
+ &1.2927D+00,1.2758D+00,1.2575D+00,1.2422D+00,1.2250D+00,1.2046D+00,
+ &1.1821D+00,1.1579D+00,1.1331D+00,1.1127D+00,1.0905D+00,1.0655D+00,
+ &1.0415D+00,1.0207D+00,1.0042D+00,9.9612D-01,9.9507D-01,1.0089D+00,
+ &1.0451D+00,1.0887D+00,1.1514D+00,1.2146D+00,1.2936D+00,1.3711D+00,
+ &1.4469D+00,1.5220D+00,1.5960D+00,1.6694D+00,1.7428D+00,1.8159D+00,
+ &1.8894D+00,1.9620D+00,2.0344D+00,2.0313D+00,2.1357D+00,2.2333D+00,
+ &2.3215D+00,2.4009D+00,2.4706D+00,2.5292D+00,2.5750D+00,2.6036D+00,
+ &2.6096D+00,2.5783D+00,2.4673D+00,0.0000D+00,1.7269D+00,1.7065D+00/
+ DATA (XDVF_L(K),K= 343, 456) /
+ &1.6866D+00,1.6676D+00,1.6480D+00,1.6279D+00,1.6089D+00,1.5891D+00,
+ &1.5701D+00,1.5502D+00,1.5307D+00,1.5113D+00,1.4910D+00,1.4799D+00,
+ &1.4673D+00,1.4526D+00,1.4373D+00,1.4221D+00,1.4060D+00,1.3922D+00,
+ &1.3771D+00,1.3596D+00,1.3414D+00,1.3234D+00,1.3045D+00,1.2879D+00,
+ &1.2689D+00,1.2468D+00,1.2227D+00,1.1966D+00,1.1706D+00,1.1487D+00,
+ &1.1248D+00,1.0980D+00,1.0724D+00,1.0495D+00,1.0310D+00,1.0212D+00,
+ &1.0181D+00,1.0291D+00,1.0609D+00,1.1002D+00,1.1563D+00,1.2136D+00,
+ &1.2840D+00,1.3528D+00,1.4201D+00,1.4854D+00,1.5492D+00,1.6125D+00,
+ &1.6751D+00,1.7368D+00,1.7981D+00,1.8579D+00,1.9157D+00,1.9057D+00,
+ &1.9875D+00,2.0577D+00,2.1190D+00,2.1700D+00,2.2094D+00,2.2370D+00,
+ &2.2484D+00,2.2403D+00,2.2047D+00,2.1261D+00,1.9567D+00,0.0000D+00,
+ &1.8047D+00,1.7833D+00,1.7626D+00,1.7418D+00,1.7220D+00,1.7009D+00,
+ &1.6810D+00,1.6603D+00,1.6403D+00,1.6193D+00,1.5986D+00,1.5775D+00,
+ &1.5570D+00,1.5441D+00,1.5309D+00,1.5156D+00,1.4991D+00,1.4828D+00,
+ &1.4658D+00,1.4510D+00,1.4350D+00,1.4160D+00,1.3966D+00,1.3772D+00,
+ &1.3565D+00,1.3386D+00,1.3184D+00,1.2942D+00,1.2680D+00,1.2404D+00,
+ &1.2125D+00,1.1887D+00,1.1631D+00,1.1342D+00,1.1064D+00,1.0813D+00,
+ &1.0608D+00,1.0480D+00,1.0426D+00,1.0500D+00,1.0774D+00,1.1111D+00,
+ &1.1608D+00,1.2107D+00,1.2719D+00,1.3315D+00,1.3886D+00,1.4445D+00/
+ DATA (XDVF_L(K),K= 457, 570) /
+ &1.4984D+00,1.5505D+00,1.6020D+00,1.6524D+00,1.7009D+00,1.7480D+00,
+ &1.7926D+00,1.7763D+00,1.8327D+00,1.8794D+00,1.9154D+00,1.9405D+00,
+ &1.9531D+00,1.9537D+00,1.9362D+00,1.8986D+00,1.8325D+00,1.7203D+00,
+ &1.5163D+00,0.0000D+00,1.8755D+00,1.8533D+00,1.8314D+00,1.8106D+00,
+ &1.7890D+00,1.7672D+00,1.7464D+00,1.7248D+00,1.7038D+00,1.6817D+00,
+ &1.6601D+00,1.6385D+00,1.6160D+00,1.6033D+00,1.5889D+00,1.5721D+00,
+ &1.5552D+00,1.5380D+00,1.5199D+00,1.5042D+00,1.4871D+00,1.4670D+00,
+ &1.4463D+00,1.4249D+00,1.4036D+00,1.3843D+00,1.3630D+00,1.3364D+00,
+ &1.3086D+00,1.2791D+00,1.2500D+00,1.2245D+00,1.1971D+00,1.1662D+00,
+ &1.1361D+00,1.1090D+00,1.0858D+00,1.0721D+00,1.0641D+00,1.0676D+00,
+ &1.0898D+00,1.1195D+00,1.1627D+00,1.2069D+00,1.2603D+00,1.3118D+00,
+ &1.3607D+00,1.4079D+00,1.4534D+00,1.4968D+00,1.5392D+00,1.5794D+00,
+ &1.6181D+00,1.6552D+00,1.6888D+00,1.6690D+00,1.7073D+00,1.7353D+00,
+ &1.7530D+00,1.7595D+00,1.7531D+00,1.7338D+00,1.6988D+00,1.6428D+00,
+ &1.5583D+00,1.4293D+00,1.2136D+00,0.0000D+00,1.9470D+00,1.9238D+00,
+ &1.9021D+00,1.8782D+00,1.8570D+00,1.8343D+00,1.8123D+00,1.7898D+00,
+ &1.7680D+00,1.7449D+00,1.7222D+00,1.6994D+00,1.6760D+00,1.6624D+00,
+ &1.6469D+00,1.6299D+00,1.6118D+00,1.5933D+00,1.5742D+00,1.5574D+00,
+ &1.5392D+00,1.5179D+00,1.4955D+00,1.4738D+00,1.4506D+00,1.4300D+00/
+ DATA (XDVF_L(K),K= 571, 684) /
+ &1.4069D+00,1.3792D+00,1.3492D+00,1.3178D+00,1.2868D+00,1.2597D+00,
+ &1.2307D+00,1.1976D+00,1.1654D+00,1.1363D+00,1.1108D+00,1.0945D+00,
+ &1.0840D+00,1.0845D+00,1.1017D+00,1.1268D+00,1.1637D+00,1.2016D+00,
+ &1.2473D+00,1.2910D+00,1.3324D+00,1.3719D+00,1.4090D+00,1.4450D+00,
+ &1.4784D+00,1.5109D+00,1.5404D+00,1.5681D+00,1.5925D+00,1.5689D+00,
+ &1.5916D+00,1.6043D+00,1.6067D+00,1.5981D+00,1.5779D+00,1.5449D+00,
+ &1.4949D+00,1.4262D+00,1.3303D+00,1.1932D+00,9.7657D-01,0.0000D+00,
+ &2.0122D+00,1.9881D+00,1.9640D+00,1.9418D+00,1.9190D+00,1.8954D+00,
+ &1.8721D+00,1.8492D+00,1.8262D+00,1.8024D+00,1.7784D+00,1.7550D+00,
+ &1.7300D+00,1.7157D+00,1.6999D+00,1.6818D+00,1.6627D+00,1.6435D+00,
+ &1.6233D+00,1.6058D+00,1.5866D+00,1.5643D+00,1.5417D+00,1.5178D+00,
+ &1.4926D+00,1.4705D+00,1.4465D+00,1.4174D+00,1.3856D+00,1.3527D+00,
+ &1.3198D+00,1.2914D+00,1.2605D+00,1.2257D+00,1.1915D+00,1.1601D+00,
+ &1.1326D+00,1.1142D+00,1.1016D+00,1.0982D+00,1.1114D+00,1.1321D+00,
+ &1.1637D+00,1.1958D+00,1.2352D+00,1.2722D+00,1.3071D+00,1.3397D+00,
+ &1.3704D+00,1.3995D+00,1.4267D+00,1.4516D+00,1.4736D+00,1.4942D+00,
+ &1.5100D+00,1.4848D+00,1.4955D+00,1.4964D+00,1.4873D+00,1.4675D+00,
+ &1.4366D+00,1.3933D+00,1.3349D+00,1.2585D+00,1.1565D+00,1.0171D+00,
+ &8.0601D-01,0.0000D+00,2.0789D+00,2.0539D+00,2.0294D+00,2.0053D+00/
+ DATA (XDVF_L(K),K= 685, 798) /
+ &1.9820D+00,1.9581D+00,1.9336D+00,1.9096D+00,1.8860D+00,1.8609D+00,
+ &1.8367D+00,1.8106D+00,1.7860D+00,1.7706D+00,1.7543D+00,1.7350D+00,
+ &1.7150D+00,1.6945D+00,1.6735D+00,1.6550D+00,1.6349D+00,1.6112D+00,
+ &1.5864D+00,1.5617D+00,1.5356D+00,1.5128D+00,1.4868D+00,1.4555D+00,
+ &1.4224D+00,1.3876D+00,1.3532D+00,1.3231D+00,1.2904D+00,1.2536D+00,
+ &1.2173D+00,1.1838D+00,1.1545D+00,1.1338D+00,1.1185D+00,1.1113D+00,
+ &1.1199D+00,1.1362D+00,1.1627D+00,1.1895D+00,1.2222D+00,1.2529D+00,
+ &1.2813D+00,1.3080D+00,1.3324D+00,1.3546D+00,1.3756D+00,1.3938D+00,
+ &1.4103D+00,1.4232D+00,1.4319D+00,1.4055D+00,1.4052D+00,1.3959D+00,
+ &1.3768D+00,1.3480D+00,1.3084D+00,1.2576D+00,1.1928D+00,1.1110D+00,
+ &1.0066D+00,8.6804D-01,6.6615D-01,0.0000D+00,2.1434D+00,2.1178D+00,
+ &2.0930D+00,2.0676D+00,2.0440D+00,2.0184D+00,1.9935D+00,1.9686D+00,
+ &1.9439D+00,1.9179D+00,1.8915D+00,1.8663D+00,1.8400D+00,1.8239D+00,
+ &1.8067D+00,1.7863D+00,1.7654D+00,1.7440D+00,1.7219D+00,1.7025D+00,
+ &1.6814D+00,1.6565D+00,1.6311D+00,1.6045D+00,1.5766D+00,1.5526D+00,
+ &1.5250D+00,1.4925D+00,1.4574D+00,1.4213D+00,1.3849D+00,1.3532D+00,
+ &1.3191D+00,1.2800D+00,1.2418D+00,1.2062D+00,1.1743D+00,1.1517D+00,
+ &1.1338D+00,1.1237D+00,1.1272D+00,1.1399D+00,1.1608D+00,1.1828D+00,
+ &1.2092D+00,1.2341D+00,1.2570D+00,1.2774D+00,1.2962D+00,1.3135D+00/
+ DATA (XDVF_L(K),K= 799, 912) /
+ &1.3280D+00,1.3406D+00,1.3511D+00,1.3588D+00,1.3613D+00,1.3335D+00,
+ &1.3246D+00,1.3067D+00,1.2801D+00,1.2441D+00,1.1985D+00,1.1418D+00,
+ &1.0724D+00,9.8806D-01,8.8293D-01,7.4746D-01,5.5665D-01,0.0000D+00,
+ &2.2035D+00,2.1769D+00,2.1514D+00,2.1259D+00,2.1000D+00,2.0743D+00,
+ &2.0488D+00,2.0226D+00,1.9973D+00,1.9702D+00,1.9428D+00,1.9166D+00,
+ &1.8890D+00,1.8729D+00,1.8548D+00,1.8337D+00,1.8116D+00,1.7895D+00,
+ &1.7662D+00,1.7461D+00,1.7239D+00,1.6980D+00,1.6714D+00,1.6436D+00,
+ &1.6146D+00,1.5889D+00,1.5604D+00,1.5266D+00,1.4895D+00,1.4515D+00,
+ &1.4138D+00,1.3806D+00,1.3448D+00,1.3040D+00,1.2638D+00,1.2261D+00,
+ &1.1920D+00,1.1669D+00,1.1469D+00,1.1341D+00,1.1335D+00,1.1420D+00,
+ &1.1583D+00,1.1760D+00,1.1971D+00,1.2168D+00,1.2343D+00,1.2501D+00,
+ &1.2640D+00,1.2762D+00,1.2866D+00,1.2942D+00,1.2996D+00,1.3020D+00,
+ &1.3003D+00,1.2725D+00,1.2557D+00,1.2312D+00,1.1982D+00,1.1569D+00,
+ &1.1068D+00,1.0465D+00,9.7460D-01,8.8884D-01,7.8459D-01,6.5333D-01,
+ &4.7359D-01,0.0000D+00,2.2800D+00,2.2524D+00,2.2256D+00,2.1987D+00,
+ &2.1730D+00,2.1459D+00,2.1192D+00,2.0922D+00,2.0656D+00,2.0374D+00,
+ &2.0100D+00,1.9802D+00,1.9520D+00,1.9346D+00,1.9156D+00,1.8937D+00,
+ &1.8706D+00,1.8475D+00,1.8228D+00,1.8017D+00,1.7783D+00,1.7509D+00,
+ &1.7221D+00,1.6937D+00,1.6627D+00,1.6354D+00,1.6050D+00,1.5688D+00/
+ DATA (XDVF_L(K),K= 913, 1026) /
+ &1.5301D+00,1.4898D+00,1.4503D+00,1.4150D+00,1.3772D+00,1.3339D+00,
+ &1.2911D+00,1.2510D+00,1.2138D+00,1.1866D+00,1.1637D+00,1.1458D+00,
+ &1.1403D+00,1.1441D+00,1.1548D+00,1.1669D+00,1.1817D+00,1.1950D+00,
+ &1.2065D+00,1.2163D+00,1.2249D+00,1.2313D+00,1.2355D+00,1.2379D+00,
+ &1.2379D+00,1.2348D+00,1.2275D+00,1.1987D+00,1.1744D+00,1.1427D+00,
+ &1.1035D+00,1.0570D+00,1.0018D+00,9.3862D-01,8.6494D-01,7.7913D-01,
+ &6.7747D-01,5.5266D-01,3.8741D-01,0.0000D+00,2.3524D+00,2.3243D+00,
+ &2.2963D+00,2.2689D+00,2.2420D+00,2.2137D+00,2.1858D+00,2.1579D+00,
+ &2.1301D+00,2.1011D+00,2.0718D+00,2.0424D+00,2.0120D+00,1.9937D+00,
+ &1.9743D+00,1.9509D+00,1.9267D+00,1.9020D+00,1.8763D+00,1.8541D+00,
+ &1.8295D+00,1.8006D+00,1.7713D+00,1.7402D+00,1.7077D+00,1.6794D+00,
+ &1.6475D+00,1.6087D+00,1.5679D+00,1.5259D+00,1.4840D+00,1.4470D+00,
+ &1.4072D+00,1.3615D+00,1.3163D+00,1.2738D+00,1.2336D+00,1.2045D+00,
+ &1.1783D+00,1.1563D+00,1.1459D+00,1.1457D+00,1.1504D+00,1.1577D+00,
+ &1.1662D+00,1.1742D+00,1.1807D+00,1.1857D+00,1.1886D+00,1.1902D+00,
+ &1.1899D+00,1.1878D+00,1.1830D+00,1.1751D+00,1.1633D+00,1.1345D+00,
+ &1.1039D+00,1.0667D+00,1.0230D+00,9.7228D-01,9.1417D-01,8.4905D-01,
+ &7.7478D-01,6.9004D-01,5.9155D-01,4.7371D-01,3.2191D-01,0.0000D+00,
+ &2.4233D+00,2.3947D+00,2.3653D+00,2.3365D+00,2.3090D+00,2.2800D+00/
+ DATA (XDVF_L(K),K= 1027, 1140) /
+ &2.2512D+00,2.2220D+00,2.1934D+00,2.1628D+00,2.1319D+00,2.1007D+00,
+ &2.0700D+00,2.0512D+00,2.0301D+00,2.0057D+00,1.9809D+00,1.9549D+00,
+ &1.9281D+00,1.9049D+00,1.8791D+00,1.8497D+00,1.8175D+00,1.7854D+00,
+ &1.7507D+00,1.7209D+00,1.6878D+00,1.6474D+00,1.6047D+00,1.5603D+00,
+ &1.5164D+00,1.4777D+00,1.4358D+00,1.3879D+00,1.3403D+00,1.2952D+00,
+ &1.2523D+00,1.2206D+00,1.1913D+00,1.1661D+00,1.1505D+00,1.1462D+00,
+ &1.1460D+00,1.1481D+00,1.1518D+00,1.1545D+00,1.1559D+00,1.1562D+00,
+ &1.1548D+00,1.1523D+00,1.1478D+00,1.1414D+00,1.1331D+00,1.1212D+00,
+ &1.1055D+00,1.0763D+00,1.0405D+00,9.9877D-01,9.5130D-01,8.9815D-01,
+ &8.3813D-01,7.7188D-01,6.9792D-01,6.1492D-01,5.2020D-01,4.0920D-01,
+ &2.7020D-01,0.0000D+00,2.4906D+00,2.4607D+00,2.4307D+00,2.4014D+00,
+ &2.3730D+00,2.3427D+00,2.3127D+00,2.2828D+00,2.2528D+00,2.2213D+00,
+ &2.1903D+00,2.1577D+00,2.1250D+00,2.1053D+00,2.0839D+00,2.0583D+00,
+ &2.0318D+00,2.0051D+00,1.9771D+00,1.9527D+00,1.9259D+00,1.8935D+00,
+ &1.8607D+00,1.8269D+00,1.7917D+00,1.7606D+00,1.7253D+00,1.6833D+00,
+ &1.6387D+00,1.5925D+00,1.5465D+00,1.5061D+00,1.4624D+00,1.4121D+00,
+ &1.3623D+00,1.3152D+00,1.2700D+00,1.2349D+00,1.2036D+00,1.1745D+00,
+ &1.1544D+00,1.1457D+00,1.1410D+00,1.1389D+00,1.1378D+00,1.1357D+00,
+ &1.1332D+00,1.1290D+00,1.1244D+00,1.1176D+00,1.1099D+00,1.0996D+00/
+ DATA (XDVF_L(K),K= 1141, 1254) /
+ &1.0875D+00,1.0729D+00,1.0538D+00,1.0249D+00,9.8511D-01,9.3994D-01,
+ &8.8948D-01,8.3410D-01,7.7332D-01,7.0681D-01,6.3377D-01,5.5280D-01,
+ &4.6214D-01,3.5755D-01,2.2965D-01,0.0000D+00,2.5589D+00,2.5291D+00,
+ &2.4979D+00,2.4676D+00,2.4370D+00,2.4060D+00,2.3753D+00,2.3443D+00,
+ &2.3135D+00,2.2809D+00,2.2486D+00,2.2146D+00,2.1810D+00,2.1602D+00,
+ &2.1376D+00,2.1114D+00,2.0841D+00,2.0557D+00,2.0265D+00,2.0011D+00,
+ &1.9730D+00,1.9392D+00,1.9055D+00,1.8697D+00,1.8327D+00,1.8003D+00,
+ &1.7635D+00,1.7197D+00,1.6727D+00,1.6246D+00,1.5770D+00,1.5346D+00,
+ &1.4890D+00,1.4363D+00,1.3841D+00,1.3341D+00,1.2867D+00,1.2492D+00,
+ &1.2151D+00,1.1824D+00,1.1578D+00,1.1451D+00,1.1356D+00,1.1298D+00,
+ &1.1233D+00,1.1169D+00,1.1105D+00,1.1027D+00,1.0940D+00,1.0840D+00,
+ &1.0726D+00,1.0592D+00,1.0444D+00,1.0265D+00,1.0045D+00,9.7613D-01,
+ &9.3249D-01,8.8451D-01,8.3193D-01,7.7510D-01,7.1373D-01,6.4749D-01,
+ &5.7554D-01,4.9725D-01,4.1072D-01,3.1254D-01,1.9551D-01,0.0000D+00,
+ &2.6244D+00,2.5927D+00,2.5615D+00,2.5299D+00,2.4990D+00,2.4671D+00,
+ &2.4356D+00,2.4034D+00,2.3717D+00,2.3377D+00,2.3034D+00,2.2689D+00,
+ &2.2340D+00,2.2126D+00,2.1892D+00,2.1616D+00,2.1331D+00,2.1040D+00,
+ &2.0736D+00,2.0471D+00,2.0180D+00,1.9830D+00,1.9472D+00,1.9112D+00,
+ &1.8717D+00,1.8375D+00,1.7996D+00,1.7538D+00,1.7053D+00,1.6548D+00/
+ DATA (XDVF_L(K),K= 1255, 1368) /
+ &1.6053D+00,1.5612D+00,1.5138D+00,1.4590D+00,1.4045D+00,1.3516D+00,
+ &1.3023D+00,1.2626D+00,1.2251D+00,1.1889D+00,1.1601D+00,1.1441D+00,
+ &1.1302D+00,1.1201D+00,1.1098D+00,1.0996D+00,1.0888D+00,1.0782D+00,
+ &1.0659D+00,1.0531D+00,1.0388D+00,1.0228D+00,1.0047D+00,9.8480D-01,
+ &9.6040D-01,9.3234D-01,8.8589D-01,8.3563D-01,7.8162D-01,7.2366D-01,
+ &6.6215D-01,5.9658D-01,5.2617D-01,4.5043D-01,3.6787D-01,2.7575D-01,
+ &1.6826D-01,0.0000D+00,2.6886D+00,2.6564D+00,2.6234D+00,2.5908D+00,
+ &2.5600D+00,2.5268D+00,2.4943D+00,2.4612D+00,2.4283D+00,2.3924D+00,
+ &2.3582D+00,2.3219D+00,2.2860D+00,2.2642D+00,2.2394D+00,2.2113D+00,
+ &2.1817D+00,2.1512D+00,2.1198D+00,2.0920D+00,2.0618D+00,2.0268D+00,
+ &1.9890D+00,1.9503D+00,1.9098D+00,1.8739D+00,1.8343D+00,1.7867D+00,
+ &1.7365D+00,1.6843D+00,1.6329D+00,1.5870D+00,1.5377D+00,1.4807D+00,
+ &1.4239D+00,1.3692D+00,1.3169D+00,1.2751D+00,1.2350D+00,1.1954D+00,
+ &1.1624D+00,1.1425D+00,1.1247D+00,1.1110D+00,1.0963D+00,1.0827D+00,
+ &1.0687D+00,1.0547D+00,1.0396D+00,1.0240D+00,1.0070D+00,9.8853D-01,
+ &9.6834D-01,9.4569D-01,9.1962D-01,8.9220D-01,8.4321D-01,7.9105D-01,
+ &7.3592D-01,6.7777D-01,6.1620D-01,5.5143D-01,4.8272D-01,4.0962D-01,
+ &3.3102D-01,2.4455D-01,1.4574D-01,0.0000D+00,2.7496D+00,2.7153D+00,
+ &2.6835D+00,2.6504D+00,2.6180D+00,2.5834D+00,2.5502D+00,2.5161D+00/
+ DATA (XDVF_L(K),K= 1369, 1482) /
+ &2.4824D+00,2.4466D+00,2.4095D+00,2.3736D+00,2.3360D+00,2.3124D+00,
+ &2.2875D+00,2.2580D+00,2.2274D+00,2.1960D+00,2.1631D+00,2.1347D+00,
+ &2.1032D+00,2.0670D+00,2.0277D+00,1.9882D+00,1.9458D+00,1.9086D+00,
+ &1.8675D+00,1.8179D+00,1.7658D+00,1.7122D+00,1.6586D+00,1.6112D+00,
+ &1.5600D+00,1.5010D+00,1.4420D+00,1.3855D+00,1.3294D+00,1.2858D+00,
+ &1.2435D+00,1.2006D+00,1.1641D+00,1.1410D+00,1.1193D+00,1.1023D+00,
+ &1.0837D+00,1.0664D+00,1.0496D+00,1.0329D+00,1.0157D+00,9.9745D-01,
+ &9.7803D-01,9.5735D-01,9.3539D-01,9.1075D-01,8.8302D-01,8.5608D-01,
+ &8.0509D-01,7.5168D-01,6.9580D-01,6.3743D-01,5.7619D-01,5.1233D-01,
+ &4.4547D-01,3.7496D-01,2.9995D-01,2.1862D-01,1.2745D-01,0.0000D+00,
+ &2.8331D+00,2.7978D+00,2.7648D+00,2.7299D+00,2.6960D+00,2.6609D+00,
+ &2.6263D+00,2.5910D+00,2.5561D+00,2.5197D+00,2.4802D+00,2.4424D+00,
+ &2.4030D+00,2.3791D+00,2.3526D+00,2.3216D+00,2.2897D+00,2.2570D+00,
+ &2.2225D+00,2.1925D+00,2.1595D+00,2.1199D+00,2.0799D+00,2.0383D+00,
+ &1.9938D+00,1.9551D+00,1.9121D+00,1.8601D+00,1.8054D+00,1.7494D+00,
+ &1.6932D+00,1.6435D+00,1.5898D+00,1.5280D+00,1.4659D+00,1.4056D+00,
+ &1.3471D+00,1.3010D+00,1.2550D+00,1.2078D+00,1.1652D+00,1.1383D+00,
+ &1.1114D+00,1.0902D+00,1.0668D+00,1.0451D+00,1.0248D+00,1.0039D+00,
+ &9.8353D-01,9.6205D-01,9.4076D-01,9.1705D-01,8.9229D-01,8.6577D-01/
+ DATA (XDVF_L(K),K= 1483, 1596) /
+ &8.3604D-01,8.0985D-01,7.5687D-01,7.0190D-01,6.4516D-01,5.8700D-01,
+ &5.2660D-01,4.6452D-01,3.9995D-01,3.3310D-01,2.6289D-01,1.8826D-01,
+ &1.0655D-01,0.0000D+00,2.9096D+00,2.8732D+00,2.8390D+00,2.8027D+00,
+ &2.7690D+00,2.7325D+00,2.6961D+00,2.6597D+00,2.6231D+00,2.5833D+00,
+ &2.5456D+00,2.5047D+00,2.4650D+00,2.4391D+00,2.4120D+00,2.3799D+00,
+ &2.3462D+00,2.3123D+00,2.2763D+00,2.2451D+00,2.2108D+00,2.1692D+00,
+ &2.1276D+00,2.0835D+00,2.0378D+00,1.9974D+00,1.9525D+00,1.8983D+00,
+ &1.8413D+00,1.7827D+00,1.7243D+00,1.6725D+00,1.6166D+00,1.5520D+00,
+ &1.4872D+00,1.4244D+00,1.3627D+00,1.3136D+00,1.2649D+00,1.2130D+00,
+ &1.1663D+00,1.1352D+00,1.1040D+00,1.0787D+00,1.0514D+00,1.0264D+00,
+ &1.0021D+00,9.7883D-01,9.5548D-01,9.3171D-01,9.0763D-01,8.8283D-01,
+ &8.5596D-01,8.2732D-01,7.9601D-01,7.7056D-01,7.1598D-01,6.6027D-01,
+ &6.0340D-01,5.4514D-01,4.8601D-01,4.2556D-01,3.6359D-01,2.9984D-01,
+ &2.3396D-01,1.6486D-01,9.0844D-02,0.0000D+00,2.9880D+00,2.9510D+00,
+ &2.9150D+00,2.8782D+00,2.8430D+00,2.8048D+00,2.7677D+00,2.7301D+00,
+ &2.6924D+00,2.6517D+00,2.6110D+00,2.5696D+00,2.5280D+00,2.5017D+00,
+ &2.4728D+00,2.4393D+00,2.4042D+00,2.3687D+00,2.3313D+00,2.2988D+00,
+ &2.2631D+00,2.2204D+00,2.1768D+00,2.1312D+00,2.0828D+00,2.0405D+00,
+ &1.9928D+00,1.9364D+00,1.8772D+00,1.8164D+00,1.7558D+00,1.7018D+00/
+ DATA (XDVF_L(K),K= 1597, 1710) /
+ &1.6434D+00,1.5762D+00,1.5084D+00,1.4432D+00,1.3783D+00,1.3261D+00,
+ &1.2741D+00,1.2182D+00,1.1669D+00,1.1315D+00,1.0961D+00,1.0671D+00,
+ &1.0360D+00,1.0071D+00,9.7992D-01,9.5371D-01,9.2801D-01,9.0200D-01,
+ &8.7588D-01,8.4862D-01,8.2038D-01,7.9020D-01,7.5770D-01,7.3298D-01,
+ &6.7721D-01,6.2090D-01,5.6394D-01,5.0631D-01,4.4841D-01,3.8970D-01,
+ &3.3019D-01,2.6973D-01,2.0791D-01,1.4420D-01,7.7416D-02,0.0000D+00,
+ &3.0661D+00,3.0288D+00,2.9911D+00,2.9537D+00,2.9160D+00,2.8778D+00,
+ &2.8392D+00,2.8000D+00,2.7610D+00,2.7200D+00,2.6782D+00,2.6345D+00,
+ &2.5900D+00,2.5625D+00,2.5329D+00,2.4982D+00,2.4617D+00,2.4247D+00,
+ &2.3857D+00,2.3518D+00,2.3145D+00,2.2697D+00,2.2245D+00,2.1764D+00,
+ &2.1269D+00,2.0819D+00,2.0331D+00,1.9746D+00,1.9126D+00,1.8497D+00,
+ &1.7862D+00,1.7303D+00,1.6696D+00,1.5995D+00,1.5285D+00,1.4608D+00,
+ &1.3929D+00,1.3377D+00,1.2826D+00,1.2228D+00,1.1669D+00,1.1279D+00,
+ &1.0882D+00,1.0555D+00,1.0205D+00,9.8876D-01,9.5876D-01,9.2969D-01,
+ &9.0171D-01,8.7356D-01,8.4551D-01,8.1668D-01,7.8701D-01,7.5564D-01,
+ &7.2196D-01,6.9797D-01,6.4121D-01,5.8469D-01,5.2810D-01,4.7131D-01,
+ &4.1460D-01,3.5783D-01,3.0063D-01,2.4338D-01,1.8544D-01,1.2660D-01,
+ &6.6270D-02,0.0000D+00,3.1379D+00,3.0995D+00,3.0600D+00,3.0213D+00,
+ &2.9840D+00,2.9442D+00,2.9047D+00,2.8641D+00,2.8239D+00,2.7813D+00/
+ DATA (XDVF_L(K),K= 1711, 1824) /
+ &2.7383D+00,2.6928D+00,2.6470D+00,2.6191D+00,2.5880D+00,2.5519D+00,
+ &2.5145D+00,2.4761D+00,2.4357D+00,2.4004D+00,2.3615D+00,2.3153D+00,
+ &2.2678D+00,2.2180D+00,2.1669D+00,2.1208D+00,2.0699D+00,2.0087D+00,
+ &1.9447D+00,1.8795D+00,1.8139D+00,1.7558D+00,1.6930D+00,1.6205D+00,
+ &1.5467D+00,1.4759D+00,1.4054D+00,1.3484D+00,1.2895D+00,1.2267D+00,
+ &1.1663D+00,1.1242D+00,1.0808D+00,1.0449D+00,1.0065D+00,9.7194D-01,
+ &9.3967D-01,9.0840D-01,8.7834D-01,8.4891D-01,8.1928D-01,7.8930D-01,
+ &7.5803D-01,7.2562D-01,6.9124D-01,6.6796D-01,6.1058D-01,5.5392D-01,
+ &4.9752D-01,4.4176D-01,3.8633D-01,3.3127D-01,2.7648D-01,2.2186D-01,
+ &1.6735D-01,1.1268D-01,5.7652D-02,0.0000D+00,3.2129D+00,3.1726D+00,
+ &3.1325D+00,3.0928D+00,3.0540D+00,3.0127D+00,2.9717D+00,2.9303D+00,
+ &2.8887D+00,2.8449D+00,2.8001D+00,2.7537D+00,2.7060D+00,2.6766D+00,
+ &2.6453D+00,2.6073D+00,2.5683D+00,2.5286D+00,2.4866D+00,2.4501D+00,
+ &2.4107D+00,2.3628D+00,2.3125D+00,2.2620D+00,2.2079D+00,2.1597D+00,
+ &2.1067D+00,2.0440D+00,1.9778D+00,1.9097D+00,1.8421D+00,1.7819D+00,
+ &1.7169D+00,1.6416D+00,1.5664D+00,1.4922D+00,1.4189D+00,1.3583D+00,
+ &1.2971D+00,1.2300D+00,1.1652D+00,1.1200D+00,1.0729D+00,1.0343D+00,
+ &9.9254D-01,9.5513D-01,9.2006D-01,8.8711D-01,8.5555D-01,8.2426D-01,
+ &7.9305D-01,7.6193D-01,7.2963D-01,6.9636D-01,6.6128D-01,6.3868D-01/
+ DATA (XDVF_L(K),K= 1825, 1836) /
+ &5.8093D-01,5.2428D-01,4.6858D-01,4.1372D-01,3.5972D-01,3.0648D-01,
+ &2.5392D-01,2.0208D-01,1.5083D-01,1.0018D-01,5.0068D-02,0.0000D+00/
+ DATA (XDEF_L(K),K= 1, 114) /
+ &4.3007D-01,4.2474D-01,4.1967D-01,4.1458D-01,4.0970D-01,4.0443D-01,
+ &3.9925D-01,3.9397D-01,3.8864D-01,3.8302D-01,3.7707D-01,3.7100D-01,
+ &3.6470D-01,3.6080D-01,3.5639D-01,3.5109D-01,3.4531D-01,3.3914D-01,
+ &3.3238D-01,3.2609D-01,3.1913D-01,3.1062D-01,3.0152D-01,2.9176D-01,
+ &2.8100D-01,2.7114D-01,2.5952D-01,2.4467D-01,2.2784D-01,2.0937D-01,
+ &1.9117D-01,1.7470D-01,1.5685D-01,1.3678D-01,1.1825D-01,1.0349D-01,
+ &9.4854D-02,9.5054D-02,1.0589D-01,1.3527D-01,1.8584D-01,2.3426D-01,
+ &2.9021D-01,3.3527D-01,3.7670D-01,4.0255D-01,4.1326D-01,4.0880D-01,
+ &3.8831D-01,3.5045D-01,2.9287D-01,2.1298D-01,1.0773D-01,0.0000D+00,
+ &0.0000D+00,2.0644D-01,1.5422D-01,1.0950D-01,7.3614D-02,4.6726D-02,
+ &2.7433D-02,1.4144D-02,6.5080D-03,2.4719D-03,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,4.4398D-01,4.3864D-01,4.3346D-01,4.2809D-01,
+ &4.2290D-01,4.1747D-01,4.1205D-01,4.0650D-01,4.0098D-01,3.9480D-01,
+ &3.8873D-01,3.8226D-01,3.7560D-01,3.7145D-01,3.6678D-01,3.6108D-01,
+ &3.5488D-01,3.4833D-01,3.4123D-01,3.3464D-01,3.2718D-01,3.1811D-01,
+ &3.0838D-01,2.9811D-01,2.8670D-01,2.7630D-01,2.6412D-01,2.4861D-01,
+ &2.3110D-01,2.1209D-01,1.9355D-01,1.7681D-01,1.5878D-01,1.3870D-01,
+ &1.2044D-01,1.0620D-01,9.8341D-02,9.9345D-02,1.1086D-01,1.4055D-01,
+ &1.9033D-01,2.3696D-01,2.8983D-01,3.3137D-01,3.6834D-01,3.8982D-01/
+ DATA (XDEF_L(K),K= 115, 228) /
+ &3.9672D-01,3.8896D-01,3.6609D-01,3.2678D-01,2.6933D-01,1.9181D-01,
+ &9.1683D-02,0.0000D+00,0.0000D+00,1.8955D-01,1.4041D-01,9.8873D-02,
+ &6.5928D-02,4.1462D-02,2.3905D-02,1.2324D-02,5.6113D-03,2.1050D-03,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,4.5980D-01,4.5420D-01,
+ &4.4884D-01,4.4319D-01,4.3780D-01,4.3208D-01,4.2642D-01,4.2053D-01,
+ &4.1457D-01,4.0824D-01,4.0181D-01,3.9484D-01,3.8780D-01,3.8328D-01,
+ &3.7831D-01,3.7223D-01,3.6559D-01,3.5853D-01,3.5072D-01,3.4400D-01,
+ &3.3590D-01,3.2633D-01,3.1598D-01,3.0508D-01,2.9301D-01,2.8197D-01,
+ &2.6915D-01,2.5289D-01,2.3470D-01,2.1511D-01,1.9623D-01,1.7918D-01,
+ &1.6098D-01,1.4092D-01,1.2294D-01,1.0928D-01,1.0224D-01,1.0401D-01,
+ &1.1623D-01,1.4620D-01,1.9488D-01,2.3948D-01,2.8894D-01,3.2681D-01,
+ &3.5905D-01,3.7613D-01,3.7908D-01,3.6817D-01,3.4299D-01,3.0266D-01,
+ &2.4596D-01,1.7115D-01,7.6792D-02,0.0000D+00,0.0000D+00,1.7267D-01,
+ &1.2670D-01,8.8446D-02,5.8458D-02,3.6380D-02,2.0551D-02,1.0608D-02,
+ &4.7732D-03,1.7670D-03,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &4.7845D-01,4.7258D-01,4.6687D-01,4.6107D-01,4.5540D-01,4.4938D-01,
+ &4.4336D-01,4.3728D-01,4.3070D-01,4.2403D-01,4.1702D-01,4.0968D-01,
+ &4.0210D-01,3.9723D-01,3.9181D-01,3.8522D-01,3.7808D-01,3.7047D-01,
+ &3.6211D-01,3.5469D-01,3.4619D-01,3.3582D-01,3.2478D-01,3.1314D-01/
+ DATA (XDEF_L(K),K= 229, 342) /
+ &3.0021D-01,2.8848D-01,2.7488D-01,2.5781D-01,2.3886D-01,2.1865D-01,
+ &1.9932D-01,1.8196D-01,1.6359D-01,1.4359D-01,1.2596D-01,1.1295D-01,
+ &1.0678D-01,1.0933D-01,1.2234D-01,1.5242D-01,1.9969D-01,2.4187D-01,
+ &2.8742D-01,3.2112D-01,3.4825D-01,3.6067D-01,3.5959D-01,3.4546D-01,
+ &3.1813D-01,2.7719D-01,2.2151D-01,1.5037D-01,6.2862D-02,0.0000D+00,
+ &0.0000D+00,1.5516D-01,1.1270D-01,7.7856D-02,5.0916D-02,3.1337D-02,
+ &1.7279D-02,8.9355D-03,3.9672D-03,1.4465D-03,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,5.0059D-01,4.9450D-01,4.8826D-01,4.8213D-01,
+ &4.7610D-01,4.6972D-01,4.6326D-01,4.5655D-01,4.4999D-01,4.4265D-01,
+ &4.3505D-01,4.2703D-01,4.1870D-01,4.1345D-01,4.0758D-01,4.0034D-01,
+ &3.9260D-01,3.8434D-01,3.7539D-01,3.6725D-01,3.5804D-01,3.4696D-01,
+ &3.3492D-01,3.2231D-01,3.0852D-01,2.9601D-01,2.8154D-01,2.6348D-01,
+ &2.4363D-01,2.2272D-01,2.0295D-01,1.8526D-01,1.6669D-01,1.4678D-01,
+ &1.2956D-01,1.1726D-01,1.1212D-01,1.1548D-01,1.2910D-01,1.5906D-01,
+ &2.0458D-01,2.4395D-01,2.8508D-01,3.1418D-01,3.3593D-01,3.4343D-01,
+ &3.3827D-01,3.2104D-01,2.9189D-01,2.5067D-01,1.9688D-01,1.3016D-01,
+ &5.0498D-02,0.0000D+00,0.0000D+00,1.3742D-01,9.8602D-02,6.7357D-02,
+ &4.3555D-02,2.6444D-02,1.4175D-02,7.3561D-03,3.2181D-03,1.1530D-03,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,5.2114D-01,5.1454D-01/
+ DATA (XDEF_L(K),K= 343, 456) /
+ &5.0806D-01,5.0160D-01,4.9520D-01,4.8843D-01,4.8165D-01,4.7456D-01,
+ &4.6738D-01,4.5962D-01,4.5149D-01,4.4293D-01,4.3400D-01,4.2833D-01,
+ &4.2194D-01,4.1420D-01,4.0580D-01,3.9678D-01,3.8741D-01,3.7848D-01,
+ &3.6878D-01,3.5682D-01,3.4416D-01,3.3062D-01,3.1602D-01,3.0269D-01,
+ &2.8749D-01,2.6857D-01,2.4798D-01,2.2641D-01,2.0626D-01,1.8828D-01,
+ &1.6960D-01,1.4976D-01,1.3293D-01,1.2126D-01,1.1684D-01,1.2099D-01,
+ &1.3505D-01,1.6471D-01,2.0841D-01,2.4521D-01,2.8248D-01,3.0770D-01,
+ &3.2484D-01,3.2845D-01,3.1999D-01,3.0047D-01,2.7030D-01,2.2924D-01,
+ &1.7739D-01,1.1482D-01,4.2174D-02,0.0000D+00,0.0000D+00,1.2330D-01,
+ &8.7586D-02,5.9211D-02,3.7890D-02,2.2733D-02,1.1877D-02,6.1865D-03,
+ &2.6713D-03,9.4247D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &5.4423D-01,5.3740D-01,5.3068D-01,5.2385D-01,5.1700D-01,5.0982D-01,
+ &5.0256D-01,4.9509D-01,4.8731D-01,4.7895D-01,4.7023D-01,4.6094D-01,
+ &4.5130D-01,4.4506D-01,4.3820D-01,4.2973D-01,4.2069D-01,4.1108D-01,
+ &4.0069D-01,3.9131D-01,3.8063D-01,3.6796D-01,3.5430D-01,3.3991D-01,
+ &3.2433D-01,3.1014D-01,2.9407D-01,2.7418D-01,2.5281D-01,2.3056D-01,
+ &2.0999D-01,1.9171D-01,1.7291D-01,1.5321D-01,1.3677D-01,1.2578D-01,
+ &1.2220D-01,1.2696D-01,1.4132D-01,1.7056D-01,2.1212D-01,2.4603D-01,
+ &2.7912D-01,3.0023D-01,3.1274D-01,3.1234D-01,3.0087D-01,2.7925D-01/
+ DATA (XDEF_L(K),K= 457, 570) /
+ &2.4820D-01,2.0782D-01,1.5841D-01,1.0056D-01,3.5470D-02,0.0000D+00,
+ &0.0000D+00,1.0941D-01,7.6864D-02,5.1391D-02,3.2506D-02,1.9250D-02,
+ &9.7741D-03,5.1192D-03,2.1775D-03,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,5.6542D-01,5.5814D-01,5.5101D-01,5.4385D-01,
+ &5.3670D-01,5.2913D-01,5.2140D-01,5.1352D-01,5.0533D-01,4.9639D-01,
+ &4.8702D-01,4.7710D-01,4.6670D-01,4.6011D-01,4.5270D-01,4.4365D-01,
+ &4.3394D-01,4.2383D-01,4.1271D-01,4.0253D-01,3.9137D-01,3.7783D-01,
+ &3.6325D-01,3.4810D-01,3.3163D-01,3.1674D-01,2.9988D-01,2.7922D-01,
+ &2.5706D-01,2.3429D-01,2.1333D-01,1.9484D-01,1.7592D-01,1.5634D-01,
+ &1.4028D-01,1.2985D-01,1.2692D-01,1.3218D-01,1.4678D-01,1.7535D-01,
+ &2.1492D-01,2.4628D-01,2.7582D-01,2.9349D-01,3.0215D-01,2.9865D-01,
+ &2.8479D-01,2.6176D-01,2.3025D-01,1.9073D-01,1.4372D-01,9.0030D-02,
+ &3.1431D-02,0.0000D+00,0.0000D+00,9.8561D-02,6.8571D-02,4.5400D-02,
+ &2.8439D-02,1.6650D-02,8.2414D-03,4.3377D-03,1.8226D-03,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,5.8660D-01,5.7912D-01,
+ &5.7170D-01,5.6412D-01,5.5660D-01,5.4858D-01,5.4040D-01,5.3194D-01,
+ &5.2336D-01,5.1383D-01,5.0381D-01,4.9326D-01,4.8220D-01,4.7515D-01,
+ &4.6719D-01,4.5756D-01,4.4719D-01,4.3619D-01,4.2441D-01,4.1376D-01,
+ &4.0188D-01,3.8750D-01,3.7220D-01,3.5617D-01,3.3884D-01,3.2317D-01/
+ DATA (XDEF_L(K),K= 571, 684) /
+ &3.0561D-01,2.8413D-01,2.6132D-01,2.3801D-01,2.1667D-01,1.9794D-01,
+ &1.7898D-01,1.5951D-01,1.4381D-01,1.3395D-01,1.3154D-01,1.3722D-01,
+ &1.5183D-01,1.7978D-01,2.1726D-01,2.4615D-01,2.7227D-01,2.8668D-01,
+ &2.9185D-01,2.8560D-01,2.6981D-01,2.4566D-01,2.1405D-01,1.7560D-01,
+ &1.3093D-01,8.1317D-02,2.8821D-02,0.0000D+00,0.0000D+00,8.9016D-02,
+ &6.1335D-02,4.0241D-02,2.4960D-02,1.4451D-02,6.9787D-03,3.6912D-03,
+ &1.5320D-03,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &6.0621D-01,5.9821D-01,5.9043D-01,5.8253D-01,5.7470D-01,5.6625D-01,
+ &5.5768D-01,5.4870D-01,5.3948D-01,5.2962D-01,5.1919D-01,5.0796D-01,
+ &4.9620D-01,4.8867D-01,4.8027D-01,4.7003D-01,4.5907D-01,4.4740D-01,
+ &4.3484D-01,4.2392D-01,4.1127D-01,3.9627D-01,3.8010D-01,3.6326D-01,
+ &3.4524D-01,3.2900D-01,3.1064D-01,2.8853D-01,2.6510D-01,2.4135D-01,
+ &2.1970D-01,2.0080D-01,1.8175D-01,1.6242D-01,1.4701D-01,1.3753D-01,
+ &1.3572D-01,1.4160D-01,1.5623D-01,1.8343D-01,2.1902D-01,2.4571D-01,
+ &2.6885D-01,2.8059D-01,2.8292D-01,2.7441D-01,2.5704D-01,2.3223D-01,
+ &2.0062D-01,1.6317D-01,1.2079D-01,7.4733D-02,2.7461D-02,0.0000D+00,
+ &0.0000D+00,8.1334D-02,5.5577D-02,3.6150D-02,2.2243D-02,1.2749D-02,
+ &6.0264D-03,3.2009D-03,1.3143D-03,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,6.2581D-01,6.1778D-01,6.0953D-01,6.0134D-01/
+ DATA (XDEF_L(K),K= 685, 798) /
+ &5.9310D-01,5.8428D-01,5.7523D-01,5.6587D-01,5.5625D-01,5.4565D-01,
+ &5.3457D-01,5.2280D-01,5.1030D-01,5.0236D-01,4.9350D-01,4.8267D-01,
+ &4.7104D-01,4.5899D-01,4.4560D-01,4.3381D-01,4.2066D-01,4.0485D-01,
+ &3.8801D-01,3.7047D-01,3.5165D-01,3.3476D-01,3.1574D-01,2.9293D-01,
+ &2.6889D-01,2.4469D-01,2.2279D-01,2.0369D-01,1.8458D-01,1.6537D-01,
+ &1.5025D-01,1.4125D-01,1.3980D-01,1.4589D-01,1.6046D-01,1.8686D-01,
+ &2.2052D-01,2.4502D-01,2.6530D-01,2.7444D-01,2.7406D-01,2.6361D-01,
+ &2.4491D-01,2.1954D-01,1.8819D-01,1.5193D-01,1.1170D-01,6.9146D-02,
+ &2.6829D-02,0.0000D+00,0.0000D+00,7.4387D-02,5.0398D-02,3.2529D-02,
+ &1.9840D-02,1.1260D-02,5.2109D-03,2.7796D-03,1.1291D-03,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,6.4510D-01,6.3663D-01,
+ &6.2809D-01,6.1948D-01,6.1090D-01,6.0165D-01,5.9256D-01,5.8263D-01,
+ &5.7237D-01,5.6121D-01,5.4960D-01,5.3710D-01,5.2390D-01,5.1555D-01,
+ &5.0615D-01,4.9474D-01,4.8273D-01,4.6980D-01,4.5603D-01,4.4343D-01,
+ &4.2983D-01,4.1325D-01,3.9561D-01,3.7731D-01,3.5765D-01,3.4017D-01,
+ &3.2063D-01,2.9709D-01,2.7258D-01,2.4795D-01,2.2572D-01,2.0647D-01,
+ &1.8735D-01,1.6824D-01,1.5339D-01,1.4470D-01,1.4366D-01,1.4990D-01,
+ &1.6437D-01,1.8986D-01,2.2169D-01,2.4408D-01,2.6175D-01,2.6863D-01,
+ &2.6585D-01,2.5363D-01,2.3397D-01,2.0813D-01,1.7714D-01,1.4205D-01/
+ DATA (XDEF_L(K),K= 799, 912) /
+ &1.0396D-01,6.4602D-02,2.6785D-02,0.0000D+00,0.0000D+00,6.8343D-02,
+ &4.5962D-02,2.9434D-02,1.7812D-02,1.0015D-02,4.5458D-03,2.4331D-03,
+ &9.7866D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &6.6281D-01,6.5407D-01,6.4523D-01,6.3631D-01,6.2740D-01,6.1775D-01,
+ &6.0821D-01,5.9770D-01,5.8724D-01,5.7535D-01,5.6321D-01,5.5021D-01,
+ &5.3640D-01,5.2763D-01,5.1775D-01,5.0583D-01,4.9310D-01,4.7946D-01,
+ &4.6520D-01,4.5225D-01,4.3811D-01,4.2074D-01,4.0247D-01,3.8355D-01,
+ &3.6315D-01,3.4516D-01,3.2502D-01,3.0091D-01,2.7589D-01,2.5090D-01,
+ &2.2842D-01,2.0903D-01,1.8987D-01,1.7087D-01,1.5631D-01,1.4790D-01,
+ &1.4709D-01,1.5345D-01,1.6771D-01,1.9243D-01,2.2253D-01,2.4307D-01,
+ &2.5846D-01,2.6327D-01,2.5857D-01,2.4493D-01,2.2441D-01,1.9832D-01,
+ &1.6773D-01,1.3380D-01,9.7606D-02,6.1077D-02,2.7123D-02,4.1687D-04,
+ &0.0000D+00,6.3316D-02,4.2290D-02,2.6899D-02,1.6166D-02,9.0143D-03,
+ &4.0214D-03,2.1587D-03,8.6042D-04,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,6.8558D-01,6.7623D-01,6.6716D-01,6.5776D-01,
+ &6.4840D-01,6.3825D-01,6.2778D-01,6.1697D-01,6.0589D-01,5.9350D-01,
+ &5.8071D-01,5.6677D-01,5.5220D-01,5.4293D-01,5.3246D-01,5.1980D-01,
+ &5.0630D-01,4.9221D-01,4.7690D-01,4.6348D-01,4.4839D-01,4.3024D-01,
+ &4.1112D-01,3.9125D-01,3.7016D-01,3.5134D-01,3.3054D-01,3.0571D-01/
+ DATA (XDEF_L(K),K= 913, 1026) /
+ &2.8005D-01,2.5463D-01,2.3186D-01,2.1230D-01,1.9311D-01,1.7422D-01,
+ &1.5985D-01,1.5187D-01,1.5138D-01,1.5783D-01,1.7178D-01,1.9543D-01,
+ &2.2331D-01,2.4162D-01,2.5415D-01,2.5666D-01,2.4964D-01,2.3438D-01,
+ &2.1293D-01,1.8681D-01,1.5680D-01,1.2430D-01,9.0488D-02,5.7352D-02,
+ &2.7942D-02,7.0995D-03,2.4780D-03,5.7612D-02,3.8138D-02,2.4057D-02,
+ &1.4329D-02,7.9111D-03,3.4566D-03,1.8603D-03,7.3347D-04,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,7.0709D-01,6.9744D-01,
+ &6.8784D-01,6.7803D-01,6.6830D-01,6.5763D-01,6.4678D-01,6.3540D-01,
+ &6.2360D-01,6.1071D-01,5.9715D-01,5.8240D-01,5.6710D-01,5.5722D-01,
+ &5.4625D-01,5.3291D-01,5.1856D-01,5.0380D-01,4.8797D-01,4.7363D-01,
+ &4.5801D-01,4.3900D-01,4.1917D-01,3.9846D-01,3.7656D-01,3.5717D-01,
+ &3.3564D-01,3.1017D-01,2.8397D-01,2.5816D-01,2.3508D-01,2.1538D-01,
+ &1.9615D-01,1.7737D-01,1.6324D-01,1.5559D-01,1.5535D-01,1.6175D-01,
+ &1.7537D-01,1.9793D-01,2.2384D-01,2.4005D-01,2.5009D-01,2.5051D-01,
+ &2.4150D-01,2.2495D-01,2.0291D-01,1.7668D-01,1.4739D-01,1.1625D-01,
+ &8.4583D-02,5.4470D-02,2.9013D-02,1.3147D-02,1.4553D-02,5.2777D-02,
+ &3.4672D-02,2.1686D-02,1.2821D-02,7.0105D-03,3.0093D-03,1.6226D-03,
+ &6.3321D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &7.2796D-01,7.1795D-01,7.0799D-01,6.9776D-01,6.8760D-01,6.7649D-01/
+ DATA (XDEF_L(K),K= 1027, 1140) /
+ &6.6523D-01,6.5299D-01,6.4099D-01,6.2720D-01,6.1289D-01,5.9763D-01,
+ &5.8140D-01,5.7108D-01,5.5954D-01,5.4555D-01,5.3082D-01,5.1501D-01,
+ &4.9841D-01,4.8352D-01,4.6718D-01,4.4758D-01,4.2678D-01,4.0543D-01,
+ &3.8267D-01,3.6267D-01,3.4052D-01,3.1445D-01,2.8771D-01,2.6154D-01,
+ &2.3817D-01,2.1835D-01,1.9910D-01,1.8043D-01,1.6662D-01,1.5905D-01,
+ &1.5900D-01,1.6548D-01,1.7871D-01,2.0015D-01,2.2403D-01,2.3835D-01,
+ &2.4610D-01,2.4469D-01,2.3394D-01,2.1634D-01,1.9372D-01,1.6761D-01,
+ &1.3910D-01,1.0920D-01,7.9530D-02,5.2165D-02,3.0250D-02,1.8723D-02,
+ &2.5275D-02,4.8575D-02,3.1676D-02,1.9677D-02,1.1540D-02,6.2533D-03,
+ &2.6411D-03,1.4253D-03,5.5072D-04,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,7.4788D-01,7.3751D-01,7.2708D-01,7.1644D-01,
+ &7.0580D-01,6.9430D-01,6.8256D-01,6.6975D-01,6.5712D-01,6.4276D-01,
+ &6.2791D-01,6.1180D-01,5.9490D-01,5.8409D-01,5.7199D-01,5.5739D-01,
+ &5.4166D-01,5.2544D-01,5.0821D-01,4.9288D-01,4.7590D-01,4.5544D-01,
+ &4.3393D-01,4.1178D-01,3.8837D-01,3.6775D-01,3.4513D-01,3.1844D-01,
+ &2.9125D-01,2.6472D-01,2.4110D-01,2.2115D-01,2.0189D-01,1.8330D-01,
+ &1.6955D-01,1.6237D-01,1.6243D-01,1.6875D-01,1.8164D-01,2.0201D-01,
+ &2.2410D-01,2.3665D-01,2.4236D-01,2.3927D-01,2.2710D-01,2.0852D-01,
+ &1.8563D-01,1.5962D-01,1.3170D-01,1.0314D-01,7.5292D-02,5.0347D-02/
+ DATA (XDEF_L(K),K= 1141, 1254) /
+ &3.1513D-02,2.3688D-02,3.4520D-02,4.4988D-02,2.9140D-02,1.7975D-02,
+ &1.0472D-02,5.6268D-03,2.3442D-03,1.2646D-03,4.8432D-04,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,7.6812D-01,7.5731D-01,
+ &7.4653D-01,7.3551D-01,7.2440D-01,7.1234D-01,6.9989D-01,6.8692D-01,
+ &6.7357D-01,6.5855D-01,6.4312D-01,6.2624D-01,6.0850D-01,5.9719D-01,
+ &5.8457D-01,5.6934D-01,5.5297D-01,5.3626D-01,5.1802D-01,5.0223D-01,
+ &4.8440D-01,4.6329D-01,4.4109D-01,4.1826D-01,3.9408D-01,3.7291D-01,
+ &3.4966D-01,3.2243D-01,2.9475D-01,2.6790D-01,2.4406D-01,2.2399D-01,
+ &2.0470D-01,1.8621D-01,1.7262D-01,1.6558D-01,1.6576D-01,1.7201D-01,
+ &1.8441D-01,2.0372D-01,2.2403D-01,2.3482D-01,2.3856D-01,2.3398D-01,
+ &2.2040D-01,2.0103D-01,1.7782D-01,1.5205D-01,1.2492D-01,9.7540D-02,
+ &7.1452D-02,4.8817D-02,3.2832D-02,2.8412D-02,4.3068D-02,4.1684D-02,
+ &2.6819D-02,1.6431D-02,9.5049D-03,5.0674D-03,2.0840D-03,1.1231D-03,
+ &4.2643D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &7.8709D-01,7.7617D-01,7.6509D-01,7.5353D-01,7.4210D-01,7.2955D-01,
+ &7.1666D-01,7.0326D-01,6.8906D-01,6.7364D-01,6.5743D-01,6.3988D-01,
+ &6.2140D-01,6.0962D-01,5.9645D-01,5.8083D-01,5.6382D-01,5.4630D-01,
+ &5.2750D-01,5.1079D-01,4.9267D-01,4.7078D-01,4.4780D-01,4.2425D-01,
+ &3.9948D-01,3.7773D-01,3.5398D-01,3.2619D-01,2.9811D-01,2.7093D-01/
+ DATA (XDEF_L(K),K= 1255, 1368) /
+ &2.4686D-01,2.2668D-01,2.0735D-01,1.8888D-01,1.7555D-01,1.6865D-01,
+ &1.6887D-01,1.7500D-01,1.8693D-01,2.0522D-01,2.2377D-01,2.3300D-01,
+ &2.3501D-01,2.2902D-01,2.1428D-01,1.9427D-01,1.7084D-01,1.4533D-01,
+ &1.1889D-01,9.2655D-02,6.8174D-02,4.7575D-02,3.4123D-02,3.2605D-02,
+ &5.0454D-02,3.8820D-02,2.4822D-02,1.5113D-02,8.6857D-03,4.5962D-03,
+ &1.8704D-03,1.0050D-03,3.7856D-04,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,8.0606D-01,7.9455D-01,7.8312D-01,7.7128D-01,
+ &7.5940D-01,7.4610D-01,7.3287D-01,7.1917D-01,7.0456D-01,6.8825D-01,
+ &6.7140D-01,6.5313D-01,6.3390D-01,6.2170D-01,6.0798D-01,5.9180D-01,
+ &5.7419D-01,5.5596D-01,5.3636D-01,5.1934D-01,5.0050D-01,4.7790D-01,
+ &4.5436D-01,4.3012D-01,4.0458D-01,3.8238D-01,3.5808D-01,3.2984D-01,
+ &3.0133D-01,2.7388D-01,2.4957D-01,2.2930D-01,2.0996D-01,1.9168D-01,
+ &1.7832D-01,1.7159D-01,1.7177D-01,1.7770D-01,1.8921D-01,2.0651D-01,
+ &2.2344D-01,2.3117D-01,2.3152D-01,2.2426D-01,2.0844D-01,1.8790D-01,
+ &1.6440D-01,1.3914D-01,1.1342D-01,8.8280D-02,6.5276D-02,4.6578D-02,
+ &3.5360D-02,3.6411D-02,5.6986D-02,3.6256D-02,2.3040D-02,1.3948D-02,
+ &7.9676D-03,4.1856D-03,1.6876D-03,9.0394D-04,3.3789D-04,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,8.2409D-01,8.1223D-01,
+ &8.0027D-01,7.8810D-01,7.7580D-01,7.6250D-01,7.4852D-01,7.3383D-01/
+ DATA (XDEF_L(K),K= 1369, 1482) /
+ &7.1879D-01,7.0216D-01,6.8466D-01,6.6571D-01,6.4580D-01,6.3303D-01,
+ &6.1887D-01,6.0161D-01,5.8362D-01,5.6485D-01,5.4490D-01,5.2736D-01,
+ &5.0788D-01,4.8465D-01,4.6048D-01,4.3549D-01,4.0949D-01,3.8678D-01,
+ &3.6198D-01,3.3325D-01,3.0435D-01,2.7667D-01,2.5212D-01,2.3179D-01,
+ &2.1241D-01,1.9410D-01,1.8093D-01,1.7428D-01,1.7445D-01,1.8022D-01,
+ &1.9133D-01,2.0758D-01,2.2299D-01,2.2941D-01,2.2823D-01,2.1990D-01,
+ &2.0319D-01,1.8211D-01,1.5852D-01,1.3371D-01,1.0856D-01,8.4430D-02,
+ &6.2776D-02,4.5758D-02,3.6514D-02,3.9756D-02,6.2597D-02,3.4019D-02,
+ &2.1502D-02,1.2943D-02,7.3506D-03,3.8366D-03,1.5351D-03,8.1923D-04,
+ &3.0383D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &8.4844D-01,8.3627D-01,8.2378D-01,8.1114D-01,7.9820D-01,7.8411D-01,
+ &7.6977D-01,7.5436D-01,7.3871D-01,7.2101D-01,7.0269D-01,6.8280D-01,
+ &6.6180D-01,6.4849D-01,6.3365D-01,6.1605D-01,5.9682D-01,5.7721D-01,
+ &5.5628D-01,5.3805D-01,5.1772D-01,4.9378D-01,4.6868D-01,4.4295D-01,
+ &4.1599D-01,3.9262D-01,3.6722D-01,3.3788D-01,3.0847D-01,2.8040D-01,
+ &2.5562D-01,2.3513D-01,2.1572D-01,1.9746D-01,1.8447D-01,1.7787D-01,
+ &1.7810D-01,1.8358D-01,1.9394D-01,2.0894D-01,2.2227D-01,2.2689D-01,
+ &2.2385D-01,2.1408D-01,1.9620D-01,1.7461D-01,1.5108D-01,1.2667D-01,
+ &1.0243D-01,7.9635D-02,5.9715D-02,4.4804D-02,3.7997D-02,4.3894D-02/
+ DATA (XDEF_L(K),K= 1483, 1596) /
+ &6.9391D-02,3.1240D-02,1.9603D-02,1.1712D-02,6.6036D-03,3.4150D-03,
+ &1.3549D-03,7.1812D-04,2.6373D-04,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,8.7089D-01,8.5819D-01,8.4535D-01,8.3207D-01,
+ &8.1860D-01,8.0424D-01,7.8877D-01,7.7320D-01,7.5642D-01,7.3822D-01,
+ &7.1895D-01,6.9816D-01,6.7640D-01,6.6244D-01,6.4701D-01,6.2817D-01,
+ &6.0860D-01,5.8841D-01,5.6672D-01,5.4767D-01,5.2667D-01,5.0182D-01,
+ &4.7599D-01,4.4955D-01,4.2190D-01,3.9787D-01,3.7196D-01,3.4199D-01,
+ &3.1220D-01,2.8382D-01,2.5874D-01,2.3816D-01,2.1874D-01,2.0063D-01,
+ &1.8770D-01,1.8107D-01,1.8121D-01,1.8638D-01,1.9622D-01,2.0994D-01,
+ &2.2156D-01,2.2456D-01,2.1986D-01,2.0892D-01,1.9015D-01,1.6817D-01,
+ &1.4465D-01,1.2070D-01,9.7309D-02,7.5665D-02,5.7234D-02,4.4095D-02,
+ &3.9289D-02,4.7307D-02,7.4739D-02,2.8958D-02,1.8046D-02,1.0716D-02,
+ &6.0010D-03,3.0801D-03,1.2145D-03,6.3833D-04,2.3251D-04,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,8.9366D-01,8.8058D-01,
+ &8.6727D-01,8.5353D-01,8.3950D-01,8.2436D-01,8.0890D-01,7.9205D-01,
+ &7.7476D-01,7.5566D-01,7.3557D-01,7.1393D-01,6.9120D-01,6.7672D-01,
+ &6.6059D-01,6.4145D-01,6.2086D-01,5.9962D-01,5.7716D-01,5.5756D-01,
+ &5.3584D-01,5.1022D-01,4.8344D-01,4.5615D-01,4.2780D-01,4.0320D-01,
+ &3.7671D-01,3.4621D-01,3.1594D-01,2.8727D-01,2.6196D-01,2.4126D-01/
+ DATA (XDEF_L(K),K= 1597, 1710) /
+ &2.2177D-01,2.0361D-01,1.9078D-01,1.8427D-01,1.8432D-01,1.8918D-01,
+ &1.9834D-01,2.1079D-01,2.2065D-01,2.2210D-01,2.1587D-01,2.0383D-01,
+ &1.8424D-01,1.6197D-01,1.3849D-01,1.1505D-01,9.2463D-02,7.1949D-02,
+ &5.4952D-02,4.3474D-02,4.0525D-02,5.0376D-02,7.9517D-02,2.6835D-02,
+ &1.6616D-02,9.8004D-03,5.4489D-03,2.7768D-03,1.0900D-03,5.6728D-04,
+ &2.0489D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &9.1643D-01,9.0298D-01,8.8901D-01,8.7472D-01,8.6030D-01,8.4449D-01,
+ &8.2790D-01,8.1090D-01,7.9278D-01,7.7287D-01,7.5201D-01,7.2942D-01,
+ &7.0580D-01,6.9067D-01,6.7395D-01,6.5357D-01,6.3264D-01,6.1082D-01,
+ &5.8728D-01,5.6718D-01,5.4478D-01,5.1825D-01,4.9075D-01,4.6263D-01,
+ &4.3360D-01,4.0844D-01,3.8138D-01,3.5032D-01,3.1963D-01,2.9065D-01,
+ &2.6511D-01,2.4428D-01,2.2479D-01,2.0678D-01,1.9385D-01,1.8735D-01,
+ &1.8722D-01,1.9179D-01,2.0029D-01,2.1158D-01,2.1961D-01,2.1971D-01,
+ &2.1194D-01,1.9894D-01,1.7862D-01,1.5609D-01,1.3279D-01,1.0972D-01,
+ &8.8007D-02,6.8578D-02,5.2905D-02,4.2942D-02,4.1624D-02,5.3065D-02,
+ &8.3506D-02,2.4920D-02,1.5334D-02,8.9876D-03,4.9653D-03,2.5112D-03,
+ &9.8300D-04,5.0629D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,9.3762D-01,9.2325D-01,9.0916D-01,8.9432D-01,
+ &8.7930D-01,8.6312D-01,8.4579D-01,8.2807D-01,8.0954D-01,7.8866D-01/
+ DATA (XDEF_L(K),K= 1711, 1824) /
+ &7.6704D-01,7.4360D-01,7.1911D-01,7.0343D-01,6.8612D-01,6.6512D-01,
+ &6.4349D-01,6.2048D-01,5.9676D-01,5.7574D-01,5.5261D-01,5.2556D-01,
+ &4.9731D-01,4.6862D-01,4.3881D-01,4.1318D-01,3.8556D-01,3.5408D-01,
+ &3.2299D-01,2.9375D-01,2.6794D-01,2.4706D-01,2.2744D-01,2.0939D-01,
+ &1.9662D-01,1.9016D-01,1.8990D-01,1.9412D-01,2.0192D-01,2.1208D-01,
+ &2.1863D-01,2.1745D-01,2.0845D-01,1.9458D-01,1.7365D-01,1.5094D-01,
+ &1.2783D-01,1.0526D-01,8.4228D-02,6.5746D-02,5.1203D-02,4.2521D-02,
+ &4.2531D-02,5.5238D-02,8.6619D-02,2.3321D-02,1.4266D-02,8.3142D-03,
+ &4.5684D-03,2.2945D-03,8.9721D-04,4.5700D-04,0.0000D+00,0.0000D+00,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,9.5912D-01,9.4446D-01,
+ &9.2967D-01,9.1446D-01,8.9890D-01,8.8176D-01,8.6424D-01,8.4567D-01,
+ &8.2630D-01,8.0492D-01,7.8242D-01,7.5817D-01,7.3271D-01,7.1653D-01,
+ &6.9849D-01,6.7725D-01,6.5433D-01,6.3091D-01,6.0625D-01,5.8456D-01,
+ &5.6088D-01,5.3305D-01,5.0402D-01,4.7461D-01,4.4411D-01,4.1800D-01,
+ &3.8988D-01,3.5790D-01,3.2644D-01,2.9690D-01,2.7087D-01,2.4987D-01,
+ &2.3039D-01,2.1219D-01,1.9955D-01,1.9298D-01,1.9248D-01,1.9636D-01,
+ &2.0355D-01,2.1258D-01,2.1752D-01,2.1512D-01,2.0490D-01,1.9021D-01,
+ &1.6876D-01,1.4586D-01,1.2296D-01,1.0090D-01,8.0587D-02,6.3034D-02,
+ &4.9591D-02,4.2122D-02,4.3355D-02,5.7203D-02,8.9336D-02,2.1802D-02/
+ DATA (XDEF_L(K),K= 1825, 1836) /
+ &1.3258D-02,7.6843D-03,4.1967D-03,2.0952D-03,8.1932D-04,4.1202D-04,
+ &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00/
+ DATA (XUDF_L(K),K= 1, 114) /
+ &1.8987D-02,1.9947D-02,2.0980D-02,2.2068D-02,2.3225D-02,2.4540D-02,
+ &2.5957D-02,2.7526D-02,2.9229D-02,3.1232D-02,3.3453D-02,3.6003D-02,
+ &3.8855D-02,4.0763D-02,4.2980D-02,4.5778D-02,4.8895D-02,5.2320D-02,
+ &5.6174D-02,5.9765D-02,6.3980D-02,6.9315D-02,7.5299D-02,8.1888D-02,
+ &8.9292D-02,9.6162D-02,1.0414D-01,1.1410D-01,1.2505D-01,1.3674D-01,
+ &1.4937D-01,1.6060D-01,1.7296D-01,1.8730D-01,2.0166D-01,2.1531D-01,
+ &2.2821D-01,2.3833D-01,2.4848D-01,2.6049D-01,2.7586D-01,2.9166D-01,
+ &3.1456D-01,3.3942D-01,3.7230D-01,4.0597D-01,4.3921D-01,4.7071D-01,
+ &4.9846D-01,5.2057D-01,5.3433D-01,5.3610D-01,5.2141D-01,4.8433D-01,
+ &4.1719D-01,6.3794D-01,6.7411D-01,7.2040D-01,7.8812D-01,8.9495D-01,
+ &1.0702D+00,1.3629D+00,1.8763D+00,2.8399D+00,4.8968D+00,1.0506D+01,
+ &3.7793D+01,0.0000D+00,3.1111D-02,3.2336D-02,3.3580D-02,3.4906D-02,
+ &3.6247D-02,3.7773D-02,3.9337D-02,4.1056D-02,4.2876D-02,4.5001D-02,
+ &4.7299D-02,4.9897D-02,5.2761D-02,5.4666D-02,5.6867D-02,5.9620D-02,
+ &6.2679D-02,6.6018D-02,6.9775D-02,7.3275D-02,7.7353D-02,8.2522D-02,
+ &8.8327D-02,9.4694D-02,1.0184D-01,1.0846D-01,1.1615D-01,1.2575D-01,
+ &1.3628D-01,1.4752D-01,1.5964D-01,1.7036D-01,1.8215D-01,1.9580D-01,
+ &2.0933D-01,2.2213D-01,2.3411D-01,2.4341D-01,2.5275D-01,2.6387D-01,
+ &2.7831D-01,2.9333D-01,3.1510D-01,3.3876D-01,3.6995D-01,4.0170D-01/
+ DATA (XUDF_L(K),K= 115, 228) /
+ &4.3298D-01,4.6172D-01,4.8742D-01,5.0700D-01,5.1856D-01,5.1873D-01,
+ &5.0352D-01,4.6746D-01,4.0418D-01,6.1801D-01,6.5339D-01,6.9923D-01,
+ &7.6627D-01,8.7125D-01,1.0408D+00,1.3199D+00,1.8020D+00,2.6920D+00,
+ &4.5574D+00,9.5310D+00,3.2877D+01,0.0000D+00,5.1176D-02,5.2640D-02,
+ &5.4100D-02,5.5603D-02,5.7095D-02,5.8737D-02,6.0416D-02,6.2154D-02,
+ &6.4016D-02,6.6046D-02,6.8273D-02,7.0765D-02,7.3444D-02,7.5182D-02,
+ &7.7263D-02,7.9781D-02,8.2626D-02,8.5707D-02,8.9176D-02,9.2402D-02,
+ &9.6182D-02,1.0098D-01,1.0635D-01,1.1227D-01,1.1893D-01,1.2513D-01,
+ &1.3230D-01,1.4128D-01,1.5115D-01,1.6164D-01,1.7300D-01,1.8301D-01,
+ &1.9397D-01,2.0660D-01,2.1907D-01,2.3072D-01,2.4154D-01,2.4985D-01,
+ &2.5817D-01,2.6810D-01,2.8136D-01,2.9535D-01,3.1585D-01,3.3824D-01,
+ &3.6743D-01,3.9701D-01,4.2565D-01,4.5205D-01,4.7460D-01,4.9184D-01,
+ &5.0110D-01,4.9954D-01,4.8363D-01,4.4878D-01,3.8940D-01,5.9452D-01,
+ &6.2820D-01,6.7181D-01,7.3612D-01,8.3598D-01,9.9560D-01,1.2543D+00,
+ &1.6953D+00,2.4947D+00,4.1415D+00,8.4275D+00,2.7797D+01,0.0000D+00,
+ &8.6266D-02,8.7847D-02,8.9380D-02,9.0869D-02,9.2337D-02,9.3826D-02,
+ &9.5315D-02,9.6842D-02,9.8333D-02,1.0003D-01,1.0178D-01,1.0370D-01,
+ &1.0575D-01,1.0710D-01,1.0872D-01,1.1075D-01,1.1295D-01,1.1538D-01,
+ &1.1821D-01,1.2088D-01,1.2396D-01,1.2796D-01,1.3252D-01,1.3756D-01/
+ DATA (XUDF_L(K),K= 229, 342) /
+ &1.4331D-01,1.4870D-01,1.5500D-01,1.6291D-01,1.7166D-01,1.8100D-01,
+ &1.9111D-01,2.0002D-01,2.0977D-01,2.2095D-01,2.3189D-01,2.4200D-01,
+ &2.5123D-01,2.5821D-01,2.6512D-01,2.7351D-01,2.8514D-01,2.9789D-01,
+ &3.1683D-01,3.3731D-01,3.6424D-01,3.9124D-01,4.1697D-01,4.4030D-01,
+ &4.6002D-01,4.7419D-01,4.8085D-01,4.7740D-01,4.6086D-01,4.2728D-01,
+ &3.7241D-01,5.6656D-01,5.9684D-01,6.3694D-01,6.9622D-01,7.8804D-01,
+ &9.3343D-01,1.1653D+00,1.5545D+00,2.2504D+00,3.6537D+00,7.2124D+00,
+ &2.2653D+01,0.0000D+00,1.4838D-01,1.4960D-01,1.5068D-01,1.5161D-01,
+ &1.5242D-01,1.5316D-01,1.5373D-01,1.5426D-01,1.5470D-01,1.5511D-01,
+ &1.5554D-01,1.5602D-01,1.5660D-01,1.5698D-01,1.5750D-01,1.5830D-01,
+ &1.5923D-01,1.6034D-01,1.6181D-01,1.6324D-01,1.6509D-01,1.6746D-01,
+ &1.7054D-01,1.7402D-01,1.7811D-01,1.8208D-01,1.8687D-01,1.9296D-01,
+ &1.9986D-01,2.0734D-01,2.1554D-01,2.2281D-01,2.3075D-01,2.3983D-01,
+ &2.4863D-01,2.5660D-01,2.6366D-01,2.6883D-01,2.7387D-01,2.8026D-01,
+ &2.8982D-01,3.0088D-01,3.1780D-01,3.3626D-01,3.6021D-01,3.8399D-01,
+ &4.0666D-01,4.2682D-01,4.4278D-01,4.5386D-01,4.5774D-01,4.5230D-01,
+ &4.3509D-01,4.0314D-01,3.5321D-01,5.3325D-01,5.5916D-01,5.9448D-01,
+ &6.4707D-01,7.2797D-01,8.5557D-01,1.0563D+00,1.3882D+00,1.9717D+00,
+ &3.1223D+00,5.9601D+00,1.7750D+01,0.0000D+00,2.3139D-01,2.3138D-01/
+ DATA (XUDF_L(K),K= 343, 456) /
+ &2.3120D-01,2.3076D-01,2.3006D-01,2.2907D-01,2.2788D-01,2.2645D-01,
+ &2.2489D-01,2.2308D-01,2.2120D-01,2.1929D-01,2.1743D-01,2.1630D-01,
+ &2.1526D-01,2.1411D-01,2.1311D-01,2.1231D-01,2.1171D-01,2.1148D-01,
+ &2.1150D-01,2.1182D-01,2.1271D-01,2.1412D-01,2.1601D-01,2.1822D-01,
+ &2.2096D-01,2.2496D-01,2.2961D-01,2.3481D-01,2.4086D-01,2.4622D-01,
+ &2.5214D-01,2.5891D-01,2.6537D-01,2.7104D-01,2.7588D-01,2.7922D-01,
+ &2.8235D-01,2.8664D-01,2.9413D-01,3.0352D-01,3.1845D-01,3.3481D-01,
+ &3.5617D-01,3.7737D-01,3.9689D-01,4.1403D-01,4.2736D-01,4.3558D-01,
+ &4.3712D-01,4.3016D-01,4.1245D-01,3.8197D-01,3.3645D-01,5.0322D-01,
+ &5.2507D-01,5.5559D-01,6.0172D-01,6.7286D-01,7.8413D-01,9.5797D-01,
+ &1.2422D+00,1.7341D+00,2.6883D+00,4.9868D+00,1.4177D+01,0.0000D+00,
+ &3.6389D-01,3.6098D-01,3.5780D-01,3.5400D-01,3.5016D-01,3.4553D-01,
+ &3.4044D-01,3.3521D-01,3.2971D-01,3.2369D-01,3.1755D-01,3.1120D-01,
+ &3.0494D-01,3.0120D-01,2.9724D-01,2.9287D-01,2.8855D-01,2.8449D-01,
+ &2.8072D-01,2.7770D-01,2.7469D-01,2.7175D-01,2.6933D-01,2.6740D-01,
+ &2.6613D-01,2.6556D-01,2.6563D-01,2.6631D-01,2.6763D-01,2.6975D-01,
+ &2.7268D-01,2.7539D-01,2.7857D-01,2.8224D-01,2.8565D-01,2.8841D-01,
+ &2.9040D-01,2.9139D-01,2.9220D-01,2.9395D-01,2.9888D-01,3.0633D-01,
+ &3.1877D-01,3.3296D-01,3.5147D-01,3.6947D-01,3.8604D-01,3.9986D-01/
+ DATA (XUDF_L(K),K= 457, 570) /
+ &4.1008D-01,4.1548D-01,4.1467D-01,4.0620D-01,3.8830D-01,3.5965D-01,
+ &3.1902D-01,4.7020D-01,4.8772D-01,5.1303D-01,5.5185D-01,6.1224D-01,
+ &7.0699D-01,8.5323D-01,1.0903D+00,1.4950D+00,2.2640D+00,4.0723D+00,
+ &0.0000D+00,0.0000D+00,5.2666D-01,5.1909D-01,5.1100D-01,5.0238D-01,
+ &4.9333D-01,4.8312D-01,4.7293D-01,4.6180D-01,4.5066D-01,4.3890D-01,
+ &4.2692D-01,4.1467D-01,4.0262D-01,3.9542D-01,3.8784D-01,3.7925D-01,
+ &3.7080D-01,3.6267D-01,3.5482D-01,3.4841D-01,3.4190D-01,3.3492D-01,
+ &3.2852D-01,3.2287D-01,3.1768D-01,3.1409D-01,3.1066D-01,3.0785D-01,
+ &3.0564D-01,3.0446D-01,3.0380D-01,3.0388D-01,3.0402D-01,3.0458D-01,
+ &3.0488D-01,3.0475D-01,3.0386D-01,3.0263D-01,3.0116D-01,3.0045D-01,
+ &3.0296D-01,3.0852D-01,3.1888D-01,3.3085D-01,3.4677D-01,3.6222D-01,
+ &3.7600D-01,3.8707D-01,3.9488D-01,3.9799D-01,3.9530D-01,3.8568D-01,
+ &3.6791D-01,3.4080D-01,3.0424D-01,4.4195D-01,4.5570D-01,4.7648D-01,
+ &5.0935D-01,5.6099D-01,6.4225D-01,7.6680D-01,9.6736D-01,1.3053D+00,
+ &1.9393D+00,3.3976D+00,0.0000D+00,0.0000D+00,7.4015D-01,7.2498D-01,
+ &7.0940D-01,6.9297D-01,6.7620D-01,6.5800D-01,6.3935D-01,6.2047D-01,
+ &6.0114D-01,5.8076D-01,5.6065D-01,5.4030D-01,5.2035D-01,5.0839D-01,
+ &4.9583D-01,4.8167D-01,4.6773D-01,4.5434D-01,4.4113D-01,4.3035D-01,
+ &4.1922D-01,4.0719D-01,3.9582D-01,3.8536D-01,3.7557D-01,3.6805D-01/
+ DATA (XUDF_L(K),K= 571, 684) /
+ &3.6079D-01,3.5336D-01,3.4710D-01,3.4173D-01,3.3719D-01,3.3400D-01,
+ &3.3124D-01,3.2819D-01,3.2494D-01,3.2158D-01,3.1765D-01,3.1400D-01,
+ &3.1011D-01,3.0684D-01,3.0682D-01,3.1046D-01,3.1856D-01,3.2861D-01,
+ &3.4189D-01,3.5475D-01,3.6597D-01,3.7463D-01,3.8003D-01,3.8108D-01,
+ &3.7681D-01,3.6631D-01,3.4865D-01,3.2327D-01,2.9078D-01,4.1488D-01,
+ &4.2529D-01,4.4193D-01,4.6945D-01,5.1322D-01,5.8236D-01,6.8846D-01,
+ &8.5739D-01,1.1394D+00,1.6617D+00,2.8395D+00,0.0000D+00,0.0000D+00,
+ &9.8501D-01,9.5975D-01,9.3420D-01,9.0757D-01,8.8092D-01,8.5237D-01,
+ &8.2383D-01,7.9445D-01,7.6556D-01,7.3524D-01,7.0484D-01,6.7495D-01,
+ &6.4547D-01,6.2798D-01,6.0969D-01,5.8904D-01,5.6882D-01,5.4932D-01,
+ &5.3014D-01,5.1443D-01,4.9826D-01,4.8058D-01,4.6380D-01,4.4815D-01,
+ &4.3330D-01,4.2167D-01,4.1020D-01,3.9827D-01,3.8748D-01,3.7784D-01,
+ &3.6931D-01,3.6303D-01,3.5669D-01,3.4992D-01,3.4358D-01,3.3710D-01,
+ &3.3025D-01,3.2429D-01,3.1817D-01,3.1242D-01,3.1001D-01,3.1195D-01,
+ &3.1802D-01,3.2610D-01,3.3719D-01,3.4770D-01,3.5674D-01,3.6357D-01,
+ &3.6695D-01,3.6631D-01,3.6075D-01,3.4960D-01,3.3214D-01,3.0855D-01,
+ &2.7931D-01,3.9198D-01,3.9931D-01,4.1263D-01,4.3550D-01,4.7310D-01,
+ &5.3259D-01,6.2375D-01,7.6876D-01,1.0087D+00,1.4464D+00,2.4185D+00,
+ &0.0000D+00,0.0000D+00,1.2917D+00,1.2523D+00,1.2128D+00,1.1722D+00/
+ DATA (XUDF_L(K),K= 685, 798) /
+ &1.1321D+00,1.0894D+00,1.0473D+00,1.0044D+00,9.6262D-01,9.1838D-01,
+ &8.7565D-01,8.3283D-01,7.9186D-01,7.6734D-01,7.4146D-01,7.1300D-01,
+ &6.8484D-01,6.5787D-01,6.3134D-01,6.0963D-01,5.8730D-01,5.6294D-01,
+ &5.3947D-01,5.1767D-01,4.9689D-01,4.8039D-01,4.6398D-01,4.4675D-01,
+ &4.3087D-01,4.1650D-01,4.0371D-01,3.9342D-01,3.8361D-01,3.7293D-01,
+ &3.6284D-01,3.5305D-01,3.4307D-01,3.3468D-01,3.2613D-01,3.1788D-01,
+ &3.1306D-01,3.1309D-01,3.1715D-01,3.2346D-01,3.3232D-01,3.4066D-01,
+ &3.4779D-01,3.5251D-01,3.5401D-01,3.5184D-01,3.4519D-01,3.3347D-01,
+ &3.1650D-01,2.9433D-01,2.6872D-01,3.6968D-01,3.7446D-01,3.8477D-01,
+ &4.0368D-01,4.3551D-01,4.8654D-01,5.6457D-01,6.8832D-01,8.9135D-01,
+ &1.2583D+00,2.0601D+00,0.0000D+00,0.0000D+00,1.6499D+00,1.5928D+00,
+ &1.5356D+00,1.4773D+00,1.4202D+00,1.3601D+00,1.3009D+00,1.2413D+00,
+ &1.1836D+00,1.1235D+00,1.0650D+00,1.0076D+00,9.5212D-01,9.1919D-01,
+ &8.8569D-01,8.4733D-01,8.1006D-01,7.7436D-01,7.3955D-01,7.1104D-01,
+ &6.8173D-01,6.4966D-01,6.1893D-01,5.9026D-01,5.6287D-01,5.4114D-01,
+ &5.1941D-01,4.9621D-01,4.7490D-01,4.5564D-01,4.3786D-01,4.2408D-01,
+ &4.1024D-01,3.9562D-01,3.8175D-01,3.6853D-01,3.5541D-01,3.4455D-01,
+ &3.3366D-01,3.2286D-01,3.1565D-01,3.1397D-01,3.1618D-01,3.2069D-01,
+ &3.2744D-01,3.3383D-01,3.3911D-01,3.4194D-01,3.4194D-01,3.3844D-01/
+ DATA (XUDF_L(K),K= 799, 912) /
+ &3.3088D-01,3.1887D-01,3.0224D-01,2.8177D-01,2.5901D-01,3.4945D-01,
+ &3.5200D-01,3.5959D-01,3.7518D-01,4.0212D-01,4.4590D-01,5.1305D-01,
+ &6.1934D-01,7.9273D-01,1.1025D+00,1.7693D+00,0.0000D+00,0.0000D+00,
+ &2.0413D+00,1.9626D+00,1.8840D+00,1.8053D+00,1.7284D+00,1.6480D+00,
+ &1.5697D+00,1.4911D+00,1.4157D+00,1.3375D+00,1.2620D+00,1.1875D+00,
+ &1.1168D+00,1.0751D+00,1.0321D+00,9.8410D-01,9.3682D-01,8.9196D-01,
+ &8.4816D-01,8.1245D-01,7.7582D-01,7.3576D-01,6.9745D-01,6.6154D-01,
+ &6.2742D-01,6.0036D-01,5.7319D-01,5.4409D-01,5.1721D-01,4.9291D-01,
+ &4.7049D-01,4.5284D-01,4.3541D-01,4.1671D-01,3.9926D-01,3.8274D-01,
+ &3.6660D-01,3.5348D-01,3.4035D-01,3.2727D-01,3.1788D-01,3.1459D-01,
+ &3.1499D-01,3.1792D-01,3.2291D-01,3.2764D-01,3.3124D-01,3.3250D-01,
+ &3.3120D-01,3.2663D-01,3.1834D-01,3.0608D-01,2.8998D-01,2.7085D-01,
+ &2.5085D-01,3.3191D-01,3.3258D-01,3.3808D-01,3.5072D-01,3.7379D-01,
+ &4.1182D-01,4.7005D-01,5.6257D-01,7.1233D-01,9.7788D-01,1.5412D+00,
+ &0.0000D+00,0.0000D+00,2.6325D+00,2.5188D+00,2.4060D+00,2.2942D+00,
+ &2.1863D+00,2.0740D+00,1.9650D+00,1.8571D+00,1.7537D+00,1.6473D+00,
+ &1.5453D+00,1.4458D+00,1.3515D+00,1.2965D+00,1.2394D+00,1.1767D+00,
+ &1.1150D+00,1.0560D+00,9.9927D-01,9.5301D-01,9.0565D-01,8.5400D-01,
+ &8.0462D-01,7.5858D-01,7.1481D-01,6.7994D-01,6.4502D-01,6.0799D-01/
+ DATA (XUDF_L(K),K= 913, 1026) /
+ &5.7349D-01,5.4206D-01,5.1299D-01,4.9028D-01,4.6789D-01,4.4387D-01,
+ &4.2168D-01,4.0096D-01,3.8070D-01,3.6457D-01,3.4857D-01,3.3249D-01,
+ &3.2026D-01,3.1503D-01,3.1326D-01,3.1423D-01,3.1703D-01,3.1974D-01,
+ &3.2120D-01,3.2086D-01,3.1799D-01,3.1221D-01,3.0315D-01,2.9072D-01,
+ &2.7522D-01,2.5796D-01,2.4114D-01,3.1079D-01,3.0956D-01,3.1267D-01,
+ &3.2223D-01,3.4089D-01,3.7246D-01,4.2134D-01,4.9853D-01,6.2305D-01,
+ &8.4191D-01,1.2983D+00,0.0000D+00,0.0000D+00,3.2997D+00,3.1427D+00,
+ &2.9900D+00,2.8374D+00,2.6927D+00,2.5421D+00,2.3973D+00,2.2549D+00,
+ &2.1191D+00,1.9809D+00,1.8488D+00,1.7209D+00,1.6001D+00,1.5300D+00,
+ &1.4576D+00,1.3771D+00,1.2999D+00,1.2268D+00,1.1551D+00,1.0975D+00,
+ &1.0385D+00,9.7437D-01,9.1327D-01,8.5649D-01,8.0236D-01,7.5952D-01,
+ &7.1667D-01,6.7091D-01,6.2847D-01,5.9005D-01,5.5422D-01,5.2636D-01,
+ &4.9890D-01,4.6976D-01,4.4269D-01,4.1752D-01,3.9377D-01,3.7477D-01,
+ &3.5594D-01,3.3710D-01,3.2226D-01,3.1511D-01,3.1131D-01,3.1067D-01,
+ &3.1132D-01,3.1227D-01,3.1198D-01,3.1021D-01,3.0606D-01,2.9926D-01,
+ &2.8958D-01,2.7716D-01,2.6233D-01,2.4655D-01,2.3275D-01,2.9229D-01,
+ &2.8941D-01,2.9061D-01,2.9753D-01,3.1273D-01,3.3909D-01,3.8034D-01,
+ &4.4548D-01,5.5028D-01,7.3256D-01,1.1074D+00,0.0000D+00,0.0000D+00,
+ &4.0557D+00,3.8486D+00,3.6460D+00,3.4480D+00,3.2579D+00,3.0626D+00/
+ DATA (XUDF_L(K),K= 1027, 1140) /
+ &2.8756D+00,2.6929D+00,2.5196D+00,2.3441D+00,2.1778D+00,2.0170D+00,
+ &1.8670D+00,1.7797D+00,1.6902D+00,1.5909D+00,1.4960D+00,1.4058D+00,
+ &1.3191D+00,1.2484D+00,1.1764D+00,1.0991D+00,1.0253D+00,9.5689D-01,
+ &8.9197D-01,8.4046D-01,7.8904D-01,7.3442D-01,6.8367D-01,6.3780D-01,
+ &5.9520D-01,5.6218D-01,5.2934D-01,4.9500D-01,4.6300D-01,4.3370D-01,
+ &4.0611D-01,3.8431D-01,3.6284D-01,3.4121D-01,3.2389D-01,3.1494D-01,
+ &3.0926D-01,3.0697D-01,3.0594D-01,3.0501D-01,3.0330D-01,3.0019D-01,
+ &2.9492D-01,2.8734D-01,2.7718D-01,2.6476D-01,2.5057D-01,2.3646D-01,
+ &2.2503D-01,2.7558D-01,2.7132D-01,2.7089D-01,2.7569D-01,2.8794D-01,
+ &3.1000D-01,3.4491D-01,4.0016D-01,4.8886D-01,6.4191D-01,9.5232D-01,
+ &0.0000D+00,0.0000D+00,4.8799D+00,4.6116D+00,4.3560D+00,4.1035D+00,
+ &3.8608D+00,3.6163D+00,3.3822D+00,3.1557D+00,2.9412D+00,2.7247D+00,
+ &2.5209D+00,2.3248D+00,2.1421D+00,2.0368D+00,1.9287D+00,1.8094D+00,
+ &1.6955D+00,1.5877D+00,1.4841D+00,1.4003D+00,1.3154D+00,1.2237D+00,
+ &1.1368D+00,1.0563D+00,9.8015D-01,9.2005D-01,8.5978D-01,7.9615D-01,
+ &7.3715D-01,6.8369D-01,6.3441D-01,5.9609D-01,5.5830D-01,5.1865D-01,
+ &4.8192D-01,4.4872D-01,4.1747D-01,3.9300D-01,3.6895D-01,3.4483D-01,
+ &3.2508D-01,3.1459D-01,3.0709D-01,3.0328D-01,3.0056D-01,2.9840D-01,
+ &2.9543D-01,2.9107D-01,2.8485D-01,2.7655D-01,2.6610D-01,2.5368D-01/
+ DATA (XUDF_L(K),K= 1141, 1254) /
+ &2.4019D-01,2.2736D-01,2.1837D-01,2.6080D-01,2.5542D-01,2.5362D-01,
+ &2.5693D-01,2.6661D-01,2.8505D-01,3.1490D-01,3.6226D-01,4.3798D-01,
+ &5.6769D-01,8.2836D-01,0.0000D+00,0.0000D+00,5.8340D+00,5.4940D+00,
+ &5.1700D+00,4.8532D+00,4.5515D+00,4.2463D+00,3.9559D+00,3.6752D+00,
+ &3.4138D+00,3.1496D+00,2.9022D+00,2.6648D+00,2.4450D+00,2.3189D+00,
+ &2.1896D+00,2.0476D+00,1.9120D+00,1.7843D+00,1.6621D+00,1.5639D+00,
+ &1.4648D+00,1.3569D+00,1.2556D+00,1.1618D+00,1.0734D+00,1.0037D+00,
+ &9.3416D-01,8.6065D-01,7.9257D-01,7.3145D-01,6.7463D-01,6.3082D-01,
+ &5.8786D-01,5.4262D-01,5.0118D-01,4.6374D-01,4.2883D-01,4.0146D-01,
+ &3.7490D-01,3.4814D-01,3.2612D-01,3.1397D-01,3.0482D-01,2.9958D-01,
+ &2.9536D-01,2.9178D-01,2.8756D-01,2.8208D-01,2.7504D-01,2.6611D-01,
+ &2.5539D-01,2.4319D-01,2.3031D-01,2.1877D-01,2.1195D-01,2.4673D-01,
+ &2.4036D-01,2.3746D-01,2.3912D-01,2.4677D-01,2.6223D-01,2.8748D-01,
+ &3.2792D-01,3.9255D-01,5.0271D-01,7.2095D-01,0.0000D+00,0.0000D+00,
+ &6.8578D+00,6.4388D+00,6.0380D+00,5.6501D+00,5.2825D+00,4.9103D+00,
+ &4.5613D+00,4.2230D+00,3.9070D+00,3.5911D+00,3.2966D+00,3.0156D+00,
+ &2.7567D+00,2.6078D+00,2.4563D+00,2.2905D+00,2.1319D+00,1.9837D+00,
+ &1.8421D+00,1.7287D+00,1.6141D+00,1.4902D+00,1.3730D+00,1.2663D+00,
+ &1.1652D+00,1.0858D+00,1.0067D+00,9.2337D-01,8.4648D-01,7.7710D-01/
+ DATA (XUDF_L(K),K= 1255, 1368) /
+ &7.1333D-01,6.6392D-01,6.1566D-01,5.6531D-01,5.1904D-01,4.7761D-01,
+ &4.3908D-01,4.0927D-01,3.8022D-01,3.5109D-01,3.2686D-01,3.1318D-01,
+ &3.0244D-01,2.9602D-01,2.9031D-01,2.8538D-01,2.8024D-01,2.7382D-01,
+ &2.6607D-01,2.5668D-01,2.4571D-01,2.3364D-01,2.2155D-01,2.1116D-01,
+ &2.0617D-01,2.3421D-01,2.2704D-01,2.2320D-01,2.2366D-01,2.2952D-01,
+ &2.4241D-01,2.6402D-01,2.9884D-01,3.5437D-01,4.4860D-01,6.3331D-01,
+ &0.0000D+00,0.0000D+00,7.9784D+00,7.4673D+00,6.9820D+00,6.5121D+00,
+ &6.0712D+00,5.6250D+00,5.2080D+00,4.8065D+00,4.4309D+00,4.0590D+00,
+ &3.7131D+00,3.3843D+00,3.0816D+00,2.9094D+00,2.7332D+00,2.5420D+00,
+ &2.3595D+00,2.1895D+00,2.0271D+00,1.8966D+00,1.7658D+00,1.6248D+00,
+ &1.4933D+00,1.3718D+00,1.2579D+00,1.1683D+00,1.0795D+00,9.8589D-01,
+ &8.9996D-01,8.2253D-01,7.5153D-01,6.9648D-01,6.4287D-01,5.8736D-01,
+ &5.3655D-01,4.9109D-01,4.4891D-01,4.1655D-01,3.8518D-01,3.5367D-01,
+ &3.2738D-01,3.1221D-01,3.0006D-01,2.9246D-01,2.8544D-01,2.7940D-01,
+ &2.7319D-01,2.6601D-01,2.5763D-01,2.4782D-01,2.3676D-01,2.2486D-01,
+ &2.1329D-01,2.0405D-01,2.0083D-01,2.2267D-01,2.1489D-01,2.1027D-01,
+ &2.0967D-01,2.1409D-01,2.2473D-01,2.4320D-01,2.7316D-01,3.2113D-01,
+ &4.0209D-01,5.5899D-01,0.0000D+00,0.0000D+00,9.1575D+00,8.5458D+00,
+ &7.9700D+00,7.4123D+00,6.8876D+00,6.3653D+00,5.8736D+00,5.4042D+00/
+ DATA (XUDF_L(K),K= 1369, 1482) /
+ &4.9684D+00,4.5359D+00,4.1366D+00,3.7576D+00,3.4110D+00,3.2138D+00,
+ &3.0122D+00,2.7943D+00,2.5871D+00,2.3944D+00,2.2102D+00,2.0646D+00,
+ &1.9163D+00,1.7581D+00,1.6109D+00,1.4753D+00,1.3483D+00,1.2486D+00,
+ &1.1500D+00,1.0462D+00,9.5130D-01,8.6585D-01,7.8770D-01,7.2741D-01,
+ &6.6891D-01,6.0781D-01,5.5266D-01,5.0342D-01,4.5788D-01,4.2322D-01,
+ &3.8960D-01,3.5594D-01,3.2768D-01,3.1125D-01,2.9779D-01,2.8890D-01,
+ &2.8091D-01,2.7385D-01,2.6670D-01,2.5886D-01,2.4989D-01,2.3976D-01,
+ &2.2861D-01,2.1703D-01,2.0604D-01,1.9777D-01,1.9598D-01,2.1238D-01,
+ &2.0408D-01,1.9879D-01,1.9735D-01,2.0048D-01,2.0933D-01,2.2523D-01,
+ &2.5120D-01,2.9296D-01,3.6305D-01,4.9711D-01,0.0000D+00,0.0000D+00,
+ &1.0956D+01,1.0188D+01,9.4660D+00,8.7704D+00,8.1209D+00,7.4727D+00,
+ &6.8721D+00,6.2972D+00,5.7646D+00,5.2434D+00,4.7595D+00,4.3051D+00,
+ &3.8911D+00,3.6559D+00,3.4174D+00,3.1598D+00,2.9153D+00,2.6889D+00,
+ &2.4732D+00,2.3031D+00,2.1311D+00,1.9475D+00,1.7771D+00,1.6202D+00,
+ &1.4748D+00,1.3609D+00,1.2481D+00,1.1301D+00,1.0222D+00,9.2549D-01,
+ &8.3728D-01,7.6947D-01,7.0373D-01,6.3561D-01,5.7438D-01,5.1959D-01,
+ &4.6984D-01,4.3187D-01,3.9529D-01,3.5864D-01,3.2783D-01,3.0967D-01,
+ &2.9444D-01,2.8428D-01,2.7469D-01,2.6638D-01,2.5813D-01,2.4942D-01,
+ &2.3986D-01,2.2937D-01,2.1819D-01,2.0682D-01,1.9665D-01,1.8966D-01/
+ DATA (XUDF_L(K),K= 1483, 1596) /
+ &1.8971D-01,1.9926D-01,1.9036D-01,1.8442D-01,1.8192D-01,1.8362D-01,
+ &1.9037D-01,2.0318D-01,2.2459D-01,2.5904D-01,3.1665D-01,4.2407D-01,
+ &0.0000D+00,0.0000D+00,1.2798D+01,1.1861D+01,1.0986D+01,1.0144D+01,
+ &9.3643D+00,8.5887D+00,7.8706D+00,7.1866D+00,6.5568D+00,5.9419D+00,
+ &5.3754D+00,4.8419D+00,4.3593D+00,4.0864D+00,3.8109D+00,3.5127D+00,
+ &3.2315D+00,2.9714D+00,2.7252D+00,2.5309D+00,2.3356D+00,2.1269D+00,
+ &1.9338D+00,1.7578D+00,1.5939D+00,1.4656D+00,1.3394D+00,1.2075D+00,
+ &1.0875D+00,9.8023D-01,8.8256D-01,8.0772D-01,7.3533D-01,6.6054D-01,
+ &5.9364D-01,5.3423D-01,4.8009D-01,4.3930D-01,4.0003D-01,3.6079D-01,
+ &3.2768D-01,3.0809D-01,2.9130D-01,2.7993D-01,2.6898D-01,2.5976D-01,
+ &2.5062D-01,2.4123D-01,2.3116D-01,2.2040D-01,2.0917D-01,1.9814D-01,
+ &1.8865D-01,1.8272D-01,1.8428D-01,1.8820D-01,1.7883D-01,1.7238D-01,
+ &1.6914D-01,1.6979D-01,1.7482D-01,1.8534D-01,2.0325D-01,2.3214D-01,
+ &2.8022D-01,3.6659D-01,0.0000D+00,0.0000D+00,1.4900D+01,1.3767D+01,
+ &1.2708D+01,1.1700D+01,1.0766D+01,9.8403D+00,8.9832D+00,8.1757D+00,
+ &7.4366D+00,6.7121D+00,6.0486D+00,5.4300D+00,4.8704D+00,4.5555D+00,
+ &4.2371D+00,3.8955D+00,3.5734D+00,3.2760D+00,2.9952D+00,2.7738D+00,
+ &2.5528D+00,2.3175D+00,2.1001D+00,1.9012D+00,1.7176D+00,1.5750D+00,
+ &1.4344D+00,1.2880D+00,1.1547D+00,1.0364D+00,9.2859D-01,8.4652D-01/
+ DATA (XUDF_L(K),K= 1597, 1710) /
+ &7.6723D-01,6.8578D-01,6.1255D-01,5.4848D-01,4.9034D-01,4.4649D-01,
+ &4.0456D-01,3.6275D-01,3.2738D-01,3.0624D-01,2.8805D-01,2.7544D-01,
+ &2.6343D-01,2.5315D-01,2.4318D-01,2.3314D-01,2.2263D-01,2.1166D-01,
+ &2.0051D-01,1.8983D-01,1.8102D-01,1.7610D-01,1.7901D-01,1.7764D-01,
+ &1.6791D-01,1.6102D-01,1.5715D-01,1.5684D-01,1.6056D-01,1.6899D-01,
+ &1.8376D-01,2.0786D-01,2.4776D-01,3.1470D-01,0.0000D+00,0.0000D+00,
+ &1.7212D+01,1.5853D+01,1.4590D+01,1.3390D+01,1.2283D+01,1.1191D+01,
+ &1.0185D+01,9.2395D+00,8.3762D+00,7.5315D+00,6.7670D+00,6.0503D+00,
+ &5.4086D+00,5.0481D+00,4.6843D+00,4.2940D+00,3.9280D+00,3.5917D+00,
+ &3.2752D+00,3.0252D+00,2.7768D+00,2.5132D+00,2.2690D+00,2.0490D+00,
+ &1.8445D+00,1.6857D+00,1.5301D+00,1.3685D+00,1.2219D+00,1.0920D+00,
+ &9.7438D-01,8.8478D-01,7.9825D-01,7.1007D-01,6.3111D-01,5.6196D-01,
+ &5.0016D-01,4.5321D-01,4.0867D-01,3.6435D-01,3.2686D-01,3.0431D-01,
+ &2.8470D-01,2.7109D-01,2.5789D-01,2.4674D-01,2.3605D-01,2.2547D-01,
+ &2.1459D-01,2.0348D-01,1.9237D-01,1.8201D-01,1.7376D-01,1.6982D-01,
+ &1.7398D-01,1.6789D-01,1.5795D-01,1.5065D-01,1.4630D-01,1.4521D-01,
+ &1.4773D-01,1.5443D-01,1.6659D-01,1.8664D-01,2.1966D-01,2.6878D-01,
+ &0.0000D+00,0.0000D+00,1.9526D+01,1.7951D+01,1.6470D+01,1.5074D+01,
+ &1.3790D+01,1.2527D+01,1.1370D+01,1.0282D+01,9.2958D+00,8.3330D+00/
+ DATA (XUDF_L(K),K= 1711, 1824) /
+ &7.4603D+00,6.6536D+00,5.9285D+00,5.5219D+00,5.1141D+00,4.6768D+00,
+ &4.2681D+00,3.8926D+00,3.5402D+00,3.2626D+00,2.9882D+00,2.6963D+00,
+ &2.4284D+00,2.1851D+00,1.9619D+00,1.7885D+00,1.6187D+00,1.4429D+00,
+ &1.2838D+00,1.1431D+00,1.0159D+00,9.1924D-01,8.2663D-01,7.3180D-01,
+ &6.4793D-01,5.7429D-01,5.0828D-01,4.5904D-01,4.1215D-01,3.6558D-01,
+ &3.2620D-01,3.0238D-01,2.8167D-01,2.6700D-01,2.5302D-01,2.4098D-01,
+ &2.2975D-01,2.1873D-01,2.0756D-01,1.9633D-01,1.8532D-01,1.7533D-01,
+ &1.6763D-01,1.6450D-01,1.6959D-01,1.5953D-01,1.4943D-01,1.4185D-01,
+ &1.3716D-01,1.3545D-01,1.3705D-01,1.4238D-01,1.5258D-01,1.6945D-01,
+ &1.9705D-01,2.3049D-01,0.0000D+00,0.0000D+00,2.2141D+01,2.0286D+01,
+ &1.8570D+01,1.6948D+01,1.5466D+01,1.4010D+01,1.2679D+01,1.1431D+01,
+ &1.0303D+01,9.2106D+00,8.2239D+00,7.3077D+00,6.4926D+00,6.0348D+00,
+ &5.5765D+00,5.0879D+00,4.6321D+00,4.2138D+00,3.8233D+00,3.5162D+00,
+ &3.2122D+00,2.8907D+00,2.5960D+00,2.3300D+00,2.0856D+00,1.8954D+00,
+ &1.7110D+00,1.5199D+00,1.3476D+00,1.1955D+00,1.0584D+00,9.5478D-01,
+ &8.5531D-01,7.5417D-01,6.6439D-01,5.8623D-01,5.1682D-01,4.6468D-01,
+ &4.1541D-01,3.6662D-01,3.2538D-01,3.0035D-01,2.7843D-01,2.6291D-01,
+ &2.4798D-01,2.3522D-01,2.2346D-01,2.1203D-01,2.0062D-01,1.8935D-01,
+ &1.7843D-01,1.6874D-01,1.6163D-01,1.5920D-01,1.6520D-01,1.5147D-01/
+ DATA (XUDF_L(K),K= 1825, 1836) /
+ &1.4120D-01,1.3349D-01,1.2844D-01,1.2620D-01,1.2701D-01,1.3118D-01,
+ &1.3954D-01,1.5369D-01,1.7631D-01,1.9416D-01,0.0000D+00,0.0000D+00/
+ DATA (XSF_L(K),K= 1, 114) /
+ &8.9277D-03,9.2838D-03,9.6380D-03,9.9960D-03,1.0349D-02,1.0719D-02,
+ &1.1082D-02,1.1442D-02,1.1792D-02,1.2148D-02,1.2489D-02,1.2817D-02,
+ &1.3124D-02,1.3295D-02,1.3474D-02,1.3661D-02,1.3835D-02,1.3985D-02,
+ &1.4121D-02,1.4217D-02,1.4303D-02,1.4379D-02,1.4419D-02,1.4434D-02,
+ &1.4412D-02,1.4366D-02,1.4286D-02,1.4158D-02,1.3991D-02,1.3790D-02,
+ &1.3553D-02,1.3335D-02,1.3094D-02,1.2821D-02,1.2580D-02,1.2410D-02,
+ &1.2357D-02,1.2459D-02,1.2790D-02,1.3571D-02,1.5018D-02,1.6665D-02,
+ &1.9113D-02,2.1832D-02,2.5587D-02,2.9818D-02,3.4535D-02,3.9813D-02,
+ &4.5737D-02,5.2358D-02,5.9765D-02,6.8021D-02,7.7185D-02,8.7258D-02,
+ &9.8198D-02,1.1073D-01,1.4216D-01,1.8364D-01,2.3959D-01,3.1758D-01,
+ &4.3050D-01,6.0203D-01,8.8214D-01,1.3845D+00,2.4294D+00,5.2463D+00,
+ &1.8903D+01,0.0000D+00,1.4987D-02,1.5468D-02,1.5936D-02,1.6403D-02,
+ &1.6855D-02,1.7319D-02,1.7760D-02,1.8194D-02,1.8600D-02,1.9008D-02,
+ &1.9382D-02,1.9730D-02,2.0033D-02,2.0199D-02,2.0359D-02,2.0523D-02,
+ &2.0654D-02,2.0760D-02,2.0831D-02,2.0870D-02,2.0886D-02,2.0858D-02,
+ &2.0798D-02,2.0680D-02,2.0523D-02,2.0363D-02,2.0127D-02,1.9825D-02,
+ &1.9464D-02,1.9060D-02,1.8607D-02,1.8200D-02,1.7750D-02,1.7240D-02,
+ &1.6759D-02,1.6362D-02,1.6103D-02,1.6050D-02,1.6240D-02,1.6916D-02,
+ &1.8336D-02,2.0030D-02,2.2586D-02,2.5447D-02,2.9418D-02,3.3874D-02/
+ DATA (XSF_L(K),K= 115, 228) /
+ &3.8821D-02,4.4375D-02,5.0509D-02,5.7343D-02,6.4974D-02,7.3385D-02,
+ &8.2640D-02,9.2732D-02,1.0354D-01,1.1667D-01,1.4809D-01,1.8910D-01,
+ &2.4387D-01,3.1940D-01,4.2764D-01,5.9054D-01,8.5228D-01,1.3150D+00,
+ &2.2623D+00,4.7596D+00,1.6445D+01,0.0000D+00,2.5010D-02,2.5616D-02,
+ &2.6180D-02,2.6758D-02,2.7279D-02,2.7792D-02,2.8274D-02,2.8729D-02,
+ &2.9134D-02,2.9513D-02,2.9836D-02,3.0110D-02,3.0324D-02,3.0417D-02,
+ &3.0492D-02,3.0537D-02,3.0551D-02,3.0517D-02,3.0432D-02,3.0326D-02,
+ &3.0181D-02,2.9954D-02,2.9663D-02,2.9316D-02,2.8913D-02,2.8508D-02,
+ &2.8021D-02,2.7422D-02,2.6741D-02,2.5997D-02,2.5204D-02,2.4500D-02,
+ &2.3734D-02,2.2858D-02,2.2019D-02,2.1281D-02,2.0698D-02,2.0402D-02,
+ &2.0365D-02,2.0844D-02,2.2137D-02,2.3807D-02,2.6404D-02,2.9338D-02,
+ &3.3433D-02,3.8036D-02,4.3135D-02,4.8799D-02,5.5061D-02,6.1999D-02,
+ &6.9633D-02,7.8024D-02,8.7156D-02,9.6998D-02,1.0742D-01,1.2099D-01,
+ &1.5162D-01,1.9121D-01,2.4363D-01,3.1510D-01,4.1638D-01,5.6669D-01,
+ &8.0557D-01,1.2216D+00,2.0572D+00,4.2084D+00,1.3911D+01,0.0000D+00,
+ &4.2554D-02,4.3210D-02,4.3820D-02,4.4379D-02,4.4862D-02,4.5317D-02,
+ &4.5708D-02,4.6037D-02,4.6300D-02,4.6434D-02,4.6540D-02,4.6530D-02,
+ &4.6426D-02,4.6317D-02,4.6155D-02,4.5919D-02,4.5622D-02,4.5267D-02,
+ &4.4833D-02,4.4425D-02,4.3932D-02,4.3298D-02,4.2582D-02,4.1785D-02/
+ DATA (XSF_L(K),K= 229, 342) /
+ &4.0903D-02,4.0097D-02,3.9179D-02,3.8047D-02,3.6815D-02,3.5547D-02,
+ &3.4199D-02,3.3020D-02,3.1748D-02,3.0298D-02,2.8905D-02,2.7644D-02,
+ &2.6563D-02,2.5882D-02,2.5485D-02,2.5614D-02,2.6651D-02,2.8199D-02,
+ &3.0731D-02,3.3652D-02,3.7768D-02,4.2390D-02,4.7530D-02,5.3188D-02,
+ &5.9436D-02,6.6257D-02,7.3734D-02,8.1918D-02,9.0696D-02,1.0004D-01,
+ &1.0978D-01,1.2357D-01,1.5274D-01,1.8999D-01,2.3888D-01,3.0452D-01,
+ &3.9656D-01,5.3136D-01,7.4246D-01,1.1043D+00,1.8158D+00,3.6023D+00,
+ &0.0000D+00,0.0000D+00,7.3602D-02,7.4085D-02,7.4460D-02,7.4729D-02,
+ &7.4904D-02,7.4982D-02,7.4902D-02,7.4713D-02,7.4446D-02,7.3972D-02,
+ &7.3397D-02,7.2626D-02,7.1803D-02,7.1200D-02,7.0479D-02,6.9610D-02,
+ &6.8654D-02,6.7624D-02,6.6495D-02,6.5467D-02,6.4313D-02,6.2898D-02,
+ &6.1380D-02,5.9788D-02,5.8079D-02,5.6557D-02,5.4876D-02,5.2866D-02,
+ &5.0733D-02,4.8592D-02,4.6341D-02,4.4415D-02,4.2370D-02,4.0073D-02,
+ &3.7825D-02,3.5778D-02,3.3956D-02,3.2702D-02,3.1749D-02,3.1334D-02,
+ &3.1922D-02,3.3216D-02,3.5534D-02,3.8322D-02,4.2321D-02,4.6830D-02,
+ &5.1816D-02,5.7335D-02,6.3369D-02,6.9947D-02,7.7109D-02,8.4752D-02,
+ &9.2948D-02,1.0153D-01,1.1031D-01,1.2405D-01,1.5100D-01,1.8509D-01,
+ &2.2905D-01,2.8761D-01,3.6847D-01,4.8537D-01,6.6543D-01,9.6831D-01,
+ &1.5524D+00,2.9766D+00,0.0000D+00,0.0000D+00,1.1509D-01,1.1500D-01/
+ DATA (XSF_L(K),K= 343, 456) /
+ &1.1474D-01,1.1430D-01,1.1371D-01,1.1292D-01,1.1196D-01,1.1079D-01,
+ &1.0948D-01,1.0791D-01,1.0620D-01,1.0426D-01,1.0215D-01,1.0076D-01,
+ &9.9224D-02,9.7466D-02,9.5472D-02,9.3507D-02,9.1346D-02,8.9460D-02,
+ &8.7382D-02,8.4914D-02,8.2326D-02,7.9663D-02,7.6874D-02,7.4459D-02,
+ &7.1794D-02,6.8694D-02,6.5489D-02,6.2266D-02,5.8964D-02,5.6164D-02,
+ &5.3226D-02,4.9916D-02,4.6721D-02,4.3794D-02,4.1128D-02,3.9225D-02,
+ &3.7654D-02,3.6613D-02,3.6666D-02,3.7626D-02,3.9655D-02,4.2227D-02,
+ &4.6000D-02,5.0288D-02,5.5044D-02,6.0308D-02,6.6020D-02,7.2218D-02,
+ &7.8943D-02,8.6079D-02,9.3611D-02,1.0141D-01,1.0925D-01,1.2274D-01,
+ &1.4748D-01,1.7840D-01,2.1791D-01,2.6997D-01,3.4109D-01,4.4280D-01,
+ &5.9706D-01,8.5325D-01,1.3371D+00,2.4909D+00,0.0000D+00,0.0000D+00,
+ &1.8131D-01,1.7986D-01,1.7802D-01,1.7597D-01,1.7372D-01,1.7110D-01,
+ &1.6825D-01,1.6515D-01,1.6187D-01,1.5820D-01,1.5428D-01,1.5016D-01,
+ &1.4582D-01,1.4314D-01,1.4017D-01,1.3677D-01,1.3315D-01,1.2951D-01,
+ &1.2571D-01,1.2248D-01,1.1891D-01,1.1472D-01,1.1045D-01,1.0615D-01,
+ &1.0173D-01,9.7944D-02,9.3854D-02,8.9131D-02,8.4347D-02,7.9597D-02,
+ &7.4799D-02,7.0788D-02,6.6599D-02,6.1932D-02,5.7438D-02,5.3307D-02,
+ &4.9546D-02,4.6816D-02,4.4417D-02,4.2536D-02,4.1862D-02,4.2361D-02,
+ &4.3960D-02,4.6198D-02,4.9612D-02,5.3553D-02,5.7974D-02,6.2830D-02/
+ DATA (XSF_L(K),K= 457, 570) /
+ &6.8141D-02,7.3865D-02,7.9970D-02,8.6422D-02,9.3160D-02,1.0006D-01,
+ &1.0685D-01,1.1989D-01,1.4199D-01,1.6937D-01,2.0407D-01,2.4925D-01,
+ &3.1029D-01,3.9635D-01,5.2529D-01,7.3579D-01,1.1263D+00,2.0347D+00,
+ &0.0000D+00,0.0000D+00,2.6278D-01,2.5883D-01,2.5460D-01,2.5007D-01,
+ &2.4526D-01,2.3995D-01,2.3437D-01,2.2848D-01,2.2242D-01,2.1578D-01,
+ &2.0894D-01,2.0181D-01,1.9465D-01,1.9018D-01,1.8540D-01,1.7984D-01,
+ &1.7415D-01,1.6846D-01,1.6261D-01,1.5768D-01,1.5234D-01,1.4615D-01,
+ &1.3987D-01,1.3368D-01,1.2736D-01,1.2199D-01,1.1628D-01,1.0975D-01,
+ &1.0321D-01,9.6788D-02,9.0380D-02,8.5059D-02,7.9532D-02,7.3436D-02,
+ &6.7594D-02,6.2243D-02,5.7363D-02,5.3720D-02,5.0502D-02,4.7772D-02,
+ &4.6346D-02,4.6358D-02,4.7497D-02,4.9377D-02,5.2401D-02,5.5965D-02,
+ &6.0009D-02,6.4489D-02,6.9334D-02,7.4546D-02,8.0117D-02,8.5936D-02,
+ &9.1972D-02,9.8056D-02,1.0398D-01,1.1644D-01,1.3628D-01,1.6068D-01,
+ &1.9127D-01,2.3085D-01,2.8377D-01,3.5756D-01,4.6698D-01,6.4315D-01,
+ &9.6485D-01,1.6969D+00,0.0000D+00,0.0000D+00,3.6944D-01,3.6187D-01,
+ &3.5380D-01,3.4525D-01,3.3659D-01,3.2716D-01,3.1761D-01,3.0767D-01,
+ &2.9759D-01,2.8675D-01,2.7586D-01,2.6462D-01,2.5339D-01,2.4660D-01,
+ &2.3933D-01,2.3101D-01,2.2257D-01,2.1415D-01,2.0571D-01,1.9854D-01,
+ &1.9083D-01,1.8216D-01,1.7338D-01,1.6480D-01,1.5613D-01,1.4885D-01/
+ DATA (XSF_L(K),K= 571, 684) /
+ &1.4115D-01,1.3244D-01,1.2380D-01,1.1542D-01,1.0713D-01,1.0031D-01,
+ &9.3226D-02,8.5515D-02,7.8171D-02,7.1449D-02,6.5307D-02,6.0723D-02,
+ &5.6523D-02,5.2878D-02,5.0622D-02,5.0109D-02,5.0720D-02,5.2187D-02,
+ &5.4770D-02,5.7950D-02,6.1582D-02,6.5595D-02,6.9997D-02,7.4716D-02,
+ &7.9677D-02,8.4886D-02,9.0221D-02,9.5543D-02,1.0065D-01,1.1245D-01,
+ &1.3012D-01,1.5166D-01,1.7859D-01,2.1305D-01,2.5881D-01,3.2188D-01,
+ &4.1454D-01,5.6186D-01,8.2718D-01,1.4188D+00,0.0000D+00,0.0000D+00,
+ &4.9195D-01,4.7916D-01,4.6620D-01,4.5277D-01,4.3908D-01,4.2463D-01,
+ &4.0985D-01,3.9491D-01,3.7975D-01,3.6377D-01,3.4790D-01,3.3178D-01,
+ &3.1592D-01,3.0640D-01,2.9622D-01,2.8462D-01,2.7303D-01,2.6160D-01,
+ &2.5012D-01,2.4047D-01,2.3023D-01,2.1867D-01,2.0717D-01,1.9597D-01,
+ &1.8477D-01,1.7546D-01,1.6568D-01,1.5468D-01,1.4387D-01,1.3343D-01,
+ &1.2319D-01,1.1482D-01,1.0622D-01,9.6828D-02,8.7978D-02,7.9884D-02,
+ &7.2526D-02,6.6973D-02,6.1948D-02,5.7359D-02,5.4304D-02,5.3263D-02,
+ &5.3381D-02,5.4456D-02,5.6601D-02,5.9380D-02,6.2613D-02,6.6252D-02,
+ &7.0174D-02,7.4432D-02,7.8943D-02,8.3559D-02,8.8282D-02,9.2963D-02,
+ &9.7382D-02,1.0858D-01,1.2441D-01,1.4363D-01,1.6745D-01,1.9778D-01,
+ &2.3771D-01,2.9246D-01,3.7200D-01,4.9738D-01,7.2010D-01,1.2083D+00,
+ &0.0000D+00,0.0000D+00,6.4521D-01,6.2534D-01,6.0540D-01,5.8499D-01/
+ DATA (XSF_L(K),K= 685, 798) /
+ &5.6467D-01,5.4301D-01,5.2143D-01,4.9951D-01,4.7813D-01,4.5538D-01,
+ &4.3325D-01,4.1083D-01,3.8899D-01,3.7591D-01,3.6210D-01,3.4648D-01,
+ &3.3091D-01,3.1578D-01,3.0062D-01,2.8797D-01,2.7469D-01,2.5979D-01,
+ &2.4501D-01,2.3066D-01,2.1649D-01,2.0481D-01,1.9252D-01,1.7884D-01,
+ &1.6549D-01,1.5274D-01,1.4029D-01,1.3018D-01,1.1985D-01,1.0865D-01,
+ &9.8135D-02,8.8550D-02,7.9829D-02,7.3318D-02,6.7269D-02,6.1748D-02,
+ &5.7838D-02,5.6250D-02,5.5826D-02,5.6474D-02,5.8181D-02,6.0533D-02,
+ &6.3373D-02,6.6563D-02,7.0085D-02,7.3865D-02,7.7842D-02,8.1937D-02,
+ &8.6092D-02,9.0169D-02,9.3962D-02,1.0448D-01,1.1858D-01,1.3561D-01,
+ &1.5663D-01,1.8318D-01,2.1803D-01,2.6529D-01,3.3349D-01,4.3985D-01,
+ &6.2661D-01,1.0291D+00,0.0000D+00,0.0000D+00,8.2462D-01,7.9558D-01,
+ &7.6680D-01,7.3764D-01,7.0860D-01,6.7834D-01,6.4822D-01,6.1798D-01,
+ &5.8880D-01,5.5792D-01,5.2800D-01,4.9801D-01,4.6912D-01,4.5197D-01,
+ &4.3393D-01,4.1360D-01,3.9348D-01,3.7394D-01,3.5462D-01,3.3856D-01,
+ &3.2180D-01,3.0303D-01,2.8460D-01,2.6681D-01,2.4932D-01,2.3502D-01,
+ &2.2005D-01,2.0359D-01,1.8747D-01,1.7224D-01,1.5746D-01,1.4551D-01,
+ &1.3337D-01,1.2028D-01,1.0805D-01,9.6986D-02,8.6877D-02,7.9334D-02,
+ &7.2326D-02,6.5799D-02,6.1060D-02,5.8911D-02,5.7957D-02,5.8189D-02,
+ &5.9441D-02,6.1387D-02,6.3834D-02,6.6632D-02,6.9732D-02,7.3070D-02/
+ DATA (XSF_L(K),K= 799, 912) /
+ &7.6595D-02,8.0190D-02,8.3816D-02,8.7358D-02,9.0631D-02,1.0046D-01,
+ &1.1304D-01,1.2815D-01,1.4670D-01,1.7006D-01,2.0049D-01,2.4154D-01,
+ &3.0039D-01,3.9121D-01,5.4894D-01,8.8378D-01,0.0000D+00,0.0000D+00,
+ &1.0199D+00,9.8025D-01,9.4100D-01,9.0151D-01,8.6283D-01,8.2243D-01,
+ &7.8262D-01,7.4321D-01,7.0465D-01,6.6494D-01,6.2647D-01,5.8811D-01,
+ &5.5152D-01,5.2985D-01,5.0721D-01,4.8183D-01,4.5681D-01,4.3274D-01,
+ &4.0883D-01,3.8916D-01,3.6878D-01,3.4589D-01,3.2366D-01,3.0238D-01,
+ &2.8152D-01,2.6437D-01,2.4685D-01,2.2733D-01,2.0858D-01,1.9085D-01,
+ &1.7375D-01,1.6000D-01,1.4607D-01,1.3115D-01,1.1722D-01,1.0469D-01,
+ &9.3284D-02,8.4739D-02,7.6803D-02,6.9420D-02,6.3844D-02,6.1178D-02,
+ &5.9720D-02,5.9561D-02,6.0398D-02,6.1984D-02,6.4051D-02,6.6494D-02,
+ &6.9202D-02,7.2161D-02,7.5274D-02,7.8453D-02,8.1651D-02,8.4728D-02,
+ &8.7564D-02,9.6777D-02,1.0806D-01,1.2157D-01,1.3806D-01,1.5882D-01,
+ &1.8566D-01,2.2170D-01,2.7301D-01,3.5168D-01,4.8696D-01,7.7010D-01,
+ &0.0000D+00,0.0000D+00,1.3158D+00,1.2585D+00,1.2024D+00,1.1462D+00,
+ &1.0919D+00,1.0352D+00,9.8042D-01,9.2608D-01,8.7345D-01,8.1987D-01,
+ &7.6814D-01,7.1724D-01,6.6882D-01,6.4053D-01,6.1093D-01,5.7796D-01,
+ &5.4572D-01,5.1470D-01,4.8433D-01,4.5934D-01,4.3358D-01,4.0495D-01,
+ &3.7717D-01,3.5082D-01,3.2513D-01,3.0408D-01,2.8258D-01,2.5918D-01/
+ DATA (XSF_L(K),K= 913, 1026) /
+ &2.3648D-01,2.1538D-01,1.9510D-01,1.7888D-01,1.6255D-01,1.4508D-01,
+ &1.2895D-01,1.1443D-01,1.0131D-01,9.1507D-02,8.2387D-02,7.3778D-02,
+ &6.7147D-02,6.3813D-02,6.1721D-02,6.1065D-02,6.1373D-02,6.2475D-02,
+ &6.4105D-02,6.6079D-02,6.8362D-02,7.0856D-02,7.3440D-02,7.6143D-02,
+ &7.8812D-02,8.1388D-02,8.3726D-02,9.2167D-02,1.0190D-01,1.1355D-01,
+ &1.2780D-01,1.4554D-01,1.6841D-01,1.9900D-01,2.4223D-01,3.0775D-01,
+ &4.1920D-01,6.4849D-01,0.0000D+00,0.0000D+00,1.6483D+00,1.5703D+00,
+ &1.4940D+00,1.4180D+00,1.3449D+00,1.2694D+00,1.1966D+00,1.1250D+00,
+ &1.0566D+00,9.8644D-01,9.1985D-01,8.5482D-01,7.9312D-01,7.5722D-01,
+ &7.1986D-01,6.7849D-01,6.3821D-01,5.9972D-01,5.6214D-01,5.3143D-01,
+ &4.9987D-01,4.6500D-01,4.3136D-01,3.9956D-01,3.6875D-01,3.4379D-01,
+ &3.1832D-01,2.9044D-01,2.6397D-01,2.3923D-01,2.1580D-01,1.9706D-01,
+ &1.7829D-01,1.5838D-01,1.3999D-01,1.2356D-01,1.0875D-01,9.7664D-02,
+ &8.7392D-02,7.7645D-02,7.0035D-02,6.6062D-02,6.3365D-02,6.2239D-02,
+ &6.2062D-02,6.2731D-02,6.3942D-02,6.5526D-02,6.7390D-02,6.9436D-02,
+ &7.1635D-02,7.3891D-02,7.6122D-02,7.8246D-02,8.0196D-02,8.7884D-02,
+ &9.6357D-02,1.0648D-01,1.1880D-01,1.3413D-01,1.5386D-01,1.7993D-01,
+ &2.1655D-01,2.7189D-01,3.6486D-01,5.5332D-01,0.0000D+00,0.0000D+00,
+ &2.0271D+00,1.9234D+00,1.8224D+00,1.7226D+00,1.6272D+00,1.5293D+00/
+ DATA (XSF_L(K),K= 1027, 1140) /
+ &1.4356D+00,1.3438D+00,1.2568D+00,1.1682D+00,1.0841D+00,1.0026D+00,
+ &9.2625D-01,8.8207D-01,8.3568D-01,7.8523D-01,7.3607D-01,6.8926D-01,
+ &6.4385D-01,6.0685D-01,5.6892D-01,5.2730D-01,4.8731D-01,4.4961D-01,
+ &4.1331D-01,3.8417D-01,3.5441D-01,3.2210D-01,2.9168D-01,2.6323D-01,
+ &2.3631D-01,2.1500D-01,1.9374D-01,1.7129D-01,1.5067D-01,1.3231D-01,
+ &1.1579D-01,1.0349D-01,9.2080D-02,8.1205D-02,7.2626D-02,6.8039D-02,
+ &6.4761D-02,6.3188D-02,6.2549D-02,6.2795D-02,6.3617D-02,6.4835D-02,
+ &6.6329D-02,6.8017D-02,6.9809D-02,7.1667D-02,7.3520D-02,7.5270D-02,
+ &7.6864D-02,8.3899D-02,9.1206D-02,1.0002D-01,1.1070D-01,1.2399D-01,
+ &1.4094D-01,1.6341D-01,1.9474D-01,2.4163D-01,3.1971D-01,4.7587D-01,
+ &0.0000D+00,0.0000D+00,2.4392D+00,2.3049D+00,2.1760D+00,2.0502D+00,
+ &1.9296D+00,1.8065D+00,1.6895D+00,1.5750D+00,1.4674D+00,1.3585D+00,
+ &1.2554D+00,1.1565D+00,1.0638D+00,1.0103D+00,9.5527D-01,8.9449D-01,
+ &8.3572D-01,7.8018D-01,7.2635D-01,6.8280D-01,6.3819D-01,5.8948D-01,
+ &5.4299D-01,4.9923D-01,4.5740D-01,4.2371D-01,3.8978D-01,3.5296D-01,
+ &3.1832D-01,2.8629D-01,2.5599D-01,2.3212D-01,2.0840D-01,1.8346D-01,
+ &1.6065D-01,1.4043D-01,1.2229D-01,1.0880D-01,9.6294D-02,8.4335D-02,
+ &7.4905D-02,6.9717D-02,6.5897D-02,6.3914D-02,6.2851D-02,6.2731D-02,
+ &6.3183D-02,6.4075D-02,6.5225D-02,6.6597D-02,6.8048D-02,6.9577D-02/
+ DATA (XSF_L(K),K= 1141, 1254) /
+ &7.1093D-02,7.2525D-02,7.3842D-02,8.0241D-02,8.6615D-02,9.4292D-02,
+ &1.0360D-01,1.1517D-01,1.2992D-01,1.4936D-01,1.7633D-01,2.1652D-01,
+ &2.8294D-01,4.1389D-01,0.0000D+00,0.0000D+00,2.9162D+00,2.7470D+00,
+ &2.5840D+00,2.4244D+00,2.2743D+00,2.1215D+00,1.9764D+00,1.8358D+00,
+ &1.7035D+00,1.5708D+00,1.4463D+00,1.3268D+00,1.2152D+00,1.1514D+00,
+ &1.0857D+00,1.0132D+00,9.4449D-01,8.7867D-01,8.1556D-01,7.6453D-01,
+ &7.1252D-01,6.5602D-01,6.0218D-01,5.5192D-01,5.0387D-01,4.6545D-01,
+ &4.2679D-01,3.8521D-01,3.4602D-01,3.1005D-01,2.7623D-01,2.4962D-01,
+ &2.2332D-01,1.9577D-01,1.7070D-01,1.4856D-01,1.2874D-01,1.1402D-01,
+ &1.0040D-01,8.7343D-02,7.6984D-02,7.1254D-02,6.6892D-02,6.4508D-02,
+ &6.3019D-02,6.2518D-02,6.2667D-02,6.3211D-02,6.4031D-02,6.5064D-02,
+ &6.6243D-02,6.7458D-02,6.8679D-02,6.9830D-02,7.0885D-02,7.6672D-02,
+ &8.2192D-02,8.8844D-02,9.6930D-02,1.0696D-01,1.1972D-01,1.3654D-01,
+ &1.5978D-01,1.9411D-01,2.5048D-01,3.6023D-01,0.0000D+00,0.0000D+00,
+ &3.4281D+00,3.2194D+00,3.0180D+00,2.8239D+00,2.6400D+00,2.4537D+00,
+ &2.2781D+00,2.1087D+00,1.9503D+00,1.7915D+00,1.6433D+00,1.5021D+00,
+ &1.3711D+00,1.2958D+00,1.2191D+00,1.1350D+00,1.0536D+00,9.7846D-01,
+ &9.0526D-01,8.4668D-01,7.8697D-01,7.2243D-01,6.6110D-01,6.0402D-01,
+ &5.4971D-01,5.0652D-01,4.6307D-01,4.1647D-01,3.7287D-01,3.3288D-01/
+ DATA (XSF_L(K),K= 1255, 1368) /
+ &2.9545D-01,2.6636D-01,2.3751D-01,2.0740D-01,1.8012D-01,1.5611D-01,
+ &1.3467D-01,1.1881D-01,1.0414D-01,9.0105D-02,7.8839D-02,7.2563D-02,
+ &6.7703D-02,6.4930D-02,6.3070D-02,6.2241D-02,6.2071D-02,6.2347D-02,
+ &6.2882D-02,6.3645D-02,6.4526D-02,6.5473D-02,6.6427D-02,6.7333D-02,
+ &6.8194D-02,7.3430D-02,7.8217D-02,8.3974D-02,9.1017D-02,9.9745D-02,
+ &1.1088D-01,1.2552D-01,1.4563D-01,1.7528D-01,2.2351D-01,3.1636D-01,
+ &0.0000D+00,0.0000D+00,3.9892D+00,3.7328D+00,3.4900D+00,3.2549D+00,
+ &3.0344D+00,2.8108D+00,2.6014D+00,2.4001D+00,2.2123D+00,2.0253D+00,
+ &1.8518D+00,1.6860D+00,1.5339D+00,1.4463D+00,1.3575D+00,1.2608D+00,
+ &1.1678D+00,1.0809D+00,9.9767D-01,9.3087D-01,8.6314D-01,7.8996D-01,
+ &7.2083D-01,6.5671D-01,5.9602D-01,5.4775D-01,4.9935D-01,4.4773D-01,
+ &3.9951D-01,3.5571D-01,3.1467D-01,2.8272D-01,2.5135D-01,2.1871D-01,
+ &1.8923D-01,1.6331D-01,1.4031D-01,1.2332D-01,1.0762D-01,9.2560D-02,
+ &8.0473D-02,7.3714D-02,6.8385D-02,6.5246D-02,6.3019D-02,6.1878D-02,
+ &6.1420D-02,6.1413D-02,6.1734D-02,6.2226D-02,6.2861D-02,6.3564D-02,
+ &6.4288D-02,6.4985D-02,6.5657D-02,7.0367D-02,7.4522D-02,7.9506D-02,
+ &8.5651D-02,9.3297D-02,1.0298D-01,1.1572D-01,1.3323D-01,1.5884D-01,
+ &2.0039D-01,2.7925D-01,0.0000D+00,0.0000D+00,4.5788D+00,4.2729D+00,
+ &3.9840D+00,3.7039D+00,3.4438D+00,3.1812D+00,2.9349D+00,2.6996D+00/
+ DATA (XSF_L(K),K= 1369, 1482) /
+ &2.4810D+00,2.2644D+00,2.0633D+00,1.8732D+00,1.6979D+00,1.5988D+00,
+ &1.4974D+00,1.3865D+00,1.2812D+00,1.1834D+00,1.0891D+00,1.0143D+00,
+ &9.3839D-01,8.5662D-01,7.7948D-01,7.0838D-01,6.4106D-01,5.8780D-01,
+ &5.3454D-01,4.7781D-01,4.2528D-01,3.7737D-01,3.3289D-01,2.9818D-01,
+ &2.6446D-01,2.2932D-01,1.9770D-01,1.7005D-01,1.4552D-01,1.2746D-01,
+ &1.1078D-01,9.4770D-02,8.1957D-02,7.4689D-02,6.8915D-02,6.5457D-02,
+ &6.2902D-02,6.1493D-02,6.0768D-02,6.0515D-02,6.0585D-02,6.0863D-02,
+ &6.1298D-02,6.1789D-02,6.2311D-02,6.2835D-02,6.3340D-02,6.7601D-02,
+ &7.1162D-02,7.5516D-02,8.0878D-02,8.7566D-02,9.6095D-02,1.0725D-01,
+ &1.2258D-01,1.4495D-01,1.8090D-01,2.4841D-01,0.0000D+00,0.0000D+00,
+ &5.4774D+00,5.0929D+00,4.7320D+00,4.3841D+00,4.0592D+00,3.7350D+00,
+ &3.4329D+00,3.1454D+00,2.8799D+00,2.6172D+00,2.3747D+00,2.1466D+00,
+ &1.9383D+00,1.8195D+00,1.6996D+00,1.5689D+00,1.4457D+00,1.3301D+00,
+ &1.2211D+00,1.1339D+00,1.0456D+00,9.5119D-01,8.6259D-01,7.8097D-01,
+ &7.0419D-01,6.4380D-01,5.8358D-01,5.1955D-01,4.6051D-01,4.0719D-01,
+ &3.5768D-01,3.1962D-01,2.8220D-01,2.4360D-01,2.0909D-01,1.7895D-01,
+ &1.5240D-01,1.3282D-01,1.1484D-01,9.7655D-02,8.3739D-02,7.5857D-02,
+ &6.9509D-02,6.5616D-02,6.2633D-02,6.0853D-02,5.9819D-02,5.9271D-02,
+ &5.9038D-02,5.9046D-02,5.9192D-02,5.9432D-02,5.9709D-02,6.0008D-02/
+ DATA (XSF_L(K),K= 1483, 1596) /
+ &6.0340D-02,6.4032D-02,6.6851D-02,7.0446D-02,7.4870D-02,8.0457D-02,
+ &8.7554D-02,9.6862D-02,1.0964D-01,1.2821D-01,1.5779D-01,2.1189D-01,
+ &0.0000D+00,0.0000D+00,6.3982D+00,5.9307D+00,5.4920D+00,5.0710D+00,
+ &4.6822D+00,4.2915D+00,3.9337D+00,3.5898D+00,3.2756D+00,2.9660D+00,
+ &2.6817D+00,2.4150D+00,2.1724D+00,2.0348D+00,1.8961D+00,1.7457D+00,
+ &1.6034D+00,1.4714D+00,1.3471D+00,1.2473D+00,1.1476D+00,1.0408D+00,
+ &9.4083D-01,8.4932D-01,7.6350D-01,6.9606D-01,6.2897D-01,5.5833D-01,
+ &4.9315D-01,4.3444D-01,3.8044D-01,3.3861D-01,2.9817D-01,2.5642D-01,
+ &2.1917D-01,1.8685D-01,1.5838D-01,1.3752D-01,1.1831D-01,9.9987D-02,
+ &8.5224D-02,7.6762D-02,6.9910D-02,6.5655D-02,6.2297D-02,6.0213D-02,
+ &5.8897D-02,5.8096D-02,5.7624D-02,5.7400D-02,5.7322D-02,5.7351D-02,
+ &5.7432D-02,5.7560D-02,5.7758D-02,6.0939D-02,6.3212D-02,6.6167D-02,
+ &6.9884D-02,7.4560D-02,8.0552D-02,8.8432D-02,9.9242D-02,1.1491D-01,
+ &1.3966D-01,1.8320D-01,0.0000D+00,0.0000D+00,7.4490D+00,6.8826D+00,
+ &6.3540D+00,5.8477D+00,5.3805D+00,4.9187D+00,4.4884D+00,4.0843D+00,
+ &3.7147D+00,3.3516D+00,3.0193D+00,2.7088D+00,2.4279D+00,2.2696D+00,
+ &2.1091D+00,1.9368D+00,1.7739D+00,1.6237D+00,1.4821D+00,1.3692D+00,
+ &1.2557D+00,1.1358D+00,1.0238D+00,9.2133D-01,8.2567D-01,7.5070D-01,
+ &6.7656D-01,5.9850D-01,5.2688D-01,4.6263D-01,4.0371D-01,3.5842D-01/
+ DATA (XSF_L(K),K= 1597, 1710) /
+ &3.1427D-01,2.6933D-01,2.2930D-01,1.9466D-01,1.6427D-01,1.4208D-01,
+ &1.2168D-01,1.0226D-01,8.6560D-02,7.7553D-02,7.0202D-02,6.5576D-02,
+ &6.1860D-02,5.9487D-02,5.7920D-02,5.6852D-02,5.6166D-02,5.5736D-02,
+ &5.5458D-02,5.5289D-02,5.5193D-02,5.5163D-02,5.5243D-02,5.7935D-02,
+ &5.9740D-02,6.2111D-02,6.5158D-02,6.9050D-02,7.4078D-02,8.0683D-02,
+ &8.9776D-02,1.0288D-01,1.2351D-01,1.5725D-01,0.0000D+00,0.0000D+00,
+ &8.6044D+00,7.9255D+00,7.2940D+00,6.6940D+00,6.1391D+00,5.5940D+00,
+ &5.0907D+00,4.6180D+00,4.1841D+00,3.7622D+00,3.3775D+00,3.0195D+00,
+ &2.6967D+00,2.5153D+00,2.3331D+00,2.1364D+00,1.9521D+00,1.7815D+00,
+ &1.6211D+00,1.4944D+00,1.3683D+00,1.2334D+00,1.1084D+00,9.9465D-01,
+ &8.8864D-01,8.0585D-01,7.2432D-01,6.3866D-01,5.6038D-01,4.9058D-01,
+ &4.2648D-01,3.7768D-01,3.3036D-01,2.8189D-01,2.3907D-01,2.0214D-01,
+ &1.6987D-01,1.4635D-01,1.2479D-01,1.0428D-01,8.7748D-02,7.8203D-02,
+ &7.0386D-02,6.5431D-02,6.1373D-02,5.8719D-02,5.6916D-02,5.5642D-02,
+ &5.4751D-02,5.4118D-02,5.3653D-02,5.3314D-02,5.3067D-02,5.2897D-02,
+ &5.2861D-02,5.5140D-02,5.6493D-02,5.8378D-02,6.0860D-02,6.4090D-02,
+ &6.8261D-02,7.3828D-02,8.1439D-02,9.2423D-02,1.0952D-01,1.3424D-01,
+ &0.0000D+00,0.0000D+00,9.7645D+00,8.9701D+00,8.2340D+00,7.5357D+00,
+ &6.8926D+00,6.2607D+00,5.6834D+00,5.1374D+00,4.6459D+00,4.1625D+00/
+ DATA (XSF_L(K),K= 1711, 1824) /
+ &3.7261D+00,3.3206D+00,2.9567D+00,2.7529D+00,2.5476D+00,2.3274D+00,
+ &2.1217D+00,1.9320D+00,1.7541D+00,1.6131D+00,1.4740D+00,1.3257D+00,
+ &1.1879D+00,1.0631D+00,9.4732D-01,8.5726D-01,7.6844D-01,6.7586D-01,
+ &5.9131D-01,5.1597D-01,4.4748D-01,3.9504D-01,3.4470D-01,2.9317D-01,
+ &2.4779D-01,2.0880D-01,1.7478D-01,1.5007D-01,1.2748D-01,1.0600D-01,
+ &8.8713D-02,7.8704D-02,7.0472D-02,6.5220D-02,6.0885D-02,5.7993D-02,
+ &5.5967D-02,5.4536D-02,5.3470D-02,5.2665D-02,5.2054D-02,5.1577D-02,
+ &5.1203D-02,5.0930D-02,5.0809D-02,5.2731D-02,5.3716D-02,5.5192D-02,
+ &5.7203D-02,5.9902D-02,6.3412D-02,6.8123D-02,7.4602D-02,8.3905D-02,
+ &9.8185D-02,1.1515D-01,0.0000D+00,0.0000D+00,1.1069D+01,1.0141D+01,
+ &9.2840D+00,8.4741D+00,7.7316D+00,7.0038D+00,6.3364D+00,5.7137D+00,
+ &5.1475D+00,4.6031D+00,4.1059D+00,3.6477D+00,3.2381D+00,3.0086D+00,
+ &2.7788D+00,2.5333D+00,2.3033D+00,2.0926D+00,1.8951D+00,1.7404D+00,
+ &1.5854D+00,1.4229D+00,1.2715D+00,1.1352D+00,1.0089D+00,9.1089D-01,
+ &8.1457D-01,7.1424D-01,6.2332D-01,5.4229D-01,4.6872D-01,4.1295D-01,
+ &3.5903D-01,3.0454D-01,2.5654D-01,2.1539D-01,1.7965D-01,1.5373D-01,
+ &1.3011D-01,1.0766D-01,8.9530D-02,7.9108D-02,7.0483D-02,6.4943D-02,
+ &6.0331D-02,5.7203D-02,5.4990D-02,5.3395D-02,5.2144D-02,5.1206D-02,
+ &5.0454D-02,4.9840D-02,4.9351D-02,4.8978D-02,4.8801D-02,5.0351D-02/
+ DATA (XSF_L(K),K= 1825, 1836) /
+ &5.1017D-02,5.2127D-02,5.3737D-02,5.5934D-02,5.8835D-02,6.2800D-02,
+ &6.8260D-02,7.6135D-02,8.7873D-02,0.0000D+00,0.0000D+00,0.0000D+00/
+ DATA (XGF_L(K),K= 1, 114) /
+ &1.0646D+00,1.0934D+00,1.1214D+00,1.1484D+00,1.1741D+00,1.1999D+00,
+ &1.2242D+00,1.2466D+00,1.2676D+00,1.2873D+00,1.3042D+00,1.3194D+00,
+ &1.3313D+00,1.3376D+00,1.3430D+00,1.3472D+00,1.3502D+00,1.3504D+00,
+ &1.3501D+00,1.3478D+00,1.3430D+00,1.3356D+00,1.3267D+00,1.3149D+00,
+ &1.3003D+00,1.2857D+00,1.2680D+00,1.2451D+00,1.2189D+00,1.1899D+00,
+ &1.1575D+00,1.1282D+00,1.0947D+00,1.0543D+00,1.0121D+00,9.6983D-01,
+ &9.2809D-01,8.9556D-01,8.6663D-01,8.4606D-01,8.4971D-01,8.7714D-01,
+ &9.3569D-01,1.0140D+00,1.1325D+00,1.2706D+00,1.4268D+00,1.6005D+00,
+ &1.7918D+00,2.0014D+00,2.2301D+00,2.4791D+00,2.7490D+00,3.0404D+00,
+ &3.3541D+00,3.5718D+00,4.2579D+00,5.0478D+00,5.9674D+00,7.0458D+00,
+ &8.3375D+00,9.9284D+00,1.1949D+01,1.4650D+01,1.8560D+01,2.5096D+01,
+ &4.0067D+01,0.0000D+00,1.6404D+00,1.6723D+00,1.7014D+00,1.7287D+00,
+ &1.7533D+00,1.7768D+00,1.7973D+00,1.8152D+00,1.8297D+00,1.8417D+00,
+ &1.8498D+00,1.8540D+00,1.8544D+00,1.8526D+00,1.8489D+00,1.8424D+00,
+ &1.8335D+00,1.8221D+00,1.8091D+00,1.7949D+00,1.7784D+00,1.7555D+00,
+ &1.7310D+00,1.7034D+00,1.6713D+00,1.6428D+00,1.6093D+00,1.5680D+00,
+ &1.5230D+00,1.4754D+00,1.4241D+00,1.3785D+00,1.3278D+00,1.2681D+00,
+ &1.2068D+00,1.1462D+00,1.0867D+00,1.0400D+00,9.9665D-01,9.6041D-01,
+ &9.4923D-01,9.6563D-01,1.0117D+00,1.0781D+00,1.1816D+00,1.3028D+00/
+ DATA (XGF_L(K),K= 115, 228) /
+ &1.4397D+00,1.5912D+00,1.7573D+00,1.9376D+00,2.1326D+00,2.3425D+00,
+ &2.5677D+00,2.8078D+00,3.0611D+00,3.2398D+00,3.7904D+00,4.4126D+00,
+ &5.1162D+00,5.9322D+00,6.8841D+00,8.0278D+00,9.4403D+00,1.1276D+01,
+ &1.3844D+01,1.7948D+01,2.6821D+01,0.0000D+00,2.5295D+00,2.5563D+00,
+ &2.5800D+00,2.5995D+00,2.6174D+00,2.6286D+00,2.6363D+00,2.6395D+00,
+ &2.6379D+00,2.6306D+00,2.6184D+00,2.6000D+00,2.5768D+00,2.5598D+00,
+ &2.5397D+00,2.5137D+00,2.4839D+00,2.4516D+00,2.4161D+00,2.3833D+00,
+ &2.3459D+00,2.3000D+00,2.2499D+00,2.1966D+00,2.1407D+00,2.0900D+00,
+ &2.0320D+00,1.9647D+00,1.8929D+00,1.8190D+00,1.7411D+00,1.6734D+00,
+ &1.5997D+00,1.5142D+00,1.4279D+00,1.3438D+00,1.2617D+00,1.1967D+00,
+ &1.1353D+00,1.0800D+00,1.0501D+00,1.0526D+00,1.0849D+00,1.1369D+00,
+ &1.2228D+00,1.3250D+00,1.4410D+00,1.5691D+00,1.7085D+00,1.8587D+00,
+ &2.0200D+00,2.1915D+00,2.3728D+00,2.5633D+00,2.7603D+00,2.9047D+00,
+ &3.3315D+00,3.8026D+00,4.3243D+00,4.9121D+00,5.5828D+00,6.3648D+00,
+ &7.3038D+00,8.4817D+00,1.0068D+01,1.2484D+01,1.7398D+01,0.0000D+00,
+ &3.9781D+00,3.9859D+00,3.9880D+00,3.9845D+00,3.9763D+00,3.9582D+00,
+ &3.9337D+00,3.9028D+00,3.8636D+00,3.8159D+00,3.7613D+00,3.6984D+00,
+ &3.6287D+00,3.5836D+00,3.5326D+00,3.4703D+00,3.4046D+00,3.3350D+00,
+ &3.2612D+00,3.1962D+00,3.1248D+00,3.0388D+00,2.9485D+00,2.8565D+00/
+ DATA (XGF_L(K),K= 229, 342) /
+ &2.7591D+00,2.6752D+00,2.5823D+00,2.4756D+00,2.3627D+00,2.2510D+00,
+ &2.1352D+00,2.0365D+00,1.9308D+00,1.8097D+00,1.6896D+00,1.5737D+00,
+ &1.4618D+00,1.3735D+00,1.2886D+00,1.2087D+00,1.1551D+00,1.1411D+00,
+ &1.1545D+00,1.1903D+00,1.2550D+00,1.3356D+00,1.4282D+00,1.5306D+00,
+ &1.6419D+00,1.7606D+00,1.8869D+00,2.0194D+00,2.1574D+00,2.2992D+00,
+ &2.4432D+00,2.5568D+00,2.8674D+00,3.2008D+00,3.5626D+00,3.9572D+00,
+ &4.3932D+00,4.8857D+00,5.4544D+00,6.1386D+00,7.0188D+00,8.2895D+00,
+ &1.0709D+01,0.0000D+00,6.3697D+00,6.3265D+00,6.2740D+00,6.2091D+00,
+ &6.1391D+00,6.0517D+00,5.9560D+00,5.8525D+00,5.7367D+00,5.6106D+00,
+ &5.4709D+00,5.3235D+00,5.1695D+00,5.0724D+00,4.9662D+00,4.8411D+00,
+ &4.7105D+00,4.5784D+00,4.4412D+00,4.3226D+00,4.1943D+00,4.0442D+00,
+ &3.8903D+00,3.7360D+00,3.5773D+00,3.4420D+00,3.2967D+00,3.1301D+00,
+ &2.9593D+00,2.7916D+00,2.6229D+00,2.4802D+00,2.3301D+00,2.1613D+00,
+ &1.9957D+00,1.8382D+00,1.6875D+00,1.5691D+00,1.4545D+00,1.3433D+00,
+ &1.2614D+00,1.2264D+00,1.2177D+00,1.2342D+00,1.2749D+00,1.3313D+00,
+ &1.3987D+00,1.4740D+00,1.5559D+00,1.6431D+00,1.7346D+00,1.8295D+00,
+ &1.9260D+00,2.0232D+00,2.1174D+00,2.2034D+00,2.4118D+00,2.6289D+00,
+ &2.8563D+00,3.0948D+00,3.3486D+00,3.6231D+00,3.9250D+00,4.2677D+00,
+ &4.6847D+00,5.2492D+00,6.2650D+00,0.0000D+00,9.3778D+00,9.2428D+00/
+ DATA (XGF_L(K),K= 343, 456) /
+ &9.0960D+00,8.9365D+00,8.7665D+00,8.5746D+00,8.3714D+00,8.1544D+00,
+ &7.9343D+00,7.6882D+00,7.4352D+00,7.1724D+00,6.9027D+00,6.7360D+00,
+ &6.5571D+00,6.3494D+00,6.1374D+00,5.9260D+00,5.7093D+00,5.5249D+00,
+ &5.3270D+00,5.0995D+00,4.8700D+00,4.6419D+00,4.4114D+00,4.2173D+00,
+ &4.0129D+00,3.7786D+00,3.5451D+00,3.3173D+00,3.0900D+00,2.9004D+00,
+ &2.7040D+00,2.4853D+00,2.2734D+00,2.0742D+00,1.8851D+00,1.7372D+00,
+ &1.5941D+00,1.4536D+00,1.3433D+00,1.2893D+00,1.2607D+00,1.2587D+00,
+ &1.2792D+00,1.3153D+00,1.3616D+00,1.4149D+00,1.4736D+00,1.5361D+00,
+ &1.6012D+00,1.6677D+00,1.7344D+00,1.7990D+00,1.8589D+00,1.9261D+00,
+ &2.0646D+00,2.2044D+00,2.3456D+00,2.4882D+00,2.6342D+00,2.7823D+00,
+ &2.9370D+00,3.1022D+00,3.2902D+00,3.5288D+00,3.9528D+00,0.0000D+00,
+ &1.3926D+01,1.3617D+01,1.3298D+01,1.2959D+01,1.2612D+01,1.2230D+01,
+ &1.1845D+01,1.1442D+01,1.1036D+01,1.0599D+01,1.0158D+01,9.7041D+00,
+ &9.2562D+00,8.9827D+00,8.6974D+00,8.3632D+00,8.0255D+00,7.6946D+00,
+ &7.3614D+00,7.0802D+00,6.7814D+00,6.4439D+00,6.1064D+00,5.7775D+00,
+ &5.4468D+00,5.1723D+00,4.8858D+00,4.5617D+00,4.2425D+00,3.9361D+00,
+ &3.6353D+00,3.3874D+00,3.1301D+00,2.8506D+00,2.5816D+00,2.3318D+00,
+ &2.0965D+00,1.9136D+00,1.7368D+00,1.5622D+00,1.4211D+00,1.3452D+00,
+ &1.2937D+00,1.2737D+00,1.2719D+00,1.2868D+00,1.3119D+00,1.3437D+00/
+ DATA (XGF_L(K),K= 457, 570) /
+ &1.3799D+00,1.4189D+00,1.4596D+00,1.5003D+00,1.5401D+00,1.5761D+00,
+ &1.6073D+00,1.6574D+00,1.7377D+00,1.8158D+00,1.8902D+00,1.9601D+00,
+ &2.0263D+00,2.0884D+00,2.1452D+00,2.1990D+00,2.2512D+00,2.3118D+00,
+ &2.4354D+00,0.0000D+00,1.9256D+01,1.8699D+01,1.8142D+01,1.7563D+01,
+ &1.6980D+01,1.6355D+01,1.5725D+01,1.5081D+01,1.4443D+01,1.3769D+01,
+ &1.3097D+01,1.2422D+01,1.1755D+01,1.1358D+01,1.0937D+01,1.0454D+01,
+ &9.9818D+00,9.5167D+00,9.0465D+00,8.6570D+00,8.2473D+00,7.7870D+00,
+ &7.3320D+00,6.8911D+00,6.4569D+00,6.0969D+00,5.7223D+00,5.3051D+00,
+ &4.8992D+00,4.5131D+00,4.1351D+00,3.8285D+00,3.5148D+00,3.1749D+00,
+ &2.8517D+00,2.5534D+00,2.2748D+00,2.0598D+00,1.8527D+00,1.6465D+00,
+ &1.4780D+00,1.3832D+00,1.3129D+00,1.2758D+00,1.2566D+00,1.2544D+00,
+ &1.2628D+00,1.2778D+00,1.2971D+00,1.3186D+00,1.3412D+00,1.3637D+00,
+ &1.3845D+00,1.4021D+00,1.4142D+00,1.4518D+00,1.4945D+00,1.5327D+00,
+ &1.5661D+00,1.5941D+00,1.6160D+00,1.6309D+00,1.6386D+00,1.6381D+00,
+ &1.6291D+00,1.6176D+00,1.6271D+00,0.0000D+00,2.5945D+01,2.5063D+01,
+ &2.4160D+01,2.3234D+01,2.2336D+01,2.1370D+01,2.0417D+01,1.9450D+01,
+ &1.8508D+01,1.7517D+01,1.6548D+01,1.5580D+01,1.4645D+01,1.4085D+01,
+ &1.3496D+01,1.2836D+01,1.2181D+01,1.1547D+01,1.0921D+01,1.0404D+01,
+ &9.8614D+00,9.2547D+00,8.6616D+00,8.0926D+00,7.5352D+00,7.0774D+00/
+ DATA (XGF_L(K),K= 571, 684) /
+ &6.6043D+00,6.0842D+00,5.5816D+00,5.1040D+00,4.6450D+00,4.2749D+00,
+ &3.8995D+00,3.4941D+00,3.1134D+00,2.7651D+00,2.4423D+00,2.1941D+00,
+ &1.9564D+00,1.7198D+00,1.5241D+00,1.4112D+00,1.3220D+00,1.2705D+00,
+ &1.2348D+00,1.2175D+00,1.2113D+00,1.2119D+00,1.2167D+00,1.2238D+00,
+ &1.2321D+00,1.2398D+00,1.2460D+00,1.2491D+00,1.2470D+00,1.2752D+00,
+ &1.2894D+00,1.2998D+00,1.3055D+00,1.3049D+00,1.2991D+00,1.2860D+00,
+ &1.2655D+00,1.2370D+00,1.1998D+00,1.1564D+00,1.1181D+00,0.0000D+00,
+ &3.3362D+01,3.2051D+01,3.0740D+01,2.9429D+01,2.8133D+01,2.6758D+01,
+ &2.5422D+01,2.4082D+01,2.2784D+01,2.1435D+01,2.0130D+01,1.8839D+01,
+ &1.7597D+01,1.6865D+01,1.6098D+01,1.5241D+01,1.4397D+01,1.3587D+01,
+ &1.2791D+01,1.2130D+01,1.1444D+01,1.0687D+01,9.9507D+00,9.2501D+00,
+ &8.5659D+00,8.0104D+00,7.4390D+00,6.8118D+00,6.2125D+00,5.6506D+00,
+ &5.1096D+00,4.6780D+00,4.2434D+00,3.7769D+00,3.3424D+00,2.9475D+00,
+ &2.5842D+00,2.3061D+00,2.0409D+00,1.7770D+00,1.5572D+00,1.4290D+00,
+ &1.3248D+00,1.2609D+00,1.2112D+00,1.1814D+00,1.1636D+00,1.1530D+00,
+ &1.1469D+00,1.1433D+00,1.1407D+00,1.1378D+00,1.1337D+00,1.1269D+00,
+ &1.1152D+00,1.1360D+00,1.1320D+00,1.1243D+00,1.1127D+00,1.0960D+00,
+ &1.0739D+00,1.0461D+00,1.0122D+00,9.7100D-01,9.2292D-01,8.6909D-01,
+ &8.1432D-01,0.0000D+00,4.2364D+01,4.0483D+01,3.8640D+01,3.6792D+01/
+ DATA (XGF_L(K),K= 685, 798) /
+ &3.4991D+01,3.3112D+01,3.1295D+01,2.9487D+01,2.7748D+01,2.5953D+01,
+ &2.4235D+01,2.2543D+01,2.0935D+01,1.9990D+01,1.9011D+01,1.7921D+01,
+ &1.6852D+01,1.5830D+01,1.4831D+01,1.4013D+01,1.3165D+01,1.2236D+01,
+ &1.1337D+01,1.0485D+01,9.6616D+00,8.9943D+00,8.3137D+00,7.5711D+00,
+ &6.8670D+00,6.2090D+00,5.5842D+00,5.0866D+00,4.5873D+00,4.0564D+00,
+ &3.5646D+00,3.1234D+00,2.7185D+00,2.4107D+00,2.1172D+00,1.8273D+00,
+ &1.5836D+00,1.4407D+00,1.3211D+00,1.2459D+00,1.1839D+00,1.1433D+00,
+ &1.1153D+00,1.0949D+00,1.0794D+00,1.0667D+00,1.0555D+00,1.0443D+00,
+ &1.0317D+00,1.0172D+00,9.9883D-01,1.0131D+00,9.9503D-01,9.7446D-01,
+ &9.5064D-01,9.2316D-01,8.9156D-01,8.5528D-01,8.1439D-01,7.6837D-01,
+ &7.1718D-01,6.6210D-01,6.0243D-01,0.0000D+00,5.2603D+01,5.0038D+01,
+ &4.7540D+01,4.5053D+01,4.2652D+01,4.0175D+01,3.7784D+01,3.5407D+01,
+ &3.3154D+01,3.0851D+01,2.8651D+01,2.6507D+01,2.4488D+01,2.3310D+01,
+ &2.2084D+01,2.0735D+01,1.9418D+01,1.8166D+01,1.6951D+01,1.5960D+01,
+ &1.4935D+01,1.3817D+01,1.2742D+01,1.1732D+01,1.0759D+01,9.9749D+00,
+ &9.1794D+00,8.3186D+00,7.5044D+00,6.7510D+00,6.0386D+00,5.4762D+00,
+ &4.9137D+00,4.3200D+00,3.7728D+00,3.2842D+00,2.8391D+00,2.5026D+00,
+ &2.1835D+00,1.8677D+00,1.6033D+00,1.4461D+00,1.3138D+00,1.2277D+00,
+ &1.1557D+00,1.1057D+00,1.0689D+00,1.0407D+00,1.0176D+00,9.9768D-01/
+ DATA (XGF_L(K),K= 799, 912) /
+ &9.7951D-01,9.6199D-01,9.4331D-01,9.2359D-01,9.0058D-01,9.0921D-01,
+ &8.8156D-01,8.5244D-01,8.2081D-01,7.8702D-01,7.5025D-01,7.1005D-01,
+ &6.6667D-01,6.1984D-01,5.6969D-01,5.1748D-01,4.5895D-01,0.0000D+00,
+ &6.3459D+01,6.0127D+01,5.6900D+01,5.3695D+01,5.0615D+01,4.7464D+01,
+ &4.4440D+01,4.1483D+01,3.8684D+01,3.5826D+01,3.3122D+01,3.0500D+01,
+ &2.8040D+01,2.6617D+01,2.5143D+01,2.3518D+01,2.1950D+01,2.0455D+01,
+ &1.9011D+01,1.7842D+01,1.6646D+01,1.5337D+01,1.4094D+01,1.2920D+01,
+ &1.1799D+01,1.0903D+01,9.9940D+00,9.0166D+00,8.0967D+00,7.2512D+00,
+ &6.4551D+00,5.8279D+00,5.2081D+00,4.5519D+00,3.9568D+00,3.4237D+00,
+ &2.9425D+00,2.5798D+00,2.2371D+00,1.8995D+00,1.6161D+00,1.4477D+00,
+ &1.3046D+00,1.2096D+00,1.1285D+00,1.0709D+00,1.0274D+00,9.9290D-01,
+ &9.6399D-01,9.3860D-01,9.1550D-01,8.9324D-01,8.7036D-01,8.4674D-01,
+ &8.2129D-01,8.2506D-01,7.9094D-01,7.5633D-01,7.2031D-01,6.8307D-01,
+ &6.4387D-01,6.0237D-01,5.5907D-01,5.1344D-01,4.6618D-01,4.1810D-01,
+ &3.6329D-01,0.0000D+00,7.9498D+01,7.4941D+01,7.0580D+01,6.6266D+01,
+ &6.2169D+01,5.8002D+01,5.4045D+01,5.0164D+01,4.6539D+01,4.2847D+01,
+ &3.9386D+01,3.6065D+01,3.2968D+01,3.1180D+01,2.9347D+01,2.7330D+01,
+ &2.5394D+01,2.3566D+01,2.1811D+01,2.0388D+01,1.8944D+01,1.7368D+01,
+ &1.5877D+01,1.4488D+01,1.3164D+01,1.2111D+01,1.1051D+01,9.9162D+00/
+ DATA (XGF_L(K),K= 913, 1026) /
+ &8.8542D+00,7.8839D+00,6.9777D+00,6.2689D+00,5.5695D+00,4.8410D+00,
+ &4.1789D+00,3.5909D+00,3.0635D+00,2.6689D+00,2.2973D+00,1.9324D+00,
+ &1.6270D+00,1.4446D+00,1.2882D+00,1.1839D+00,1.0926D+00,1.0266D+00,
+ &9.7585D-01,9.3473D-01,8.9976D-01,8.6898D-01,8.4068D-01,8.1374D-01,
+ &7.8714D-01,7.6011D-01,7.3262D-01,7.3148D-01,6.9170D-01,6.5270D-01,
+ &6.1357D-01,5.7426D-01,5.3417D-01,4.9316D-01,4.5166D-01,4.0914D-01,
+ &3.6649D-01,3.2429D-01,2.7651D-01,0.0000D+00,9.7091D+01,9.1127D+01,
+ &8.5440D+01,7.9869D+01,7.4603D+01,6.9275D+01,6.4220D+01,5.9343D+01,
+ &5.4780D+01,5.0195D+01,4.5912D+01,4.1816D+01,3.8028D+01,3.5857D+01,
+ &3.3637D+01,3.1205D+01,2.8880D+01,2.6695D+01,2.4601D+01,2.2923D+01,
+ &2.1219D+01,1.9374D+01,1.7634D+01,1.6009D+01,1.4488D+01,1.3276D+01,
+ &1.2064D+01,1.0772D+01,9.5709D+00,8.4795D+00,7.4649D+00,6.6775D+00,
+ &5.9046D+00,5.1015D+00,4.3733D+00,3.7372D+00,3.1677D+00,2.7434D+00,
+ &2.3459D+00,1.9566D+00,1.6317D+00,1.4368D+00,1.2699D+00,1.1572D+00,
+ &1.0581D+00,9.8558D-01,9.2913D-01,8.8297D-01,8.4349D-01,8.0862D-01,
+ &7.7667D-01,7.4686D-01,7.1760D-01,6.8906D-01,6.6005D-01,6.5493D-01,
+ &6.1209D-01,5.7080D-01,5.3038D-01,4.9085D-01,4.5137D-01,4.1231D-01,
+ &3.7316D-01,3.3442D-01,2.9613D-01,2.5928D-01,2.1912D-01,0.0000D+00,
+ &1.1660D+02,1.0899D+02,1.0178D+02,9.4752D+01,8.8142D+01,8.1480D+01/
+ DATA (XGF_L(K),K= 1027, 1140) /
+ &7.5219D+01,6.9198D+01,6.3578D+01,5.7986D+01,5.2800D+01,4.7867D+01,
+ &4.3328D+01,4.0736D+01,3.8088D+01,3.5213D+01,3.2469D+01,2.9907D+01,
+ &2.7451D+01,2.5501D+01,2.3516D+01,2.1392D+01,1.9391D+01,1.7546D+01,
+ &1.5800D+01,1.4426D+01,1.3057D+01,1.1607D+01,1.0266D+01,9.0517D+00,
+ &7.9294D+00,7.0617D+00,6.2165D+00,5.3397D+00,4.5572D+00,3.8687D+00,
+ &3.2598D+00,2.8078D+00,2.3859D+00,1.9745D+00,1.6317D+00,1.4267D+00,
+ &1.2497D+00,1.1305D+00,1.0247D+00,9.4657D-01,8.8556D-01,8.3542D-01,
+ &7.9253D-01,7.5465D-01,7.2037D-01,6.8840D-01,6.5775D-01,6.2793D-01,
+ &5.9852D-01,5.9015D-01,5.4553D-01,5.0339D-01,4.6306D-01,4.2411D-01,
+ &3.8622D-01,3.4909D-01,3.1294D-01,2.7773D-01,2.4373D-01,2.1150D-01,
+ &1.7848D-01,0.0000D+00,1.3738D+02,1.2796D+02,1.1904D+02,1.1042D+02,
+ &1.0233D+02,9.4222D+01,8.6662D+01,7.9409D+01,7.2655D+01,6.6001D+01,
+ &5.9833D+01,5.4007D+01,4.8672D+01,4.5642D+01,4.2552D+01,3.9214D+01,
+ &3.6040D+01,3.3082D+01,3.0272D+01,2.8026D+01,2.5779D+01,2.3361D+01,
+ &2.1093D+01,1.9009D+01,1.7062D+01,1.5526D+01,1.4003D+01,1.2396D+01,
+ &1.0916D+01,9.5845D+00,8.3611D+00,7.4188D+00,6.5021D+00,5.5589D+00,
+ &4.7169D+00,3.9865D+00,3.3389D+00,2.8617D+00,2.4178D+00,1.9872D+00,
+ &1.6283D+00,1.4143D+00,1.2296D+00,1.1049D+00,9.9315D-01,9.1079D-01,
+ &8.4623D-01,7.9317D-01,7.4768D-01,7.0802D-01,6.7178D-01,6.3836D-01/
+ DATA (XGF_L(K),K= 1141, 1254) /
+ &6.0703D-01,5.7658D-01,5.4733D-01,5.3630D-01,4.9100D-01,4.4879D-01,
+ &4.0920D-01,3.7138D-01,3.3521D-01,3.0054D-01,2.6721D-01,2.3523D-01,
+ &2.0485D-01,1.7634D-01,1.4852D-01,0.0000D+00,1.6103D+02,1.4938D+02,
+ &1.3848D+02,1.2798D+02,1.1818D+02,1.0840D+02,9.9309D+01,9.0651D+01,
+ &8.2647D+01,7.4733D+01,6.7469D+01,6.0672D+01,5.4433D+01,5.0913D+01,
+ &4.7343D+01,4.3482D+01,3.9833D+01,3.6452D+01,3.3242D+01,3.0689D+01,
+ &2.8134D+01,2.5404D+01,2.2863D+01,2.0531D+01,1.8362D+01,1.6652D+01,
+ &1.4967D+01,1.3197D+01,1.1573D+01,1.0120D+01,8.7877D+00,7.7679D+00,
+ &6.7819D+00,5.7685D+00,4.8731D+00,4.0967D+00,3.4122D+00,2.9097D+00,
+ &2.4451D+00,1.9953D+00,1.6222D+00,1.3995D+00,1.2076D+00,1.0771D+00,
+ &9.6151D-01,8.7563D-01,8.0819D-01,7.5269D-01,7.0548D-01,6.6395D-01,
+ &6.2666D-01,5.9253D-01,5.6034D-01,5.3005D-01,5.0122D-01,4.8790D-01,
+ &4.4273D-01,4.0115D-01,3.6251D-01,3.2632D-01,2.9224D-01,2.5988D-01,
+ &2.2931D-01,2.0039D-01,1.7324D-01,1.4805D-01,1.2201D-01,0.0000D+00,
+ &1.8591D+02,1.7193D+02,1.5886D+02,1.4632D+02,1.3469D+02,1.2310D+02,
+ &1.1237D+02,1.0218D+02,9.2839D+01,8.3643D+01,7.5256D+01,6.7382D+01,
+ &6.0231D+01,5.6204D+01,5.2127D+01,4.7743D+01,4.3601D+01,3.9784D+01,
+ &3.6172D+01,3.3310D+01,3.0455D+01,2.7410D+01,2.4579D+01,2.2009D+01,
+ &1.9599D+01,1.7727D+01,1.5886D+01,1.3956D+01,1.2193D+01,1.0620D+01/
+ DATA (XGF_L(K),K= 1255, 1368) /
+ &9.1866D+00,8.0925D+00,7.0383D+00,5.9623D+00,5.0119D+00,4.1917D+00,
+ &3.4750D+00,2.9503D+00,2.4663D+00,1.9999D+00,1.6141D+00,1.3840D+00,
+ &1.1856D+00,1.0518D+00,9.3192D-01,8.4324D-01,7.7348D-01,7.1642D-01,
+ &6.6779D-01,6.2531D-01,5.8732D-01,5.5231D-01,5.2039D-01,4.9037D-01,
+ &4.6218D-01,4.4711D-01,4.0225D-01,3.6159D-01,3.2438D-01,2.8982D-01,
+ &2.5765D-01,2.2765D-01,1.9954D-01,1.7331D-01,1.4889D-01,1.2621D-01,
+ &9.6984D-02,0.0000D+00,2.1269D+02,1.9609D+02,1.8060D+02,1.6582D+02,
+ &1.5214D+02,1.3863D+02,1.2613D+02,1.1431D+02,1.0351D+02,9.2957D+01,
+ &8.3294D+01,7.4318D+01,6.6188D+01,6.1617D+01,5.7019D+01,5.2073D+01,
+ &4.7428D+01,4.3153D+01,3.9122D+01,3.5941D+01,3.2764D+01,2.9404D+01,
+ &2.6282D+01,2.3458D+01,2.0836D+01,1.8796D+01,1.6786D+01,1.4693D+01,
+ &1.2792D+01,1.1101D+01,9.5678D+00,8.4010D+00,7.2773D+00,6.1402D+00,
+ &5.1403D+00,4.2791D+00,3.5311D+00,2.9851D+00,2.4835D+00,2.0017D+00,
+ &1.6039D+00,1.3677D+00,1.1646D+00,1.0265D+00,9.0375D-01,8.1271D-01,
+ &7.4135D-01,6.8280D-01,6.3328D-01,5.9018D-01,5.5184D-01,5.1677D-01,
+ &4.8494D-01,4.5537D-01,4.2797D-01,4.1146D-01,3.6736D-01,3.2788D-01,
+ &2.9207D-01,2.5923D-01,2.2901D-01,2.0110D-01,1.7527D-01,1.5131D-01,
+ &1.2926D-01,1.0839D-01,6.9776D-02,0.0000D+00,2.4043D+02,2.2104D+02,
+ &2.0300D+02,1.8582D+02,1.7003D+02,1.5443D+02,1.4007D+02,1.2658D+02/
+ DATA (XGF_L(K),K= 1369, 1482) /
+ &1.1426D+02,1.0227D+02,9.1332D+01,8.1197D+01,7.2119D+01,6.6989D+01,
+ &6.1846D+01,5.6342D+01,5.1188D+01,4.6448D+01,4.2002D+01,3.8498D+01,
+ &3.5016D+01,3.1335D+01,2.7931D+01,2.4848D+01,2.2009D+01,1.9797D+01,
+ &1.7637D+01,1.5389D+01,1.3354D+01,1.1550D+01,9.9187D+00,8.6824D+00,
+ &7.4988D+00,6.3022D+00,5.2549D+00,4.3589D+00,3.5788D+00,3.0139D+00,
+ &2.4962D+00,2.0005D+00,1.5931D+00,1.3514D+00,1.1435D+00,1.0028D+00,
+ &8.7751D-01,7.8479D-01,7.1218D-01,6.5272D-01,6.0250D-01,5.5920D-01,
+ &5.2061D-01,4.8590D-01,4.5422D-01,4.2519D-01,3.9858D-01,3.8094D-01,
+ &3.3789D-01,2.9975D-01,2.6524D-01,2.3401D-01,2.0560D-01,1.7956D-01,
+ &1.5565D-01,1.3374D-01,1.1354D-01,9.4096D-02,3.9275D-02,0.0000D+00,
+ &2.8195D+02,2.5830D+02,2.3640D+02,2.1554D+02,1.9645D+02,1.7774D+02,
+ &1.6058D+02,1.4448D+02,1.2990D+02,1.1575D+02,1.0299D+02,9.1121D+01,
+ &8.0574D+01,7.4642D+01,6.8724D+01,6.2402D+01,5.6498D+01,5.1101D+01,
+ &4.6042D+01,4.2081D+01,3.8152D+01,3.4014D+01,3.0201D+01,2.6780D+01,
+ &2.3611D+01,2.1171D+01,1.8789D+01,1.6329D+01,1.4107D+01,1.2148D+01,
+ &1.0386D+01,9.0557D+00,7.7874D+00,6.5118D+00,5.4006D+00,4.4539D+00,
+ &3.6370D+00,3.0467D+00,2.5088D+00,1.9959D+00,1.5762D+00,1.3274D+00,
+ &1.1142D+00,9.7065D-01,8.4265D-01,7.4825D-01,6.7451D-01,6.1445D-01,
+ &5.6374D-01,5.2024D-01,4.8166D-01,4.4741D-01,4.1643D-01,3.8830D-01/
+ DATA (XGF_L(K),K= 1483, 1596) /
+ &3.6282D-01,3.4411D-01,3.0249D-01,2.6607D-01,2.3369D-01,2.0474D-01,
+ &1.7852D-01,1.5489D-01,1.3341D-01,1.1384D-01,9.5862D-02,7.7509D-02,
+ &0.0000D+00,0.0000D+00,3.2379D+02,2.9556D+02,2.6960D+02,2.4513D+02,
+ &2.2265D+02,2.0073D+02,1.8071D+02,1.6202D+02,1.4515D+02,1.2887D+02,
+ &1.1419D+02,1.0071D+02,8.8650D+01,8.1931D+01,7.5233D+01,6.8140D+01,
+ &6.1510D+01,5.5467D+01,4.9832D+01,4.5419D+01,4.1070D+01,3.6493D+01,
+ &3.2295D+01,2.8536D+01,2.5086D+01,2.2426D+01,1.9846D+01,1.7175D+01,
+ &1.4781D+01,1.2681D+01,1.0797D+01,9.3831D+00,8.0380D+00,6.6897D+00,
+ &5.5221D+00,4.5337D+00,3.6831D+00,3.0714D+00,2.5159D+00,1.9884D+00,
+ &1.5586D+00,1.3048D+00,1.0886D+00,9.4191D-01,8.1217D-01,7.1679D-01,
+ &6.4238D-01,5.8194D-01,5.3136D-01,4.8766D-01,4.4965D-01,4.1594D-01,
+ &3.8570D-01,3.5847D-01,3.3403D-01,3.1456D-01,2.7454D-01,2.3977D-01,
+ &2.0922D-01,1.8216D-01,1.5795D-01,1.3622D-01,1.1669D-01,9.9012D-02,
+ &8.2668D-02,6.4604D-02,0.0000D+00,0.0000D+00,3.7071D+02,3.3727D+02,
+ &3.0660D+02,2.7790D+02,2.5169D+02,2.2608D+02,2.0283D+02,1.8123D+02,
+ &1.6179D+02,1.4311D+02,1.2635D+02,1.1097D+02,9.7357D+01,8.9759D+01,
+ &8.2263D+01,7.4239D+01,6.6821D+01,6.0073D+01,5.3813D+01,4.8927D+01,
+ &4.4114D+01,3.9072D+01,3.4471D+01,3.0351D+01,2.6592D+01,2.3699D+01,
+ &2.0903D+01,1.8031D+01,1.5459D+01,1.3211D+01,1.1204D+01,9.7024D+00/
+ DATA (XGF_L(K),K= 1597, 1710) /
+ &8.2828D+00,6.8644D+00,5.6367D+00,4.6059D+00,3.7241D+00,3.0915D+00,
+ &2.5189D+00,1.9786D+00,1.5396D+00,1.2816D+00,1.0611D+00,9.1306D-01,
+ &7.8207D-01,6.8594D-01,6.1118D-01,5.5075D-01,5.0031D-01,4.5732D-01,
+ &4.1996D-01,3.8671D-01,3.5732D-01,3.3101D-01,3.0775D-01,2.8769D-01,
+ &2.4931D-01,2.1637D-01,1.8763D-01,1.6241D-01,1.4002D-01,1.2013D-01,
+ &1.0238D-01,8.6311D-02,7.1348D-02,5.2982D-02,0.0000D+00,0.0000D+00,
+ &4.2142D+02,3.8237D+02,3.4660D+02,3.1292D+02,2.8259D+02,2.5300D+02,
+ &2.2626D+02,2.0148D+02,1.7927D+02,1.5797D+02,1.3896D+02,1.2163D+02,
+ &1.0632D+02,9.7858D+01,8.9366D+01,8.0488D+01,7.2234D+01,6.4771D+01,
+ &5.7843D+01,5.2468D+01,4.7182D+01,4.1663D+01,3.6633D+01,3.2165D+01,
+ &2.8082D+01,2.4971D+01,2.1960D+01,1.8866D+01,1.6118D+01,1.3723D+01,
+ &1.1595D+01,1.0008D+01,8.5101D+00,7.0232D+00,5.7443D+00,4.6705D+00,
+ &3.7584D+00,3.1066D+00,2.5189D+00,1.9659D+00,1.5193D+00,1.2575D+00,
+ &1.0346D+00,8.8517D-01,7.5338D-01,6.5695D-01,5.8219D-01,5.2200D-01,
+ &4.7218D-01,4.2954D-01,3.9258D-01,3.6043D-01,3.3190D-01,3.0663D-01,
+ &2.8431D-01,2.6413D-01,2.2746D-01,1.9612D-01,1.6912D-01,1.4557D-01,
+ &1.2488D-01,1.0660D-01,9.0362D-02,7.5731D-02,6.1890D-02,4.2720D-02,
+ &0.0000D+00,0.0000D+00,4.7166D+02,4.2676D+02,3.8580D+02,3.4749D+02,
+ &3.1273D+02,2.7927D+02,2.4899D+02,2.2108D+02,1.9611D+02,1.7230D+02/
+ DATA (XGF_L(K),K= 1711, 1824) /
+ &1.5107D+02,1.3178D+02,1.1483D+02,1.0548D+02,9.6179D+01,8.6383D+01,
+ &7.7331D+01,6.9156D+01,6.1613D+01,5.5763D+01,5.0019D+01,4.4056D+01,
+ &3.8633D+01,3.3819D+01,2.9446D+01,2.6108D+01,2.2889D+01,1.9617D+01,
+ &1.6706D+01,1.4179D+01,1.1938D+01,1.0276D+01,8.7112D+00,7.1630D+00,
+ &5.8345D+00,4.7275D+00,3.7856D+00,3.1171D+00,2.5164D+00,1.9532D+00,
+ &1.4997D+00,1.2350D+00,1.0108D+00,8.6027D-01,7.2804D-01,6.3166D-01,
+ &5.5726D-01,4.9745D-01,4.4802D-01,4.0623D-01,3.7002D-01,3.3850D-01,
+ &3.1081D-01,2.8644D-01,2.6509D-01,2.4476D-01,2.0951D-01,1.7979D-01,
+ &1.5426D-01,1.3217D-01,1.1290D-01,9.5951D-02,8.0975D-02,6.7483D-02,
+ &5.4483D-02,3.4309D-02,0.0000D+00,0.0000D+00,5.2745D+02,4.7595D+02,
+ &4.2900D+02,3.8543D+02,3.4589D+02,3.0795D+02,2.7377D+02,2.4235D+02,
+ &2.1434D+02,1.8771D+02,1.6408D+02,1.4266D+02,1.2392D+02,1.1358D+02,
+ &1.0335D+02,9.2593D+01,8.2702D+01,7.3780D+01,6.5553D+01,5.9207D+01,
+ &5.2983D+01,4.6535D+01,4.0700D+01,3.5531D+01,3.0842D+01,2.7278D+01,
+ &2.3855D+01,2.0386D+01,1.7301D+01,1.4635D+01,1.2282D+01,1.0538D+01,
+ &8.9065D+00,7.2932D+00,5.9178D+00,4.7769D+00,3.8086D+00,3.1240D+00,
+ &2.5114D+00,1.9387D+00,1.4794D+00,1.2125D+00,9.8604D-01,8.3538D-01,
+ &7.0309D-01,6.0683D-01,5.3289D-01,4.7378D-01,4.2493D-01,3.8387D-01,
+ &3.4846D-01,3.1778D-01,2.9097D-01,2.6744D-01,2.4699D-01,2.2688D-01/
+ DATA (XGF_L(K),K= 1825, 1836) /
+ &1.9308D-01,1.6489D-01,1.4079D-01,1.2009D-01,1.0214D-01,8.6447D-02,
+ &7.2603D-02,6.0131D-02,4.7893D-02,2.6613D-02,0.0000D+00,0.0000D+00/
+
+*
+ X = Xinp
+*...CHECK OF X AND Q2 VALUES :
+ IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
+* WRITE(6,91) X
+* 91 FORMAT (2X,'PHO_DOR98LO: x out of range',1p,E12.4)
+ X = 0.99D-9
+* STOP
+ ENDIF
+
+ Q2 = Q2inp
+ IF ( (Q2.LT.0.799D0) .OR. (Q2.GT.1.E6) ) THEN
+* WRITE(6,92) Q2
+* 92 FORMAT (2X,'PHO_DOR98LO: Q2 out of range',1p,E12.4)
+ Q2 = 0.99D6
+* STOP
+ ENDIF
+
+*
+*...INTERPOLATION :
+ NA(1) = NX
+ NA(2) = NQ
+ XT(1) = DLOG(X)
+ XT(2) = DLOG(Q2)
+ X1 = 1.D0- X
+ XV = X**0.5D0
+ XS = X**(-0.2D0)
+ UV = SIB_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
+ DV = SIB_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
+ DE = SIB_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
+ UD = SIB_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
+ US = 0.5D0 * (UD - DE)
+ DS = 0.5D0 * (UD + DE)
+ SS = SIB_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
+ GL = SIB_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
+
+ END
diff --git a/Framework/Cascade/sibyll2.3c.h b/Framework/Cascade/sibyll2.3c.h
new file mode 100644
index 0000000000000000000000000000000000000000..5d2d1e69644e812246b731aa4bf276d090d79910
--- /dev/null
+++ b/Framework/Cascade/sibyll2.3c.h
@@ -0,0 +1,90 @@
+#ifndef _include_sib23c_interface_h_
+#define _include_sib23c_interface_h_
+//----------------------------------------------
+// C++ interface for the SIBYLL event generator
+//----------------------------------------------
+// wrapper
+
+extern "C" {
+
+typedef char s_name[6];
+
+// SIBYLL particle stack (FORTRAN COMMON)
+// variables are: np : numer of particles on stack
+// p : 4momentum + mass of particles on stack
+// llist : id of particles on stack
+extern struct {
+ double p[5][8000];
+ int llist[8000];
+ int np;
+} s_plist_;
+
+extern struct {
+ double cbr[223 + 16 + 12 + 8];
+ int kdec[1338 + 6 * (16 + 12 + 8)];
+ int lbarp[99];
+ int idb[99];
+} s_csydec_;
+
+// additional particle stack for the mother particles of unstable particles
+// stable particles have entry zero
+extern struct { int llist1[8000]; } s_plist1_;
+
+// tables with particle properties
+// charge, strangeness and baryon number
+extern struct {
+ int ichp[99];
+ int istr[99];
+ int ibar[99];
+} s_chp_;
+
+// tables with particle properties
+// mass and mass squared
+extern struct {
+ double am[99];
+ double am2[99];
+} s_mass1_;
+
+// table with particle names
+extern struct { char namp[6][99]; } s_cnam_;
+
+// debug info
+extern struct {
+ int ncall;
+ int ndebug;
+ int lun;
+} s_debug_;
+
+// lund random generator setup
+// extern struct {int mrlu[6]; float rrlu[100]; }ludatr_;
+
+// sibyll main subroutine
+void sibyll_(int&, int&, double&);
+
+// subroutine to initiate sibyll
+void sibyll_ini_();
+
+// subroutine to SET DECAYS
+void dec_ini_();
+
+// subroutine to initiate random number generator
+// void rnd_ini_();
+
+// print event
+void sib_list_(int&);
+
+// decay routine
+void decsib_();
+
+// interaction length
+// double fpni_(double&, int&);
+
+void sib_sigma_hnuc_(int&, int&, double&, double&, double&);
+void sib_sigma_hp_(int&, double&, double&, double&, double&, double*, double&, double&);
+
+double s_rndm_(int&);
+
+// phojet random generator setup
+void pho_rndin_(int&, int&, int&, int&);
+}
+#endif
diff --git a/Framework/Cascade/testCascade.cc b/Framework/Cascade/testCascade.cc
index 7e0bd76ba6e94655dc8c3a4c83c06c1acd87c7a5..ad4daa2e4df0a554727f1a0584cc88a3af3cff72 100644
--- a/Framework/Cascade/testCascade.cc
+++ b/Framework/Cascade/testCascade.cc
@@ -1,14 +1,37 @@
+
+/**
+ * (c) Copyright 2018 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/cascade/Cascade.h>
-#include <corsika/geometry/LineTrajectory.h>
+
#include <corsika/process/ProcessSequence.h>
+#include <corsika/process/stack_inspector/StackInspector.h>
+#include <corsika/process/tracking_line/TrackingLine.h>
+
#include <corsika/stack/super_stupid/SuperStupidStack.h>
+#include <corsika/geometry/Point.h>
+#include <corsika/geometry/Vector.h>
+
+#include <corsika/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+using corsika::setup::Trajectory;
+
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
// cpp file
#include <catch2/catch.hpp>
+using namespace corsika;
using namespace corsika::process;
using namespace corsika::units;
+using namespace corsika::geometry;
#include <iostream>
using namespace std;
@@ -20,12 +43,12 @@ public:
ProcessSplit() {}
template <typename Particle>
- double MinStepLength(Particle&) const {
- return 0;
- }
+ void MinStepLength(Particle&, setup::Trajectory&) const {}
- template <typename Particle, typename Trajectory, typename Stack>
- void DoContinuous(Particle& p, Trajectory& t, Stack& s) const {}
+ template <typename Particle, typename Stack>
+ EProcessReturn DoContinuous(Particle&, setup::Trajectory&, Stack&) const {
+ return EProcessReturn::eOk;
+ }
template <typename Particle, typename Stack>
void DoDiscrete(Particle& p, Stack& s) const {
@@ -35,69 +58,42 @@ public:
fCount++;
} else {
p.SetEnergy(E / 2);
- s.NewParticle().SetEnergy(E / 2);
- }
+ auto pnew = s.NewParticle();
+ // s.Copy(p, pnew);
+ pnew.SetEnergy(E / 2);
+ pnew.SetPosition(p.GetPosition());
+ pnew.SetMomentum(p.GetMomentum());
+ }
}
void Init() { fCount = 0; }
- int GetCount() { return fCount; }
+ int GetCount() const { return fCount; }
private:
};
-class ProcessReport : public corsika::process::BaseProcess<ProcessReport> {
- bool fReport = false;
-
-public:
- ProcessReport(bool v)
- : fReport(v) {}
-
- template <typename Particle>
- double MinStepLength(Particle&) const {
- return 0;
- }
-
- template <typename Particle, typename Trajectory, typename Stack>
- void DoContinuous(Particle& p, Trajectory& t, Stack& s) const {
- static int countStep = 0;
- if (!fReport) return;
- //std::cout << "generation " << countStep << std::endl;
- int i = 0;
- EnergyType Etot = 0_GeV;
- for (auto& iterP : s) {
- EnergyType E = iterP.GetEnergy();
- Etot += E;
- /* std::cout << " particle data: " << i++ << ", id=" << iterP.GetPID()
- << ", E=" << double(E / 1_GeV) << " GeV "
- << " | " << std::endl;
- */
- }
- countStep++;
- //cout << "#=" << countStep << " " << s.GetSize() << " " << Etot/1_GeV << endl;
- cout << countStep << " " << s.GetSize() << " " << Etot/1_GeV << " " << fCount << endl;
- }
-
- template <typename Particle, typename Stack>
- void DoDiscrete(Particle& p, Stack& s) const {}
- void Init() {}
-};
TEST_CASE("Cascade", "[Cascade]") {
- ProcessReport p0(true);
+ tracking_line::TrackingLine<setup::Stack> tracking;
+
+ stack_inspector::StackInspector<setup::Stack> p0(true);
ProcessSplit p1;
const auto sequence = p0 + p1;
- corsika::stack::super_stupid::SuperStupidStack stack;
-
- corsika::cascade::Cascade<corsika::geometry::LineTrajectory, decltype(sequence),
- decltype(stack)>
- EAS(sequence, stack);
+ setup::Stack stack;
+
+ corsika::cascade::Cascade EAS(tracking, sequence, stack);
+
+ CoordinateSystem& rootCS = RootCoordinateSystem::GetInstance().GetRootCS();
stack.Clear();
auto particle = stack.NewParticle();
EnergyType E0 = 100_GeV;
particle.SetEnergy(E0);
+ particle.SetPosition(Point(rootCS, {0_m, 0_m, 10_km}));
+ particle.SetMomentum(
+ corsika::stack::super_stupid::MomentumVector(rootCS, {0*newton*second, 0*newton*second, -1*newton*second}));
EAS.Init();
EAS.Run();
@@ -109,8 +105,8 @@ TEST_CASE("Cascade", "[Cascade]") {
particle.SetEnergy(E0);
EAS.Init();
EAS.Run();
-
- //cout << "Result: E0=" << E0 / 1_GeV << "GeV, count=" << p1.GetCount() << endl;
+
+ // cout << "Result: E0=" << E0 / 1_GeV << "GeV, count=" << p1.GetCount() << endl;
}
}
}
diff --git a/Framework/Geometry/BaseTrajectory.h b/Framework/Geometry/BaseTrajectory.h
index 485e4b734d960e77f332a3b09146215af0e7ac6e..8289e0dca67fbdaa2865fd7c7799ccf51d619c35 100644
--- a/Framework/Geometry/BaseTrajectory.h
+++ b/Framework/Geometry/BaseTrajectory.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_BASETRAJECTORY_H
#define _include_BASETRAJECTORY_H
@@ -9,13 +20,41 @@
namespace corsika::geometry {
/*!
- * Base class for trajectories.
+ * Interface / base class for trajectories.
*/
class BaseTrajectory {
+ BaseTrajectory() = delete;
+
public:
- //!< t for \f$ t = 0 \f$, the starting Point shall be returned.
- virtual Point GetPosition(corsika::units::si::TimeType t) const = 0;
+ BaseTrajectory(corsika::units::si::TimeType start, corsika::units::si::TimeType end)
+ : fTStart(start)
+ , fTEnd(end) {}
+
+ //!< for \f$ t = 0 \f$, the starting Point shall be returned.
+ virtual Point GetPosition(corsika::units::si::TimeType) const = 0;
+
+ //!< the Point is return from u=0 (start) to u=1 (end)
+ virtual Point GetPosition(double u) const = 0;
+
+ /*!
+ * returns the length between two points of the trajectory
+ * parameterized by \arg t1 and \arg t2. Requires \arg t2 > \arg t1.
+ */
+
+ virtual LengthType GetDistance(corsika::units::si::TimeType t1,
+ corsika::units::si::TimeType t2) const = 0;
+
+ virtual corsika::units::si::TimeType GetDuration(
+ corsika::units::si::TimeType t1, corsika::units::si::TimeType t2) const {
+ return t2 - t1;
+ }
+
+ virtual Point GetEndpoint() const { return GetPosition(fTEnd); }
+ virtual Point GetStartpoint() const { return GetPosition(fTStart); }
+
+ protected:
+ corsika::units::si::TimeType const fTStart, fTEnd;
};
} // namespace corsika::geometry
diff --git a/Framework/Geometry/BaseVector.h b/Framework/Geometry/BaseVector.h
index f2079e91cc953b34499c2146da68c4cf88dfed8d..2cd1c3e490be90485164a060cefc708dbd64806e 100644
--- a/Framework/Geometry/BaseVector.h
+++ b/Framework/Geometry/BaseVector.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_BASEVECTOR_H_
#define _include_BASEVECTOR_H_
diff --git a/Framework/Geometry/CMakeLists.txt b/Framework/Geometry/CMakeLists.txt
index a4fc43cb3364881d7f3e42939b0985b69df4afab..2b0c8d3af13a5ba00b5fbe6674febb0b21461f96 100644
--- a/Framework/Geometry/CMakeLists.txt
+++ b/Framework/Geometry/CMakeLists.txt
@@ -8,14 +8,15 @@ set (
GEOMETRY_HEADERS
Vector.h
Point.h
+ Line.h
Sphere.h
CoordinateSystem.h
+ RootCoordinateSystem.h
Helix.h
BaseVector.h
QuantityVector.h
- BaseTrajectory.h
- LineTrajectory.h
Trajectory.h
+ # BaseTrajectory.h
)
set (
@@ -42,7 +43,7 @@ target_link_libraries (
target_include_directories (
CORSIKAgeometry
- PRIVATE ${EIGEN3_INCLUDE_DIR}
+ PUBLIC ${EIGEN3_INCLUDE_DIR}
INTERFACE ${EIGEN3_INCLUDE_DIR}
$<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
$<INSTALL_INTERFACE:include/include>
diff --git a/Framework/Geometry/CoordinateSystem.cc b/Framework/Geometry/CoordinateSystem.cc
index db0dea292aa5757f636c374da7d2c8155e34287f..9cf3a1a64125d4fe53236529bd821c6b2c5e57c5 100644
--- a/Framework/Geometry/CoordinateSystem.cc
+++ b/Framework/Geometry/CoordinateSystem.cc
@@ -1,15 +1,33 @@
+
+/**
+ * (c) Copyright 2018 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/geometry/CoordinateSystem.h>
using namespace corsika::geometry;
-EigenTransform CoordinateSystem::GetTransformation(CoordinateSystem const& c1,
- CoordinateSystem const& c2) {
- CoordinateSystem const* a{&c1};
- CoordinateSystem const* b{&c2};
+/**
+ * returns the transformation matrix necessary to transform primitives with coordinates
+ * in \a pFrom to \a pTo, e.g.
+ * \f$ \vec{v}^{\text{(to)}} = \mathcal{M} \vec{v}^{\text{(from)}} \f$
+ * (\f$ \vec{v}^{(.)} \f$ denotes the coordinates/components of the component in
+ * the indicated CoordinateSystem).
+ */
+EigenTransform CoordinateSystem::GetTransformation(CoordinateSystem const& pFrom,
+ CoordinateSystem const& pTo) {
+ CoordinateSystem const* a{&pFrom};
+ CoordinateSystem const* b{&pTo};
CoordinateSystem const* commonBase{nullptr};
while (a != b && b != nullptr) {
- a = &c1;
+ a = &pFrom;
while (a != b && a != nullptr) { a = a->GetReference(); }
@@ -26,18 +44,17 @@ EigenTransform CoordinateSystem::GetTransformation(CoordinateSystem const& c1,
}
EigenTransform t = EigenTransform::Identity();
-
- auto* p = &c1;
+ auto* p = &pFrom;
while (p != commonBase) {
t = p->GetTransform() * t;
p = p->GetReference();
}
- p = &c2;
+ p = &pTo;
while (p != commonBase) {
- t = p->GetTransform().inverse(Eigen::TransformTraits::Isometry) * t;
+ t = t * p->GetTransform().inverse(Eigen::TransformTraits::Isometry);
p = p->GetReference();
}
diff --git a/Framework/Geometry/CoordinateSystem.h b/Framework/Geometry/CoordinateSystem.h
index d30e9b4389ad772de241446bf1eb1c22b5e301e9..3a06dfbd8bc65b06a83a58184088d5bec42e8b03 100644
--- a/Framework/Geometry/CoordinateSystem.h
+++ b/Framework/Geometry/CoordinateSystem.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_COORDINATESYSTEM_H_
#define _include_COORDINATESYSTEM_H_
@@ -10,6 +21,8 @@ typedef Eigen::Translation<double, 3> EigenTranslation;
namespace corsika::geometry {
+ class RootCoordinateSystem;
+
using corsika::units::si::length_d;
class CoordinateSystem {
@@ -20,14 +33,19 @@ namespace corsika::geometry {
: reference(&reference)
, transf(transf) {}
- public:
- static EigenTransform GetTransformation(CoordinateSystem const& c1,
- CoordinateSystem const& c2);
-
CoordinateSystem()
: // for creating the root CS
transf(EigenTransform::Identity()) {}
+ protected:
+ static auto CreateCS() { return CoordinateSystem(); }
+ friend corsika::geometry::RootCoordinateSystem; /// this is the only class that can
+ /// creat ONE unique root CS
+
+ public:
+ static EigenTransform GetTransformation(CoordinateSystem const& c1,
+ CoordinateSystem const& c2);
+
auto& operator=(const CoordinateSystem& pCS) {
reference = pCS.reference;
transf = pCS.transf;
@@ -41,6 +59,10 @@ namespace corsika::geometry {
}
auto rotate(QuantityVector<phys::units::length_d> axis, double angle) const {
+ if (axis.eVector.isZero()) {
+ throw std::string("null-vector given as axis parameter");
+ }
+
EigenTransform const rotation{Eigen::AngleAxisd(angle, axis.eVector.normalized())};
return CoordinateSystem(*this, rotation);
@@ -48,6 +70,10 @@ namespace corsika::geometry {
auto translateAndRotate(QuantityVector<phys::units::length_d> translation,
QuantityVector<phys::units::length_d> axis, double angle) {
+ if (axis.eVector.isZero()) {
+ throw std::string("null-vector given as axis parameter");
+ }
+
EigenTransform const transf{Eigen::AngleAxisd(angle, axis.eVector.normalized()) *
EigenTranslation(translation.eVector)};
diff --git a/Framework/Geometry/Helix.h b/Framework/Geometry/Helix.h
index af92a68a5bb1e0bfae39390e46e14eafb7b68bf7..8eb215820097fae23eef0e535631384d31db01c4 100644
--- a/Framework/Geometry/Helix.h
+++ b/Framework/Geometry/Helix.h
@@ -1,7 +1,17 @@
+
+/**
+ * (c) Copyright 2018 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_HELIX_H_
#define _include_HELIX_H_
-#include <corsika/geometry/BaseTrajectory.h>
#include <corsika/geometry/Point.h>
#include <corsika/geometry/Vector.h>
#include <corsika/units/PhysicalUnits.h>
@@ -20,7 +30,8 @@ namespace corsika::geometry {
\f}
*/
- class Helix : public BaseTrajectory {
+ class Helix {
+
using VelocityVec = Vector<corsika::units::si::SpeedType::dimension_type>;
Point const r0;
@@ -46,6 +57,11 @@ namespace corsika::geometry {
}
auto GetRadius() const { return radius; }
+
+ LengthType GetDistanceBetween(corsika::units::si::TimeType t1,
+ corsika::units::si::TimeType t2) const {
+ return (vPar + vPerp).norm() * (t2 - t1);
+ }
};
} // namespace corsika::geometry
diff --git a/Framework/Geometry/Line.h b/Framework/Geometry/Line.h
new file mode 100644
index 0000000000000000000000000000000000000000..e093a0055fb82ceaeab2c656227b2c005f15958e
--- /dev/null
+++ b/Framework/Geometry/Line.h
@@ -0,0 +1,44 @@
+
+/**
+ * (c) Copyright 2018 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_LINETRAJECTORY_H
+#define _include_LINETRAJECTORY_H
+
+#include <corsika/geometry/Point.h>
+#include <corsika/geometry/Vector.h>
+#include <corsika/units/PhysicalUnits.h>
+
+namespace corsika::geometry {
+
+ class Line {
+
+ using VelocityVec = Vector<corsika::units::si::SpeedType::dimension_type>;
+
+ Point const r0;
+ VelocityVec const v0;
+
+ public:
+ Line(Point const& pR0, VelocityVec const& pV0)
+ : r0(pR0)
+ , v0(pV0) {}
+
+ Point GetPosition(corsika::units::si::TimeType t) const { return r0 + v0 * t; }
+
+ LengthType GetDistanceBetween(corsika::units::si::TimeType t1,
+ corsika::units::si::TimeType t2) const {
+ // assert(t2 >= t1);
+ return v0.norm() * (t2 - t1);
+ }
+ };
+
+} // namespace corsika::geometry
+
+#endif
diff --git a/Framework/Geometry/LineTrajectory.h b/Framework/Geometry/LineTrajectory.h
deleted file mode 100644
index b3aa4423eff2488fd5f2b80d034cb692c4a884ba..0000000000000000000000000000000000000000
--- a/Framework/Geometry/LineTrajectory.h
+++ /dev/null
@@ -1,27 +0,0 @@
-#ifndef _include_LINETRAJECTORY_H
-#define _include_LINETRAJECTORY_H
-
-#include <corsika/geometry/BaseTrajectory.h>
-#include <corsika/geometry/Point.h>
-#include <corsika/geometry/Vector.h>
-#include <corsika/units/PhysicalUnits.h>
-
-namespace corsika::geometry {
-
- class LineTrajectory : public BaseTrajectory {
- using VelocityVec = Vector<corsika::units::si::SpeedType::dimension_type>;
-
- Point const r0;
- VelocityVec const v0;
-
- public:
- LineTrajectory(Point const& pR0, VelocityVec const& pV0)
- : r0(pR0)
- , v0(pV0) {}
-
- Point GetPosition(corsika::units::si::TimeType t) const override { return r0 + v0 * t; }
- };
-
-} // namespace corsika::geometry
-
-#endif
diff --git a/Framework/Geometry/Point.h b/Framework/Geometry/Point.h
index debbf91854abdb1852052d487981400d4966da8a..c9c88d7bf599e3f41d33bd92dfe746706f5e5339 100644
--- a/Framework/Geometry/Point.h
+++ b/Framework/Geometry/Point.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_POINT_H_
#define _include_POINT_H_
@@ -23,8 +34,11 @@ namespace corsika::geometry {
Point(CoordinateSystem const& cs, LengthType x, LengthType y, LengthType z)
: BaseVector<phys::units::length_d>(cs, {x, y, z}) {}
+ // TODO: this should be private or protected, we don NOT want to expose numbers
+ // without reference to outside:
auto GetCoordinates() const { return BaseVector<phys::units::length_d>::qVector; }
+ /// this always returns a QuantityVector as triple
auto GetCoordinates(CoordinateSystem const& pCS) const {
if (&pCS == BaseVector<phys::units::length_d>::cs) {
return BaseVector<phys::units::length_d>::qVector;
diff --git a/Framework/Geometry/QuantityVector.h b/Framework/Geometry/QuantityVector.h
index 6066e1d50fa181fd653217b115e2afe7b79a764b..c128039df660cb00aca4908d1b24dc9568258c02 100644
--- a/Framework/Geometry/QuantityVector.h
+++ b/Framework/Geometry/QuantityVector.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_QUANTITYVECTOR_H_
#define _include_QUANTITYVECTOR_H_
@@ -15,11 +26,11 @@ namespace corsika::geometry {
* with a phys::units::si::dimension. Arithmethic operators are defined that
* propagate the dimensions by dimensional analysis.
*/
-
+
template <typename dim>
class QuantityVector {
protected:
- // todo: check if we need to move "quantity" into namespace corsika::units
+ // todo: check if we need to move "quantity" into namespace corsika::units
using Quantity = phys::units::quantity<dim, double>; //< the phys::units::quantity
// corresponding to the dimension
@@ -106,7 +117,7 @@ namespace corsika::geometry {
auto operator==(QuantityVector<dim> const& p) const { return eVector == p.eVector; }
};
-} // end namespace corsika
+} // namespace corsika::geometry
template <typename dim>
auto& operator<<(std::ostream& os, corsika::geometry::QuantityVector<dim> qv) {
diff --git a/Framework/Geometry/RootCoordinateSystem.h b/Framework/Geometry/RootCoordinateSystem.h
new file mode 100644
index 0000000000000000000000000000000000000000..4c3133becd9c59e4b50a9730b893a933657c5518
--- /dev/null
+++ b/Framework/Geometry/RootCoordinateSystem.h
@@ -0,0 +1,33 @@
+#ifndef _include_corsika_geometry_rootcoordinatesystem_h_
+#define _include_corsika_geometry_rootcoordinatesystem_h_
+
+#include <corsika/utl/Singleton.h>
+
+#include <corsika/geometry/CoordinateSystem.h>
+
+/*!
+ * This is the only way to get a root-coordinate system, and it is a
+ * singleton. All other CoordinateSystems must be relative to the
+ * RootCoordinateSystem
+ */
+
+namespace corsika::geometry {
+
+ class RootCoordinateSystem : public corsika::utl::Singleton<RootCoordinateSystem> {
+
+ friend class corsika::utl::Singleton<RootCoordinateSystem>;
+
+ protected:
+ RootCoordinateSystem() {}
+
+ public:
+ corsika::geometry::CoordinateSystem& GetRootCS() { return fRootCS; }
+ const corsika::geometry::CoordinateSystem& GetRootCS() const { return fRootCS; }
+
+ private:
+ corsika::geometry::CoordinateSystem fRootCS; // THIS IS IT
+ };
+
+} // namespace corsika::geometry
+
+#endif
diff --git a/Framework/Geometry/Sphere.h b/Framework/Geometry/Sphere.h
index 28b4e7dc63d5ded1ecd6d047df442af4557e4f20..6ab7c8b9690a7d92e51a6cbb75fc3a73fc227f8c 100644
--- a/Framework/Geometry/Sphere.h
+++ b/Framework/Geometry/Sphere.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_SPHERE_H_
#define _include_SPHERE_H_
@@ -15,8 +26,8 @@ namespace corsika::geometry {
: center(pCenter)
, radius(pRadius) {}
- //! returns true if the Point p is within the sphere
- auto isInside(Point const& p) const {
+ //! returns true if the Point \a p is within the sphere
+ auto Contains(Point const& p) const {
return radius * radius > (center - p).squaredNorm();
}
};
diff --git a/Framework/Geometry/Trajectory.h b/Framework/Geometry/Trajectory.h
index 5c8cc739deb2e40cafd4642ff9fedf04031f1ecd..686799756504138e349aacfa428b325166ef1e23 100644
--- a/Framework/Geometry/Trajectory.h
+++ b/Framework/Geometry/Trajectory.h
@@ -1,28 +1,49 @@
+
+/**
+ * (c) Copyright 2018 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_TRAJECTORY_H
#define _include_TRAJECTORY_H
-#include <corsika/geometry/BaseTrajectory.h>
#include <corsika/units/PhysicalUnits.h>
+using corsika::units::si::LengthType;
+using corsika::units::si::TimeType;
+
namespace corsika::geometry {
- class Trajectory {
- corsika::units::si::TimeType const fTStart, fTEnd;
- BaseTrajectory const& fTrajectory;
+ template <typename T>
+ class Trajectory : public T {
+
+ corsika::units::si::TimeType fTimeLength;
public:
- Trajectory(corsika::units::si::TimeType pTStart, corsika::units::si::TimeType pTEnd,
- BaseTrajectory const& pTrajectory)
- : fTStart(pTStart)
- , fTEnd(pTEnd)
- , fTrajectory(pTrajectory) {}
-
- Point GetPosition(corsika::units::si::TimeType t) const {
- return fTrajectory.GetPosition(t + fTStart);
- }
+ using T::GetDistanceBetween;
+ using T::GetPosition;
+
+ Trajectory(T const& theT, corsika::units::si::TimeType timeLength)
+ : T(theT)
+ , fTimeLength(timeLength) {}
+
+ /*Point GetPosition(corsika::units::si::TimeType t) const {
+ return fTraj.GetPosition(t + fTStart);
+ }*/
+
+ Point GetPosition(const double u) const { return T::GetPosition(fTimeLength * u); }
+
+ TimeType GetDuration() const { return fTimeLength; }
- Point GetPosition(double u) const {
- return GetPosition(fTEnd * u + fTStart * (1 - u));
+ LengthType GetDistance(const corsika::units::si::TimeType t) const {
+ assert(t > fTimeLength);
+ assert(t >= 0 * corsika::units::si::second);
+ return T::DistanceBetween(0, t);
}
};
diff --git a/Framework/Geometry/Vector.h b/Framework/Geometry/Vector.h
index fcebc10f73a12ad37494a59d32614c88e9697a31..cb4e4900544705c10a37ff16a0fd4ba00b0f9b29 100644
--- a/Framework/Geometry/Vector.h
+++ b/Framework/Geometry/Vector.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_VECTOR_H_
#define _include_VECTOR_H_
diff --git a/Framework/Geometry/testGeometry.cc b/Framework/Geometry/testGeometry.cc
index ac444ef162a220ea92d51b240bd160d0d50694af..9e3be3310bbaf3ed6c9ae22bb6faa67701f20687 100644
--- a/Framework/Geometry/testGeometry.cc
+++ b/Framework/Geometry/testGeometry.cc
@@ -1,11 +1,23 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
// cpp file
#include <catch2/catch.hpp>
#include <corsika/geometry/CoordinateSystem.h>
#include <corsika/geometry/Helix.h>
-#include <corsika/geometry/LineTrajectory.h>
+#include <corsika/geometry/Line.h>
#include <corsika/geometry/Point.h>
+#include <corsika/geometry/RootCoordinateSystem.h>
#include <corsika/geometry/Sphere.h>
#include <corsika/geometry/Trajectory.h>
#include <corsika/units/PhysicalUnits.h>
@@ -16,9 +28,8 @@ using namespace corsika::units::si;
double constexpr absMargin = 1.0e-8;
-
TEST_CASE("transformations between CoordinateSystems") {
- CoordinateSystem rootCS;
+ CoordinateSystem& rootCS = RootCoordinateSystem::GetInstance().GetRootCS();
REQUIRE(CoordinateSystem::GetTransformation(rootCS, rootCS)
.isApprox(EigenTransform::Identity()));
@@ -26,8 +37,7 @@ TEST_CASE("transformations between CoordinateSystems") {
QuantityVector<length_d> const coordinates{0_m, 0_m, 0_m};
Point p1(rootCS, coordinates);
- QuantityVector<magnetic_flux_density_d> components{1. * tesla, 0. * tesla,
- 0. * tesla};
+ QuantityVector<magnetic_flux_density_d> components{1. * tesla, 0. * tesla, 0. * tesla};
Vector<magnetic_flux_density_d> v1(rootCS, components);
REQUIRE((p1.GetCoordinates() - coordinates).norm().magnitude() ==
@@ -35,10 +45,11 @@ TEST_CASE("transformations between CoordinateSystems") {
REQUIRE((p1.GetCoordinates(rootCS) - coordinates).norm().magnitude() ==
Approx(0).margin(absMargin));
+ /*
SECTION("unconnected CoordinateSystems") {
- CoordinateSystem rootCS2;
+ CoordinateSystem rootCS2 = CoordinateSystem::CreateRootCS();
REQUIRE_THROWS(CoordinateSystem::GetTransformation(rootCS, rootCS2));
- }
+ }*/
SECTION("translations") {
QuantityVector<length_d> const translationVector{0_m, 4_m, 0_m};
@@ -98,6 +109,10 @@ TEST_CASE("transformations between CoordinateSystems") {
QuantityVector<length_d> const yAxis{0_m, 7_nm, 0_m};
QuantityVector<length_d> const xAxis{2_m, 0_nm, 0_m};
+ QuantityVector<magnetic_flux_density_d> components{1. * tesla, 2. * tesla,
+ 3. * tesla};
+ Vector<magnetic_flux_density_d> v1(rootCS, components);
+
double const angle = 90. / 180. * M_PI;
CoordinateSystem rotated1 = rootCS.rotate(zAxis, angle);
@@ -106,46 +121,51 @@ TEST_CASE("transformations between CoordinateSystems") {
CoordinateSystem combined = rootCS.rotate(xAxis, -angle);
- auto comp1 = v1.GetComponents(rootCS);
+ auto comp1 = v1.GetComponents(rotated3);
auto comp3 = v1.GetComponents(combined);
REQUIRE((comp1 - comp3).norm().magnitude() == Approx(0).margin(absMargin));
}
}
TEST_CASE("Sphere") {
- CoordinateSystem rootCS;
+ CoordinateSystem& rootCS = RootCoordinateSystem::GetInstance().GetRootCS();
Point center(rootCS, {0_m, 3_m, 4_m});
Sphere sphere(center, 5_m);
SECTION("isInside") {
- REQUIRE_FALSE(sphere.isInside(Point(rootCS, {100_m, 0_m, 0_m})));
- REQUIRE(sphere.isInside(Point(rootCS, {2_m, 3_m, 4_m})));
+ REQUIRE_FALSE(sphere.Contains(Point(rootCS, {100_m, 0_m, 0_m})));
+ REQUIRE(sphere.Contains(Point(rootCS, {2_m, 3_m, 4_m})));
}
}
TEST_CASE("Trajectories") {
- CoordinateSystem rootCS;
+ CoordinateSystem& rootCS = RootCoordinateSystem::GetInstance().GetRootCS();
Point r0(rootCS, {0_m, 0_m, 0_m});
SECTION("Line") {
Vector<SpeedType::dimension_type> v0(rootCS,
{1_m / second, 0_m / second, 0_m / second});
- LineTrajectory const lineTrajectory(r0, v0);
- CHECK((lineTrajectory.GetPosition(2_s).GetCoordinates() -
- QuantityVector<length_d>(2_m, 0_m, 0_m))
- .norm()
- .magnitude() == Approx(0).margin(absMargin));
+ Line const line(r0, v0);
+ CHECK(
+ (line.GetPosition(2_s).GetCoordinates() - QuantityVector<length_d>(2_m, 0_m, 0_m))
+ .norm()
+ .magnitude() == Approx(0).margin(absMargin));
+
+ Trajectory<Line> base(line, 1_s);
+ CHECK(line.GetPosition(2_s).GetCoordinates() ==
+ base.GetPosition(2_s).GetCoordinates());
- BaseTrajectory const* base = &lineTrajectory;
- CHECK(lineTrajectory.GetPosition(2_s).GetCoordinates() ==
- base->GetPosition(2_s).GetCoordinates());
+ CHECK(base.GetDistanceBetween(1_s, 2_s) / 1_m == Approx(1));
}
SECTION("Helix") {
Vector<SpeedType::dimension_type> const vPar(
- rootCS, {0_m / second, 0_m / second, 4_m / second}),
- vPerp(rootCS, {1_m / second, 0_m / second, 0_m / second});
+ rootCS, {0_m / second, 0_m / second, 4_m / second});
+
+ Vector<SpeedType::dimension_type> const vPerp(
+ rootCS, {3_m / second, 0_m / second, 0_m / second});
+
auto const omegaC = 2 * M_PI / 1_s;
Helix const helix(r0, omegaC, vPar, vPerp);
@@ -156,12 +176,14 @@ TEST_CASE("Trajectories") {
.magnitude() == Approx(0).margin(absMargin));
CHECK((helix.GetPosition(0.25_s).GetCoordinates() -
- QuantityVector<length_d>(-1_m / (2 * M_PI), -1_m / (2 * M_PI), 1_m))
+ QuantityVector<length_d>(-3_m / (2 * M_PI), -3_m / (2 * M_PI), 1_m))
.norm()
.magnitude() == Approx(0).margin(absMargin));
- BaseTrajectory const* base = &helix;
+ Trajectory<Helix> const base(helix, 1_s);
CHECK(helix.GetPosition(1234_s).GetCoordinates() ==
- base->GetPosition(1234_s).GetCoordinates());
+ base.GetPosition(1234_s).GetCoordinates());
+
+ CHECK(base.GetDistanceBetween(1_s, 2_s) / 1_m == Approx(5));
}
}
diff --git a/Framework/Logging/BufferedSink.h b/Framework/Logging/BufferedSink.h
index 7ad36927fec13087d8875af96279013a82003a4e..2c0f7be9b721c7910724a25aca4d8488d54e2422 100644
--- a/Framework/Logging/BufferedSink.h
+++ b/Framework/Logging/BufferedSink.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_BufferedSink_h_
#define _include_BufferedSink_h_
@@ -32,7 +43,7 @@ namespace corsika::logging {
inline void Add(const std::string& s) { fBuffer << s; }
private:
- int fSize;
+ unsigned int fSize;
std::ostringstream fBuffer;
};
diff --git a/Framework/Logging/Logger.h b/Framework/Logging/Logger.h
index fca23d70caa28a899af91f025852df0089c10b81..2639df8af6a573170c096d4f44b72e93bc593697 100644
--- a/Framework/Logging/Logger.h
+++ b/Framework/Logging/Logger.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
/**
@File Logger.h
diff --git a/Framework/Logging/MessageOff.h b/Framework/Logging/MessageOff.h
index d60070002cbcb25e76eb641b19597bc6c2fac752..4bdf10d5af622b5fdc1b35316fa258be1322573e 100644
--- a/Framework/Logging/MessageOff.h
+++ b/Framework/Logging/MessageOff.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_MessageOff_h_
#define _include_MessageOff_h_
@@ -10,7 +21,7 @@ namespace corsika::logging {
class MessageOff {
protected:
template <typename First, typename... Strings>
- std::string Message(const First& arg, const Strings&... rest) {
+ std::string Message(const First&, const Strings&...) {
return "";
}
};
diff --git a/Framework/Logging/MessageOn.h b/Framework/Logging/MessageOn.h
index a25928674a73ccbe1837190043a2688be4118ea1..c7756150f03f521ee7b54f0385270face22edb6e 100644
--- a/Framework/Logging/MessageOn.h
+++ b/Framework/Logging/MessageOn.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_MessageOn_h_
#define _include_MessageOn_h_
diff --git a/Framework/Logging/NoSink.h b/Framework/Logging/NoSink.h
index d0ba53649f2f4654e9b19fd75c1e84445eed84f6..6e2fe48ebf66b072031eab47c6a2370b38cd2a52 100644
--- a/Framework/Logging/NoSink.h
+++ b/Framework/Logging/NoSink.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_NoSink_h_
#define _include_NoSink_h_
diff --git a/Framework/Logging/Sink.h b/Framework/Logging/Sink.h
index f51b70294ebdf4ac63362448e5b851d7a52b62b3..74a42185e6be225da119f0812d653756ef30da4f 100644
--- a/Framework/Logging/Sink.h
+++ b/Framework/Logging/Sink.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_Sink_h_
#define _include_Sink_h_
diff --git a/Framework/Logging/testLogging.cc b/Framework/Logging/testLogging.cc
index d28c46de441f66801367ef39f1f103ac3997b057..12a77b3cab504672438e0e6f7d4fe2383d35b8d6 100644
--- a/Framework/Logging/testLogging.cc
+++ b/Framework/Logging/testLogging.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/logging/Logger.h>
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
diff --git a/Framework/Particles/CMakeLists.txt b/Framework/Particles/CMakeLists.txt
index 99b458bbeb20ff3188190fec97e5087b593d36e5..8ea8654fad658692dbbc1819dbc2ab957cb64de5 100644
--- a/Framework/Particles/CMakeLists.txt
+++ b/Framework/Particles/CMakeLists.txt
@@ -1,6 +1,7 @@
add_custom_command (
OUTPUT ${PROJECT_BINARY_DIR}/Framework/Particles/GeneratedParticleProperties.inc
+ ${PROJECT_BINARY_DIR}/Framework/Particles/pythia_db.pkl
COMMAND ${PROJECT_SOURCE_DIR}/Framework/Particles/pdxml_reader.py
${PROJECT_SOURCE_DIR}/Framework/Particles/ParticleData.xml
${PROJECT_SOURCE_DIR}/Framework/Particles/ParticleClassNames.xml
@@ -13,6 +14,11 @@ add_custom_command (
VERBATIM
)
+set (
+ PARTICLE_SOURCES
+ ParticleProperties.cc
+ )
+
# all public header files of library, includes automatic generated file(s)
set (
PARTICLE_HEADERS
@@ -25,7 +31,7 @@ set (
corsika/particles
)
-add_library (CORSIKAparticles INTERFACE)
+add_library (CORSIKAparticles STATIC ${PARTICLE_SOURCES})
CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKAparticles ${PARTICLE_NAMESPACE} ${PARTICLE_HEADERS})
@@ -38,14 +44,27 @@ add_custom_command (
COMMAND ${CMAKE_COMMAND} -E create_symlink ${PROJECT_BINARY_DIR}/include/corsika/particles/GeneratedParticleProperties.inc ${CMAKE_CURRENT_SOURCE_DIR}/GeneratedParticleProperties.inc
COMMENT "Generate link in source-dir: ${CMAKE_CURRENT_SOURCE_DIR}/GeneratedParticleProperties.inc"
)
-add_custom_target (SourceDirLink DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/GeneratedParticleProperties.inc)
+add_custom_target (SourceDirLink DEPENDS ${PROJECT_BINARY_DIR}/Framework/Particles/GeneratedParticleProperties.inc)
add_dependencies (CORSIKAparticles SourceDirLink)
# .....................................................
+target_link_libraries (
+ CORSIKAparticles
+ PUBLIC
+ CORSIKAunits
+ )
+
+set_target_properties (
+ CORSIKAparticles
+ PROPERTIES
+ VERSION ${PROJECT_VERSION}
+ SOVERSION 1
+ PUBLIC_HEADER "${PARTICLE_HEADERS}"
+ )
target_include_directories (
CORSIKAparticles
- INTERFACE
+ PUBLIC
$<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
$<INSTALL_INTERFACE:include>
)
diff --git a/Framework/Particles/ParticleClassNames.xml b/Framework/Particles/ParticleClassNames.xml
index 2c909fb1ae904e9f22d3af0da1682ef842aee54b..1a8e249ea63186e80d59d433dd218ab3ea4c8039 100644
--- a/Framework/Particles/ParticleClassNames.xml
+++ b/Framework/Particles/ParticleClassNames.xml
@@ -3,7 +3,7 @@
<!-- For selected particles it is possible to specify the C++ class
names for a specific unique PDG code -->
- <particle pdgID="0" classname="unknown"/> <!-- VOID in Pythia8 -->
+ <particle pdgID="0" classname="Unknown"/> <!-- VOID in Pythia8 -->
<particle pdgID="11" classname="Electron"/>
<particle pdgID="-11" classname="Positron"/>
diff --git a/Framework/Particles/ParticleProperties.cc b/Framework/Particles/ParticleProperties.cc
new file mode 100644
index 0000000000000000000000000000000000000000..6c8230561f6d76b0bf44a8b68bbdc62e1dab4f0d
--- /dev/null
+++ b/Framework/Particles/ParticleProperties.cc
@@ -0,0 +1,20 @@
+
+/**
+ * (c) Copyright 2018 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>
+
+namespace corsika::particles::io {
+
+ std::ostream& operator<<(std::ostream& stream, Code const p) {
+ return stream << GetName(p);
+ }
+
+} // namespace corsika::particles::io
diff --git a/Framework/Particles/ParticleProperties.h b/Framework/Particles/ParticleProperties.h
index 9e3c557d6df2662e3bf3ae58f8121bf51f4ce164..4bb3cda140f4b5c986d004a3c8c48fc3533deb53 100644
--- a/Framework/Particles/ParticleProperties.h
+++ b/Framework/Particles/ParticleProperties.h
@@ -1,11 +1,22 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
/**
@file Particles.h
Interface to particle properties
*/
-#ifndef _include_ParticleProperties_h_
-#define _include_ParticleProperties_h_
+#ifndef _include_corsika_particles_ParticleProperties_h_
+#define _include_corsika_particles_ParticleProperties_h_
#include <array>
#include <cstdint>
@@ -15,6 +26,7 @@
#include <corsika/units/PhysicalConstants.h>
#include <corsika/units/PhysicalUnits.h>
+
/**
* @namespace particle
*
@@ -24,6 +36,9 @@
*/
namespace corsika::particles {
+
+ using corsika::units::si::second;
+
enum class Code : int16_t;
using PDGCodeType = int16_t;
@@ -34,7 +49,8 @@ namespace corsika::particles {
corsika::units::si::ElectricChargeType constexpr GetElectricCharge(Code const);
corsika::units::si::MassType constexpr GetMass(Code const);
PDGCodeType constexpr GetPDG(Code const);
- std::string const GetName(Code const);
+ constexpr std::string const& GetName(Code const);
+ corsika::units::si::TimeType constexpr GetLifetime(Code const);
#include <corsika/particles/GeneratedParticleProperties.inc>
@@ -60,15 +76,17 @@ namespace corsika::particles {
return GetElectricChargeNumber(p) * (corsika::units::si::constants::e / 3.);
}
- std::string const GetName(Code const p) {
+ constexpr std::string const& GetName(Code const p) {
return names[static_cast<CodeIntType const>(p)];
}
+ corsika::units::si::TimeType constexpr GetLifetime(Code const p) {
+ return lifetime[static_cast<CodeIntType const>(p)];
+ }
+
namespace io {
- std::ostream& operator<<(std::ostream& stream, Code const p) {
- return stream << GetName(p);
- }
+ std::ostream& operator<<(std::ostream& stream, Code const p);
} // namespace io
diff --git a/Framework/Particles/pdxml_reader.py b/Framework/Particles/pdxml_reader.py
index 8f39bd7ef193ece82395bc7849f7cb89aa891503..39aaddd310dfeb51969660a7c17bcabdf9c6eb87 100755
--- a/Framework/Particles/pdxml_reader.py
+++ b/Framework/Particles/pdxml_reader.py
@@ -3,7 +3,7 @@
import sys, math, itertools, re, csv, pprint
import xml.etree.ElementTree as ET
from collections import OrderedDict
-
+import pickle
##############################################################
@@ -14,27 +14,37 @@ from collections import OrderedDict
def parse(filename):
tree = ET.parse(filename)
root = tree.getroot()
-
+
+ GeVfm = 0.19732696312541853
+ c_speed_of_light = 29.9792458e10 # mm / s
+
for particle in root.iter("particle"):
name = particle.attrib["name"]
antiName = "Unknown"
- # print (str(particle.attrib))
if ("antiName" in particle.attrib):
- antiName = particle.attrib["antiName"]
-# print ("found anti: " + name + " " + antiName + "\n" )
+ antiName = particle.attrib["antiName"]
pdg_id = int(particle.attrib["id"])
- mass = float(particle.attrib["m0"]) # GeV
- electric_charge = int(particle.attrib["chargeType"]) # in units of e/3
-
- decay_width = float(particle.attrib.get("mWidth", 0)) # GeV
- lifetime = float(particle.attrib.get("tau0", math.inf)) # mm / c
+ mass = float(particle.attrib["m0"]) # GeV
+ electric_charge = int(particle.attrib["chargeType"]) # in units of e/3
+ ctau = 0.
+ if pdg_id in (11, 12, 14, 16, 22, 2212): # these are the stable particles !
+ ctau = float('Inf')
+ elif 'tau0' in particle.attrib:
+ ctau = float(particle.attrib['tau0']) # mm / c
+ elif 'mWidth' in particle.attrib:
+ ctau = GeVfm / float(particle.attrib['mWidth']) * 1e-15 * 1000.0 # mm / s
+ elif pdg_id in (0, 423, 433, 4312, 4322, 5112, 5222): # those are certainly not stable....
+ ctau = 0.
+ else:
+ print ("missing lifetime: " + str(pdg_id) + " " + str(name))
+ sys.exit(0)
- yield (pdg_id, name, mass, electric_charge, antiName)
+ yield (pdg_id, name, mass, electric_charge, antiName, ctau/c_speed_of_light)
# TODO: read decay channels from child elements
if "antiName" in particle.attrib:
- yield (-pdg_id, antiName, mass, -electric_charge, name)
+ yield (-pdg_id, antiName, mass, -electric_charge, name, ctau/c_speed_of_light)
@@ -113,7 +123,7 @@ def c_identifier_camel(name):
# move "Bar" to end of name
ibar = name.find('Bar')
if ibar > 0 and ibar < len(name)-3:
- name = name[:ibar] + name[ibar+3:] + str('Bar')
+ name = name[:ibar] + name[ibar+3:] + 'Bar'
# cleanup "_"s
while True:
@@ -158,9 +168,12 @@ def c_identifier_camel(name):
def build_pythia_db(filename, classnames):
particle_db = OrderedDict()
- for (pdg, name, mass, electric_charge, antiName) in parse(filename):
+
+ counter = itertools.count(0)
+
+ for (pdg, name, mass, electric_charge, antiName, lifetime) in parse(filename):
- c_id = "unknown"
+ c_id = "Unknown"
if pdg in classnames:
c_id = classnames[pdg]
else:
@@ -171,7 +184,9 @@ def build_pythia_db(filename, classnames):
"antiName" : antiName,
"pdg" : pdg,
"mass" : mass, # in GeV
- "electric_charge" : electric_charge # in e/3
+ "electric_charge" : electric_charge, # in e/3
+ "lifetime" : lifetime,
+ "ngc_code" : next(counter)
}
return particle_db
@@ -245,6 +260,15 @@ def gen_properties(pythia_db):
# string += " {anti:d},\n".format(charge = p['anti_particle'])
# string += "};\n"
+ # lifetime
+ string += "static constexpr std::array<corsika::units::si::TimeType const, size> lifetime = {\n"
+ for p in pythia_db.values():
+ if p['lifetime'] == float("Inf") :
+ string += " std::numeric_limits<double>::infinity() * corsika::units::si::second, \n"
+ else :
+ string += " {tau:f} * corsika::units::si::second, \n".format(tau = p['lifetime'])
+ string += "};\n"
+
return string
@@ -261,7 +285,7 @@ def gen_classes(pythia_db):
for cname in pythia_db:
- antiP = 'unknown'
+ antiP = 'Unknown'
for cname_anti in pythia_db:
if (pythia_db[cname_anti]['name'] == pythia_db[cname]['antiName']):
antiP = cname_anti
@@ -271,7 +295,7 @@ def gen_classes(pythia_db):
string += "/** @class " + cname + "\n\n"
string += " * Particle properties are taken from the PYTHIA8 ParticleData.xml file:<br>\n"
string += " * - pdg=" + str(pythia_db[cname]['pdg']) +"\n"
- string += " * - mass=" + str(pythia_db[cname]['mass']) + " GeV/c² \n"
+ string += " * - mass=" + str(pythia_db[cname]['mass']) + " GeV/c2 \n"
string += " * - charge= " + str(pythia_db[cname]['electric_charge']/3) + " \n"
string += " * - name=" + str(cname) + "\n"
string += " * - anti=" + str(antiP) + "\n"
@@ -282,7 +306,7 @@ def gen_classes(pythia_db):
string += " static constexpr corsika::units::si::MassType GetMass() { return corsika::particles::GetMass(Type); }\n"
string += " static constexpr corsika::units::si::ElectricChargeType GetCharge() { return corsika::particles::GetElectricCharge(Type); }\n"
string += " static constexpr int16_t GetChargeNumber() { return corsika::particles::GetElectricChargeNumber(Type); }\n"
- string += " static std::string const GetName() { return corsika::particles::GetName(Type); }\n"
+ string += " static std::string const& GetName() { return corsika::particles::GetName(Type); }\n"
string += " static constexpr Code GetAntiParticle() { return AntiType; }\n"
string += " static constexpr Code Type = Code::" + cname + ";\n"
string += " static constexpr Code AntiType = Code::" + antiP + ";\n"
@@ -312,6 +336,14 @@ def inc_end():
return string
+###################################################################
+#
+# Serialize pythia_db into file
+#
+
+def serialize_pythia_db(pythia_db, file):
+ pickle.dump(pythia_db, file)
+
###################################################################
#
# Main function
@@ -320,19 +352,15 @@ def inc_end():
if __name__ == "__main__":
if len(sys.argv) != 3:
- print("usage: {:s} <Pythia8.xml> <ClassNames.xml>".format(sys.argv[0]))
+ print("usage: {:s} <Pythia8.xml> <ClassNames.xml>".format(sys.argv[0]), file=sys.stderr)
sys.exit(1)
+ print("\n pdxml_reader.py: Automatically produce particle-properties from PYTHIA8 xml file\n")
+
names = class_names(sys.argv[2])
pythia_db = build_pythia_db(sys.argv[1], names)
- print("\n pdxml_reader.py: Automatically produce particle-properties from PYTHIA8 xml file\n")
-
- counter = itertools.count(0)
-
- not_modeled = []
- for p in pythia_db:
- pythia_db[p]['ngc_code'] = next(counter)
+ print (str(pythia_db))
with open("GeneratedParticleProperties.inc", "w") as f:
print(inc_start(), file=f)
@@ -341,7 +369,5 @@ if __name__ == "__main__":
print(gen_classes(pythia_db), file=f)
print(inc_end(), file=f)
- #~ print(pdg_id_table, mass_table, name_table, enums, sep='\n\n')
-
-
-
+ with open("pythia_db.pkl", "wb") as f:
+ serialize_pythia_db(pythia_db, f)
diff --git a/Framework/Particles/testParticles.cc b/Framework/Particles/testParticles.cc
index 5e80d0081ed824408484fa38cdb50789df7a6528..283bb48c9dfe38db8225d5f8944c1fe7eeaec04c 100644
--- a/Framework/Particles/testParticles.cc
+++ b/Framework/Particles/testParticles.cc
@@ -1,4 +1,14 @@
+/**
+ * (c) Copyright 2018 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/units/PhysicalUnits.h>
@@ -38,10 +48,17 @@ TEST_CASE("ParticleProperties", "[Particles]") {
SECTION("PDG") {
REQUIRE(GetPDG(Code::PiPlus) == 211);
- REQUIRE(GetPDG(Code::DPlus) == 411);
- REQUIRE(GetPDG(Code::NuMu) == 14);
- REQUIRE(GetPDG(Code::NuE) == 12);
- REQUIRE(GetPDG(Code::MuMinus) == 13);
+ REQUIRE(GetPDG(Code::DPlus) == 411);
+ REQUIRE(GetPDG(Code::NuMu) == 14);
+ REQUIRE(GetPDG(Code::NuE) == 12);
+ REQUIRE(GetPDG(Code::MuMinus) == 13);
+ }
+
+ SECTION("Lifetimes") {
+ REQUIRE(GetLifetime(Code::Electron) == std::numeric_limits<double>::infinity() * corsika::units::si::second);
+ REQUIRE(GetLifetime(Code::DPlus) < GetLifetime(Code::Gamma));
+ //REQUIRE(GetLifetime(Code::RhoPlus)/corsika::units::si::second == (Approx(4.414566727909413e-24).epsilon(1e-3)));
+ //REQUIRE(GetLifetime(Code::SigmaMinusBar)/corsika::units::si::second == (Approx(8.018880848563575e-11).epsilon(1e-5)));
+ //REQUIRE(GetLifetime(Code::MuPlus)/corsika::units::si::second == (Approx(2.1970332555864364e-06).epsilon(1e-5)));
}
-
}
diff --git a/Framework/ProcessSequence/BaseProcess.h b/Framework/ProcessSequence/BaseProcess.h
new file mode 100644
index 0000000000000000000000000000000000000000..897497d83c82caee4dbc6c19f90996a5ee7f97fa
--- /dev/null
+++ b/Framework/ProcessSequence/BaseProcess.h
@@ -0,0 +1,45 @@
+
+/**
+ * (c) Copyright 2018 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_corsika_baseprocess_h_
+#define _include_corsika_baseprocess_h_
+
+#include <corsika/process/ProcessReturn.h> // for convenience
+
+namespace corsika::process {
+
+ /**
+ \class BaseProcess
+
+ The structural base type of a process object in a
+ ProcessSequence. Both, the ProcessSequence and all its elements
+ are of type BaseProcess<T>
+
+ */
+
+ template <typename derived>
+ struct BaseProcess {
+ derived& GetRef() { return static_cast<derived&>(*this); }
+ const derived& GetRef() const { return static_cast<const derived&>(*this); }
+ };
+
+ template <typename T>
+ struct is_base {
+ static const bool value = false;
+ };
+ template <typename T>
+ struct is_base<BaseProcess<T>> {
+ static const bool value = true;
+ };
+
+} // namespace corsika::process
+
+#endif
diff --git a/Framework/ProcessSequence/CMakeLists.txt b/Framework/ProcessSequence/CMakeLists.txt
index ac853c837f5611d23fd1bbed7f221711ffc11613..c1f5a45862faffc92aba606e8fc1abde94220d89 100644
--- a/Framework/ProcessSequence/CMakeLists.txt
+++ b/Framework/ProcessSequence/CMakeLists.txt
@@ -10,7 +10,11 @@ set (
#header files of this library
set (
CORSIKAprocesssequence_HEADERS
+ BaseProcess.h
+ ContinuousProcess.h
+ DiscreteProcess.h
ProcessSequence.h
+ ProcessReturn.h
)
CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKAprocesssequence ${CORSIKAprocesssequence_NAMESPACE} ${CORSIKAprocesssequence_HEADERS})
@@ -38,6 +42,8 @@ add_executable (
target_link_libraries (
testProcessSequence
+ CORSIKAsetup
+ CORSIKAgeometry
CORSIKAprocesssequence
CORSIKAthirdparty # for catch2
)
diff --git a/Framework/ProcessSequence/ContinuousProcess.h b/Framework/ProcessSequence/ContinuousProcess.h
new file mode 100644
index 0000000000000000000000000000000000000000..c53365f1afcdfb64ac808580077dd0e284dcdbd2
--- /dev/null
+++ b/Framework/ProcessSequence/ContinuousProcess.h
@@ -0,0 +1,36 @@
+
+/**
+ * (c) Copyright 2018 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_corsika_continuousprocess_h_
+#define _include_corsika_continuousprocess_h_
+
+#include <corsika/process/ProcessReturn.h> // for convenience
+
+namespace corsika::process {
+
+ /**
+ \class ContinuousProcess
+
+ The structural base type of a process object in a
+ ProcessSequence. Both, the ProcessSequence and all its elements
+ are of type ContinuousProcess<T>
+
+ */
+
+ template <typename derived>
+ struct ContinuousProcess {
+ derived& GetRef() { return static_cast<derived&>(*this); }
+ const derived& GetRef() const { return static_cast<const derived&>(*this); }
+ };
+
+} // namespace corsika::process
+
+#endif
diff --git a/Framework/ProcessSequence/DiscreteProcess.h b/Framework/ProcessSequence/DiscreteProcess.h
new file mode 100644
index 0000000000000000000000000000000000000000..83064f5d8767c93619f6742d50c56aeae0863700
--- /dev/null
+++ b/Framework/ProcessSequence/DiscreteProcess.h
@@ -0,0 +1,56 @@
+
+/**
+ * (c) Copyright 2018 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_corsika_discreteprocess_h_
+#define _include_corsika_discreteprocess_h_
+
+#include <corsika/process/ProcessReturn.h> // for convenience
+
+#include <iostream> // debug
+
+namespace corsika::process {
+
+ /**
+ \class DiscreteProcess
+
+ The structural base type of a process object in a
+ ProcessSequence. Both, the ProcessSequence and all its elements
+ are of type DiscreteProcess<T>
+
+ */
+
+ template <typename derived>
+ struct DiscreteProcess {
+
+ // DiscreteProcess() {
+ // static_assert(mustProvide<derived>::mustProvide, "");
+ //}
+
+ derived& GetRef() { return static_cast<derived&>(*this); }
+ const derived& GetRef() const { return static_cast<const derived&>(*this); }
+
+ // here starts the interface part
+ // -> enforce derived to implement DoDiscrete...
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const; // {}
+
+ // private:
+ template <typename D, typename T, typename S>
+ inline EProcessReturn DoContinuous(D& d, T&, S&) const {
+ std::cout << "yeah" << std::endl;
+ return EProcessReturn::eOk;
+ } // find out how to make this FINAL
+ // void DoContinuous;
+ };
+
+} // namespace corsika::process
+
+#endif
diff --git a/Framework/ProcessSequence/ProcessReturn.h b/Framework/ProcessSequence/ProcessReturn.h
new file mode 100644
index 0000000000000000000000000000000000000000..82cc816c5ae9bd9d731f00c33f9bf0321a02d650
--- /dev/null
+++ b/Framework/ProcessSequence/ProcessReturn.h
@@ -0,0 +1,29 @@
+
+/**
+ * (c) Copyright 2018 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_ProcessReturn_h_
+#define _include_ProcessReturn_h_
+
+namespace corsika::process {
+
+ /**
+ since in a process sequence many status updates can accumulate
+ for a single particle, this enum should define only bit-flags
+ that can be accumulated easily with "|="
+ */
+
+ enum class EProcessReturn {
+ eOk = 1,
+ eParticleAbsorbed = 2,
+ };
+} // namespace corsika::process
+
+#endif
diff --git a/Framework/ProcessSequence/ProcessSequence.h b/Framework/ProcessSequence/ProcessSequence.h
index 75ab8dad3a2bf612fbaec4aba3cdf910902d840a..a07e3ef84c91e6e4e54743c4a4e87c09d933bf2f 100644
--- a/Framework/ProcessSequence/ProcessSequence.h
+++ b/Framework/ProcessSequence/ProcessSequence.h
@@ -1,26 +1,129 @@
+
+/**
+ * (c) Copyright 2018 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_ProcessSequence_h_
#define _include_ProcessSequence_h_
-#include <cmath>
-#include <iostream>
-#include <typeinfo>
+#include <corsika/process/BaseProcess.h>
+#include <corsika/process/ContinuousProcess.h>
+#include <corsika/process/DiscreteProcess.h>
+#include <corsika/process/ProcessReturn.h>
+
+#include <corsika/setup/SetupTrajectory.h>
+
+#include <variant>
+
+//#include <type_traits> // still needed ?
+
+using corsika::setup::Trajectory;
namespace corsika::process {
- /**
- \class BaseProcess
+ /* namespace detail { */
- The structural base type of a process object in a
- ProcessSequence. Both, the ProcessSequence and all its elements
- are of type BaseProcess<T>
+ /* /\* template<typename TT1, typename TT2, typename Type = void> *\/ */
+ /* /\* struct CallHello { *\/ */
+ /* /\* static void Call(const TT1&, const TT2&) { *\/ */
+ /* /\* std::cout << "normal" << std::endl; *\/ */
+ /* /\* } *\/ */
+ /* /\* }; *\/ */
- */
+ /* /\* template<typename TT1, typename TT2> *\/ */
+ /* /\* struct CallHello<TT1, TT2, typename
+ * std::enable_if<std::is_base_of<ContinuousProcess<TT2>, TT2>::value>::type> *\/ */
+ /* /\* { *\/ */
+ /* /\* static void Call(const TT1&, const TT2&) { *\/ */
+ /* /\* std::cout << "special" << std::endl; *\/ */
+ /* /\* } *\/ */
+ /* /\* }; *\/ */
- template <typename derived>
- struct BaseProcess {
- derived& GetRef() { return static_cast<derived&>(*this); }
- const derived& GetRef() const { return static_cast<const derived&>(*this); }
- };
+ /* template<typename T1, typename T2, typename Particle, typename Trajectory, typename
+ * Stack> //, typename Type = void> */
+ /* struct DoContinuous { */
+ /* static EProcessReturn Call(const T1& A, const T2& B, Particle& p, Trajectory& t,
+ * Stack& s) { */
+ /* EProcessReturn ret = EProcessReturn::eOk; */
+ /* if constexpr (!std::is_base_of<DiscreteProcess<T1>, T1>::value) { */
+ /* A.DoContinuous(p, t, s); */
+ /* } */
+ /* if constexpr (!std::is_base_of<DiscreteProcess<T2>, T2>::value) { */
+ /* B.DoContinuous(p, t, s); */
+ /* } */
+ /* return ret; */
+ /* } */
+ /* }; */
+
+ /* /\* */
+ /* template<typename T1, typename T2, typename Particle, typename Trajectory, typename
+ * Stack> */
+ /* struct DoContinuous<T1,T2,Particle,Trajectory,Stack, typename
+ * std::enable_if<std::is_base_of<DiscreteProcess<T1>, T1>::value>::type> { */
+ /* static EProcessReturn Call(const T1& A, const T2& B, Particle& p, Trajectory& t,
+ * Stack& s) { */
+ /* EProcessReturn ret = EProcessReturn::eOk; */
+ /* A.DoContinuous(p, t, s); */
+ /* B.DoContinuous(p, t, s); */
+ /* return ret; */
+ /* } */
+ /* }; */
+
+ /* template<typename T1, typename T2, typename Particle, typename Trajectory,
+ * typename Stack> */
+ /* struct DoContinuous<T1,T2,Particle,Trajectory,Stack, typename
+ * std::enable_if<std::is_base_of<DiscreteProcess<T2>, T2>::value>::type> { */
+ /* static EProcessReturn Call(const T1& A, const T2&, Particle& p, Trajectory& t,
+ * Stack& s) { */
+ /* EProcessReturn ret = EProcessReturn::eOk; */
+ /* A.DoContinuous(p, t, s); */
+ /* B.DoContinuous(p, t, s); */
+ /* return ret; */
+ /* } */
+ /* }; */
+ /* *\/ */
+
+ /* template<typename T1, typename T2, typename Particle, typename Stack>//, typename
+ * Type = void> */
+ /* struct DoDiscrete { */
+ /* static EProcessReturn Call(const T1& A, const T2& B, Particle& p, Stack& s) { */
+ /* if constexpr (!std::is_base_of<ContinuousProcess<T1>, T1>::value) { */
+ /* A.DoDiscrete(p, s); */
+ /* } */
+ /* if constexpr (!std::is_base_of<ContinuousProcess<T2>, T2>::value) { */
+ /* B.DoDiscrete(p, s); */
+ /* } */
+ /* return EProcessReturn::eOk; */
+ /* } */
+ /* }; */
+ /* /\* */
+ /* template<typename T1, typename T2, typename Particle, typename Stack> */
+ /* struct DoDiscrete<T1,T2,Particle,Stack, typename
+ * std::enable_if<std::is_base_of<ContinuousProcess<T1>, T1>::value>::type> { */
+ /* static EProcessReturn Call(const T1&, const T2& B, Particle& p, Stack& s) { */
+ /* // A.DoDiscrete(p, s); */
+ /* B.DoDiscrete(p, s); */
+ /* return EProcessReturn::eOk; */
+ /* } */
+ /* }; */
+
+ /* template<typename T1, typename T2, typename Particle, typename Stack> */
+ /* struct DoDiscrete<T1,T2,Particle,Stack, typename
+ * std::enable_if<std::is_base_of<ContinuousProcess<T2>, T2>::value>::type> { */
+ /* static EProcessReturn Call(const T1& A, const T2&, Particle& p, Stack& s) { */
+ /* A.DoDiscrete(p, s); */
+ /* //B.DoDiscrete(p, s); */
+ /* return EProcessReturn::eOk; */
+ /* } */
+ /* }; */
+ /* *\/ */
+ /* } // end namespace detail */
/**
\class ProcessSequence
@@ -43,25 +146,46 @@ namespace corsika::process {
: A(in_A)
, B(in_B) {}
- template <typename Particle, typename Trajectory, typename Stack>
- inline void DoContinuous(Particle& p, Trajectory& t, Stack& s) const {
- A.DoContinuous(p, t, s);
- B.DoContinuous(p, t, s);
- } // add trajectory
+ // example for a trait-based call:
+ // void Hello() const { detail::CallHello<T1,T2>::Call(A, B); }
+
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoContinuous(Particle& p, Trajectory& t, Stack& s) const {
+ EProcessReturn ret = EProcessReturn::eOk;
+ if constexpr (!std::is_base_of<DiscreteProcess<T1>, T1>::value) {
+ A.DoContinuous(p, t, s);
+ }
+ if constexpr (!std::is_base_of<DiscreteProcess<T2>, T2>::value) {
+ B.DoContinuous(p, t, s);
+ }
+ return ret;
+ }
- template <typename D>
- inline double MinStepLength(D& d) const {
- return std::min(A.MinStepLength(d), B.MinStepLength(d));
+ template <typename Particle>
+ inline void MinStepLength(Particle& p, Trajectory& step) const {
+ A.MinStepLength(p, step);
+ B.MinStepLength(p, step);
}
- // template<typename D>
- // inline Trajectory Transport(D& d, double& length) const { A.Transport(d, length);
- // B.Transport(d, length); }
+ /*
+ template <typename Particle, typename Trajectory>
+ inline Trajectory Transport(Particle& p, double& length) const {
+ A.Transport(p, length); // todo: maybe check (?) if there is more than one Transport
+ // process implemented??
+ return B.Transport(
+ p, length); // need to do this also to decide which Trajectory to return!!!!
+ }
+ */
template <typename Particle, typename Stack>
- void DoDiscrete(Particle& p, Stack& s) const {
- A.DoDiscrete(p, s);
- B.DoDiscrete(p, s);
+ inline EProcessReturn DoDiscrete(Particle& p, Stack& s) const {
+ if constexpr (!std::is_base_of<ContinuousProcess<T1>, T1>::value) {
+ A.DoDiscrete(p, s);
+ }
+ if constexpr (!std::is_base_of<ContinuousProcess<T2>, T2>::value) {
+ B.DoDiscrete(p, s);
+ }
+ return EProcessReturn::eOk;
}
/// TODO the const_cast is not nice, think about the constness here
@@ -71,13 +195,27 @@ namespace corsika::process {
}
};
- /// the + operator that assembles more BaseProcess objects into a ProcessSequence
- template <typename T1, typename T2>
- inline const ProcessSequence<T1, T2> operator+(const BaseProcess<T1>& A,
- const BaseProcess<T2>& B) {
- return ProcessSequence<T1, T2>(A.GetRef(), B.GetRef());
+ /// the +operator assembles many BaseProcess, ContinuousProcess, and
+ /// DiscreteProcess objects into a ProcessSequence, all combinatorics
+ /// must be allowed, this is why we define a macro to define all
+ /// combinations here:
+
+#define OPSEQ(C1, C2) \
+ template <typename T1, typename T2> \
+ inline const ProcessSequence<T1, T2> operator+(const C1<T1>& A, const C2<T2>& B) { \
+ return ProcessSequence<T1, T2>(A.GetRef(), B.GetRef()); \
}
+ OPSEQ(BaseProcess, BaseProcess)
+ OPSEQ(BaseProcess, DiscreteProcess)
+ OPSEQ(BaseProcess, ContinuousProcess)
+ OPSEQ(ContinuousProcess, BaseProcess)
+ OPSEQ(ContinuousProcess, DiscreteProcess)
+ OPSEQ(ContinuousProcess, ContinuousProcess)
+ OPSEQ(DiscreteProcess, BaseProcess)
+ OPSEQ(DiscreteProcess, DiscreteProcess)
+ OPSEQ(DiscreteProcess, ContinuousProcess)
+
/*
template <typename T1>
struct depth_lhs
diff --git a/Framework/ProcessSequence/ProcessSignature.h b/Framework/ProcessSequence/ProcessSignature.h
new file mode 100644
index 0000000000000000000000000000000000000000..cb0081df416b19057f995065545f92d4f083f8a0
--- /dev/null
+++ b/Framework/ProcessSequence/ProcessSignature.h
@@ -0,0 +1,32 @@
+
+/**
+ * (c) Copyright 2018 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_process_processsignature_h_
+#define _include_process_processsignature_h_
+
+#define FORCE_SIGNATURE(nameTrait, nameMethod, signatureMethod) \
+ template <typename U> \
+ class nameTrait { \
+ private: \
+ template <typename T, T> \
+ struct helper; \
+ template <typename T> \
+ static std::uint8_t check(helper<signatureMethod, &nameMethod>*); \
+ template <typename T> \
+ static std::uint16_t check(...); \
+ \
+ public: \
+ static constexpr bool value = sizeof(check<U>(0)) == sizeof(std::uint8_t); \
+ }
+
+// FORCE_SIGNATURE(thisMustBeDefined, T::thisMustBeDefined, int(*)(void));
+
+#endif
diff --git a/Framework/ProcessSequence/testProcessSequence.cc b/Framework/ProcessSequence/testProcessSequence.cc
index d057facff29092be0f2ba3f14c47c65708ce07f2..9757298cdc2269a90fd875cdedfa68a16f19ab5a 100644
--- a/Framework/ProcessSequence/testProcessSequence.cc
+++ b/Framework/ProcessSequence/testProcessSequence.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
// cpp file
#include <catch2/catch.hpp>
@@ -8,56 +19,117 @@
#include <corsika/process/ProcessSequence.h>
+#include <corsika/setup/SetupTrajectory.h> // TODO: maybe try to break this dependency later!
+using corsika::setup::Trajectory;
+#include <corsika/units/PhysicalUnits.h>
+using namespace corsika::units::si;
+
using namespace std;
using namespace corsika::process;
-class Process1 : public BaseProcess<Process1> {
+static const int nData = 10;
+
+class ContinuousProcess1 : public ContinuousProcess<ContinuousProcess1> {
+public:
+ ContinuousProcess1() {}
+ void Init() { cout << "ContinuousProcess1::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ cout << "ContinuousProcess1::DoContinuous" << endl;
+ for (int i = 0; i < nData; ++i) d.p[i] += 0.933;
+ return EProcessReturn::eOk;
+ }
+
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const {
+ cout << "ContinuousProcess1::DoDiscrete" << endl;
+ return EProcessReturn::eOk;
+ }
+};
+
+class ContinuousProcess2 : public ContinuousProcess<ContinuousProcess2> {
+public:
+ ContinuousProcess2() {}
+ void Init() { cout << "ContinuousProcess2::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ cout << "ContinuousProcess2::DoContinuous" << endl;
+ for (int i = 0; i < nData; ++i) d.p[i] += 0.933;
+ return EProcessReturn::eOk;
+ }
+
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const {
+ cout << "ContinuousProcess2::DoDiscrete" << endl;
+ return EProcessReturn::eOk;
+ }
+};
+
+class Process1 : public DiscreteProcess<Process1> {
public:
Process1() {}
- void Init() {} // cout << "Process1::Init" << endl; }
- template <typename D, typename T, typename S>
- void DoContinuous(D& d, T& t, S& s) const {
- for (int i = 0; i < 10; ++i) d.p[i] += 1 + i;
+ void Init() { cout << "Process1::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ for (int i = 0; i < nData; ++i) d.p[i] += 1 + i;
+ return EProcessReturn::eOk;
+ }
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const {
+ cout << "Process1::DoDiscrete" << endl;
+ return EProcessReturn::eOk;
}
};
-class Process2 : public BaseProcess<Process2> {
+class Process2 : public DiscreteProcess<Process2> {
public:
Process2() {}
- void Init() {} // cout << "Process2::Init" << endl; }
- template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
- for (int i = 0; i < 10; ++i) d.p[i] *= 0.7;
+ void Init() { cout << "Process2::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ for (int i = 0; i < nData; ++i) d.p[i] *= 0.7;
+ return EProcessReturn::eOk;
+ }
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const {
+ cout << "Process2::DoDiscrete" << endl;
+ return EProcessReturn::eOk;
}
};
-class Process3 : public BaseProcess<Process3> {
+class Process3 : public DiscreteProcess<Process3> {
public:
Process3() {}
- void Init() {} // cout << "Process3::Init" << endl; }
- template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
- for (int i = 0; i < 10; ++i) d.p[i] += 0.933;
+ void Init() { cout << "Process3::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ for (int i = 0; i < nData; ++i) d.p[i] += 0.933;
+ return EProcessReturn::eOk;
+ }
+ template <typename Particle, typename Stack>
+ inline EProcessReturn DoDiscrete(Particle&, Stack&) const {
+ cout << "Process3::DoDiscrete" << endl;
+ return EProcessReturn::eOk;
}
};
class Process4 : public BaseProcess<Process4> {
public:
Process4() {}
- void Init() {} // cout << "Process4::Init" << endl; }
- template <typename D, typename T, typename S>
- inline void DoContinuous(D& d, T& t, S& s) const {
- for (int i = 0; i < 10; ++i) d.p[i] /= 1.2;
+ void Init() { cout << "Process4::Init" << endl; }
+ template <typename D, typename S>
+ inline EProcessReturn DoContinuous(D& d, Trajectory&, S&) const {
+ for (int i = 0; i < nData; ++i) d.p[i] /= 1.2;
+ return EProcessReturn::eOk;
}
// inline double MinStepLength(D& d) {
// void DoDiscrete(Particle& p, Stack& s) const {
};
struct DummyData {
- double p[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
+ double p[nData] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
};
struct DummyStack {};
-struct DummyTrajectory {};
TEST_CASE("Cascade", "[Cascade]") {
@@ -70,17 +142,37 @@ TEST_CASE("Cascade", "[Cascade]") {
const auto sequence = m1 + m2 + m3 + m4;
+ ContinuousProcess1 cp1;
+ ContinuousProcess2 cp2;
+
+ const auto sequence2 = cp1 + m2 + m3 + cp2;
+
DummyData p;
- DummyTrajectory t;
DummyStack s;
- sequence.Init();
+ cout << "-->init" << endl;
+ sequence2.Init();
+ cout << "-->docont" << endl;
- const int n = 100;
- INFO("Running loop with n=" << n);
- for (int i = 0; i < n; ++i) { sequence.DoContinuous(p, t, s); }
+ // auto const root = corsika::geometry::CoordinateSystem::CreateRootCS();
+ // corsika::geometry::Point pos(root, {0_m, 0_m, 0_m});
+ // corsika::geometry::Vector<SpeedType::dimension_type> vec(root,
+ // {1_m/1_s,0_m/1_s,0_m/1_s}); corsika::geometry::Line traj(pos, vec);
+ Trajectory
+ t; //(corsika::geometry::Trajectory<corsika::geometry::Line>(traj, 0_s, 100_ns));
+
+ sequence2.DoContinuous(p, t, s);
+ cout << "-->dodisc" << endl;
+ sequence2.DoDiscrete(p, s);
+ cout << "-->done" << endl;
+
+ sequence.Init();
- for (int i = 0; i < 10; i++) { INFO("data[" << i << "]=" << p.p[i]); }
+ const int nLoop = 5;
+ cout << "Running loop with n=" << nLoop << endl;
+ for (int i = 0; i < nLoop; ++i) { sequence.DoContinuous(p, t, s); }
+ for (int i = 0; i < nData; i++) { cout << "data[" << i << "]=" << p.p[i] << endl; }
+ cout << "done" << endl;
}
SECTION("sectionThree") {}
diff --git a/Framework/Random/CMakeLists.txt b/Framework/Random/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..3c1947d2508b318eafe6ab426bceac9af7b9e752
--- /dev/null
+++ b/Framework/Random/CMakeLists.txt
@@ -0,0 +1,49 @@
+
+set (
+ CORSIKArandom_SOURCES
+ RNGManager.cc
+ )
+
+set (
+ CORSIKArandom_HEADERS
+ RNGManager.h
+ )
+
+set (
+ CORSIKArandom_NAMESPACE
+ corsika/random
+ )
+
+add_library (CORSIKArandom STATIC ${CORSIKArandom_SOURCES})
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKArandom ${CORSIKArandom_NAMESPACE} ${CORSIKArandom_HEADERS})
+
+target_include_directories (
+ CORSIKArandom
+ PUBLIC
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/>
+ )
+
+# target dependencies on other libraries (also the header onlys)
+# none
+
+install (
+ TARGETS CORSIKArandom
+ LIBRARY DESTINATION lib
+ ARCHIVE DESTINATION lib
+ PUBLIC_HEADER DESTINATION include/${CORSIKArandom_NAMESPACE}
+ )
+
+
+# --------------------
+# code unit testing
+add_executable (testRandom testRandom.cc)
+
+target_link_libraries (
+ testRandom
+ CORSIKArandom
+ CORSIKAthirdparty # for catch2
+ )
+
+add_test (NAME testRandom COMMAND testRandom)
+
diff --git a/Framework/Random/RNGManager.cc b/Framework/Random/RNGManager.cc
new file mode 100644
index 0000000000000000000000000000000000000000..3245e8bfd4b5557fcf0cda06f9a09cf15a4ca90e
--- /dev/null
+++ b/Framework/Random/RNGManager.cc
@@ -0,0 +1,42 @@
+
+/**
+ * (c) Copyright 2018 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/random/RNGManager.h>
+
+void corsika::random::RNGManager::RegisterRandomStream(std::string const& pStreamName) {
+ corsika::random::RNG rng;
+
+ if (auto const& it = seeds.find(pStreamName); it != seeds.end()) {
+ rng.seed(it->second);
+ }
+
+ rngs[pStreamName] = std::move(rng);
+}
+
+corsika::random::RNG& corsika::random::RNGManager::GetRandomStream(
+ std::string const& pStreamName) {
+ return rngs.at(pStreamName);
+}
+
+std::stringstream corsika::random::RNGManager::dumpState() const {
+ std::stringstream buffer;
+ for (auto const& [streamName, rng] : rngs) {
+ buffer << '"' << streamName << "\" = \"" << rng << '"' << std::endl;
+ }
+
+ return buffer;
+}
+/*
+void corsika::random::RNGManager::SetSeedSeq(std::string const& pStreamName,
+ std::seed_seq const& pSeedSeq) {
+ seeds[pStreamName] = pSeedSeq;
+}
+*/
diff --git a/Framework/Random/RNGManager.h b/Framework/Random/RNGManager.h
new file mode 100644
index 0000000000000000000000000000000000000000..c440e7aaae0beb3ae745562fa4949eff5ff504ee
--- /dev/null
+++ b/Framework/Random/RNGManager.h
@@ -0,0 +1,68 @@
+
+/**
+ * (c) Copyright 2018 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_RNGManager_h_
+#define _include_RNGManager_h_
+
+#include <corsika/utl/Singleton.h>
+
+#include <map>
+#include <random>
+#include <sstream>
+#include <string>
+
+/*!
+ * With this class modules can register streams of random numbers.
+ */
+
+namespace corsika::random {
+
+ using RNG = std::mt19937; //!< the actual RNG type that will be used
+
+ class RNGManager : public corsika::utl::Singleton<RNGManager> {
+
+ friend class corsika::utl::Singleton<RNGManager>;
+
+ std::map<std::string, RNG> rngs;
+ std::map<std::string, std::seed_seq> seeds;
+
+ protected:
+ RNGManager() {}
+
+ public:
+ /*!
+ * This function is to be called by a module requiring a random-number
+ * stream during its initialization.
+ *
+ * \throws sth. when stream \a pModuleName is already registered
+ */
+ void RegisterRandomStream(std::string const& pStreamName);
+
+ /*!
+ * returns the pre-stored stream of given name \a pStreamName if
+ * available
+ */
+ RNG& GetRandomStream(std::string const& pStreamName);
+
+ /*!
+ * dumps the names and states of all registered random-number streams
+ * into a std::stringstream.
+ */
+ std::stringstream dumpState() const;
+
+ /**
+ * set seed_seq of \a pStreamName to \a pSeedSeq
+ */
+ // void SetSeedSeq(std::string const& pStreamName, std::seed_seq& const pSeedSeq);
+ };
+
+} // namespace corsika::random
+#endif
diff --git a/Framework/Random/testRandom.cc b/Framework/Random/testRandom.cc
new file mode 100644
index 0000000000000000000000000000000000000000..041a96c21ff241e3a86a903a887e521ff17c9e29
--- /dev/null
+++ b/Framework/Random/testRandom.cc
@@ -0,0 +1,39 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
+#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
+ // cpp file
+#include <catch2/catch.hpp>
+
+#include <corsika/random/RNGManager.h>
+#include <iostream>
+
+using namespace corsika::random;
+
+SCENARIO("random-number streams can be registered and retrieved") {
+ GIVEN("a RNGManager") {
+ RNGManager& rngManager = RNGManager::GetInstance();
+
+ WHEN("a sequence is registered by name") {
+ rngManager.RegisterRandomStream("stream_A");
+
+ THEN("the sequence can be retrieved") {
+ REQUIRE_NOTHROW(rngManager.GetRandomStream("stream_A"));
+ }
+
+ THEN("an unknown sequence cannot be retrieved") {
+ REQUIRE_THROWS(rngManager.GetRandomStream("stream_UNKNOWN"));
+ }
+
+ // seeding not covered yet
+ }
+ }
+}
diff --git a/Framework/StackInterface/CMakeList.txt b/Framework/StackInterface/CMakeList.txt
deleted file mode 100644
index aea441bd22ca6fd91def7826534b5c5e3e98814d..0000000000000000000000000000000000000000
--- a/Framework/StackInterface/CMakeList.txt
+++ /dev/null
@@ -1,10 +0,0 @@
-
-add_library (CORSIKAstack INTERFACE)
-
-target_include_directories (CORSIKAstack INTERFACE $<BUILD_INTERFACE:${PROJECT_SOURCE_DIR}/Framework>
- $<INSTALL_INTERFACE:include/Framework>
- )
-
-install (FILES Stack.h StackIterator.h
- DESTINATION include/Stack)
-
diff --git a/Framework/StackInterface/CMakeLists.txt b/Framework/StackInterface/CMakeLists.txt
index 11a30200e4e29191012850c33063b5a0ddeba385..42c52ceab9c30014de606890a37ae596538f4e1c 100644
--- a/Framework/StackInterface/CMakeLists.txt
+++ b/Framework/StackInterface/CMakeLists.txt
@@ -31,9 +31,7 @@ install (
include/${CORSIKAstackinterface_NAMESPACE}
)
-
-# code testing
+#code testing
add_executable (testStackInterface testStackInterface.cc)
-target_link_libraries (testStackInterface CORSIKAstackinterface CORSIKAthirdparty) # for catch2
add_test(NAME testStackInterface COMMAND testStackInterface)
-
+target_link_libraries (testStackInterface CORSIKAstackinterface CORSIKAthirdparty) # for catch2
diff --git a/Framework/StackInterface/ParticleBase.h b/Framework/StackInterface/ParticleBase.h
index aa0bb3d11a9e11369ce1fa0ac4d83092262707f5..1d1d51efaed25155e88976ac364f2605e7498a33 100644
--- a/Framework/StackInterface/ParticleBase.h
+++ b/Framework/StackInterface/ParticleBase.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_particleBase_h_
#define _include_particleBase_h_
@@ -48,6 +59,6 @@ namespace corsika::stack {
int GetIndex() const { return GetIterator().GetIndex(); }
};
-}; // namespace corsika::stack
+} // namespace corsika::stack
#endif
diff --git a/Framework/StackInterface/Stack.h b/Framework/StackInterface/Stack.h
index d493ef5eff59912afd195f9e75f6c5f21744cd2f..b4660144df60754df6ff8e78e45d0920f5a58cf8 100644
--- a/Framework/StackInterface/Stack.h
+++ b/Framework/StackInterface/Stack.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_Stack_h__
#define _include_Stack_h__
diff --git a/Framework/StackInterface/StackIterator.h b/Framework/StackInterface/StackIterator.h
index a6ca8bed67c4d25fbbd97abab1bda1bb3157e9ec..9e8d07e68bedc5080a0a750b3e73972664bf712c 100644
--- a/Framework/StackInterface/StackIterator.h
+++ b/Framework/StackInterface/StackIterator.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_StackIterator_h__
#define _include_StackIterator_h__
@@ -56,18 +67,18 @@ namespace corsika::stack {
public:
// StackIterator() : fData(0), fIndex(0) { }
StackIteratorInterface(StackType& data, const int index)
- : fData(&data)
- , fIndex(index) {}
+ : fIndex(index)
+ , fData(&data) {}
private:
StackIteratorInterface(const StackIteratorInterface& mit)
- : fData(mit.fData)
- , fIndex(mit.fIndex) {}
-
+ : fIndex(mit.fIndex)
+ , fData(mit.fData) {}
+
public:
StackIteratorInterface& operator=(const StackIteratorInterface& mit) {
- fData = mit.fData;
fIndex = mit.fIndex;
+ fData = mit.fData;
return *this;
}
diff --git a/Framework/StackInterface/testStackInterface.cc b/Framework/StackInterface/testStackInterface.cc
index e00ecc18333c18baee2b7372d473726e5460419c..078a09407c713287c36c9a48d20e5e842a32bc09 100644
--- a/Framework/StackInterface/testStackInterface.cc
+++ b/Framework/StackInterface/testStackInterface.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/stack/Stack.h>
#include <iomanip>
diff --git a/Framework/Units/PhysicalConstants.h b/Framework/Units/PhysicalConstants.h
index 7add499dd5b000172de38da22074e5427ce36b76..94f98ac2ccf6a0f9c96f06e7b4429b9c022e1e19 100644
--- a/Framework/Units/PhysicalConstants.h
+++ b/Framework/Units/PhysicalConstants.h
@@ -54,6 +54,9 @@ namespace corsika::units::si::constants {
// unified atomic mass unit
constexpr quantity<mass_d> u{Rep(1.6605402e-27L) * kilogram};
+ // barn moved to PhysicalUnits
+ // constexpr quantity<area_d> barn{Rep(1.e-28L) * meter * meter};
+
// etc.
} // namespace corsika::units::si::constants
diff --git a/Framework/Units/PhysicalUnits.h b/Framework/Units/PhysicalUnits.h
index 5d1f676a08bf4ce21e60aed9a12e9ec86bb53b19..f2c1b8213d511ab00054ef52eeb796e71643670e 100644
--- a/Framework/Units/PhysicalUnits.h
+++ b/Framework/Units/PhysicalUnits.h
@@ -9,7 +9,7 @@
/**
* @file PhysicalUnits
*
- * Add units and types we need
+ * Add new units and types we need
*
* Define _XeV literals, etc., allowing 10_GeV in the code.
*/
@@ -33,6 +33,17 @@ namespace corsika::units::si {
using namespace phys::units::literals;
// namespace literals = phys::units::literals;
+ /// defining momentum you suckers
+ /// dimensions, i.e. composition in base SI dimensions
+ using momentum_d = phys::units::dimensions<1, 1, -1>;
+ // defining the unit of momentum, so far newton-meter, maybe go to HEP?
+ constexpr phys::units::quantity<momentum_d> newton_second{meter * kilogram / second};
+
+ /// defining cross section
+ using sigma_d = phys::units::dimensions<2, 0, 0>;
+ constexpr phys::units::quantity<sigma_d> barn{Rep(1.e-28L) * meter * meter};
+
+ /// add the unit-types
using LengthType = phys::units::quantity<phys::units::length_d, double>;
using TimeType = phys::units::quantity<phys::units::time_interval_d, double>;
using SpeedType = phys::units::quantity<phys::units::speed_d, double>;
@@ -41,19 +52,40 @@ namespace corsika::units::si {
phys::units::quantity<phys::units::electric_charge_d, double>;
using EnergyType = phys::units::quantity<phys::units::energy_d, double>;
using MassType = phys::units::quantity<phys::units::mass_d, double>;
+ using MomentumType = phys::units::quantity<momentum_d, double>;
+ using CrossSectionType = phys::units::quantity<sigma_d, double>;
} // end namespace corsika::units::si
+/**
+ * @file PhysicalUnits
+ *
+ * Define _XeV literals, alowing 10_GeV in the code.
+ * Define _meter literal
+ * Define _barn literal
+ * Define _newton_second literal for SI momenta
+ */
+
namespace phys {
namespace units {
namespace literals {
QUANTITY_DEFINE_SCALING_LITERALS(eV, energy_d,
magnitude(corsika::units::si::constants::eV))
+
+ QUANTITY_DEFINE_SCALING_LITERALS(barn, corsika::units::si::sigma_d,
+ magnitude(corsika::units::si::constants::barn))
+
+
+ QUANTITY_DEFINE_SCALING_LITERALS(meter, length_d,
+ magnitude(corsika::units::si::constants::meter))
+
+ QUANTITY_DEFINE_SCALING_LITERALS(newton_second, corsika::units::si::momentum_d,
+ magnitude(corsika::units::si::newton_second))
+
} // namespace literals
} // namespace units
} // namespace phys
-
// we want to call the operator<< without namespace... I think
using namespace phys::units::io;
diff --git a/Framework/Units/testUnits.cc b/Framework/Units/testUnits.cc
index de119e3d3c2cd7f6bad85efe6f0a7e6900fcdb7c..9124431862b6d0215d44306403b2f31457d1ccda 100644
--- a/Framework/Units/testUnits.cc
+++ b/Framework/Units/testUnits.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
// cpp file
#include <catch2/catch.hpp>
@@ -17,19 +28,23 @@ TEST_CASE("PhysicalUnits", "[Units]") {
}
SECTION("Constructors") {
- auto E1 = 10_GeV;
+ [[maybe_unused]] auto E1 = 10_GeV;
REQUIRE(E1 == 10_GeV);
LengthType l1 = 10_nm;
+ l1 = l1;
LengthType arr0[5];
arr0[0] = 5_m;
- LengthType arr1[2] = {{1_mm}, {2_cm}};
+ [[maybe_unused]] LengthType arr1[2] = {{1_mm}, {2_cm}};
std::array<EnergyType, 4> arr2; // empty array
- std::array<EnergyType, 4> arr3 = {1_GeV, 1_eV, 5_MeV};
+ [[maybe_unused]] std::array<EnergyType, 4> arr3 = {1_GeV, 1_eV, 5_MeV};
+
+ [[maybe_unused]] auto p1 = 10_newton_second;
+ REQUIRE(p1 == 10_newton_second);
}
SECTION("Powers in literal units") {
@@ -43,6 +58,7 @@ TEST_CASE("PhysicalUnits", "[Units]") {
REQUIRE(1_mol / 1_amol == Approx(1e18));
REQUIRE(1_K / 1_zK == Approx(1e21));
REQUIRE(1_K / 1_yK == Approx(1e24));
+ REQUIRE(1_barn / 1_mbarn == Approx(1e3));
REQUIRE(1_A / 1_hA == Approx(1e-2));
REQUIRE(1_m / 1_km == Approx(1e-3));
@@ -65,6 +81,10 @@ TEST_CASE("PhysicalUnits", "[Units]") {
REQUIRE(E2 == 40_GeV);
REQUIRE(E2 / 1_GeV == Approx(40));
+ const MassType m = 1_kg;
+ const SpeedType v = 1_m / 1_s;
+ REQUIRE(m * v == 1_newton_second);
+
const double lgE = log10(E2 / 1_GeV);
REQUIRE(lgE == Approx(log10(40.)));
@@ -87,4 +107,11 @@ TEST_CASE("PhysicalUnits", "[Units]") {
}
+ SECTION("Special") {
+
+ const LengthType farAway = std::numeric_limits<double>::infinity() * meter;
+ REQUIRE(farAway > 100000_m);
+ REQUIRE_FALSE(farAway < 1e19 * meter);
+ }
+
}
diff --git a/Framework/Utilities/Bit.h b/Framework/Utilities/Bit.h
new file mode 100644
index 0000000000000000000000000000000000000000..67473b37a131e2baff58cf9ca5f4b0d744a84a18
--- /dev/null
+++ b/Framework/Utilities/Bit.h
@@ -0,0 +1,86 @@
+#ifndef _corsika_utl_Bit_h_
+#define _corsika_utl_Bit_h_
+
+/**
+ \author Hans Dembinski
+ \author Lukas Nellen
+ \author Darko Veberic
+ \date 27 Jan 2014
+
+ \version $Id: Bit.h 25126 2014-02-03 22:13:10Z darko $
+*/
+
+#include <exception>
+
+// #include <utl/AugerException.h>
+
+namespace corsika::utl {
+
+ namespace Bit {
+
+ template <typename T>
+ class Array {
+ public:
+ Array(T& target)
+ : fTarget(target) {}
+
+ class Bit {
+ public:
+ Bit(T& target, T mask)
+ : fTarget(target)
+ , fMask(mask) {}
+
+ operator bool() const { return fTarget & fMask; }
+
+ bool operator~() const { return !bool(*this); }
+
+ Bit& operator=(const bool value) {
+ if (value)
+ fTarget |= fMask;
+ else
+ fTarget &= ~fMask;
+ return *this;
+ }
+
+ Bit& Flip() { return *this = ~(*this); }
+
+ private:
+ T& fTarget;
+ T fMask;
+ };
+
+ Bit operator[](unsigned int position) { return Bit(fTarget, T(1) << position); }
+
+ Bit At(unsigned int position) {
+ if (position >= 8 * sizeof(T))
+ // throw std::exceptionOutOfBoundException("Running out of bits.");
+ throw std::exception("Running out of bits.");
+ return (*this)[position];
+ }
+
+ template <typename M>
+ Array& Mask(const M mask, const bool value) {
+ Bit(fTarget, mask) = value;
+ return *this;
+ }
+
+ template <typename M>
+ T Get(const M mask) {
+ return fTarget & T(mask);
+ }
+
+ private:
+ T& fTarget;
+ };
+
+ } // namespace Bit
+
+ // helper
+ template <typename T>
+ inline Bit::Array<T> AsBitArray(T& target) {
+ return Bit::Array<T>(target);
+ }
+
+} // namespace corsika::utl
+
+#endif
diff --git a/Framework/Utilities/CMakeList.txt b/Framework/Utilities/CMakeList.txt
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/Framework/Utilities/CMakeLists.txt b/Framework/Utilities/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..ab6c148d9311817456198282eb1757a25264952e
--- /dev/null
+++ b/Framework/Utilities/CMakeLists.txt
@@ -0,0 +1,61 @@
+
+set (
+ UTILITIES_SOURCES
+ Dummy.cc
+ )
+
+set (
+ UTILITIES_HEADERS
+ Dummy.h
+ Bit.h
+ Test.h
+ Singleton.h
+ )
+
+set (
+ UTILITIES_NAMESPACE
+ corsika/utl
+ )
+
+add_library (CORSIKAutilities STATIC ${UTILITIES_SOURCES})
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKAutilities ${UTILITIES_NAMESPACE} ${UTILITIES_HEADERS})
+
+set_target_properties (
+ CORSIKAutilities
+ PROPERTIES
+ VERSION ${PROJECT_VERSION}
+ SOVERSION 1
+ PUBLIC_HEADER "${UTILITIES_HEADERS}"
+ )
+
+# target dependencies on other libraries (also the header onlys)
+#target_link_libraries (
+# )
+
+target_include_directories (
+ CORSIKAutilities
+ PUBLIC
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/include>
+ )
+
+install (
+ TARGETS CORSIKAutilities
+ LIBRARY DESTINATION lib
+ ARCHIVE DESTINATION lib
+ PUBLIC_HEADER DESTINATION include/${UTILITIES_NAMESPACE}
+ )
+
+
+# --------------------
+# code unit testing
+# add_executable (testBit testBit.cc)
+
+# target_link_libraries (
+# testBit
+# CORSIKAutilities
+# CORSIKAthirdparty # for catch2
+# )
+
+# add_test (NAME testBit COMMAND testBit)
+
diff --git a/Framework/Utilities/Dummy.cc b/Framework/Utilities/Dummy.cc
new file mode 100644
index 0000000000000000000000000000000000000000..fd578b8e09c10e3b26932dbc1dfdc1c36a1030b9
--- /dev/null
+++ b/Framework/Utilities/Dummy.cc
@@ -0,0 +1,5 @@
+#include <corsika/utl/Dummy.h>
+
+using namespace corsika::utl;
+
+// big void...
diff --git a/Framework/Utilities/Dummy.h b/Framework/Utilities/Dummy.h
new file mode 100644
index 0000000000000000000000000000000000000000..dac2021b49df401d221c5160f825909440468e22
--- /dev/null
+++ b/Framework/Utilities/Dummy.h
@@ -0,0 +1,9 @@
+#ifndef _include_corsika_utilties_dummy_h_
+#define _include_corsika_utilties_dummy_h_
+
+namespace corsika::utl {
+
+ // void....
+}
+
+#endif
diff --git a/Framework/Utilities/Singleton.h b/Framework/Utilities/Singleton.h
new file mode 100644
index 0000000000000000000000000000000000000000..e06d974cc3c7de8003991227ded2cd6df0b0ab53
--- /dev/null
+++ b/Framework/Utilities/Singleton.h
@@ -0,0 +1,140 @@
+#ifndef _corsika_utl_Singleton_h_
+#define _corsika_utl_Singleton_h_
+
+//#define OFFLINE_USE_GAMMA_SINGLETON
+
+namespace corsika::utl {
+
+#ifndef OFFLINE_USE_GAMMA_SINGLETON
+
+ /**
+ * \class Singleton Singleton.h utl/Singleton.h
+ *
+ * \brief Curiously Recurring Template Pattern (CRTP) for Meyers singleton
+ *
+ * The singleton class is implemented as follows
+ * \code
+ * #include <utl/Singleton.h>
+ *
+ * class SomeClass : public utl::Singleton<SomeClass> {
+ * ...
+ * private:
+ * // prevent creation, destruction
+ * SomeClass() { }
+ * ~SomeClass() { }
+ *
+ * friend class utl::Singleton<SomeClass>;
+ * };
+ * \endcode
+ * Singleton automatically prevents copying of the derived class.
+ *
+ * \author Darko Veberic
+ * \date 9 Aug 2006
+ * \version $Id: Singleton.h 25091 2014-01-30 09:49:57Z darko $
+ * \ingroup stl
+ */
+
+ template <typename T>
+ class Singleton {
+ public:
+ static T& GetInstance()
+#ifdef __MAKECINT__
+ ;
+#else
+ {
+ static T instance;
+ return instance;
+ }
+#endif
+
+ protected:
+ // derived class can call ctor and dtor
+ Singleton() {}
+ ~Singleton() {}
+
+ private:
+ // no one should do copies
+ Singleton(const Singleton&);
+ Singleton& operator=(const Singleton&);
+ };
+
+#else
+
+ /// classical Gamma singleton
+ template <typename T>
+ class Singleton {
+ public:
+ static T& GetInstance() {
+ if (!fgInstance) fgInstance = new T;
+ return *fgInstance;
+ }
+
+ protected:
+ // derived class can call ctor and dtor
+ Singleton() {}
+ ~Singleton() {}
+
+ private:
+ // no one should do copies
+ Singleton(const Singleton&);
+ Singleton& operator=(const Singleton&);
+
+ static T* fgInstance = 0;
+ };
+
+#endif
+
+ /**
+ * \class LeakingSingleton Singleton.h utl/Singleton.h
+ *
+ * \brief CRTP for leaking singleton
+ *
+ * This type of creation (Gamma singleton) leaks the object at
+ * the end of the run, i.e. class T destructor does not get called
+ * in at_exit().
+ *
+ * This singleton can be implemented as follows
+ * \code
+ * #include <utl/Singleton.h>
+ *
+ * class SomeClass : public utl::LeakingSingleton<SomeClass> {
+ * ...
+ * private:
+ * // prevent creation, destruction
+ * SomeClass() { }
+ * ~SomeClass() { }
+ *
+ * friend class utl::LeakingSingleton<SomeClass>;
+ * };
+ * \endcode
+ * LeakingSingleton automatically prevents copying of the derived
+ * class.
+ *
+ * \author Darko Veberic
+ * \date 9 Aug 2006
+ * \version $Id: Singleton.h 25091 2014-01-30 09:49:57Z darko $
+ * \ingroup stl
+ */
+
+ template <class T>
+ class LeakingSingleton {
+ public:
+ static T& GetInstance() {
+ static T* const instance = new T;
+ return *instance;
+ }
+
+ protected:
+ // derived class can call ctor and dtor
+ LeakingSingleton() {}
+ ~LeakingSingleton() {}
+
+ private:
+ // no one should do copies
+ LeakingSingleton(const LeakingSingleton&);
+ LeakingSingleton& operator=(const LeakingSingleton&);
+ };
+
+} // namespace corsika::utl
+
+#endif
diff --git a/Framework/Utilities/Test.h b/Framework/Utilities/Test.h
new file mode 100644
index 0000000000000000000000000000000000000000..41c7cecd7a9856e2c5b68f845d22a25f64a3cf0a
--- /dev/null
+++ b/Framework/Utilities/Test.h
@@ -0,0 +1,237 @@
+#ifndef _utl_Test_h_
+#define _utl_Test_h_
+
+/**
+ \file
+ Tools to do simple testing in a readable way
+
+ \author Lukas Nellen
+ \author Darko Veberic
+ \version $Id: Test.h 31925 2018-09-25 16:02:12Z darko $
+ \date 08 Feb 2004
+
+ \ingroup testing
+*/
+
+#include <utl/Triple.h>
+#include <boost/format.hpp>
+#include <boost/tuple/tuple.hpp>
+#include <boost/tuple/tuple_comparison.hpp>
+#include <boost/tuple/tuple_io.hpp>
+#include <cmath>
+
+namespace utl {
+
+ //! Predicate used in STL for searching for whitespace
+ struct IsSpace {
+ bool operator()(const char x) const {
+ return x == ' ' || x == '\r' || x == '\n' || x == '\t';
+ }
+ };
+
+ /// Predicate for equality
+ class Equal {
+ public:
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return lhs == rhs;
+ }
+
+ static const char* Name() { return "equal"; }
+ };
+
+ /// Predicate for less
+ class Less {
+ public:
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return lhs < rhs;
+ }
+
+ static const char* Name() { return "less"; }
+ };
+
+ /// Predicate for less or equal
+ class LessOrEqual {
+ public:
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return lhs <= rhs;
+ }
+
+ static const char* Name() { return "less or equal"; }
+ };
+
+ /// Predicate for greater
+ class Greater {
+ public:
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return lhs > rhs;
+ }
+
+ static const char* Name() { return "greater"; }
+ };
+
+ /// Predicate for greater or equal
+ class GreaterOrEqual {
+ public:
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return lhs >= rhs;
+ }
+
+ static const char* Name() { return "greater or equal"; }
+ };
+
+ /// Predicate for approximate equality (for floating point)
+ /** The default precision is 1e-6, but it can be changed at
+ construction time.
+ */
+ class CloseTo {
+ public:
+ CloseTo(const double eps = 1e-6)
+ : fEpsilon(eps) {}
+
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return IsCloseTo(lhs, rhs);
+ }
+
+ boost::format Name() const { return boost::format("close (@%g) to") % fEpsilon; }
+
+ protected:
+ template <typename T>
+ bool IsCloseAbs(const T& lhs, const T& rhs) const {
+ return std::abs(double(lhs) - double(rhs)) < fEpsilon;
+ }
+
+ bool IsCloseAbs(const utl::Triple& lhs, const utl::Triple& rhs) const {
+ return std::sqrt(TupleDist2(lhs, rhs)) < fEpsilon;
+ }
+
+ template <typename T>
+ bool IsCloseRel(const T& lhs, const T& rhs) const {
+ return 2 * std::abs(double(lhs) - double(rhs)) /
+ (std::abs(double(lhs)) + std::abs(double(rhs))) <
+ fEpsilon;
+ }
+
+ bool IsCloseRel(const utl::Triple& lhs, const utl::Triple& rhs) const {
+ return (2 * sqrt(TupleDist2(lhs, rhs)) /
+ (sqrt(TupleDist2(lhs, utl::Triple(0, 0, 0))) +
+ sqrt(TupleDist2(rhs, utl::Triple(0, 0, 0))))) < fEpsilon;
+ }
+
+ template <typename T>
+ bool IsCloseTo(const T& lhs, const T& rhs) const {
+ if (IsCloseAbs(lhs, rhs))
+ return true;
+ else
+ return IsCloseRel(lhs, rhs);
+ }
+
+ // tuple distance
+ template <typename Head, typename Tail>
+ static double TupleDist2(const boost::tuples::cons<Head, Tail>& lhs,
+ const boost::tuples::cons<Head, Tail>& rhs) {
+ const double t = lhs.get_head() - rhs.get_head();
+ return t * t + TupleDist2(lhs.get_tail(), rhs.get_tail());
+ }
+
+ static double TupleDist2(const boost::tuples::null_type& /*lhs*/,
+ const boost::tuples::null_type& /*rhs*/) {
+ return 0;
+ }
+
+ double fEpsilon;
+ };
+
+ class CloseAbs : public CloseTo {
+ public:
+ CloseAbs(const double eps = 1e-6)
+ : CloseTo(eps) {}
+
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return IsCloseAbs(lhs, rhs);
+ }
+
+ boost::format Name() const {
+ return boost::format("absolutely close (@%g) to") % fEpsilon;
+ }
+ };
+
+ class CloseRel : public CloseTo {
+ public:
+ CloseRel(const double eps = 1e-6)
+ : CloseTo(eps) {}
+
+ template <typename T>
+ bool operator()(const T& lhs, const T& rhs) const {
+ return IsCloseRel(lhs, rhs);
+ }
+
+ boost::format Name() const {
+ return boost::format("relatively close (@%g) to") % fEpsilon;
+ }
+ };
+
+ template <typename Predicate>
+ class Not : public Predicate {
+ public:
+ Not()
+ : Predicate() {}
+
+ Not(const double eps)
+ : Predicate(eps) {}
+
+ template <typename T>
+ bool operator()(const T& x) const {
+ return !Predicate::operator()(x);
+ }
+
+ template <typename T, typename U>
+ bool operator()(const T& x, const U& y) const {
+ return !Predicate::operator()(x, y);
+ }
+
+ template <typename T, typename U, typename W>
+ bool operator()(const T& x, const U& y, const W& z) const {
+ return !Predicate::operator()(x, y, z);
+ }
+
+ static boost::format Name() { return boost::format("not-%s") % Predicate().Name(); }
+ };
+
+ inline utl::Triple Diff(const utl::Triple& lhs, const utl::Triple& rhs) {
+ return utl::Triple(lhs.get<0>() - rhs.get<0>(), lhs.get<1>() - rhs.get<1>(),
+ lhs.get<2>() - rhs.get<2>());
+ }
+
+ /// Test condition by evaluating a predicate
+ /** If the predicate evaluates to false, we print a failure message
+ with the values of the left- and right-hand side and the name of
+ the predicate. This information is normally not available when
+ using the CPPUNIT_ASSERT macro.
+ */
+ template <class Predicate, typename T>
+ inline bool Test(const Predicate& pred, const T& lhs, const T& rhs) {
+ return pred(lhs, rhs);
+ }
+
+ /// Main test function
+ template <class Predicate, typename T>
+ inline bool Test(const T& lhs, const T& rhs) {
+ return Test(Predicate(), lhs, rhs);
+ }
+
+ /// Test function for predicates that take an option
+ template <class Predicate, typename T, typename U>
+ inline bool Test(const T& lhs, const T& rhs, const U& eps) {
+ return Test(Predicate(eps), lhs, rhs);
+ }
+
+} // namespace utl
+
+#endif
diff --git a/Framework/Utilities/testBit.cc b/Framework/Utilities/testBit.cc
new file mode 100644
index 0000000000000000000000000000000000000000..a4d36d1bcae35a23c3baaa0fa96a0c05821c8fa5
--- /dev/null
+++ b/Framework/Utilities/testBit.cc
@@ -0,0 +1,90 @@
+/**
+ \file
+ Test Bit functions
+
+ \author Hans Dembinski
+ \version $Id: testBit.cc 25126 2014-02-03 22:13:10Z darko $
+ \date 27 Jan 2014
+
+ \ingroup testing
+*/
+
+#include <corsika/utl/Test.h>
+#include <cppunit/extensions/HelperMacros.h>
+#include <tst/Verify.h>
+#include <utl/Bit.h>
+#include <bitset>
+#include <cstdio>
+#include <iostream>
+
+using namespace tst;
+using namespace utl;
+using namespace std;
+
+/**
+ \ingroup testing
+*/
+class TestBit : public CppUnit::TestFixture {
+
+ CPPUNIT_TEST_SUITE(TestBit);
+ CPPUNIT_TEST(TestGet);
+ CPPUNIT_TEST(TestSet);
+ CPPUNIT_TEST(TestMask);
+ CPPUNIT_TEST_SUITE_END();
+
+public:
+ void setUp() {}
+
+ void tearDown() {}
+
+ void TestGet() {
+ const int size = sizeof(int) * 8;
+ const int bc2 = 12345;
+ int b2 = bc2;
+ bitset<size> b1(bc2);
+
+ ostringstream out1;
+ ostringstream out2;
+ ostringstream out3;
+ for (int i = 0; i < size; ++i) {
+ out1 << (b1[i] ? '^' : '.');
+ out2 << (AsBitArray(bc2)[i] ? '^' : '.');
+ out3 << (AsBitArray(b2)[i] ? '^' : '.');
+ }
+
+ CPPUNIT_ASSERT(Verify<Equal>(out1.str(), out2.str()));
+ CPPUNIT_ASSERT(Verify<Equal>(out1.str(), out3.str()));
+ }
+
+ void TestSet() {
+ const int size = sizeof(int) * 8;
+ const int number = 12345;
+ bitset<size> b1(number);
+ int b2 = 11111;
+
+ for (int i = 0; i < size; ++i) AsBitArray(b2)[i] = b1[i];
+
+ CPPUNIT_ASSERT(Verify<Equal>(b2, number));
+ }
+
+ void TestMask() {
+ const int n = (1 << 18) | (1 << 5);
+ int m = 0;
+
+ AsBitArray(m)[18] = true;
+ AsBitArray(m)[5] = true;
+ CPPUNIT_ASSERT(Verify<Equal>(n, m));
+
+ for (unsigned int i = 0; i < 8 * sizeof(int); ++i) AsBitArray(m)[i] = 0;
+ CPPUNIT_ASSERT(Verify<Equal>(m, 0));
+
+ m = 1;
+ AsBitArray(m).Mask(n, true);
+ CPPUNIT_ASSERT(Verify<Equal>(m, n + 1));
+
+ AsBitArray(m).Mask(n, false);
+ CPPUNIT_ASSERT(Verify<Equal>(m, 1));
+ }
+};
+
+CPPUNIT_TEST_SUITE_REGISTRATION(TestBit);
diff --git a/GUIDELINES.md b/GUIDELINES.md
new file mode 100644
index 0000000000000000000000000000000000000000..8558b13263a63cdacd9c60b88e9aa55f63d49454
--- /dev/null
+++ b/GUIDELINES.md
@@ -0,0 +1,117 @@
+# Guidelines for code development, structure, formating etc.
+
+The CORSIKA Project very much welcomes contributions. Here we outlined
+how you can find the right place to contribute, and how to do that.
+Connect to http://gitlab.ikp.kit.edu and corsika-devel@lists.kit.edu
+or corsika-project@lists.kit.edu to get in touch with the project.
+The CORSIKA Project decides on the [GUIDELINES](GUIDELINES.md), and can
+change them.
+
+# How to contribute
+
+ - We organize all development via `Issues` that may be feature requests,
+ ideas, or bugs fix requests.
+ - New issues can be created, or existing issues
+ picked up.
+ - Issues are discussed in meetings or via corsika-devel@lists.kit.edu within the CORSIKA Project.
+ - Issues are assigned to milestones.
+ - The work on issues is performed in `branches` that can be best
+ created directly via the gitlab web interface.
+ - Proposed code to close one issue (located in a specific git
+ branch) is reviewed and eventually discussed, and finally merged
+ into the master branch to close the issue.
+
+
+## Code formatting
+
+We rely on `clang-format` for code formatting. This has the tremendous
+advantage that definitely all code follows the same formatting rules,
+and nobody at any point needs to invest time and effort into code
+formatting. We provide a script `do-clang-format.sh`, which can be
+very useful. But we urge everybody to integrate `clang-format` already
+on the level of your source code editor. See [the official
+page](https://clang.llvm.org/docs/ClangFormat.html) for information
+about `clang-format` and its editor integration.
+
+The definition of source code format is written down in the file
+[.clang-format](.clang-format) and can be changed, if the CORSIKA
+Project agrees on it. To see what is possible, check
+e.g. [link1](https://clangformat.com/) or
+[link2](https://zed0.co.uk/clang-format-configurator/).
+
+## Naming conventions
+
+While `clang-format` does the structural formatting, we still need to agree on naming conventions:
+
+ - Classes and structs start with capital letters
+ - Class member variables start with "f"
+ - Any static variable has a "g" prefix. A static member variable starts with "fg"
+ - Class member functions start with capital letters
+ - Any class getter begins with "Get", and setter with "Set"
+ - enums should be "enum class", and start with a capital "E", enum entries start with "e"
+
+ - We use namespaces to avoid clashes and to structure code
+ - *Everything* is part of the corsika namespace
+ - All classes and objects are encapsulated into suited sub-namespaces,
+ thus corsika::geometry, corsika::processes, corsika::units, etc.
+ - Namespace names do not use capital letters.
+ - Every header file is copied during build and install into
+ "include/corsika/[namespace]" which also means, each header file
+ can only provide definitions for a _single_ namespace. It is one
+ main purpose of namespaces to structure the location of header
+ files.
+ - Each header file uses an include protection that includes at
+ least the namespace name, and header file name, thus, `#ifndef
+ __include_geometry_Point_h__` or `#ifnedf __geometry_Point_h__`,
+ or similar are acceptable.
+ - Header files should always be included with `<..>`, thus,
+ `#include <corsika/geometry/Point.h>` since the build system
+ will always provide the correct include directives (and files
+ anyway cannot be found in file-system paths that typically do
+ not follow the namespace naming conventions outlined
+ here).
+
+ - Header files are named after the main class (or object) they
+ define. This also means each header file name starts with a
+ capital letter.
+
+
+## Coding rules
+
+ - Code may not introduce any compiler errors, or warnings
+ - All unit tests must succeed at all times
+ - We use C++17 concepts wherever useful and helpful
+ - On any major error or malfunction we throw an exception. This is needed and required for complex physics and shower debugging.
+ - We never catch exceptions for error handling, there might be very few special exceptions from this. We need to discuss such cases.
+ - Everything that should not change should be `const`
+ - Everything that does not need to be visible to the outside of a class/struct should be `private` or `protected`
+ - We prefer the use of references, wherever useful
+ - There cannot be any pointer in the interface of any class or object
+ exposed to outside users, there might be pointers for very special cases
+ inside of classes.
+ - When you contribute new code, or extend existing code, at the same time provide unit-tests for all functionality.
+ - Code must be documented with `doxygen` commands
+
+
+## Release versioning scheme
+
+Releases of CORSIKA are thought to be the baseline for larger scale testing, and full production.
+The releases are numbered as x.y.z, starting with x=8 form the gitlab c++ version. X will only be incremented
+for major design or physics changes. The y index is updated for new official releases that normally contain improved or enhanced physics
+performance, and may also contain normal interface changes to accomodate improvements. The z index can be updated frequently for
+bug fixes or new features. Changes in z will not contain interface changes, thus, code will remain fully compatible.
+Special releases of CORSIKA can also have a tag name from git, e.g. as in the "milestone1" release.
+
+
+# How to become scientific author of the CORSIKA Project
+
+The CORSIKA Project decides on who becomes scientific author. The
+following conditions are clearly sufficient, but not all of them are
+required all the time:
+ - responsibility for a particular functionality or part
+ - follows these [GUIDELINES](GUIDELINES.md)
+ - agrees to the [COLLABORATION_AGREEMENT](COLLABORATION_AGREEMENT.md)
+ - active in the CORSIKA Project, that means responsive to
+ discussions and problems in corsika-devel@list.kit.edu or on https//gitlab.ikp.kit.edu, of relevant *issues*,
+ or in (phone) meetings
+ - the members of the CORSIKA Project panel agree
diff --git a/MCNET_GUIDELINES b/MCNET_GUIDELINES
new file mode 100644
index 0000000000000000000000000000000000000000..60d53f92a3d9f5edab6725c863591b286d6b618c
--- /dev/null
+++ b/MCNET_GUIDELINES
@@ -0,0 +1,112 @@
+These guidelines are copied from: http://www.montecarlonet.org/
+---------------------------------------------------------------
+
+
+ MCNET GUIDELINES
+
+ for Event Generator Authors and Users
+
+
+ PREAMBLE
+
+This generator has been developed as part of an academic research
+project and is the result of many years of work by the authors.
+Proper academic recognition is a requirement for its continued
+development.
+
+The components of the program have been developed to work together
+as a coherent physics framework. We believe that the creation of
+separately maintained forks or piecewise distribution of individual
+parts would diminish their scientific value.
+
+The authors are convinced that software development in a scientific
+context requires full availability of all source code, to further
+progress and to allow local modifications to meet the specific
+requirements of the individual user.
+
+Therefore we have decided to release this program under the GNU
+General Public License (GPL) version 2 (with the option to instead
+follow the terms and conditions of any later version of GPL). This
+ensures that the source code will be available to you and grants you
+the freedom to use and modify the program. You can redistribute your
+modified versions as long as you retain the GPL and respect existing
+copyright notices (see the file 'COPYING' for details).
+
+By using the GPL, we entrust you with considerable freedom and expect
+you to use it wisely, since the GPL does not address the issues in
+the first two paragraphs. To remedy this shortcoming, we have
+formulated the following guidelines relevant for the distribution
+and usage of event generator software in an academic setting.
+
+
+ GUIDELINES
+
+1) The integrity of the program should be respected.
+ -------------------------------------------------
+
+1.1) Suspected bugs and proposed fixes should be reported back to the
+ original authors to be considered for inclusion in the standard
+ distribution. No independently developed and maintained forks
+ should be created as long as the original authors actively work on
+ the program.
+
+1.2) The program should normally be redistributed in its entirety.
+ When there are special reasons, an agreement should be sought with
+ the original authors to redistribute only specific parts. This
+ should be arranged such that the redistributed parts remain
+ updated in step with the standard distribution.
+
+1.3) Any changes in the code must be clearly marked in the source
+ (reason, author, date) and documented. If any modified version is
+ redistributed it should be stated at the point of distribution
+ (download link) that it has been modified and why.
+
+1.4) If a significant part of the code is used by another program,
+ this should be clearly specified in that program's documentation and
+ stated at its point of distribution.
+
+1.5) Copyright information and references may not be removed.
+ Copyright-related program messages may not be altered and must be
+ printed even if only a part of the program is used. Adding further
+ messages specifying any modifications is encouraged.
+
+
+2) The program and its physics should be properly cited when used for
+ academic publications
+ ------------------------------------------------------------------
+
+2.1) The main software reference as designated by the program authors
+ should always be cited.
+
+2.2) In addition, the original literature on which the program is based
+ should be cited to the extent that it is of relevance for a study,
+ applying the same threshold criteria as for other literature.
+
+2.3) When several programs are combined, they should all be mentioned,
+ commensurate with their importance for the physics study at hand.
+
+2.4) To make published results reproducible, the exact versions of the
+ codes that were used and any relevant program and parameter
+ modifications should be spelled out.
+
+
+ POSTSCRIPT
+
+The copyright license of the software is the GPL v2 alone, therefore
+the above guidelines are not legally binding. However, we reserve the
+right to criticize offenders. The guidelines should always be combined
+with common sense, for interpretation and for issues not covered.
+Enquiries regarding the guidelines and related issues are encouraged
+and should be directed to the authors of the program.
+
+Please note that the program, including all its code and documentation,
+is intended for academic use and is delivered "as is" to be used at
+your own risk, without any guarantees.
+
+----------------------------------------------------------------------
+
+These guidelines were edited by Nils Lavesson and David Grellscheid
+for the MCnet collaboration, which has approved and agreed to respect
+them. MCnet is a Marie Curie Research Training Network funded under
+Framework Programme 6 contract MRTN-CT-2006-035606.
+
diff --git a/Main/Environment.h b/Main/Environment.h
index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..90582b3dfb00d2d85850b81455a2a4c0c061413b 100644
--- a/Main/Environment.h
+++ b/Main/Environment.h
@@ -0,0 +1,10 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
diff --git a/Main/Stack.h b/Main/Stack.h
index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..90582b3dfb00d2d85850b81455a2a4c0c061413b 100644
--- a/Main/Stack.h
+++ b/Main/Stack.h
@@ -0,0 +1,10 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
diff --git a/Main/shower.cc b/Main/shower.cc
index 7bc09673a29ed82e49f1939a52b3f5c86f31adad..10facda7435af5d9f6f1ab83223a25ad61c068b1 100644
--- a/Main/shower.cc
+++ b/Main/shower.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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 <utl/Stack.h>
int main(int argc, char** argv) { return 0; }
diff --git a/Processes/CMakeLists.txt b/Processes/CMakeLists.txt
index 9b81c6d9857687cb808691565a1b5c9b6b413cfd..41a8277d9c736f387d68b255ff2af7415133c10c 100644
--- a/Processes/CMakeLists.txt
+++ b/Processes/CMakeLists.txt
@@ -1,2 +1,12 @@
+
add_subdirectory (NullModel)
add_subdirectory (Sibyll)
+add_subdirectory (StackInspector)
+add_subdirectory (TrackingLine)
+
+#add_custom_target(CORSIKAprocesses)
+add_library (CORSIKAprocesses INTERFACE)
+add_dependencies(CORSIKAprocesses ProcessNullModel)
+add_dependencies(CORSIKAprocesses ProcessSibyll)
+add_dependencies(CORSIKAprocesses ProcessStackInspector)
+add_dependencies(CORSIKAprocesses ProcessTrackingLine)
diff --git a/Processes/NullModel/NullModel.cc b/Processes/NullModel/NullModel.cc
index 4da71dc16066f65af4623db7a45338ac9c8fde0c..3629d522a3383abcb5954a84f2fa47d1a1d45354 100644
--- a/Processes/NullModel/NullModel.cc
+++ b/Processes/NullModel/NullModel.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/null_model/NullModel.h>
using namespace corsika::process::null_model;
diff --git a/Processes/NullModel/NullModel.h b/Processes/NullModel/NullModel.h
index 98782765696e7d0a87d19611bba0d9fc1e9f4c7f..dc3bf504bca57e2cadcc264ec50e9903dcd9a2ad 100644
--- a/Processes/NullModel/NullModel.h
+++ b/Processes/NullModel/NullModel.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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 _Physics_NullModel_NullModel_h_
#define _Physics_NullModel_NullModel_h_
diff --git a/Processes/NullModel/testNullModel.cc b/Processes/NullModel/testNullModel.cc
index 311c732cec4b3cbdb8bcb4d4886b37df0e940696..c098b025b678427f1e244fc8052d0dd889f11d08 100644
--- a/Processes/NullModel/testNullModel.cc
+++ b/Processes/NullModel/testNullModel.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
// cpp file
#include <catch2/catch.hpp>
diff --git a/Processes/Sibyll/CMakeLists.txt b/Processes/Sibyll/CMakeLists.txt
index 041fdb8c34e8947d9ecc10b19961b7a2a653519b..f2e4a9fee1aabbbb5196a597db36de06e6385594 100644
--- a/Processes/Sibyll/CMakeLists.txt
+++ b/Processes/Sibyll/CMakeLists.txt
@@ -1,4 +1,17 @@
-
+add_custom_command (
+ OUTPUT ${PROJECT_BINARY_DIR}/Processes/Sibyll/Generated.inc
+ COMMAND ${PROJECT_SOURCE_DIR}/Processes/Sibyll/code_generator.py
+ ${PROJECT_BINARY_DIR}/Framework/Particles/pythia_db.pkl
+ ${PROJECT_SOURCE_DIR}/Processes/Sibyll/sibyll_codes.dat
+ DEPENDS code_generator.py
+ sibyll_codes.dat
+ ${PROJECT_BINARY_DIR}/Framework/Particles/pythia_db.pkl
+ WORKING_DIRECTORY
+ ${PROJECT_BINARY_DIR}/Processes/Sibyll/
+ COMMENT "Generate conversion tables for particle codes SIBYLL <-> CORSIKA"
+ VERBATIM
+ )
+
set (
MODEL_SOURCES
ParticleConversion.cc
@@ -7,6 +20,7 @@ set (
set (
MODEL_HEADERS
ParticleConversion.h
+ ${PROJECT_BINARY_DIR}/Processes/Sibyll/Generated.inc
)
set (
@@ -17,6 +31,21 @@ set (
add_library (ProcessSibyll STATIC ${MODEL_SOURCES})
CORSIKA_COPY_HEADERS_TO_NAMESPACE (ProcessSibyll ${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/sibyll/Generated.inc ${CMAKE_CURRENT_SOURCE_DIR}/Generated.inc
+ COMMENT "Generate link in source-dir: ${CMAKE_CURRENT_SOURCE_DIR}/Generated.inc"
+ )
+add_custom_target (SourceDirLink2 DEPENDS ${PROJECT_BINARY_DIR}/Processes/Sibyll/Generated.inc)
+add_dependencies (ProcessSibyll SourceDirLink2)
+# .....................................................
+
+
+
set_target_properties (
ProcessSibyll
PROPERTIES
@@ -28,7 +57,9 @@ set_target_properties (
# target dependencies on other libraries (also the header onlys)
target_link_libraries (
ProcessSibyll
+ CORSIKAparticles
CORSIKAunits
+ CORSIKAthirdparty
)
target_include_directories (
@@ -48,7 +79,10 @@ install (
# --------------------
# code unit testing
-add_executable (testSibyll testSibyll.cc)
+add_executable (testSibyll
+ testSibyll.cc
+ ${MODEL_HEADERS}
+ )
target_link_libraries (
testSibyll
diff --git a/Processes/Sibyll/ParticleConversion.cc b/Processes/Sibyll/ParticleConversion.cc
index 6aca2fcf0a07a1ee89eeb859fbb6b40b37e96ec3..9925b97b9e90dba68dc38f46fd5ddb32e71c68c7 100644
--- a/Processes/Sibyll/ParticleConversion.cc
+++ b/Processes/Sibyll/ParticleConversion.cc
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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/sibyll/ParticleConversion.h>
diff --git a/Processes/Sibyll/ParticleConversion.h b/Processes/Sibyll/ParticleConversion.h
index f39c1297964d33846bedcb6160203f11f882c95d..35bfbc617df904ba0e859fbf451ab1356092f207 100644
--- a/Processes/Sibyll/ParticleConversion.h
+++ b/Processes/Sibyll/ParticleConversion.h
@@ -1,199 +1,57 @@
+
+/**
+ * (c) Copyright 2018 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_sibyll_particles_h_
#define _include_processes_sibyll_particles_h_
#include <corsika/particles/ParticleProperties.h>
+#include <bitset2/bitset2.hpp>
+
#include <map>
-namespace corsika::process {
-
- namespace sibyll {
-
- enum class PID : int {
- E_MINUS = 3,
- E_PLUS = 2,
- NU_E = 15,
- NU_E_BAR = 16,
- MU_MINUS = 5,
- MU_PLUS = 4,
- NU_MU = 17,
- NU_MU_BAR = 18,
- TAU_MINUS = 91,
- TAU_PLUS = 90,
- NU_TAU = 92,
- NU_TAU_BAR = 93,
- GAMMA = 1,
- PI_0 = 6,
- RHO_0 = 27,
- K_L_0 = 11,
- PI_PLUS = 7,
- PI_MINUS = 8,
- RHO_PLUS = 25,
- RHO_MINUS = 26,
- ETA = 23,
- OMEGA = 32,
- K_S_0 = 12,
- K_STAR_0 = 30,
- K_STAR_BAR_0 = 31,
- K_PLUS = 9,
- K_MINUS = 10,
- K_STAR_PLUS = 28,
- K_STAR_MINUS = 29,
- D_PLUS = 59,
- D_MINUS = 60,
- D_STAR_PLUS = 78,
- D_STAR_MINUS = 79,
- D_0 = 71,
- D_BAR_0 = 72,
- D_STAR_0 = 80,
- D_STAR_BAR_0 = 81,
- D_S_PLUS = 74,
- D_S_MINUS = 75,
- D_STAR_S_PLUS = 76,
- D_STAR_S_MINUS = 77,
- ETA_C = 73,
- N_0 = 14,
- N_BAR_0 = -14,
- DELTA_0 = 42,
- DELTA_BAR_0 = -42,
- P_PLUS = 13,
- P_BAR_MINUS = -13,
- DELTA_PLUS = 41,
- DELTA_BAR_MINUS = -41,
- DELTA_PLUS_PLUS = 40,
- DELTA_BAR_MINUS_MINUS = -40,
- SIGMA_MINUS = 36,
- SIGMA_BAR_PLUS = -36,
- LAMBDA_0 = 39,
- LAMBDA_BAR_0 = -39,
- SIGMA_0 = 35,
- SIGMA_BAR_0 = -35,
- SIGMA_PLUS = 34,
- SIGMA_BAR_MINUS = -34,
- XI_MINUS = 38,
- XI_BAR_PLUS = -38,
- XI_0 = 37,
- XI_BAR_0 = -37,
- OMEGA_MINUS = 49,
- OMEGA_BAR_PLUS = -49,
- SIGMA_C_0 = 86,
- SIGMA_C_BAR_0 = -86,
- SIGMA_STAR_C_0 = 96,
- SIGMA_STAR_C_BAR_0 = -96,
- LAMBDA_C_PLUS = 89,
- LAMBDA_C_BAR_MINUS = -89,
- XI_C_0 = 88,
- XI_C_BAR_0 = -88,
- SIGMA_C_PLUS = 85,
- SIGMA_C_BAR_MINUS = -85,
- SIGMA_STAR_C_PLUS = 95,
- SIGMA_STAR_C_BAR_MINUS = -95,
- SIGMA_C_PLUS_PLUS = 84,
- SIGMA_C_BAR_MINUS_MINUS = -84,
- SIGMA_STAR_C_PLUS_PLUS = 94,
- SIGMA_STAR_C_BAR_MINUS_MINUS = -94,
- XI_C_PLUS = 87,
- XI_C_BAR_MINUS = -87,
- OMEGA_C_0 = 99,
- OMEGA_C_BAR_0 = -99,
- J_PSI = 83,
- VOID = 0,
- };
-
- static const std::map<sibyll::PID, corsika::particles::Code> Sibyll2Corsika = {
- {PID::E_MINUS, corsika::particles::Code::Electron},
- {PID::E_PLUS, corsika::particles::Code::Positron},
- {PID::NU_E, corsika::particles::Code::NuE},
- {PID::NU_E_BAR, corsika::particles::Code::NuEBar},
- {PID::MU_MINUS, corsika::particles::Code::MuMinus},
- {PID::MU_PLUS, corsika::particles::Code::MuPlus},
- {PID::NU_MU, corsika::particles::Code::NuMu},
- {PID::NU_MU_BAR, corsika::particles::Code::NuMuBar},
- {PID::TAU_MINUS, corsika::particles::Code::TauMinus},
- /*
- TAU_PLUS = 90,
- NU_TAU = 92,
- NU_TAU_BAR = 93,
- GAMMA = 1,
- PI_0 = 6,
- RHO_0 = 27,
- K_L_0 = 11,
- PI_PLUS = 7,
- PI_MINUS = 8,
- RHO_PLUS = 25,
- RHO_MINUS = 26,
- ETA = 23,
- OMEGA = 32,
- K_S_0 = 12,
- K_STAR_0 = 30,
- K_STAR_BAR_0 = 31,
- K_PLUS = 9,
- K_MINUS = 10,
- K_STAR_PLUS = 28,
- K_STAR_MINUS = 29,
- D_PLUS = 59,
- D_MINUS = 60,
- D_STAR_PLUS = 78,
- D_STAR_MINUS = 79,
- D_0 = 71,
- D_BAR_0 = 72,
- D_STAR_0 = 80,
- D_STAR_BAR_0 = 81,
- D_S_PLUS = 74,
- D_S_MINUS = 75,
- D_STAR_S_PLUS = 76,
- D_STAR_S_MINUS = 77,
- ETA_C = 73,
- N_0 = 14,
- N_BAR_0 = -14,
- DELTA_0 = 42,
- DELTA_BAR_0 = -42,
- P_PLUS = 13,
- P_BAR_MINUS = -13,
- DELTA_PLUS = 41,
- DELTA_BAR_MINUS = -41,
- DELTA_PLUS_PLUS = 40,
- DELTA_BAR_MINUS_MINUS = -40,
- SIGMA_MINUS = 36,
- SIGMA_BAR_PLUS = -36,
- LAMBDA_0 = 39,
- LAMBDA_BAR_0 = -39,
- SIGMA_0 = 35,
- SIGMA_BAR_0 = -35,
- SIGMA_PLUS = 34,
- SIGMA_BAR_MINUS = -34,
- XI_MINUS = 38,
- XI_BAR_PLUS = -38,
- XI_0 = 37,
- XI_BAR_0 = -37,
- OMEGA_MINUS = 49,
- OMEGA_BAR_PLUS = -49,
- SIGMA_C_0 = 86,
- SIGMA_C_BAR_0 = -86,
- SIGMA_STAR_C_0 = 96,
- SIGMA_STAR_C_BAR_0 = -96,
- LAMBDA_C_PLUS = 89,
- LAMBDA_C_BAR_MINUS = -89,
- XI_C_0 = 88,
- XI_C_BAR_0 = -88,
- SIGMA_C_PLUS = 85,
- SIGMA_C_BAR_MINUS = -85,
- SIGMA_STAR_C_PLUS = 95,
- SIGMA_STAR_C_BAR_MINUS = -95,
- SIGMA_C_PLUS_PLUS = 84,
- SIGMA_C_BAR_MINUS_MINUS = -84,
- SIGMA_STAR_C_PLUS_PLUS = 94,
- SIGMA_STAR_C_BAR_MINUS_MINUS = -94,
- XI_C_PLUS = 87,
- XI_C_BAR_MINUS = -87,
- OMEGA_C_0 = 99,
- OMEGA_C_BAR_0 = -99,
- J_PSI = 83,
- VOID = 0,*/
- };
-
- } // namespace sibyll
-
-} // namespace corsika::process
+namespace corsika::process::sibyll {
+
+ enum class SibyllCode : int8_t;
+ using SibyllCodeIntType = std::underlying_type<SibyllCode>::type;
+
+#include <corsika/process/sibyll/Generated.inc>
+
+ bool KnownBySibyll(corsika::particles::Code pCode) {
+ return isKnown[static_cast<corsika::particles::CodeIntType>(pCode)];
+ }
+
+ bool CanInteract(corsika::particles::Code pCode) {
+ return canInteract[static_cast<corsika::particles::CodeIntType>(pCode)];
+ }
+
+ SibyllCode constexpr ConvertToSibyll(corsika::particles::Code pCode) {
+ //~ assert(handledBySibyll(pCode));
+ return static_cast<SibyllCode>(
+ corsika2sibyll[static_cast<corsika::particles::CodeIntType>(pCode)]);
+ }
+
+ corsika::particles::Code constexpr ConvertFromSibyll(SibyllCode pCode) {
+ return sibyll2corsika[static_cast<SibyllCodeIntType>(pCode) - minSibyll];
+ }
+
+ int ConvertToSibyllRaw(corsika::particles::Code pCode) {
+ return (int)static_cast<corsika::process::sibyll::SibyllCodeIntType>(
+ corsika::process::sibyll::ConvertToSibyll(pCode));
+ }
+
+ int GetSibyllXSCode(corsika::particles::Code pCode) {
+ return corsika2sibyllXStype[static_cast<corsika::particles::CodeIntType>(pCode)];
+ }
+
+} // namespace corsika::process::sibyll
#endif
diff --git a/Processes/Sibyll/code_generator.py b/Processes/Sibyll/code_generator.py
new file mode 100755
index 0000000000000000000000000000000000000000..77c1f5dd8216ad48ebf5c4aa476ef57695bb7fea
--- /dev/null
+++ b/Processes/Sibyll/code_generator.py
@@ -0,0 +1,171 @@
+#!/usr/bin/env python3
+
+# (c) Copyright 2018 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 pythia_db (which is an OrderedDict)
+def load_pythiadb(filename):
+ with open(filename, "rb") as f:
+ pythia_db = pickle.load(f)
+ return pythia_db
+
+
+
+#
+def read_sibyll_codes(filename, pythia_db):
+ with open(filename) as f:
+ for line in f:
+ line = line.strip()
+ if line[0] == '#':
+ continue
+ identifier, sib_code, canInteractFlag, xsType = line.split()
+ try:
+ pythia_db[identifier]["sibyll_code"] = int(sib_code)
+ pythia_db[identifier]["sibyll_canInteract"] = int(canInteractFlag)
+ pythia_db[identifier]["sibyll_xsType"] = int(xsType)
+ except KeyError as e:
+ raise Exception("Identifier '{:s}' not found in pythia_db".format(identifier))
+
+
+
+
+# generates the enum to access sibyll particles by readable names
+def generate_sibyll_enum(pythia_db):
+ output = "enum class SibyllCode : int8_t {\n"
+ for identifier, pData in pythia_db.items():
+ if pData.get('sibyll_code') != None:
+ output += " {:s} = {:d},\n".format(identifier, pData['sibyll_code'])
+ output += "};\n"
+ return output
+
+
+
+# generates the look-up table to convert corsika codes to sibyll codes
+def generate_corsika2sibyll(pythia_db):
+ string = "std::array<SibyllCodeIntType, {:d}> constexpr corsika2sibyll = {{\n".format(len(pythia_db))
+ for identifier, pData in pythia_db.items():
+ sibCode = pData.get("sibyll_code", 0)
+ string += " {:d}, // {:s}\n".format(sibCode, identifier if sibCode else identifier + " (not implemented in SIBYLL)")
+ string += "};\n"
+ return string
+
+
+
+# generates the look-up table to convert corsika codes to sibyll codes
+def generate_corsika2sibyll_xsType(pythia_db):
+ string = "std::array<int, {:d}> constexpr corsika2sibyllXStype = {{\n".format(len(pythia_db))
+ for identifier, pData in pythia_db.items():
+ sibCodeXS = pData.get("sibyll_xsType", -1)
+ string += " {:d}, // {:s}\n".format(sibCodeXS, identifier if sibCodeXS else identifier + " (not implemented in SIBYLL)")
+ string += "};\n"
+ return string
+
+
+# generates the look-up table to convert sibyll codes to corsika codes
+def generate_sibyll2corsika(pythia_db) :
+ string = ""
+
+ minID = 0
+ for identifier, pData in pythia_db.items() :
+ if 'sibyll_code' in pData:
+ minID = min(minID, pData['sibyll_code'])
+
+ string += "SibyllCodeIntType constexpr minSibyll = {:d};\n\n".format(minID)
+
+ pDict = {}
+ for identifier, pData in pythia_db.items() :
+ if 'sibyll_code' in pData:
+ sib_code = pData['sibyll_code'] - minID
+ pDict[sib_code] = identifier
+
+ nPart = max(pDict.keys()) - min(pDict.keys()) + 1
+ string += "std::array<corsika::particles::Code, {:d}> sibyll2corsika = {{\n".format(nPart)
+
+ for iPart in range(nPart) :
+ if iPart in pDict:
+ identifier = pDict[iPart]
+ else:
+ identifier = "Unknown"
+ string += " corsika::particles::Code::{:s}, \n".format(identifier)
+
+ string += "};\n"
+ return string
+
+
+
+# generates the bitset for the flag whether Sibyll knows the particle
+def generate_known_particle(pythia_db):
+ num_particles = len(pythia_db)
+ num_bytes = num_particles // 32 + 1
+ string = "Bitset2::bitset2<{:d}> constexpr isKnown{{ std::array<uint32_t, {:d}>{{{{\n".format(num_particles, num_bytes)
+
+ numeric = 0
+ for identifier, pData in reversed(pythia_db.items()):
+ handledBySibyll = int("sibyll_code" in pData) & 0x1
+ numeric = (numeric << 1) | handledBySibyll
+
+ while numeric != 0:
+ low = numeric & 0xFFFFFFFF
+ numeric = numeric >> 32
+ string += " 0x{:0x},\n".format(low)
+
+ string += "}}};\n"
+ return string
+
+
+
+# generates the bitset for the flag whether Sibyll can use particle as projectile
+def generate_interacting_particle(pythia_db):
+ num_particles = len(pythia_db)
+ num_bytes = num_particles // 32 + 1
+ string = "Bitset2::bitset2<{:d}> constexpr canInteract{{ std::array<uint32_t, {:d}>{{{{\n".format(num_particles, num_bytes)
+ #string = "std::array<bool, {:d}> constexpr corsika2sibyll = {{\n".format(num_particles)
+
+ numeric = 0
+ for identifier, pData in reversed(pythia_db.items()):
+ can = 0
+ if 'sibyll_canInteract' in pData:
+ if pData['sibyll_canInteract'] > 0:
+ can = 0x1
+ numeric = (numeric << 1) | can
+
+ while numeric != 0:
+ low = numeric & 0xFFFFFFFF
+ numeric = numeric >> 32
+ string += " 0x{:0x},\n".format(low)
+
+ string += "}}};\n"
+ return string
+
+
+
+if __name__ == "__main__":
+ if len(sys.argv) != 3:
+ print("usage: {:s} <pythia_db.pkl> <sibyll_codes.dat>".format(sys.argv[0]), file=sys.stderr)
+ sys.exit(1)
+
+ print("code_generator.py for SIBYLL")
+
+ pythia_db = load_pythiadb(sys.argv[1])
+ read_sibyll_codes(sys.argv[2], pythia_db)
+
+ print (str(pythia_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_sibyll_enum(pythia_db), file=f)
+ print(generate_corsika2sibyll(pythia_db), file=f)
+ print(generate_known_particle(pythia_db), file=f)
+ print(generate_sibyll2corsika(pythia_db), file=f)
+ print(generate_interacting_particle(pythia_db), file=f)
+ print(generate_corsika2sibyll_xsType(pythia_db), file=f)
diff --git a/Processes/Sibyll/sibyll_codes.dat b/Processes/Sibyll/sibyll_codes.dat
index edc282f17398c435f5a3b0c81d6a51daf0c027c6..fc8515886b07c5f5a8f7a9307a7f06b88a65366c 100644
--- a/Processes/Sibyll/sibyll_codes.dat
+++ b/Processes/Sibyll/sibyll_codes.dat
@@ -1,88 +1,91 @@
-E_MINUS 3
-E_PLUS 2
-NU_E 15
-NU_E_BAR 16
-MU_MINUS 5
-MU_PLUS 4
-NU_MU 17
-NU_MU_BAR 18
-TAU_MINUS 91
-TAU_PLUS 90
-NU_TAU 92
-NU_TAU_BAR 93
-GAMMA 1
-PI_0 6
-RHO_0 27
-K_L_0 11
-PI_PLUS 7
-PI_MINUS 8
-RHO_PLUS 25
-RHO_MINUS 26
-ETA 23
-OMEGA 32
-K_S_0 12
-K_STAR_0 30
-K_STAR_BAR_0 31
-K_PLUS 9
-K_MINUS 10
-K_STAR_PLUS 28
-K_STAR_MINUS 29
-D_PLUS 59
-D_MINUS 60
-D_STAR_PLUS 78
-D_STAR_MINUS 79
-D_0 71
-D_BAR_0 72
-D_STAR_0 80
-D_STAR_BAR_0 81
-D_S_PLUS 74
-D_S_MINUS 75
-D_STAR_S_PLUS 76
-D_STAR_S_MINUS 77
-ETA_C 73
-N_0 14
-N_BAR_0 -14
-DELTA_0 42
-DELTA_BAR_0 -42
-P_PLUS 13
-P_BAR_MINUS -13
-DELTA_PLUS 41
-DELTA_BAR_MINUS -41
-DELTA_PLUS_PLUS 40
-DELTA_BAR_MINUS_MINUS -40
-SIGMA_MINUS 36
-SIGMA_BAR_PLUS -36
-LAMBDA_0 39
-LAMBDA_BAR_0 -39
-SIGMA_0 35
-SIGMA_BAR_0 -35
-SIGMA_PLUS 34
-SIGMA_BAR_MINUS -34
-XI_MINUS 38
-XI_BAR_PLUS -38
-XI_0 37
-XI_BAR_0 -37
-OMEGA_MINUS 49
-OMEGA_BAR_PLUS -49
-SIGMA_C_0 86
-SIGMA_C_BAR_0 -86
-SIGMA_STAR_C_0 96
-SIGMA_STAR_C_BAR_0 -96
-LAMBDA_C_PLUS 89
-LAMBDA_C_BAR_MINUS -89
-XI_C_0 88
-XI_C_BAR_0 -88
-SIGMA_C_PLUS 85
-SIGMA_C_BAR_MINUS -85
-SIGMA_STAR_C_PLUS 95
-SIGMA_STAR_C_BAR_MINUS -95
-SIGMA_C_PLUS_PLUS 84
-SIGMA_C_BAR_MINUS_MINUS -84
-SIGMA_STAR_C_PLUS_PLUS 94
-SIGMA_STAR_C_BAR_MINUS_MINUS -94
-XI_C_PLUS 87
-XI_C_BAR_MINUS -87
-OMEGA_C_0 99
-OMEGA_C_BAR_0 -99
-J_PSI 83
-VOID 0
+# input file for particle conversion to/from SIBYLL
+# the format of this file is: "corsika-identifier" "sibyll-id" "can-interact-in-sibyll" "cross-section-type"
+Electron 3 0 0
+Positron 2 0 0
+NuE 15 0 0
+NuEBar 16 0 0
+MuMinus 5 0 0
+MuPlus 4 0 0
+NuMu 17 0 0
+NuMuBar 18 0 0
+TauMinus 91 0 0
+TauPlus 90 0 0
+NuTau 92 0 0
+NuTauBar 93 0 0
+Gamma 1 0 0
+Pi0 6 1 2
+# rho0 could interact but sibyll has no cross section/interaction length. was used for gamma had int
+Rho0 27 0 0
+K0Long 11 1 3
+PiPlus 7 1 2
+PiMinus 8 1 2
+RhoPlus 25 0 0
+RhoMinus 26 0 0
+Eta 23 0 0
+Omega 32 0 0
+K0Short 12 1 3
+KStar0 30 0 0
+KStar0Bar 31 0 0
+KPlus 9 1 3
+KMinus 10 1 3
+KStarPlus 28 0 0
+KStarMinus 29 0 0
+DPlus 59 1 0
+DMinus 60 1 0
+DStarPlus 78 0 0
+DStarMinus 79 0 0
+D0 71 1 0
+D0Bar 72 1 0
+DStar0 80 0 0
+DStar0Bar 81 0 0
+DsPlus 74 1 0
+DsMinus 75 1 0
+DStarSPlus 76 0 0
+DStarSMinus 77 0 0
+EtaC 73 0 0
+Neutron 14 1 1
+AntiNeutron -14 1 1
+Delta0 42 0 0
+Delta0Bar -42 0 0
+Proton 13 1 1
+AntiProton -13 1 1
+DeltaPlus 41 0 0
+DeltaMinusBar -41 0 0
+DeltaPlusPlus 40 0 0
+DeltaMinusMinusBar -40 0 0
+SigmaMinus 36 1 1
+SigmaPlusBar -36 1 1
+Lambda0 39 1 1
+Lambda0Bar -39 1 1
+Sigma0 35 1 1
+Sigma0Bar -35 1 1
+SigmaPlus 34 1 1
+SigmaMinusBar -34 1 1
+XiMinus 38 1 1
+XiPlusBar -38 1 1
+Xi0 37 1 1
+Xi0Bar -37 1 1
+OmegaMinus 49 0 0
+OmegaPlusBar -49 0 0
+SigmaC0 86 0 0
+SigmaC0Bar -86 0 0
+SigmaStarC0 96 0 0
+SigmaStarC0Bar -96 0 0
+LambdaCPlus 89 1 1
+LambdaCMinusBar -89 1 1
+XiC0 88 1 1
+XiC0Bar -88 1 1
+SigmaCPlus 85 0 0
+SigmaCMinusBar -85 0 0
+SigmaStarCPlus 95 0 0
+SigmaStarCMinusBar -95 0 0
+SigmaCPlusPlus 84 0 0
+SigmaCMinusMinusBar -84 0 0
+SigmaStarCPlusPlus 94 0 0
+SigmaStarCMinusMinusBar -94 0 0
+XiCPlus 87 1 1
+XiCMinusBar -87 1 1
+OmegaC0 99 0 0
+OmegaC0Bar -99 0 0
+Jpsi 83 0 0
+#Unknown 0 0 0
diff --git a/Processes/Sibyll/testSibyll.cc b/Processes/Sibyll/testSibyll.cc
index 4c5bed4df1b42c351587569ed5a0b192f19f1f2d..67c950e5585f831f8a95ae4f0e00f59df95c8919 100644
--- a/Processes/Sibyll/testSibyll.cc
+++ b/Processes/Sibyll/testSibyll.cc
@@ -1,4 +1,14 @@
+/**
+ * (c) Copyright 2018 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/sibyll/ParticleConversion.h>
#include <corsika/units/PhysicalUnits.h>
@@ -7,21 +17,45 @@
// cpp file
#include <catch2/catch.hpp>
+#include <iostream>
+using namespace std;
using namespace corsika;
TEST_CASE("Sibyll", "[processes]") {
- SECTION("ParticleConversion") {
+ SECTION("Sibyll -> Corsika") {
REQUIRE(corsika::particles::Electron::GetCode() ==
- process::sibyll::Sibyll2Corsika.at(process::sibyll::PID::E_MINUS));
+ process::sibyll::ConvertFromSibyll(process::sibyll::SibyllCode::Electron));
}
- SECTION("Data") {
- REQUIRE(corsika::particles::GetName(process::sibyll::Sibyll2Corsika.at(
- process::sibyll::PID::E_PLUS)) == "e+");
+ SECTION("Corsika -> Sibyll") {
+ REQUIRE(process::sibyll::ConvertToSibyll(corsika::particles::Electron::GetCode()) ==
+ process::sibyll::SibyllCode::Electron);
+ REQUIRE(process::sibyll::ConvertToSibyllRaw(corsika::particles::Proton::GetCode()) ==
+ 13);
}
- SECTION("bla") {}
+ SECTION("KnownBySibyll") {
+ REQUIRE(process::sibyll::KnownBySibyll(corsika::particles::Electron::GetCode()));
+
+ REQUIRE_FALSE(
+ process::sibyll::KnownBySibyll(corsika::particles::XiPrimeC0::GetCode()));
+ }
+
+ SECTION("canInteractInSibyll") {
+
+ REQUIRE(process::sibyll::CanInteract(corsika::particles::Proton::GetCode()));
+ REQUIRE(process::sibyll::CanInteract(corsika::particles::Code::XiCPlus));
- SECTION("blubb") {}
+ REQUIRE_FALSE(process::sibyll::CanInteract(corsika::particles::Electron::GetCode()));
+ REQUIRE_FALSE(process::sibyll::CanInteract(corsika::particles::SigmaC0::GetCode()));
+ }
+
+ SECTION("cross-section type") {
+
+ REQUIRE(process::sibyll::GetSibyllXSCode(corsika::particles::Code::Electron) == 0);
+ REQUIRE(process::sibyll::GetSibyllXSCode(corsika::particles::Code::K0Long) == 3);
+ REQUIRE(process::sibyll::GetSibyllXSCode(corsika::particles::Code::SigmaPlus) == 1);
+ REQUIRE(process::sibyll::GetSibyllXSCode(corsika::particles::Code::PiMinus) == 2);
+ }
}
diff --git a/Processes/StackInspector/CMakeLists.txt b/Processes/StackInspector/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..b0b9d379e9b5b1c7536e1619e9c9e55f322b791c
--- /dev/null
+++ b/Processes/StackInspector/CMakeLists.txt
@@ -0,0 +1,61 @@
+
+set (
+ MODEL_SOURCES
+ StackInspector.cc
+ )
+
+set (
+ MODEL_HEADERS
+ StackInspector.h
+ )
+
+set (
+ MODEL_NAMESPACE
+ corsika/process/stack_inspector
+ )
+
+add_library (ProcessStackInspector STATIC ${MODEL_SOURCES})
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (ProcessStackInspector ${MODEL_NAMESPACE} ${MODEL_HEADERS})
+
+set_target_properties (
+ ProcessStackInspector
+ PROPERTIES
+ VERSION ${PROJECT_VERSION}
+ SOVERSION 1
+# PUBLIC_HEADER "${MODEL_HEADERS}"
+ )
+
+# target dependencies on other libraries (also the header onlys)
+target_link_libraries (
+ ProcessStackInspector
+ CORSIKAunits
+ CORSIKAsetup
+ )
+
+target_include_directories (
+ ProcessStackInspector
+ INTERFACE
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/include>
+ )
+
+install (
+ TARGETS ProcessStackInspector
+ LIBRARY DESTINATION lib
+ ARCHIVE DESTINATION lib
+# PUBLIC_HEADER DESTINATION include/${MODEL_NAMESPACE}
+ )
+
+
+# --------------------
+# code unit testing
+add_executable (testStackInspector testStackInspector.cc)
+
+target_link_libraries (
+ testStackInspector
+ CORSIKAunits
+ CORSIKAthirdparty # for catch2
+ )
+
+add_test (NAME testStackInspector COMMAND testStackInspector)
+
diff --git a/Processes/StackInspector/StackInspector.cc b/Processes/StackInspector/StackInspector.cc
new file mode 100644
index 0000000000000000000000000000000000000000..b0acefc4a86c72acba373feafc82b7434aa2b9a0
--- /dev/null
+++ b/Processes/StackInspector/StackInspector.cc
@@ -0,0 +1,68 @@
+
+/**
+ * (c) Copyright 2018 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/geometry/RootCoordinateSystem.h>
+#include <corsika/process/stack_inspector/StackInspector.h>
+#include <corsika/units/PhysicalUnits.h>
+
+#include <corsika/logging/Logger.h>
+
+#include <corsika/setup/SetupTrajectory.h>
+
+#include <iostream>
+using namespace std;
+
+using namespace corsika;
+using namespace corsika::units::si;
+using namespace corsika::process::stack_inspector;
+
+template <typename Stack>
+StackInspector<Stack>::StackInspector(const bool aReport)
+ : fReport(aReport) {}
+
+template <typename Stack>
+StackInspector<Stack>::~StackInspector() {}
+
+template <typename Stack>
+process::EProcessReturn StackInspector<Stack>::DoContinuous(Particle&, setup::Trajectory&,
+ Stack& s) const {
+ static int countStep = 0;
+ if (!fReport) return EProcessReturn::eOk;
+ [[maybe_unused]] int i = 0;
+ EnergyType Etot = 0_GeV;
+
+ for (auto& iterP : s) {
+ EnergyType E = iterP.GetEnergy();
+ Etot += E;
+ geometry::CoordinateSystem& rootCS =
+ geometry::RootCoordinateSystem::GetInstance().GetRootCS(); // for printout
+ auto pos = iterP.GetPosition().GetCoordinates(rootCS);
+ cout << "StackInspector: i=" << setw(5) << fixed << (i++) << ", id=" << setw(30)
+ << iterP.GetPID() << " E=" << setw(15) << scientific << (E / 1_GeV) << " GeV, "
+ << " pos=" << pos << endl;
+ }
+ countStep++;
+ cout << "StackInspector: nStep=" << countStep << " stackSize=" << s.GetSize()
+ << " Estack=" << Etot / 1_GeV << " GeV" << endl;
+ return EProcessReturn::eOk;
+}
+
+template <typename Stack>
+void StackInspector<Stack>::MinStepLength(Particle&, setup::Trajectory&) const {
+ // return 0;
+}
+
+template <typename Stack>
+void StackInspector<Stack>::Init() {}
+
+#include <corsika/setup/SetupStack.h>
+
+template class process::stack_inspector::StackInspector<setup::Stack>;
diff --git a/Processes/StackInspector/StackInspector.h b/Processes/StackInspector/StackInspector.h
new file mode 100644
index 0000000000000000000000000000000000000000..e40517499d7c07b984c5d9b30caac469269cf649
--- /dev/null
+++ b/Processes/StackInspector/StackInspector.h
@@ -0,0 +1,50 @@
+
+/**
+ * (c) Copyright 2018 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 _Physics_StackInspector_StackInspector_h_
+#define _Physics_StackInspector_StackInspector_h_
+
+#include <corsika/process/ContinuousProcess.h>
+
+#include <corsika/setup/SetupTrajectory.h>
+
+
+namespace corsika::process {
+
+ namespace stack_inspector {
+
+ template <typename Stack>
+ class StackInspector
+ : public corsika::process::ContinuousProcess<StackInspector<Stack>> {
+
+ typedef typename Stack::ParticleType Particle;
+
+ public:
+ StackInspector(const bool aReport);
+ ~StackInspector();
+
+ void Init();
+
+ // template <typename Particle, typename Trajectory, typename Stack>
+ EProcessReturn DoContinuous(Particle&, corsika::setup::Trajectory&, Stack& s) const;
+
+ // template <typename Particle>
+ void MinStepLength(Particle&, corsika::setup::Trajectory&) const;
+
+ private:
+ bool fReport;
+ };
+
+ } // namespace stack_inspector
+
+} // namespace corsika::process
+
+#endif
diff --git a/Processes/StackInspector/testStackInspector.cc b/Processes/StackInspector/testStackInspector.cc
new file mode 100644
index 0000000000000000000000000000000000000000..c098b025b678427f1e244fc8052d0dd889f11d08
--- /dev/null
+++ b/Processes/StackInspector/testStackInspector.cc
@@ -0,0 +1,23 @@
+
+/**
+ * (c) Copyright 2018 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.
+ */
+
+#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
+ // cpp file
+#include <catch2/catch.hpp>
+
+#include <corsika/units/PhysicalUnits.h>
+
+TEST_CASE("NullModel", "[processes]") {
+
+ SECTION("bla") {}
+
+ SECTION("blubb") {}
+}
diff --git a/Processes/TrackingLine/CMakeLists.txt b/Processes/TrackingLine/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..2911c9b787787f43ba837e64fd67c89921c699b0
--- /dev/null
+++ b/Processes/TrackingLine/CMakeLists.txt
@@ -0,0 +1,38 @@
+
+set (
+ MODEL_HEADERS
+ TrackingLine.h
+ )
+
+set (
+ MODEL_NAMESPACE
+ corsika/process/tracking_line
+ )
+
+add_library (ProcessTrackingLine INTERFACE)
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (ProcessTrackingLine ${MODEL_NAMESPACE} ${MODEL_HEADERS})
+
+
+target_include_directories (
+ ProcessTrackingLine
+ INTERFACE
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/include>
+ )
+
+install (FILES ${MODEL_HEADERS} DESTINATION include/${MODEL_NAMESPACE})
+
+
+
+# # --------------------
+# # code unit testing
+# add_executable (testStackInspector testStackInspector.cc)
+
+# target_link_libraries (
+# testStackInspector
+# CORSIKAunits
+# CORSIKAthirdparty # for catch2
+# )
+
+# add_test (NAME testStackInspector COMMAND testStackInspector)
+
diff --git a/Processes/TrackingLine/TrackingLine.h b/Processes/TrackingLine/TrackingLine.h
new file mode 100644
index 0000000000000000000000000000000000000000..602d5473269c8e15561967fe9adc8b16ff4dfa0c
--- /dev/null
+++ b/Processes/TrackingLine/TrackingLine.h
@@ -0,0 +1,35 @@
+#ifndef _include_corsika_processes_TrackinLine_h_
+#define _include_corsika_processes_TrackinLine_h_
+
+#include <corsika/geometry/Vector.h>
+#include <corsika/geometry/Point.h>
+
+#include <corsika/units/PhysicalUnits.h>
+
+#include <corsika/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+
+using namespace corsika;
+
+namespace corsika::process {
+
+ namespace tracking_line {
+
+ template <typename Stack>
+ class TrackingLine { // Newton-step, naja.. not yet
+ typedef typename Stack::ParticleType Particle;
+
+ public:
+ void Init() {}
+ setup::Trajectory GetTrack(Particle& p) {
+ geometry::Vector<SpeedType::dimension_type> v = p.GetDirection();
+ geometry::Line traj(p.GetPosition(), v);
+ return geometry::Trajectory<corsika::geometry::Line>(traj, 100_ns);
+ }
+ };
+
+ } // namespace stack_inspector
+
+} // namespace corsika::process
+
+#endif
diff --git a/README.md b/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..a419aea4e835db375fe7293746c9b218aaea22c5
--- /dev/null
+++ b/README.md
@@ -0,0 +1,53 @@
+# CORSIKA8 Framework for Particle Cascades in Astroparticle Physics**
+
+Documentation and reference guide for the CORSIKA8 software framework
+for air shower simulations. We aim that CORSIKA remains the most comprehensive
+framework for simulating particle cascades with stochastic and continuous processes. The purpose of CORSIKA is to
+simulate any particle cascades in astroparticle physics or astrophysical context. A lot of emphasis is put on modularity, completeness, validation and correctness. To boost computational efficiency different techniques are
+provided, like thinning or cascade equations.
+
+The software makes extensive use of static design patterns and
+compiler optimization. Thus, the most fundamental configuration
+decision of the user must be performed at compile time. At run time
+only specific model parameters can still be changed.
+
+CORSIKA8 is released under the GPL3 license. See [license file](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika/blob/master/LICENSE) which is part of every release and the source code.
+
+When you contribute to CORSIKA check the guidelines outlined here:
+[coding guidelines](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika/blob/master/GUIDELINES.md). Code that fail the review by the CORSIKA author group must be improved before it can be merged in the official code base. After your code has been accepted and merged you become a contributor of the CORSIKA project and you should include yourself in the [AUTHORS](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika/blob/master/AUTHORS) file.
+
+You need to read and agree to the [collaboration agreement](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika/blob/master/COLLABORATION_AGREEMENT.md). The agreement can be discussed, and eventually improved.
+
+We also want to point you to the [MCnet guidelines](https://gitlab.ikp.kit.edu/AirShowerPhysics/corsika/blob/master/MCNET_GUIDELINES), which are very useful also for us.
+
+## Installation
+
+Prerequisites: eigen3, boost, cmake, g++, git. On Ubuntu 18.04, just do:
+```
+sudo apt-get install libeigen3-dev libboost-dev cmake g++ git
+```
+
+Follow these steps to download and install CORSIKA8-milestone1
+```
+git clone git@gitlab.ikp.kit.edu:AirShowerPhysics/corsika.git
+cd corsika
+git checkout milestone1
+mkdir ../corsika-build
+cd ../corsika-build
+cmake ../corsika -DCMAKE_INSTALL_PREFIX=../corsika-install
+make -j8
+make install
+make test
+```
+and if you want to see how the Heitler model works and is implemented, see `Framework/Cascade/testCascade.cc` for a starting point.
+
+### Generating doxygen documentation
+
+To generate the documentation, you need doxygen and graphviz. On Ubuntu 18.04, do:
+```
+sudo apt-get install doxygen graphviz
+```
+Switch to the corsika build directory and do
+```
+make doxygen
+```
diff --git a/SCIENTIFIC_AUTHORS b/SCIENTIFIC_AUTHORS
new file mode 100644
index 0000000000000000000000000000000000000000..2e7676f3785ea1388b14abc71b9298e810c4cca3
--- /dev/null
+++ b/SCIENTIFIC_AUTHORS
@@ -0,0 +1,2 @@
+(empty...tbd)
+
diff --git a/Setup/CMakeLists.txt b/Setup/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..2f9a4ddf36a57d5f73d523fa5771ee17193a83bd
--- /dev/null
+++ b/Setup/CMakeLists.txt
@@ -0,0 +1,35 @@
+
+set (
+ SETUP_HEADERS
+ SetupStack.h
+ SetupLogger.h
+ SetupEnvironment.h
+ SetupTrajectory.h
+ )
+
+set (
+ SETUP_NAMESPACE
+ corsika/setup
+ )
+
+add_library (CORSIKAsetup INTERFACE)
+CORSIKA_COPY_HEADERS_TO_NAMESPACE (CORSIKAsetup ${SETUP_NAMESPACE} ${SETUP_HEADERS})
+
+target_link_libraries (
+ CORSIKAsetup
+ INTERFACE
+ CORSIKAgeometry
+ SuperStupidStack
+ )
+
+target_include_directories (
+ CORSIKAsetup
+ INTERFACE
+ $<BUILD_INTERFACE:${PROJECT_BINARY_DIR}/include>
+ $<INSTALL_INTERFACE:include/include>
+ )
+
+install (
+ FILES ${SETUP_HEADERS}
+ DESTINATION include/${SETUP_NAMESPACE}
+ )
diff --git a/Setup/SetupEnvironment.h b/Setup/SetupEnvironment.h
new file mode 100644
index 0000000000000000000000000000000000000000..1beb2748052770fc25b84991fdf3e651744c3dc8
--- /dev/null
+++ b/Setup/SetupEnvironment.h
@@ -0,0 +1,17 @@
+
+/**
+ * (c) Copyright 2018 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_corsika_setup_environment_h_
+#define _include_corsika_setup_environment_h_
+
+namespace corsika {}
+
+#endif
diff --git a/Setup/SetupLogger.h b/Setup/SetupLogger.h
new file mode 100644
index 0000000000000000000000000000000000000000..2760bc7623fd244f38647d03e956e06ba39e84cd
--- /dev/null
+++ b/Setup/SetupLogger.h
@@ -0,0 +1,17 @@
+
+/**
+ * (c) Copyright 2018 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_corsika_setup_logger_h_
+#define _include_corsika_setup_logger_h_
+
+namespace corsika {}
+
+#endif
diff --git a/Setup/SetupStack.h b/Setup/SetupStack.h
new file mode 100644
index 0000000000000000000000000000000000000000..053d485f9e2352112f8c3db9dddfeba6bee775bf
--- /dev/null
+++ b/Setup/SetupStack.h
@@ -0,0 +1,22 @@
+
+/**
+ * (c) Copyright 2018 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_setup_setupstack_h_
+#define _corsika_setup_setupstack_h_
+
+#include <corsika/stack/super_stupid/SuperStupidStack.h>
+
+namespace corsika::setup {
+
+ typedef corsika::stack::super_stupid::SuperStupidStack Stack;
+}
+
+#endif
diff --git a/Setup/SetupTrajectory.h b/Setup/SetupTrajectory.h
new file mode 100644
index 0000000000000000000000000000000000000000..f1dfd497a6bec31eeb9e4d84967a8b80f380ebb0
--- /dev/null
+++ b/Setup/SetupTrajectory.h
@@ -0,0 +1,64 @@
+
+/**
+ * (c) Copyright 2018 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_setup_setuptrajectory_h_
+#define _corsika_setup_setuptrajectory_h_
+
+#include <corsika/geometry/Helix.h>
+#include <corsika/geometry/Line.h>
+#include <corsika/geometry/Trajectory.h>
+
+#include <corsika/units/PhysicalUnits.h>
+
+#include <variant>
+
+namespace corsika::setup {
+
+ using corsika::geometry::Helix;
+ using corsika::geometry::Line;
+
+ /// definition of Trajectory base class, to be used in tracking and cascades
+ typedef std::variant<std::monostate, corsika::geometry::Trajectory<Line>,
+ corsika::geometry::Trajectory<Helix>>
+ Trajectory;
+
+ /// helper visitor to modify Particle by moving along Trajectory
+ template <typename Particle>
+ class ParticleUpdate {
+
+ Particle& fP;
+
+ public:
+ ParticleUpdate(Particle& p)
+ : fP(p) {}
+ void operator()(std::monostate const&) {}
+
+ template <typename T>
+ void operator()(T const& trajectory) {
+ fP.SetPosition(trajectory.GetPosition(1));
+ }
+ };
+
+ /// helper visitor to modify Particle by moving along Trajectory
+ class GetDuration {
+ public:
+ corsika::units::si::TimeType operator()(std::monostate const&) {
+ return 0 * corsika::units::si::second;
+ }
+ template <typename T>
+ corsika::units::si::TimeType operator()(T const& trajectory) {
+ return trajectory.GetDuration();
+ }
+ };
+
+} // namespace corsika::setup
+
+#endif
diff --git a/Stack/DummyStack/DummyStack.h b/Stack/DummyStack/DummyStack.h
index 8dd528a7e1f7a1fa9fe35f0ac6373f3a881727db..63b84bf30e4c03a80de512a78c1cb0677d95f7b9 100644
--- a/Stack/DummyStack/DummyStack.h
+++ b/Stack/DummyStack/DummyStack.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_dummystack_h_
#define _include_dummystack_h_
diff --git a/Stack/DummyStack/SuperStupidStack.h b/Stack/DummyStack/SuperStupidStack.h
index c1b9215d08c96d6c5f3ca5923718bd64df9ff12a..47647e2c397ba8c7aab7ecda35cb05a700516176 100644
--- a/Stack/DummyStack/SuperStupidStack.h
+++ b/Stack/DummyStack/SuperStupidStack.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_superstupidstack_h_
#define _include_superstupidstack_h_
diff --git a/Stack/SuperStupidStack/CMakeLists.txt b/Stack/SuperStupidStack/CMakeLists.txt
index 6b00c993c4c712a4a2107ebd1539d21431da1752..b9634f1d1bc523089dd4e90cb7caeaefe024480c 100644
--- a/Stack/SuperStupidStack/CMakeLists.txt
+++ b/Stack/SuperStupidStack/CMakeLists.txt
@@ -12,6 +12,7 @@ target_link_libraries (
CORSIKAstackinterface
CORSIKAunits
CORSIKAparticles
+ CORSIKAgeometry
)
target_include_directories (
@@ -27,3 +28,24 @@ install (
DESTINATION
include/${SuperStupidStack_NAMESPACE}
)
+
+# ----------------
+# code unit testing
+add_executable (
+ testSuperStupidStack
+ testSuperStupidStack.cc
+ )
+
+target_link_libraries (
+ testSuperStupidStack
+# CORSIKAutls
+ ProcessStackInspector
+ CORSIKAgeometry
+ CORSIKAunits
+ CORSIKAthirdparty # for catch2
+ )
+
+add_test (
+ NAME testSuperStupidStack
+ COMMAND testSuperStupidStack
+ )
diff --git a/Stack/SuperStupidStack/SuperStupidStack.h b/Stack/SuperStupidStack/SuperStupidStack.h
index a09fe930f5546f807e282376a1afd7ef776b6fc1..064edffa2c4497743cfd4a5e5ef2caca6c86860a 100644
--- a/Stack/SuperStupidStack/SuperStupidStack.h
+++ b/Stack/SuperStupidStack/SuperStupidStack.h
@@ -1,3 +1,14 @@
+
+/**
+ * (c) Copyright 2018 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_superstupidstack_h_
#define _include_superstupidstack_h_
@@ -5,15 +16,33 @@
#include <corsika/stack/Stack.h>
#include <corsika/units/PhysicalUnits.h>
+#include <corsika/geometry/Point.h>
+#include <corsika/geometry/RootCoordinateSystem.h> // remove
+#include <corsika/geometry/Vector.h>
+
+#include <algorithm>
#include <vector>
+using namespace corsika;
+
namespace corsika::stack {
namespace super_stupid {
+ using corsika::geometry::Point;
+ using corsika::geometry::Vector;
using corsika::particles::Code;
+ using corsika::units::si::energy_d;
using corsika::units::si::EnergyType;
- using corsika::units::si::operator""_GeV; // literals;
+ using corsika::units::si::joule;
+ using corsika::units::si::meter;
+ using corsika::units::si::momentum_d;
+ using corsika::units::si::newton_second;
+ using corsika::units::si::second;
+ using corsika::units::si::SpeedType;
+ using corsika::units::si::TimeType;
+
+ typedef Vector<momentum_d> MomentumVector;
/**
* Example of a particle object on the stack.
@@ -28,9 +57,25 @@ namespace corsika::stack {
public:
void SetPID(const Code id) { GetStackData().SetPID(GetIndex(), id); }
void SetEnergy(const EnergyType& e) { GetStackData().SetEnergy(GetIndex(), e); }
+ void SetMomentum(const MomentumVector& v) {
+ GetStackData().SetMomentum(GetIndex(), v);
+ }
+ void SetPosition(const Point& v) { GetStackData().SetPosition(GetIndex(), v); }
+ void SetTime(const TimeType& v) { GetStackData().SetTime(GetIndex(), v); }
Code GetPID() const { return GetStackData().GetPID(GetIndex()); }
EnergyType GetEnergy() const { return GetStackData().GetEnergy(GetIndex()); }
+ MomentumVector GetMomentum() const {
+ return GetStackData().GetMomentum(GetIndex());
+ }
+ Point GetPosition() const { return GetStackData().GetPosition(GetIndex()); }
+ TimeType GetTime() const { return GetStackData().GetTime(GetIndex()); }
+
+#warning this does not really work, nor make sense:
+ Vector<SpeedType::dimension_type> GetDirection() const {
+ auto P = GetMomentum();
+ return P / P.norm() * 1e10 * (units::si::meter / units::si::second);
+ }
};
/**
@@ -53,39 +98,57 @@ namespace corsika::stack {
void SetPID(const int i, const Code id) { fDataPID[i] = id; }
void SetEnergy(const int i, const EnergyType e) { fDataE[i] = e; }
+ void SetMomentum(const int i, const MomentumVector& v) { fMomentum[i] = v; }
+ void SetPosition(const int i, const Point& v) { fPosition[i] = v; }
+ void SetTime(const int i, const TimeType& v) { fTime[i] = v; }
Code GetPID(const int i) const { return fDataPID[i]; }
EnergyType GetEnergy(const int i) const { return fDataE[i]; }
+ MomentumVector GetMomentum(const int i) const { return fMomentum[i]; }
+ Point GetPosition(const int i) const { return fPosition[i]; }
+ TimeType GetTime(const int i) const { return fTime[i]; }
/**
* Function to copy particle at location i2 in stack to i1
*/
void Copy(const int i1, const int i2) {
- fDataE[i2] = fDataE[i1];
fDataPID[i2] = fDataPID[i1];
+ fDataE[i2] = fDataE[i1];
+ fMomentum[i2] = fMomentum[i1];
+ fPosition[i2] = fPosition[i1];
+ fTime[i2] = fTime[i1];
}
/**
* Function to copy particle at location i2 in stack to i1
*/
void Swap(const int i1, const int i2) {
- EnergyType tE = fDataE[i2];
- Code tC = fDataPID[i2];
- fDataE[i2] = fDataE[i1];
- fDataPID[i2] = fDataPID[i1];
- fDataE[i1] = tE;
- fDataPID[i1] = tC;
+ std::swap(fDataPID[i2], fDataPID[i1]);
+ std::swap(fDataE[i2], fDataE[i1]);
+ std::swap(fMomentum[i2], fMomentum[i1]); // should be Momentum !!!!
+ std::swap(fPosition[i2], fPosition[i1]);
+ std::swap(fTime[i2], fTime[i1]);
}
protected:
void IncrementSize() {
- fDataE.push_back(0_GeV);
- fDataPID.push_back(Code::unknown);
+ fDataPID.push_back(Code::Unknown);
+ fDataE.push_back(0 * joule);
+#warning this here makes no sense: see issue #48
+ geometry::CoordinateSystem& dummyCS =
+ geometry::RootCoordinateSystem::GetInstance().GetRootCS();
+ fMomentum.push_back(MomentumVector(
+ dummyCS, {0 * newton_second, 0 * newton_second, 0 * newton_second}));
+ fPosition.push_back(Point(dummyCS, {0 * meter, 0 * meter, 0 * meter}));
+ fTime.push_back(0 * second);
}
void DecrementSize() {
if (fDataE.size() > 0) {
- fDataE.pop_back();
fDataPID.pop_back();
+ fDataE.pop_back();
+ fMomentum.pop_back();
+ fPosition.pop_back();
+ fTime.pop_back();
}
}
@@ -94,6 +157,9 @@ namespace corsika::stack {
std::vector<Code> fDataPID;
std::vector<EnergyType> fDataE;
+ std::vector<MomentumVector> fMomentum;
+ std::vector<Point> fPosition;
+ std::vector<TimeType> fTime;
}; // end class SuperStupidStackImpl
diff --git a/Stack/SuperStupidStack/testSuperStupidStack.cc b/Stack/SuperStupidStack/testSuperStupidStack.cc
new file mode 100644
index 0000000000000000000000000000000000000000..28cb891bdc8dfead5e3b04e8113d46f7bc127108
--- /dev/null
+++ b/Stack/SuperStupidStack/testSuperStupidStack.cc
@@ -0,0 +1,67 @@
+
+/**
+ * (c) Copyright 2018 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/geometry/RootCoordinateSystem.h>
+#include <corsika/stack/super_stupid/SuperStupidStack.h>
+#include <corsika/units/PhysicalUnits.h>
+
+using namespace corsika::geometry;
+using namespace corsika::units::si;
+
+#define CATCH_CONFIG_MAIN // This tells Catch to provide a main() - only do this in one
+ // cpp file
+#include <catch2/catch.hpp>
+
+using namespace corsika;
+using namespace corsika::stack::super_stupid;
+
+#include <iostream>
+using namespace std;
+
+TEST_CASE("SuperStupidStack", "[stack]") {
+
+ SECTION("read+write") {
+
+ SuperStupidStack s;
+ auto p = s.NewParticle();
+ p.SetPID(particles::Code::Electron);
+ p.SetEnergy(1.5_GeV);
+ geometry::CoordinateSystem& dummyCS =
+ geometry::RootCoordinateSystem::GetInstance().GetRootCS();
+ p.SetMomentum(MomentumVector(
+ dummyCS, {1 * newton_second, 1 * newton_second, 1 * newton_second}));
+ p.SetPosition(Point(dummyCS, {1 * meter, 1 * meter, 1 * meter}));
+ p.SetTime(100_s);
+
+ // read
+ REQUIRE(s.GetSize() == 1);
+ auto pout = s.GetNextParticle();
+ REQUIRE(pout.GetPID() == particles::Code::Electron);
+ REQUIRE(pout.GetEnergy() == 1.5_GeV);
+#warning Fix the next two lines:
+ // REQUIRE(pout.GetMomentum() == MomentumVector(dummyCS, {1 * joule, 1 * joule, 1 *
+ // joule})); REQUIRE(pout.GetPosition() == Point(dummyCS, {1 * meter, 1 * meter, 1 *
+ // meter}));
+ REQUIRE(pout.GetTime() == 100_s);
+ }
+
+ SECTION("write+delete") {
+
+ SuperStupidStack s;
+ for (int i = 0; i < 99; ++i) s.NewParticle();
+
+ REQUIRE(s.GetSize() == 99);
+
+ for (int i = 0; i < 99; ++i) s.GetNextParticle().Delete();
+
+ REQUIRE(s.GetSize() == 0);
+ }
+}
diff --git a/ThirdParty/CMakeLists.txt b/ThirdParty/CMakeLists.txt
index c7f90c5b9bdb6ad21d4f918e22a8f973abd838eb..fb6c08fce7c2fcc869b9c51853db0b0388ca5613 100644
--- a/ThirdParty/CMakeLists.txt
+++ b/ThirdParty/CMakeLists.txt
@@ -9,3 +9,4 @@ target_include_directories (CORSIKAthirdparty SYSTEM
install (DIRECTORY phys DESTINATION include/ThirdParty/)
install (DIRECTORY catch2 DESTINATION include/ThirdParty/)
+install (DIRECTORY bitset2 DESTINATION include/ThirdParty/)
diff --git a/ThirdParty/ThirdParty.dox b/ThirdParty/ThirdParty.dox
index ec0e3de3826ccab8b9685df1b54c357e86957cfc..a7e46398fad57d563726578dd734677320785c67 100644
--- a/ThirdParty/ThirdParty.dox
+++ b/ThirdParty/ThirdParty.dox
@@ -10,23 +10,32 @@ the individual copyrights and licences here!
@section PhysUnits
The PhysUnits library is an external dependency included here just for
-convenience:
+convenience:
-Original source code from: https://github.com/martinmoene/PhysUnits-CT-Cpp11#references
+Original source code from:
+https://github.com/martinmoene/PhysUnits-CT-Cpp11#references
-Licence: BSL-1.0 (https://github.com/martinmoene/PhysUnits-CT-Cpp11/blob/master/LICENSE_1_0.txt)
+Licence: BSL-1.0
+(https://github.com/martinmoene/PhysUnits-CT-Cpp11/blob/master/LICENSE_1_0.txt)
References: https://github.com/martinmoene/PhysUnits-CT-Cpp11#references
@section catch2
-The catch2 unit testing library is from: https://github.com/catchorg/Catch2
-Licence: BSL-1.0 (https://github.com/martinmoene/PhysUnits-CT-Cpp11/blob/master/LICENSE_1_0.txt)
+The catch2 unit testing library is from:
+https://github.com/catchorg/Catch2 Licence: BSL-1.0
+(https://github.com/martinmoene/PhysUnits-CT-Cpp11/blob/master/LICENSE_1_0.txt)
References: https://github.com/catchorg/Catch2
@section eigen3
eigen3 ....
+@section bitset2
+
+see https://github.com/ClaasBontus/bitset2, this package was obtained
+from a Boost Software License 1.0.
+
+
*/
diff --git a/ThirdParty/bitset2/LICENSE.txt b/ThirdParty/bitset2/LICENSE.txt
new file mode 100644
index 0000000000000000000000000000000000000000..36b7cd93cdfbac762f5be4c6ce276df2ea6305c2
--- /dev/null
+++ b/ThirdParty/bitset2/LICENSE.txt
@@ -0,0 +1,23 @@
+Boost Software License - Version 1.0 - August 17th, 2003
+
+Permission is hereby granted, free of charge, to any person or organization
+obtaining a copy of the software and accompanying documentation covered by
+this license (the "Software") to use, reproduce, display, distribute,
+execute, and transmit the Software, and to prepare derivative works of the
+Software, and to permit third-parties to whom the Software is furnished to
+do so, all subject to the following:
+
+The copyright notices in the Software and this entire statement, including
+the above license grant, this restriction and the following disclaimer,
+must be included in all copies of the Software, in whole or in part, and
+all derivative works of the Software, unless such copies or derivative
+works are solely in the form of machine-executable object code generated by
+a source language processor.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
+SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
+FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
diff --git a/ThirdParty/bitset2/README.md b/ThirdParty/bitset2/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..5e7f2f9e83cf2034030d0f7ff4761c13fbaff86f
--- /dev/null
+++ b/ThirdParty/bitset2/README.md
@@ -0,0 +1,232 @@
+# bitset2: bitset improved
+
+|Note|
+|----|
+|This version of bitset2 is for C++17. For C++14 checkout the corresponding [branch](https://github.com/ClaasBontus/bitset2/tree/cpp14).|
+
+Bitset2::bitset2 is a header only library. It provides the same functionality as [std::bitset](http://en.cppreference.com/w/cpp/utility/bitset) with the
+following extentions/changes.
+
+
+Focus was set on having as many functions
+implemented as [constexpr](http://en.cppreference.com/w/cpp/language/constexpr)
+as possible. Moreover a second template parameter (with appropriate default)
+allows control of the underlying data structure (see below).
+* Copy and move constructors are specified constexpr.
+* Additional constexpr constructor `bitset2( std::array<T,N> const & )`, where `T` needs not necessarily be equal to `base_t`. `T` has to be an unsigned integral type.
+* Conversion from and to `std::bitset`.
+* Operators implemented as constexpr are `~`, `==`, `!=`, `|`, `&`, `^`, `<<` (shift left), `>>` (shift right), `[]` (bit access).
+* Non-const operators implemented as constexpr are `<<=`, `>>=`, `|=`, `&=`, `^=`
+* Functions implemented as constexpr are `test`, `none`, `any`, `all`, `count`, `to_ulong`, `to_ullong`.
+* Non-const functions implemented as constexpr are `set`, `reset`, `flip`.
+* Additional constexpr operator `+` for adding two bitset2 objects.
+* Additional constexpr operators `++`, `--`, `+=`.
+* Additional constexpr operators `<`, `>`, `<=`, `>=`.
+* Additional constexpr functions `rotate_left` and `rotate_right` for binary rotations.
+* Additional constexpr member functions `rotate_left` and `rotate_right`.
+* Additional member function `to_hex_string()` (see below).
+* Additional constexpr member function `test_set( size_t bit, bool value= true )`, which sets or clears the specified bit and returns its previous state. Throws `out_of_range` if bit >= N.
+* Additional constexpr function `difference`, which computes the set difference (`bs1 & ~bs2`) of two bitset2 objects.
+* Additional constexpr member function `difference`.
+* Additional constexpr member functions `find_first()` and `find_next(size_t)` returning the index of the first (next) bit set. Returning npos if all (remaining) bits are false.
+* Additional constexpr function `complement2(bs)` computing the [two's complement](https://en.wikipedia.org/wiki/Two%27s_complement) (~bs +1).
+* Additional constexpr member function `complement2`.
+* Additional constexpr function `reverse`, which returns argument with bits reversed.
+* Additional constexpr member function `reverse`.
+* Additional constexpr function `convert_to<n>` for converting an *m*-bit bitset2 into an *n*-bit bitset2.
+* Additional constexpr function `convert_to<n,T>` for converting an *m*-bit bitset2 into an *n*-bit bitset2 with `base_t=T`.
+* Constexpr member function `data()` gives read access to the underlying `array<base_t,N>`. Here element with index zero is the least significant word.
+* Additional constexpr functions `zip_fold_and` and `zip_fold_or`. See below for details.
+
+## Examples
+```.cpp
+#include <iostream>
+#include <array>
+#include <cassert>
+#include "bitset2.hpp"
+
+template<size_t n_bits>
+using BS2= Bitset2::bitset2<n_bits>;
+
+int main()
+{
+ using bs_128= BS2<128>;
+ using base_t_128= bs_128::base_t;
+ constexpr std::array<base_t_128,2>
+ ar1{{ ~(base_t_128(0)), base_t_128(0xFEDCBA) }};
+ constexpr bs_128 b1{ ar1 };
+ constexpr auto b1_add= b1 + b1;
+ constexpr auto b1_shft= b1 << 1; // binary shift
+ static_assert( b1_add == b1_shft, "" );
+
+ std::cout << b1.to_hex_string() // 0000000000fedcbaffffffffffffffff
+ << "\n"
+ << b1_add.to_hex_string() // 0000000001fdb975fffffffffffffffe
+ << "\n";
+
+ BS2<12> b2;
+ for( size_t c= 0; c < 12; c += 2 ) b2[c]= true;
+ auto b3= ~b2;
+ std::cout << b2 << "\n"; // 010101010101
+ std::cout << b2.flip() << "\n"; // 101010101010
+ assert( b2 == b3 );
+
+ BS2<7> const b4{ "1110000" };
+ auto const b5= Bitset2::rotate_left( b4, 3 );
+ std::cout << b4 << "\n" // 1110000
+ << b5 << "\n"; // 0000111
+
+ BS2<7> b6{ "1010010" };
+ b6.reverse();
+ std::cout << b6 << "\n"; // 0100101
+}
+```
+
+The following example illustrates how
+[non-const constexpr](https://stackoverflow.com/q/43592862/3876684)
+operators and functions are useful for writing constexpr functions.
+It converts between [gray](https://en.wikipedia.org/wiki/Gray_code)
+and binary coding.
+
+```.cpp
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+binary_to_gray( Bitset2::bitset2<N,T> const &bs )
+{ return bs ^ (bs >> 1); }
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+gray_to_binary( Bitset2::bitset2<N,T> bs )
+{
+ Bitset2::bitset2<N,T> mask= bs >> 1;
+ for( ; !mask.none(); mask >>= 1 ) bs ^= mask;
+ return bs;
+} // gray_to_binary
+
+int main()
+{
+ using ULLONG= unsigned long long;
+ constexpr std::array<ULLONG,2> arr_01a{{ 0xFEFDFCFBFAF9F8F7ull, 1ull }};
+ constexpr Bitset2::bitset2<129> bs_01a{ arr_01a };
+ constexpr auto gray_01a= binary_to_gray( bs_01a );
+ constexpr auto bin_01a= gray_to_binary( gray_01a );
+
+ static_assert( bs_01a == bin_01a, "" );
+}
+```
+
+## Template parameters and underlying data type
+`bitset2` is declared as
+```.cpp
+template< size_t N, class T >
+class bitset2;
+```
+`N` is the number of bits and `T` has to be an unsigned
+[integral type](http://en.cppreference.com/w/cpp/types/is_integral). Data
+represented by `bitset2` objects are stored in elements of type
+`std::array<T,n_array>`.
+
+`T` defaults
+to `uint8_t`, `uint16_t`, or `uint32_t` if `N` bits fit into these integers
+(and the type is supported by the system).
+`T` defaults to `unsigned long long` otherwise. The following aliases and
+constants are public within `bitset2`:
+* `using base_t= T;`
+* `size_t n_array;` Number of words in underlying array
+* `using array_t= std::array<T,n_array>;` Underlying data type
+
+## to_hex_string
+Function `to_hex_string` takes - as an optional argument - an element of type
+`hex_params`, which is defined as
+```.cpp
+template< class CharT = char,
+ class Traits = std::char_traits<CharT>,
+ class Allocator = std::allocator<CharT> >
+struct hex_params
+{
+ using str_t= std::basic_string<CharT,Traits,Allocator>;
+
+ CharT zeroCh= CharT( '0' );
+ CharT aCh= CharT( 'a' );
+ bool leadingZeroes= true;
+ bool nonEmpty= true;
+ str_t prefix;
+};
+```
+It allows fine tuning the outcome of the function. In the following
+examples the output is shown in the comments.
+```.cpp
+bitset2<16> b16_a( "0000101000011111" );
+bitset2<16> b16_b;
+std::cout
+ << b16_a.to_hex_string() << '\n' // 0a1f
+ << b16_a.to_hex_string( hex_params<>{'0', 'A', false, true, "0x"}) // 0xA1F
+ << '\n'
+ << b16_b.to_hex_string() << '\n' // 0000
+ << b16_b.to_hex_string( hex_params<>{'0', 'a', false, false, "0X"}) // 0X
+ << '\n';
+```
+
+## zip\_fold\_*
+Functions `zip_fold_and(bs1,bs2,f)` and `zip_fold_or(bs1,bs2,f)` expect two
+variables of type `bitset2` and a functional object `f`.
+The latter must accept two variables of type `base_t` and return a `bool`.
+`zip_fold_*` are mapped over the underlying
+`std::array<base_t,n>`s. They will
+[short-circuit](http://en.cppreference.com/w/cpp/language/operator_logical)
+if possible, which can result in performance advantages.
+`zip_fold_and` returns `true` if `f`
+returns `true` for each pair of `base_t`s, while `zip_fold_or` returns `true`
+if `f` returns `true` for at least one pair of `base_t`s.
+In other words `zip_fold_and` and `zip_fold_or` are similar to
+[`std::inner_product(...,BinOp1 op1,BinOp2 op2)`](http://en.cppreference.com/w/cpp/algorithm/inner_product)
+with `op1` set to `&&` and `||`, resp.
+
+For instance `is_subset_of` as proposed in [p0125r0](http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2015/p0125r0.html)
+can be implemented as follows.
+```.cpp
+template<size_t N,class T>
+constexpr
+bool
+is_subset_of( Bitset2::bitset2<N,T> const &bs1,
+ Bitset2::bitset2<N,T> const &bs2 ) noexcept
+{
+ using base_t= T;
+ return Bitset2::zip_fold_and( bs1, bs2,
+ []( base_t v1, base_t v2 ) noexcept
+ // Any bit unset in v2 must not be set in v1
+ { return (v1 & ~v2) == 0; } );
+}
+
+constexpr Bitset2::bitset2<7> b7_a( 0b1000101ull );
+constexpr Bitset2::bitset2<7> b7_b( 0b1010101ull );
+static_assert( is_subset_of( b7_a, b7_b), "" );
+```
+
+Similarly an `unequal` function can be defined as
+```.cpp
+template<size_t N,class T>
+bool
+unequal( Bitset2::bitset2<N,T> const &bs1, Bitset2::bitset2<N,T> const &bs2 )
+{
+ using base_t= T;
+ return Bitset2::zip_fold_or( bs1, bs2,
+ []( base_t v1, base_t v2 ) noexcept
+ { return v1 != v2; } );
+}
+```
+
+## Trivia
+The following code shows a counter based on a 128-bit integer. If the
+counter gets incremented once at each nanosecond, you have to wait for
+overflow for *only* [1.078 * 10<sup>22</sup> years](http://www.wolframalpha.com/input/?i=2%5E128+nanoseconds).
+```.cpp
+Bitset2::bitset2<128> c;
+for( ;; ++c ) {}
+```
+
+## Caveats
+* bitset2 requires a C++17 compliant compiler.
+* Tested with gcc 7 and clang 5.
diff --git a/ThirdParty/bitset2/bitset2.hpp b/ThirdParty/bitset2/bitset2.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..0b9c95aadfa809715104fd79c248a8382d694a30
--- /dev/null
+++ b/ThirdParty/bitset2/bitset2.hpp
@@ -0,0 +1,646 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#ifndef BITSET2_CB_HPP
+#define BITSET2_CB_HPP
+
+
+#include "detail/hex_params.hpp"
+#include "detail/select_base_t.hpp"
+#include "detail/hash.hpp"
+#include "detail/array_access.hpp"
+#include "detail/array_funcs.hpp"
+#include "detail/array_add.hpp"
+#include "detail/array_ops.hpp"
+#include "detail/array_complement2.hpp"
+#include "detail/array2array.hpp"
+#include "detail/bitset2_impl.hpp"
+
+#include <bitset>
+#include <climits>
+#include <cstdint>
+#include <array>
+#include <stdexcept>
+#include <utility>
+#include <string>
+#include <functional>
+#include <type_traits>
+
+
+
+namespace Bitset2
+{
+
+
+
+template<size_t N,
+ class T= Bitset2::detail::select_base_t<N>,
+ class Enabled=void> class bitset2;
+
+template<size_t N,class T>
+class bitset2<N,T,
+ typename std::enable_if< std::is_integral<T>::value
+ && std::is_unsigned<T>::value>::type>
+: public detail::bitset2_impl<N,T>
+{
+ enum : size_t { base_t_n_bits= detail::bitset2_impl<N,T>::base_t_n_bits };
+public:
+ using array_t= typename detail::bitset2_impl<N,T>::array_t;
+ using ULLONG_t= typename detail::bitset2_impl<N,T>::ULLONG_t;
+ using base_t= T;
+ using detail::bitset2_impl<N,T>::n_array;
+
+ enum : size_t { npos= detail::h_types<T>::npos };
+
+ class reference
+ {
+ friend class bitset2;
+ reference() noexcept {}
+ reference( bitset2<N,T> *ptr, size_t bit ) noexcept
+ : m_ptr( ptr )
+ , m_bit( bit )
+ {}
+ bitset2<N,T> *m_ptr= nullptr;
+ size_t m_bit;
+ public:
+ ~reference() noexcept {}
+ reference& operator=( bool x ) noexcept
+ {
+ m_ptr->set_noexcept( m_bit, x );
+ return *this;
+ }
+ reference& operator=( reference const & r ) noexcept
+ {
+ m_ptr->set_noexcept( m_bit, bool( r ) );
+ return *this;
+ }
+ reference& flip() noexcept
+ {
+ m_ptr->flip_noexcept( m_bit );
+ return *this;
+ }
+ operator bool() const noexcept
+ { return m_ptr->test_noexcept(m_bit); }
+ bool operator~() const noexcept
+ { return !bool(*this); }
+ }; // class reference
+
+
+ /* ------------------------------------------------------------- */
+ constexpr
+ bitset2() noexcept
+ : detail::bitset2_impl<N,T>()
+ {}
+
+ constexpr
+ bitset2( bitset2 const & ) noexcept= default;
+
+ constexpr
+ bitset2( bitset2 && ) noexcept= default;
+
+ constexpr
+ bitset2 &
+ operator=( bitset2 const & ) noexcept= default;
+
+ constexpr
+ bitset2 &
+ operator=( bitset2 && ) noexcept= default;
+
+ explicit
+ bitset2( const std::bitset<N> &bs ) noexcept
+ : detail::bitset2_impl<N,T>( bs )
+ {}
+
+ explicit
+ constexpr
+ bitset2( ULLONG_t v ) noexcept
+ : detail::bitset2_impl<N,T>( v )
+ {}
+
+ template<size_t n,class Tsrc>
+ explicit
+ constexpr
+ bitset2( std::array<Tsrc,n> const & value ) noexcept
+ : detail::bitset2_impl<N,T>( value )
+ {}
+
+ template< class CharT, class Traits, class Alloc >
+ explicit
+ bitset2( std::basic_string<CharT,Traits,Alloc> const
+ & str,
+ typename std::basic_string<CharT,Traits,Alloc>::size_type
+ pos = 0,
+ typename std::basic_string<CharT,Traits,Alloc>::size_type
+ n = std::basic_string<CharT,Traits,Alloc>::npos,
+ CharT zero= CharT('0'),
+ CharT one= CharT('1') )
+ : detail::bitset2_impl<N,T>( str, pos, n, zero, one )
+ {}
+
+
+ template< class CharT >
+ explicit
+ bitset2( const CharT *str,
+ typename std::basic_string<CharT>::size_type
+ n= std::basic_string<CharT>::npos,
+ CharT zero= CharT('0'),
+ CharT one= CharT('1') )
+ : detail::bitset2_impl<N,T>( n == std::basic_string<CharT>::npos
+ ? std::basic_string<CharT>( str )
+ : std::basic_string<CharT>( str, n ),
+ 0, n, zero, one )
+ {}
+ /* ------------------------------------------------------------- */
+
+
+ //****************************************************
+
+ /// Bitwise NOT
+ constexpr
+ bitset2
+ operator~() const noexcept
+ { return bitset2(detail::array_ops<N,T>( 0 ).flip(this->data())); }
+
+ constexpr
+ bool
+ operator[]( size_t bit ) const noexcept
+ { return detail::bitset2_impl<N,T>::operator[]( bit ); }
+
+ reference
+ operator[]( size_t bit ) noexcept
+ { return reference( this, bit ); }
+
+ constexpr
+ bitset2 &
+ operator<<=( size_t n_shift ) noexcept
+ {
+ detail::array_ops<N,T>( n_shift ).shift_left_assgn( this->get_data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ operator>>=( size_t n_shift ) noexcept
+ {
+ detail::array_ops<N,T>( n_shift ).shift_right_assgn( this->get_data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ rotate_left( size_t n_rot ) noexcept
+ {
+ this->get_data()= detail::array_ops<N,T>(n_rot).rotate_left( this->data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ rotate_right( size_t n_rot ) noexcept
+ {
+ this->get_data()= detail::array_ops<N,T>( N - ( n_rot % N ) )
+ .rotate_left( this->data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ reverse() noexcept
+ {
+ this->get_data()= detail::array_ops<N,T>( 0 ).reverse( this->data() );
+ return *this;
+ }
+
+ /// Computes two's complement
+ constexpr
+ bitset2 &
+ complement2() noexcept
+ {
+ detail::array_complement2<N,T>().comp2_assgn( this->get_data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ operator+=( bitset2 const &bs2 ) noexcept
+ {
+ detail::array_add<N,T>().add_assgn(this->get_data(), bs2.data());
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ operator++() noexcept
+ {
+ detail::array_ops<N,T>(0).increment( this->get_data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2
+ operator++(int) noexcept
+ {
+ bitset2 tmp( *this );
+ operator++();
+ return tmp;
+ }
+
+ constexpr
+ bitset2 &
+ operator--() noexcept
+ {
+ detail::array_ops<N,T>(0).decrement( this->get_data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2
+ operator--(int) noexcept
+ {
+ bitset2 tmp( *this );
+ operator--();
+ return tmp;
+ }
+
+ constexpr
+ bitset2 &
+ operator|=( bitset2 const & v2 ) noexcept
+ {
+ detail::array_funcs<bitset2::n_array,T>()
+ .bitwise_or_assgn(this->get_data(), v2.data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ operator&=( bitset2 const & v2 ) noexcept
+ {
+ detail::array_funcs<bitset2::n_array,T>()
+ .bitwise_and_assgn( this->get_data(), v2.data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ operator^=( bitset2 const & v2 ) noexcept
+ {
+ detail::array_funcs<bitset2::n_array,T>()
+ .bitwise_xor_assgn( this->get_data(), v2.data() );
+ return *this;
+ }
+
+ /// Computes the set difference, i.e. *this &= ~v2
+ constexpr
+ bitset2 &
+ difference( bitset2 const & v2 ) noexcept
+ {
+ detail::array_funcs<bitset2::n_array,T>()
+ .bitwise_setdiff_assgn( this->get_data(), v2.data() );
+ return *this;
+ }
+
+ constexpr
+ bitset2 &
+ set() noexcept
+ { detail::bitset2_impl<N,T>::set(); return *this; }
+
+ constexpr
+ bitset2 &
+ set( size_t bit, bool value= true )
+ { detail::bitset2_impl<N,T>::set( bit, value ); return *this; }
+
+ constexpr
+ bitset2 &
+ reset() noexcept
+ { detail::bitset2_impl<N,T>::reset(); return *this; }
+
+ constexpr
+ bitset2 &
+ reset( size_t bit )
+ {
+ if( bit >= N ) throw std::out_of_range( "bitset2: reset out of range" );
+ return set( bit, false );
+ }
+
+ /// \brief Sets the specified bit if value==true,
+ /// clears it otherwise. Returns the previous state of the bit.
+ constexpr
+ bool
+ test_set( size_t bit, bool value= true )
+ { return detail::bitset2_impl<N,T>::test_set( bit, value ); }
+
+ constexpr
+ bitset2 &
+ flip() noexcept
+ { detail::bitset2_impl<N,T>::flip(); return *this; }
+
+ constexpr
+ bitset2 &
+ flip( size_t bit )
+ { detail::bitset2_impl<N,T>::flip( bit ); return *this; }
+
+ constexpr std::size_t size() const noexcept { return N; }
+
+ template<class CharT = char,
+ class Traits = std::char_traits<CharT>,
+ class Allocator = std::allocator<CharT> >
+ std::basic_string<CharT,Traits,Allocator>
+ to_string( CharT zero = CharT('0'), CharT one = CharT('1') ) const
+ {
+ std::basic_string<CharT,Traits,Allocator> ret_val;
+ ret_val.reserve( N );
+ for( size_t ct= N; ct > 0; )
+ {
+ --ct;
+ ret_val += this->operator[]( ct ) ? one : zero;
+ }
+ return ret_val;
+ } // to_string
+
+ template<class CharT = char,
+ class Traits = std::char_traits<CharT>,
+ class Allocator = std::allocator<CharT>,
+ typename std::enable_if<base_t_n_bits % 4 == 0>::type* = nullptr >
+ std::basic_string<CharT,Traits,Allocator>
+ to_hex_string( hex_params<CharT,Traits,Allocator> const ¶ms=
+ hex_params<CharT,Traits,Allocator>{} ) const
+ {
+ using arr_acc= detail::array_access<N,T>;
+ arr_acc a_a;
+ constexpr auto div_four= arr_acc::div_four;
+ constexpr auto mod_four= arr_acc::mod_four;
+ constexpr auto n_char= div_four + ( mod_four > 0 );
+
+ auto const zeroCh= params.zeroCh;
+ auto const aCh= params.aCh;
+
+ std::basic_string<CharT,Traits,Allocator> ret_val;
+ ret_val.reserve( n_char + params.prefix.size() );
+ ret_val= params.prefix;
+ size_t ct= n_char;
+ if( !params.leadingZeroes )
+ {
+ for( ; ct > 0; --ct )
+ {
+ auto const val= a_a.get_four_bits( this->data(), 4 * ct - 1 );
+ if( val != 0 ) break;
+ }
+ }
+ if( ct == 0 && params.nonEmpty ) ret_val += zeroCh;
+ for( ; ct > 0; --ct )
+ {
+ auto const val= a_a.get_four_bits( this->data(), 4 * ct - 1 );
+ CharT const c=
+ ( val < 10 ) ? ( zeroCh + val ) : ( aCh + ( val - 10 ) );
+ ret_val += c;
+ }
+ return ret_val;
+ } // to_hex_string
+
+}; // class bitset2
+
+
+template<size_t N, class T>
+constexpr
+bitset2<N,T>
+rotate_left( bitset2<N,T> const & bs, size_t n_rot ) noexcept
+{
+ return
+ bitset2<N,T>( detail::array_ops<N,T>( n_rot ).rotate_left( bs.data() ) );
+}
+
+
+template<size_t N, class T>
+constexpr
+bitset2<N,T>
+rotate_right( bitset2<N,T> const & bs, size_t n_rot ) noexcept
+{
+ return
+ bitset2<N,T>( detail::array_ops<N,T>( N - ( n_rot % N ) ).
+ rotate_left( bs.data() ) );
+}
+
+
+/// Computes the set difference, i.e. bs1 & ~bs2
+template<size_t N, class T>
+constexpr
+bitset2<N,T>
+difference( bitset2<N,T> const & bs1, bitset2<N,T> const & bs2 ) noexcept
+{
+ return
+ bitset2<N,T>( detail::array_funcs<bitset2<N,T>::n_array,T>()
+ .bitwise_setdiff( bs1.data(), bs2.data() ) );
+}
+
+
+/// Returns bs with bits reversed
+template<size_t N, class T>
+constexpr
+bitset2<N,T>
+reverse( bitset2<N,T> const & bs ) noexcept
+{ return bitset2<N,T>( detail::array_ops<N,T>( 0 ).reverse( bs.data() ) ); }
+
+
+/// Computes the two's complement
+template<size_t N, class T>
+constexpr
+bitset2<N,T>
+complement2( bitset2<N,T> const & bs ) noexcept
+{ return bitset2<N,T>( detail::array_complement2<N,T>().comp2(bs.data()) ); }
+
+
+/// Converts an M-bit bitset2 to an N-bit bitset2.
+template<size_t N,class T1,size_t M, class T2>
+constexpr
+bitset2<N,T1>
+convert_to( bitset2<M,T2> const & bs ) noexcept
+{
+ using a2a=
+ detail::array2array<bitset2<N,T1>::n_array,bitset2<M,T2>::n_array,T1,T2>;
+ return
+ bitset2<N,T1>(a2a()(detail::bit_chars<N,T1>::hgh_bit_pattern, bs.data()));
+}
+
+
+/// Converts an M-bit bitset2 to an N-bit bitset2.
+template<size_t N,size_t M, class T>
+constexpr
+bitset2<N,T>
+convert_to( bitset2<M,T> const & bs ) noexcept
+{ return bitset2<N,T>( bs.data() ); }
+
+
+/// \brief Returns true if f returns true for each pair
+/// of base_t=T values in bs1 and bs2. f should be a binary function
+/// taking two base_t values and returning bool.
+/// zip_fold_and does short circuit if possible.
+template<size_t N, class F, class T>
+constexpr
+bool
+zip_fold_and( bitset2<N,T> const & bs1, bitset2<N,T> const & bs2,
+ F f ) noexcept(noexcept( f( T(0), T(0) ) ))
+{
+ return
+ detail::array_funcs<bitset2<N,T>::n_array,T>().zip_fold_and(bs1.data(),
+ bs2.data(), f);
+}
+
+
+/// \brief Returns true if f returns true for at least one pair
+/// of base_t=T values in bs1 and bs2. f should be a binary function
+/// taking two base_t values and returning bool.
+/// zip_fold_or does short circuit if possible.
+template<size_t N, class F,class T>
+constexpr
+bool
+zip_fold_or( bitset2<N,T> const & bs1, bitset2<N,T> const & bs2,
+ F f ) noexcept(noexcept( f( T(0), T(0) ) ))
+{
+ return
+ detail::array_funcs<bitset2<N,T>::n_array,T>().zip_fold_or( bs1.data(),
+ bs2.data(), f );
+}
+
+
+} // namespace Bitset2
+
+
+
+
+/// Stream output
+template <class CharT, class Traits, size_t N,class T>
+std::basic_ostream<CharT, Traits>&
+operator<<( std::basic_ostream<CharT, Traits> & os,
+ Bitset2::bitset2<N,T> const & x )
+{
+ for( size_t ct= N; ct > 0; )
+ {
+ --ct;
+ os << ( x[ct] ? "1" : "0" );
+ }
+ return os;
+}
+
+/// Stream input
+template <class CharT, class Traits, size_t N,class T>
+std::basic_istream<CharT, Traits>&
+operator>>( std::basic_istream<CharT, Traits> & is,
+ Bitset2::bitset2<N,T> & x )
+{
+ std::bitset<N> bs;
+ is >> bs;
+ x= Bitset2::bitset2<N,T>( bs );
+ return is;
+}
+
+
+
+/// Shift left
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator<<( Bitset2::bitset2<N,T> const & bs, size_t n_shift ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>( Bitset2::detail::array_ops<N,T>( n_shift )
+ .shift_left( bs.data() ) );
+}
+
+
+/// Shift right
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator>>( Bitset2::bitset2<N,T> const & bs, size_t n_shift ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>( Bitset2::detail::array_ops<N,T>( n_shift )
+ .shift_right( bs.data() ) );
+}
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator|( Bitset2::bitset2<N,T> const & bs1,
+ Bitset2::bitset2<N,T> const & bs2 ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>(
+ Bitset2::detail::array_funcs<Bitset2::bitset2<N,T>::n_array,T>()
+ .bitwise_or( bs1.data(), bs2.data() ) );
+}
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator&( Bitset2::bitset2<N,T> const & bs1,
+ Bitset2::bitset2<N,T> const & bs2 ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>(
+ Bitset2::detail::array_funcs<Bitset2::bitset2<N,T>::n_array,T>()
+ .bitwise_and( bs1.data(), bs2.data() ) );
+}
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator^( Bitset2::bitset2<N,T> const & bs1,
+ Bitset2::bitset2<N,T> const & bs2 ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>(
+ Bitset2::detail::array_funcs<Bitset2::bitset2<N,T>::n_array,T>()
+ .bitwise_xor( bs1.data(), bs2.data() ) );
+}
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+operator+( Bitset2::bitset2<N,T> const & bs1,
+ Bitset2::bitset2<N,T> const & bs2 ) noexcept
+{
+ return
+ Bitset2::bitset2<N,T>(
+ Bitset2::detail::array_add<N,T>().add( bs1.data(), bs2.data() ) );
+}
+
+
+namespace std
+{
+ template<size_t N,class T>
+ struct hash<Bitset2::bitset2<N,T> >
+ {
+ private:
+ enum : size_t
+ { n_array= Bitset2::detail::bitset2_impl<N,T>::n_array };
+
+ Bitset2::detail::hash_impl<n_array,T> m_func;
+
+ public:
+ using argument_type= Bitset2::bitset2<N,T>;
+ using result_type=
+ typename Bitset2::detail::hash_impl<n_array,T>::result_type;
+
+ result_type operator()( argument_type const& bs ) const
+ { return m_func( bs.data() ); }
+ }; // struct hash
+
+} // namespace std
+
+
+#endif // BITSET2_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array2array.hpp b/ThirdParty/bitset2/detail/array2array.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..618af64eeef50fd5bda55b94867f14d572fd8afa
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array2array.hpp
@@ -0,0 +1,122 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY2ARRAY_CB_HPP
+#define BITSET2_ARRAY2ARRAY_CB_HPP
+
+
+#include "h_types.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+
+/// \brief Convert std::array<Tsrc,src_n> to std::array<Ttrgt,trgt_n>
+template<size_t trgt_n, size_t src_n, class Ttrgt, class Tsrc>
+struct array2array
+{
+ using h_t_trgt= h_types<Ttrgt>;
+ using h_t_src= h_types<Tsrc>;
+ using trgt_array_t= typename h_t_trgt::template array_t<trgt_n>;
+ using src_array_t= typename h_t_src:: template array_t<src_n>;
+
+ enum : size_t
+ { trgt_base_n_bits= h_t_trgt::base_t_n_bits
+ , src_base_n_bits= h_t_src:: base_t_n_bits
+ };
+
+ enum : bool
+ { small_to_large= ( src_base_n_bits < trgt_base_n_bits ) };
+
+ enum : size_t
+ { ts_div= small_to_large ? trgt_base_n_bits / src_base_n_bits
+ : src_base_n_bits / trgt_base_n_bits };
+
+ enum : Tsrc
+ { h_all_set= Tsrc( Ttrgt(~Ttrgt(0)) ) };
+
+ /// Applies pttrn to most significant entry in result
+ constexpr
+ trgt_array_t
+ operator()( Ttrgt pttrn, src_array_t const &src ) const noexcept
+ {
+ static_assert( ( small_to_large && trgt_base_n_bits % src_base_n_bits == 0)
+ || (!small_to_large && src_base_n_bits % trgt_base_n_bits == 0),
+ "Conversion between arrays of these types not supported" );
+ return small_to_large
+ ? conv_small_to_large( pttrn, src, std::make_index_sequence<trgt_n-1>() )
+ : conv_large_to_small( pttrn, src, std::make_index_sequence<trgt_n-1>() );
+ }
+
+
+ template<size_t ... S1>
+ constexpr
+ trgt_array_t
+ conv_small_to_large( Ttrgt pttrn,
+ src_array_t const &src,
+ std::index_sequence<S1...> ) const noexcept
+ {
+ return {{ get_from_smaller( S1, src, S1 * ts_div )...,
+ Ttrgt( get_from_smaller( trgt_n-1, src, (trgt_n-1) * ts_div )
+ & pttrn ) }};
+ }
+
+ template<size_t ... S1>
+ constexpr
+ trgt_array_t
+ conv_large_to_small( Ttrgt pttrn,
+ src_array_t const &src,
+ std::index_sequence<S1...> ) const noexcept
+ {
+ return
+ {{ get_from_larger( S1 / ts_div, S1 % ts_div, src )...,
+ Ttrgt( get_from_larger((trgt_n-1) / ts_div, (trgt_n-1) % ts_div, src)
+ & pttrn ) }};
+ }
+
+ constexpr
+ Ttrgt
+ get_from_smaller( size_t trgt_idx,
+ src_array_t const &src,
+ size_t src_idx,
+ size_t src_ct= 0,
+ Ttrgt so_far= Ttrgt(0) ) const noexcept
+ {
+ return ( src_ct >= ts_div || src_idx >= src_n )
+ ? so_far
+ : get_from_smaller( trgt_idx, src, src_idx + 1, src_ct + 1,
+ so_far | Ttrgt( Ttrgt(src[src_idx])
+ << (src_base_n_bits * src_ct) ) );
+ }
+
+ constexpr
+ Ttrgt
+ get_from_larger( size_t div_val,
+ size_t mod_val,
+ src_array_t const &src ) const noexcept
+ {
+ return ( div_val >= src_n ) ? Ttrgt(0)
+ : Ttrgt(Tsrc( src[div_val] >> (mod_val*trgt_base_n_bits) ) & h_all_set );
+ }
+}; // struct array2array
+
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+#endif // BITSET2_ARRAY2ARRAY_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array2u_long_t.hpp b/ThirdParty/bitset2/detail/array2u_long_t.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..ec2ddc4ca8d736efea1b44abe733964640649b79
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array2u_long_t.hpp
@@ -0,0 +1,110 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#ifndef BITSET2_ARRAY2U_LONG_T_CB_HPP
+#define BITSET2_ARRAY2U_LONG_T_CB_HPP
+
+#include "bit_chars.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ /// \brief Takes a std::array 'arr' and returns a variable 'x' of type Tlong.
+ /// Bits in 'x' are set if corresponding bits in 'arr' are set.
+ template<size_t N, class T, class Tlong>
+ struct array2u_long_t
+ {
+ using base_t= T;
+ using b_c= bit_chars<N,T>;
+
+ enum : size_t
+ { n_bits= N
+ , base_t_n_bits= b_c::base_t_n_bits
+ , long_t_n_bits= sizeof( Tlong ) * CHAR_BIT
+ , n_array= b_c::n_array
+ , div_val= long_t_n_bits / base_t_n_bits
+ , mod_val= long_t_n_bits % base_t_n_bits
+ , use_vals= ce_min( div_val + (mod_val!=0), n_array )
+ , bit_diff= mod_val == 0 ? 0 : ( base_t_n_bits - mod_val )
+ };
+
+ enum : base_t
+ { allset= base_t( ~base_t(0) )
+ , h_pttrn= use_vals < n_array ? allset : ce_right_shift( allset, bit_diff )
+ , i_pttrn= base_t( ~h_pttrn )
+ };
+
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+ constexpr
+ Tlong
+ operator()( array_t const & arr ) const noexcept
+ {
+ return
+ base_t_n_bits >= long_t_n_bits ? Tlong( arr[0] )
+ : combine( Tlong(0), arr, 0 );
+ }
+
+ /// \brief Returns true if arr cannot be converted to Tlong.
+ constexpr
+ bool
+ check_overflow( array_t const & arr ) const noexcept
+ { return N <= long_t_n_bits ? false : check_impl( arr, use_vals - 1 ); }
+
+
+
+ constexpr
+ Tlong
+ combine( Tlong v, array_t const & arr, size_t idx ) const noexcept
+ {
+ return ( idx >= use_vals ) ? v
+ : idx + 1 == use_vals
+ ? Tlong( v + take_v( arr, idx, h_pttrn ) )
+ : combine( Tlong( v + take_v( arr, idx ) ), arr, idx + 1 );
+ }
+
+ constexpr
+ Tlong
+ take_v( array_t const & arr, size_t idx, base_t pttrn= allset ) const noexcept
+ { return ce_left_shift( Tlong( arr[idx] & pttrn ), idx * base_t_n_bits ); }
+
+ constexpr
+ bool
+ check_impl( array_t const & arr, size_t idx ) const noexcept
+ {
+ return idx >= n_array ? false
+ : ( ( take_check( arr, idx ) != base_t(0) )
+ || check_impl( arr, idx + 1 ) );
+ }
+
+ constexpr
+ base_t
+ take_check( array_t const & arr, size_t idx ) const noexcept
+ { return arr[idx] & ( idx + 1 == use_vals ? i_pttrn : allset ); }
+
+ }; // struct array2u_long_t
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+
+
+
+#endif // BITSET2_ARRAY2U_LONG_T_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array_access.hpp b/ThirdParty/bitset2/detail/array_access.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..a4e42b492eb3c246078fc088f5fe720c036511f6
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array_access.hpp
@@ -0,0 +1,82 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY_ACCESS_CB_HPP
+#define BITSET2_ARRAY_ACCESS_CB_HPP
+
+#include "bit_chars.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ /// \brief array_access is used for getting bunches of 4 bits, which is
+ /// needed when creating hex-strings
+ template<size_t N,class T>
+ struct array_access
+ {
+ using base_t= T;
+ using b_chars= bit_chars<N,T>;
+ enum : size_t { base_t_n_bits= b_chars::base_t_n_bits
+ , n_array= b_chars::n_array
+ };
+ enum : size_t { div_four= N / 4
+ , mod_four= N % 4
+ };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+ constexpr
+ base_t
+ get_four_bits( array_t const &arr, size_t offset ) const noexcept
+ {
+ return
+ get_four_bits_impl( arr,
+ offset / base_t_n_bits, offset % base_t_n_bits );
+ }
+
+ constexpr
+ base_t
+ get_four_bits_impl( array_t const &arr,
+ size_t idx, size_t bit_idx ) const noexcept
+ {
+ return ( bit_idx >= 3 )
+ ? h1_get_four_bits( arr[idx], bit_idx )
+ : h2_get_four_bits( arr, idx, bit_idx );
+ }
+
+ constexpr
+ base_t
+ h1_get_four_bits( base_t v, size_t bit_idx ) const noexcept
+ { return ( v >> ( bit_idx - 3 ) ) & base_t(0xF); }
+
+ constexpr
+ base_t
+ h2_get_four_bits( array_t const &arr,
+ size_t idx, size_t bit_idx ) const noexcept
+ {
+ return
+ (( arr[idx] & ( ( base_t(1) << (bit_idx+1) ) - 1 ) ) << ( 3 - bit_idx ))
+ + ( ( idx == 0 ) ? base_t(0)
+ : ( arr[idx-1] >> (base_t_n_bits - (3 - bit_idx)) ) );
+ }
+ }; // struct array_access
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_ARRAY_ACCESS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array_add.hpp b/ThirdParty/bitset2/detail/array_add.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..55dc6f7a1ade67a4a4c0f04de0499f4cd0816088
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array_add.hpp
@@ -0,0 +1,153 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY_ADD_CB_HPP
+#define BITSET2_ARRAY_ADD_CB_HPP
+
+
+#include "bit_chars.hpp"
+#include "array_funcs.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<size_t N,size_t it_n,class T>
+ struct array_add_base
+ {
+ using base_t= T;
+ using b_chars= bit_chars<N,T>;
+ enum : size_t { n_array= b_chars::n_array };
+ enum : base_t
+ { hgh_bit_pattern= b_chars::hgh_bit_pattern
+ , all_one= b_chars::all_one
+ };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+ using zero_array_t= typename h_types<T>::template array_t<0>;
+
+ /// Used to submit the curent result of the addition and the carry over
+ template<size_t n>
+ using array_pair_t= std::pair<base_t,
+ typename h_types<T>::template array_t<n> >;
+
+
+ constexpr
+ array_pair_t<it_n+1>
+ add_h1( base_t a, base_t b, base_t sm1, base_t sum,
+ typename
+ h_types<T>::template array_t<it_n> const &so_far ) const noexcept
+ {
+ return
+ std::make_pair( ( sum < a || sm1 < b ) ? base_t(1) : base_t(0)
+ , array_funcs<it_n,T>()
+ .append( so_far
+ , ( it_n + 1 < n_array )
+ ? sum
+ : base_t(sum & hgh_bit_pattern) ) );
+ }
+
+ constexpr
+ array_pair_t<it_n+1>
+ add_h2( base_t a, base_t b, array_pair_t<it_n> const &a_p ) const noexcept
+ { return add_h1( a, b, b + a_p.first, a + b + a_p.first, a_p.second ); }
+ }; //struct array_add_base
+
+
+ /// \brief This struct is introduced for beeing able to partially
+ /// specialize function add_h3.
+ template<size_t N,size_t it_n,class T>
+ struct array_add_h : public array_add_base<N,it_n,T>
+ {
+ using array_t= typename array_add_base<N,it_n,T>::array_t;
+
+ template<size_t n>
+ using array_pair_t=
+ typename array_add_base<N,it_n,T>::template array_pair_t<n>;
+
+ constexpr
+ array_pair_t<it_n+1>
+ add_h3( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return
+ this->add_h2( arr1[it_n], arr2[it_n]
+ , array_add_h<N,it_n-1,T>().add_h3( arr1, arr2 ) );
+ }
+ }; // struct array_add_h
+
+
+ template<size_t N,class T>
+ struct array_add_h<N,0,T> : public array_add_base<N,0,T>
+ {
+ using array_t= typename array_add_base<N,0,T>::array_t;
+ using zero_array_t= typename array_add_base<N,0,T>::zero_array_t;
+
+ template<size_t n>
+ using array_pair_t=typename array_add_base<N,0,T>::template array_pair_t<n>;
+
+ constexpr
+ array_pair_t<1>
+ add_h3( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return
+ this->add_h2( arr1[0], arr2[0]
+ , std::make_pair( T(0), zero_array_t{} ) );
+ }
+ }; // struct array_add_h
+
+
+ /// Allows to add two std::array's in a constexpr
+ template<size_t N,class T>
+ struct array_add
+ {
+ using base_t= T;
+ using b_chars= bit_chars<N,T>;
+ enum : base_t
+ { hgh_bit_pattern= b_chars::hgh_bit_pattern
+ , all_one= b_chars::all_one
+ };
+ enum : size_t { n_array= b_chars::n_array };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+ constexpr
+ array_t
+ add( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return
+ ( N == 0 ) ? array_t{}
+ : array_add_h<N,n_array-1,T>().add_h3( arr1, arr2 ).second;
+ }
+
+ constexpr
+ void
+ add_assgn( array_t &arr1, array_t const &arr2 ) const noexcept
+ {
+ base_t carry= base_t(0);
+ for( size_t c= 0; c < n_array; ++c )
+ {
+ auto const sm1= base_t( arr2[c] + carry );
+ auto const sm= base_t( arr1[c] + sm1 );
+ carry= sm < arr1[c] || sm1 < arr2[c];
+ arr1[c]= sm;
+ }
+ arr1[n_array-1] &= hgh_bit_pattern;
+ } // add_assgn
+ }; // struct array_add
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_ARRAY_ADD_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array_complement2.hpp b/ThirdParty/bitset2/detail/array_complement2.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..eaab57be63332ddd91e73d2b12e614137d9d2cf0
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array_complement2.hpp
@@ -0,0 +1,149 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY_COMPLEMENT2_CB_HPP
+#define BITSET2_ARRAY_COMPLEMENT2_CB_HPP
+
+
+#include "bit_chars.hpp"
+#include "array_funcs.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<size_t N,size_t it_n,class T>
+ struct array_complement2_base
+ {
+ using base_t= T;
+ using b_chars= bit_chars<N,T>;
+ enum : base_t { hgh_bit_pattern= b_chars::hgh_bit_pattern };
+ enum : size_t { n_array= b_chars::n_array };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+ template<size_t n>
+ using arr_t= typename h_types<T>::template array_t<n>;
+
+ constexpr
+ arr_t<it_n+1>
+ comp2_h1( arr_t<it_n> const &so_far, base_t sum ) const noexcept
+ {
+ return
+ array_funcs<it_n,T>().append( so_far
+ , ( it_n + 1 < n_array )
+ ? sum
+ : base_t(sum & hgh_bit_pattern) );
+ }
+
+ constexpr
+ arr_t<it_n+1>
+ comp2_h2( array_t const &arr,
+ arr_t<it_n> const &so_far,
+ base_t carry ) const noexcept
+ { return comp2_h1( so_far, base_t( base_t(~arr[it_n]) + carry ) ); }
+
+ constexpr
+ arr_t<it_n+1>
+ comp2_h3( array_t const &arr,
+ arr_t<it_n> const &so_far ) const noexcept
+ {
+ return comp2_h2( arr, so_far,
+ it_n == 0
+ ? base_t(1)
+ : base_t(so_far[it_n-1] == 0 && arr[it_n-1] == 0) );
+ }
+
+ }; // struct array_complement2_base
+
+
+ template<size_t N,size_t it_n,class T>
+ struct array_complement2_h : array_complement2_base<N,it_n,T>
+ {
+ using array_t= typename array_complement2_base<N,it_n,T>::array_t;
+
+ template<size_t n>
+ using arr_t= typename array_complement2_base<N,it_n,T>::template arr_t<n>;
+
+ constexpr
+ arr_t<it_n+1>
+ comp2_h4( array_t const &arr ) const noexcept
+ {
+ return
+ this->comp2_h3( arr,
+ array_complement2_h<N,it_n-1,T>().comp2_h4( arr ) );
+ }
+
+ }; // struct array_complement2_h
+
+
+ template<size_t N,class T>
+ struct array_complement2_h<N,0,T> : array_complement2_base<N,0,T>
+ {
+ using array_t= typename array_complement2_base<N,0,T>::array_t;
+
+ template<size_t n>
+ using arr_t= typename array_complement2_base<N,0,T>::template arr_t<n>;
+
+ constexpr
+ arr_t<1>
+ comp2_h4( array_t const &arr ) const noexcept
+ { return this->comp2_h3( arr, arr_t<0>{} ); }
+
+ }; // struct array_complement2_h<N,0,T>
+
+
+
+ /// Computes the two's complement of the number encoded in the array
+ template<size_t N,class T>
+ struct array_complement2
+ {
+ using base_t= T;
+ using b_chars= bit_chars<N,T>;
+ enum : base_t { hgh_bit_pattern= b_chars::hgh_bit_pattern };
+ enum : size_t { n_array= b_chars::n_array };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+
+ constexpr
+ array_t
+ comp2( array_t const &arr ) const noexcept
+ {
+ return
+ ( N == 0 ) ? array_t{}
+ : array_complement2_h<N,n_array-1,T>().comp2_h4( arr );
+ }
+
+ constexpr
+ void
+ comp2_assgn( array_t &arr ) const noexcept
+ {
+ base_t carry= base_t(1);
+ for( size_t c= 0; c < n_array; ++c )
+ {
+ auto const sm= base_t( base_t(~arr[c]) + carry );
+ carry= base_t( (carry == base_t(1)) && ( sm == 0 ) );
+ arr[c]= sm;
+ } // for c
+ arr[n_array-1] &= hgh_bit_pattern;
+ } // comp2_assgn
+
+ }; // struct array_complement2
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+#endif // BITSET2_ARRAY_COMPLEMENT2_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array_funcs.hpp b/ThirdParty/bitset2/detail/array_funcs.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..f75afb02d2d342c6330451b4c70717db0d02f8bd
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array_funcs.hpp
@@ -0,0 +1,346 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY_FUNCS_CB_HPP
+#define BITSET2_ARRAY_FUNCS_CB_HPP
+
+
+#include "h_types.hpp"
+#include "count_bits.hpp"
+#include "index_lsb_set.hpp"
+#include <utility>
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<size_t n_array,class T>
+ struct array_funcs
+ {
+ using base_t= T;
+ using array_t= typename h_types<T>::template array_t<n_array>;
+ using array_p1_t= typename h_types<T>::template array_t<n_array+1>;
+
+ enum : size_t { base_t_n_bits= h_types<T>::base_t_n_bits
+ , npos= h_types<T>::npos };
+
+ /// Binary operator type
+ enum class op_type { or_op, and_op, xor_op, sdiff_op };
+
+ constexpr
+ array_t
+ bitwise_or( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return bitwise_op_impl( op_type::or_op, arr1, arr2,
+ std::make_index_sequence<n_array>() );
+ }
+
+ /// Used for |= operator. Separate implementation for better performance.
+ constexpr
+ void
+ bitwise_or_assgn( array_t &arr1, array_t const &arr2 ) const noexcept
+ { return bitwise_op_assgn_impl( op_type::or_op, arr1, arr2 ); }
+
+ constexpr
+ array_t
+ bitwise_and( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return bitwise_op_impl( op_type::and_op, arr1, arr2,
+ std::make_index_sequence<n_array>() );
+ }
+
+ /// Used for &= operator. Separate implementation for better performance.
+ constexpr
+ void
+ bitwise_and_assgn( array_t &arr1, array_t const &arr2 ) const noexcept
+ { return bitwise_op_assgn_impl( op_type::and_op, arr1, arr2 ); }
+
+ constexpr
+ array_t
+ bitwise_xor( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return bitwise_op_impl( op_type::xor_op, arr1, arr2,
+ std::make_index_sequence<n_array>() );
+ }
+
+ /// Used for ^= operator. Separate implementation for better performance.
+ constexpr
+ void
+ bitwise_xor_assgn( array_t &arr1, array_t const &arr2 ) const noexcept
+ { return bitwise_op_assgn_impl( op_type::xor_op, arr1, arr2 ); }
+
+ /// Computes the set difference, i.e. arr1 & ~arr2
+ constexpr
+ array_t
+ bitwise_setdiff( array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return bitwise_op_impl( op_type::sdiff_op, arr1, arr2,
+ std::make_index_sequence<n_array>() );
+ }
+
+ /// \brief Computes the set difference, i.e. arr1 & ~arr2.
+ /// Separate implementation for better performance.
+ constexpr
+ void
+ bitwise_setdiff_assgn( array_t &arr1, array_t const &arr2 ) const noexcept
+ { return bitwise_op_assgn_impl( op_type::sdiff_op, arr1, arr2 ); }
+
+
+ constexpr
+ bool
+ none( array_t const &arr ) const noexcept
+ { return none_impl( n_array - 1, arr ); }
+
+
+ constexpr
+ size_t
+ count( array_t const &arr ) const noexcept
+ {
+ return
+ sum_impl( count_impl( arr, std::make_index_sequence<n_array>() ) );
+ }
+
+
+ constexpr
+ bool
+ equal( array_t const &arr1, array_t const &arr2 ) const noexcept
+ { return equal_impl( arr1, arr2, 0 ); }
+
+
+ constexpr
+ bool
+ less_than( array_t const &arr1, array_t const &arr2 ) const noexcept
+ { return less_than_impl( arr1, arr2, n_array - 1 ); }
+
+
+ /// \brief Returns true if f returns true for each pair
+ /// of elements in arr1 and arr2
+ template<class F>
+ constexpr
+ bool
+ zip_fold_and( array_t const &arr1, array_t const &arr2,
+ F &f ) const noexcept(noexcept( f( base_t(0), base_t(0) ) ))
+ { return zip_fold_and_impl( arr1, arr2, f, 0 ); }
+
+
+ /// \brief Returns true if f returns true for at least one pair
+ /// of elements in arr1 and arr2
+ template<class F>
+ constexpr
+ bool
+ zip_fold_or( array_t const &arr1, array_t const &arr2,
+ F &f ) const noexcept(noexcept( f( base_t(0), base_t(0) ) ))
+ { return zip_fold_or_impl( arr1, arr2, f, 0 ); }
+
+
+ /// Prepend v1 in front of arr
+ constexpr
+ array_p1_t
+ prepend( base_t const v1, array_t const &arr ) const noexcept
+ { return prepend_impl( v1, arr, std::make_index_sequence<n_array>()); }
+
+
+ /// Append v1 to arr
+ constexpr
+ array_p1_t
+ append( array_t const &arr, base_t const v1 ) const noexcept
+ { return append_impl( arr, v1, std::make_index_sequence<n_array>()); }
+
+
+ /// Copy each element in arr but apply pttrn to most significant entry
+ template<size_t n>
+ constexpr
+ array_t
+ copy_and_map( base_t const pttrn,
+ typename
+ h_types<T>::template array_t<n> const &arr ) const noexcept
+ {
+ return
+ n_array == 0 ? array_t{}
+ : copy_and_map_impl(
+ pttrn,
+ arr,
+ gen_empty_array<n_array,T>(),
+ n >= n_array,
+ std::make_index_sequence<ce_min( n_array-1, n )>(),
+ std::make_index_sequence<n_array-1-ce_min(n_array-1, n)>() );
+ } // copy_and_map
+
+
+ //** _impl functions
+
+ template<size_t n,size_t ... S1,size_t ... S2>
+ constexpr
+ array_t
+ copy_and_map_impl( base_t const pttrn,
+ typename
+ h_types<T>::template array_t<n> const &arr,
+ array_t const &zeroes,
+ bool const take_all,
+ std::index_sequence<S1...>,
+ std::index_sequence<S2...> ) const noexcept
+ {
+ return {{ arr[S1]..., zeroes[S2]...,
+ base_t(( take_all ? arr[n_array-1] : base_t(0) ) & pttrn) }};
+ }
+
+
+
+ constexpr
+ bool
+ none_impl( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( arr[idx] == base_t(0) )
+ && ( ( idx == 0 ) ? true : none_impl( idx - 1, arr ) );
+ }
+
+
+ template<size_t ... S>
+ constexpr
+ array_p1_t
+ append_impl( array_t const &arr, base_t const v1,
+ std::index_sequence<S...> ) const noexcept
+ { return {{ arr[S]..., v1 }}; }
+
+
+ template<size_t ... S>
+ constexpr
+ array_p1_t
+ prepend_impl( base_t const v1, array_t const &arr,
+ std::index_sequence<S...> ) const noexcept
+ { return {{ v1, arr[S]... }}; }
+
+
+ constexpr
+ bool
+ equal_impl( array_t const &arr1, array_t const &arr2,
+ size_t ct ) const noexcept
+ {
+ return ( ct == n_array ) ? true
+ : ( arr1[ct] == arr2[ct] ) && equal_impl( arr1, arr2, ct + 1 );
+ }
+
+
+ constexpr
+ bool
+ less_than_impl( array_t const &arr1, array_t const &arr2,
+ size_t ct ) const noexcept
+ {
+ return
+ ( arr1[ct] < arr2[ct] )
+ || ( arr1[ct] == arr2[ct]
+ && ( ct == 0 ? false : less_than_impl( arr1, arr2, ct-1 ) ) );
+ }
+
+
+ template<class F>
+ constexpr
+ bool
+ zip_fold_and_impl( array_t const &arr1, array_t const &arr2,
+ F &f,
+ size_t ct )
+ const noexcept(noexcept( f(base_t(0), base_t(0))))
+ {
+ return ( ct == n_array ) ? true
+ : ( f( arr1[ct], arr2[ct] )
+ && zip_fold_and_impl( arr1, arr2, f, ct + 1 ) );
+ }
+
+
+ template<class F>
+ constexpr
+ bool
+ zip_fold_or_impl( array_t const &arr1, array_t const &arr2,
+ F &f,
+ size_t ct )
+ const noexcept(noexcept( f(base_t(0), base_t(0))))
+ {
+ return ( ct == n_array ) ? false
+ : ( f( arr1[ct], arr2[ct] )
+ || zip_fold_or_impl( arr1, arr2, f, ct + 1 ) );
+ }
+
+
+ constexpr
+ void
+ bitwise_op_assgn_impl( op_type opt,
+ array_t &arr1, array_t const &arr2 ) const noexcept
+ {
+ for( size_t c= 0; c < n_array; ++c )
+ {
+ if( opt == op_type::or_op ) arr1[c] |= arr2[c];
+ else if( opt == op_type::and_op ) arr1[c] &= arr2[c];
+ else if( opt == op_type::xor_op ) arr1[c] ^= arr2[c];
+ else arr1[c] &= ~arr2[c];
+ }
+ } // bitwise_op_assgn_impl
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ bitwise_op_impl( op_type opt,
+ array_t const &arr1, array_t const &arr2,
+ std::index_sequence<S...> ) const noexcept
+ { return {{ h_bitwise_op( S, opt, arr1, arr2 )... }}; }
+
+ constexpr
+ base_t
+ h_bitwise_op( size_t idx, op_type opt,
+ array_t const &arr1, array_t const &arr2 ) const noexcept
+ {
+ return ( opt == op_type::or_op ) ? ( arr1[idx] | arr2[idx] )
+ : ( ( opt == op_type::and_op ) ? ( arr1[idx] & arr2[idx] )
+ : ( opt == op_type::xor_op ) ? ( arr1[idx] ^ arr2[idx] )
+ : ( arr1[idx] & ~arr2[idx] ) );
+ }
+
+ /// Count bits in each element of arr
+ template<size_t ... S>
+ constexpr
+ std::array<size_t, n_array>
+ count_impl( array_t const &arr, std::index_sequence<S...> ) const noexcept
+ { return {{ count_bits( arr[S] )... }}; }
+
+
+ /// Sum over all elements in vals
+ template<class T1>
+ constexpr
+ T1
+ sum_impl( std::array<T1, n_array> const &vals,
+ size_t ct= n_array - 1 ) const noexcept
+ { return vals[ct] + ( ( ct == 0 ) ? T1(0) : sum_impl( vals, ct - 1 ) ); }
+
+
+ constexpr
+ size_t
+ idx_lsb_set( array_t const &arr, base_t v, size_t idx ) const noexcept
+ {
+ return
+ v == base_t(0)
+ ? ( idx + 1 == n_array ? npos
+ : idx_lsb_set( arr, arr[idx+1], idx + 1 ) )
+ : idx * base_t_n_bits + index_lsb_set<base_t>()( v );
+ }
+
+ }; // struct array_funcs
+
+} // namespace detail
+
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_ARRAY_FUNCS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/array_ops.hpp b/ThirdParty/bitset2/detail/array_ops.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..eecbc6d03a7d7f324dd251c1abf2c379f877b657
--- /dev/null
+++ b/ThirdParty/bitset2/detail/array_ops.hpp
@@ -0,0 +1,336 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_ARRAY_OPS_CB_HPP
+#define BITSET2_ARRAY_OPS_CB_HPP
+
+#include "bit_chars.hpp"
+#include "reverse_bits.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<size_t N,class T>
+ struct array_ops
+ {
+ using base_t= T;
+ using this_t= array_ops<N,T>;
+ using b_chars= bit_chars<N,T>;
+ enum : size_t { base_t_n_bits= b_chars::base_t_n_bits
+ , n_words= b_chars::n_words
+ , n_array= b_chars::n_array
+ , mod_val= b_chars::mod_val
+ , n_m_mod= mod_val == 0 ? 0 : base_t_n_bits-mod_val
+ };
+ enum : base_t
+ { hgh_bit_pattern= b_chars::hgh_bit_pattern
+ , all_one= b_chars::all_one };
+ using array_t= typename h_types<T>::template array_t<n_array>;
+ using zero_array_t= typename h_types<T>::template array_t<0>;
+
+ constexpr
+ array_ops( size_t n_shift ) noexcept
+ : m_n_shift_mod( n_shift % N )
+ , m_shft_div( n_shift / base_t_n_bits )
+ , m_shft_mod( n_shift % base_t_n_bits )
+ , m_shft_leftright_shift( base_t_n_bits-(n_shift % base_t_n_bits) )
+ , m_shft_left_pattern( ce_left_shift( T(~T(0)),
+ base_t_n_bits
+ - (n_shift % base_t_n_bits) ))
+ , m_shft_right_pattern( ce_right_shift( T(~T(0)),
+ base_t_n_bits
+ - (n_shift % base_t_n_bits) ))
+ {}
+
+ constexpr
+ array_t
+ shift_left( array_t const &arr ) const noexcept
+ { return shift_left_impl( arr, std::make_index_sequence<n_array>() ); }
+
+ constexpr
+ array_t
+ shift_right( array_t const &arr ) const noexcept
+ { return shift_right_impl( arr, std::make_index_sequence<n_array>() ); }
+
+ /// Used for <<= operator. Separate implementation for better performance.
+ constexpr
+ void
+ shift_left_assgn( array_t &arr ) const noexcept
+ {
+ for( size_t c= n_words; c > 0; )
+ {
+ --c;
+ if( c >= m_shft_div )
+ {
+ auto const c2= c - m_shft_div;
+ base_t const v1= arr[c2] << m_shft_mod;
+ base_t const v2=
+ c2 == 0 ? base_t(0)
+ : ce_right_shift( base_t(arr[c2-1] & m_shft_left_pattern),
+ m_shft_leftright_shift );
+ arr[c]= base_t( v1 | v2 );
+ }
+ else arr[c]= base_t(0);
+ } // for c
+ arr[n_array-1] &= hgh_bit_pattern;
+ } // shift_left_assgn
+
+ /// Used for >>= operator. Separate implementation for better performance.
+ constexpr
+ void
+ shift_right_assgn( array_t &arr ) const noexcept
+ {
+ for( size_t c= 0; c < n_words; ++c )
+ {
+ auto const c2= c + m_shft_div;
+ if( c2 < n_words )
+ {
+ base_t const v1= arr[c2] >> m_shft_mod;
+ base_t const v2=
+ ( c2 + 1 >= n_words ) ? base_t(0)
+ : ce_left_shift( base_t( arr[c2+1] & m_shft_right_pattern ),
+ m_shft_leftright_shift );
+ arr[c]= v1 | v2;
+ }
+ else arr[c]= base_t(0);
+ } // for c
+ arr[n_array-1] &= hgh_bit_pattern;
+ } // shift_right_assgn
+
+
+ constexpr
+ array_t
+ rotate_left( array_t const &arr ) const noexcept
+ {
+ return
+ ( n_array == 1 )
+ ? array_t{{ base_t(( base_t( arr[0] << m_n_shift_mod )
+ | ( ce_right_shift( arr[0], N - m_n_shift_mod ) )
+ ) & hgh_bit_pattern ) }}
+ : rotate_left_impl( arr,
+ array_ops<N,T>( m_n_shift_mod ),
+ array_ops<N,T>( N - m_n_shift_mod ),
+ std::make_index_sequence<n_array>() );
+ } // rotate_left
+
+ constexpr
+ array_t
+ flip( array_t const &arr ) const noexcept
+ { return flip_impl( arr, std::make_index_sequence<n_array>() ); }
+
+ constexpr
+ bool
+ all( array_t const &arr ) const noexcept
+ { return ( N > 0 ) && all_impl( n_words - 1, arr ); }
+
+
+ /// Used for ++ operator.
+ constexpr
+ void
+ increment( array_t &arr ) const noexcept
+ {
+ if( N == 0 ) return;
+
+ size_t c= 0;
+ for( ; c + 1 < n_words; ++c )
+ {
+ if( ( ++arr[c] ) != base_t(0) ) return;
+ }
+ ++arr[c];
+ arr[c] &= hgh_bit_pattern;
+ } // increment
+
+
+ /// Used for -- operator.
+ constexpr
+ void
+ decrement( array_t &arr ) const noexcept
+ {
+ if( N == 0 ) return;
+
+ size_t c= 0;
+ for( ; c + 1 < n_words; ++c )
+ {
+ if( ( arr[c]-- ) != base_t(0) ) return;
+ }
+ --arr[c];
+ arr[c] &= hgh_bit_pattern;
+ } // decrement
+
+ /// Reverse bits
+ constexpr
+ array_t
+ reverse( array_t const &arr ) const noexcept
+ {
+ return n_array == 1
+ ? array_t{{ base_t( reverse_bits<base_t>()(arr[0]) >> n_m_mod ) }}
+ : reverse_impl( arr, std::make_index_sequence<n_array>() );
+ } // reverse
+
+
+ //****************************************************
+
+
+ constexpr
+ bool
+ all_impl( size_t idx, array_t const &arr ) const noexcept
+ {
+ return h_all( idx, arr )
+ && ( ( idx == 0 ) ? true : all_impl( idx - 1, arr ) );
+ }
+
+ constexpr
+ bool
+ h_all( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx + 1 == n_words ) ? ( arr[idx] == hgh_bit_pattern )
+ : ( arr[idx] == all_one );
+ }
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ shift_left_impl( array_t const &arr,
+ std::index_sequence<S...> ) const noexcept
+ { return {{ h_shift_left( S, arr )... }}; }
+
+ constexpr
+ base_t
+ h_shift_left( size_t idx, array_t const &arr ) const noexcept
+ {
+ return h_shift_left1( idx, arr )
+ & ( ( idx+1 == n_words ) ? hgh_bit_pattern : all_one );
+ }
+
+ constexpr
+ base_t
+ h_shift_left1( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx >= n_words || idx < m_shft_div ) ? base_t(0)
+ : base_t( ( arr[idx-m_shft_div] << m_shft_mod )
+ | h_shift_left_rem( idx - m_shft_div, arr ) );
+ }
+
+ constexpr
+ base_t
+ h_shift_left_rem( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx == 0 ) ? base_t(0)
+ : ce_right_shift( base_t( arr[idx-1] & m_shft_left_pattern ),
+ m_shft_leftright_shift );
+ }
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ shift_right_impl( array_t const &arr,
+ std::index_sequence<S...> ) const noexcept
+ { return {{ h_shift_right( S, arr )... }}; }
+
+ constexpr
+ base_t
+ h_shift_right( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx + m_shft_div >= n_words ) ? base_t(0)
+ : base_t( ( arr[idx+m_shft_div] >> m_shft_mod )
+ | h_shift_right_rem( idx + m_shft_div, arr ) );
+ }
+
+ constexpr
+ base_t
+ h_shift_right_rem( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx + 1 >= n_words ) ? base_t(0)
+ : ce_left_shift( base_t( arr[idx+1] & m_shft_right_pattern ),
+ m_shft_leftright_shift );
+ }
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ rotate_left_impl( array_t const &arr,
+ this_t lft,
+ this_t rgt,
+ std::index_sequence<S...> ) const noexcept
+ {
+ return
+ {{ ( S > lft.m_shft_div ? lft.h_shift_left( S, arr )
+ : S == lft.m_shft_div
+ ? base_t( lft.h_shift_left( lft.m_shft_div, arr )
+ | rgt.h_shift_right( lft.m_shft_div, arr ) )
+ : rgt.h_shift_right( S, arr ) )... }};
+ } // rotate_left_impl
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ flip_impl( array_t const &arr, std::index_sequence<S...> ) const noexcept
+ { return {{ h_flip( S, arr )... }}; }
+
+ constexpr
+ base_t
+ h_flip( size_t idx, array_t const &arr ) const noexcept
+ {
+ return ( idx >= n_words ) ? base_t(0)
+ : ( ~arr[idx] )
+ & ( (idx+1 == n_words) ? hgh_bit_pattern : all_one );
+ }
+
+
+ template<size_t ... S>
+ constexpr
+ array_t
+ reverse_impl( array_t const &arr, std::index_sequence<S...> ) const noexcept
+ { return {{ h_reverse( S, arr )... }}; }
+
+ constexpr
+ base_t
+ h_reverse( size_t idx, array_t const &arr ) const noexcept
+ {
+ return idx + 1 == n_words
+ ? base_t( reverse_bits<base_t>()( arr[0] ) >> n_m_mod )
+ : reverse_bits<base_t>()( h2_reverse( idx, arr ) );
+ }
+
+ constexpr
+ base_t
+ h2_reverse( size_t idx, array_t const &arr ) const noexcept
+ {
+ return mod_val == 0 ? arr[n_words-idx-1]
+ : base_t( ( arr[n_words-idx-1] << n_m_mod )
+ | ( arr[n_words-idx-2] >> mod_val ) );
+ }
+
+
+ size_t const m_n_shift_mod;
+ size_t const m_shft_div;
+ size_t const m_shft_mod;
+ size_t const m_shft_leftright_shift;
+ base_t const m_shft_left_pattern;
+ base_t const m_shft_right_pattern;
+
+ }; // struct array_ops
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_ARRAY_OPS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/bit_chars.hpp b/ThirdParty/bitset2/detail/bit_chars.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..5823d384de22c5fbba8ab20df92d5cd31e0171c5
--- /dev/null
+++ b/ThirdParty/bitset2/detail/bit_chars.hpp
@@ -0,0 +1,65 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_BIT_CHARS_CB_HPP
+#define BITSET2_BIT_CHARS_CB_HPP
+
+#include "h_types.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<size_t N,class T>
+ struct bit_chars
+ {
+ using h_t= h_types<T>;
+ using ULONG_t= typename h_t::ULONG_t;
+ using ULLONG_t= typename h_t::ULLONG_t;
+ using base_t= T;
+ //
+ enum : size_t
+ { n_bits= N
+ , ulong_n_bits= h_t::ulong_n_bits ///< #bits in ULONG_t
+ , ullong_n_bits= h_t::ullong_n_bits ///< #bits in ULLONG_t
+ , base_t_n_bits= h_t::base_t_n_bits ///< #bits in T
+ , div_val= n_bits / base_t_n_bits
+ , mod_val= n_bits % base_t_n_bits
+ , n_words= mod_val ? div_val + 1 : div_val ///< #words required
+ , n_array= ( n_words == 0 ) ? 1 : n_words ///< #words used
+ };
+ enum : ULONG_t
+ { ulong_max= ULONG_MAX };
+ enum : base_t
+ { all_one= base_t(~base_t(0))
+ , low_bit_pattern= ///< Mask for idx==0
+ n_bits == 0 ? base_t(0)
+ : ( div_val > 0 || mod_val == 0 )
+ ? all_one
+ : ce_right_shift( all_one, base_t_n_bits - mod_val )
+ , hgh_bit_pattern= ///< Mask for idx+1==n_words
+ n_bits == 0 ? base_t(0)
+ : mod_val == 0
+ ? all_one
+ : ce_right_shift( all_one, base_t_n_bits - mod_val )
+ };
+ }; // struct bit_chars
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_BIT_CHARS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/bitset2_impl.hpp b/ThirdParty/bitset2/detail/bitset2_impl.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..835d76b96ca93392b89416c07d41019547799a60
--- /dev/null
+++ b/ThirdParty/bitset2/detail/bitset2_impl.hpp
@@ -0,0 +1,400 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_IMPL_CB_HPP
+#define BITSET2_IMPL_CB_HPP
+
+#include "bit_chars.hpp"
+#include "array_add.hpp"
+#include "ullong2array.hpp"
+#include "array2u_long_t.hpp"
+#include <bitset>
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+template<size_t N,class T>
+class bitset2_impl
+{
+ using b_chars= bit_chars<N,T>;
+ using h_t= h_types<T>;
+
+public:
+ enum : size_t { n_array= b_chars::n_array
+ , npos= h_t::npos };
+ using base_t= T;
+ using ULONG_t= typename b_chars::ULONG_t;
+ using ULLONG_t= typename b_chars::ULLONG_t;
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+protected:
+ enum : size_t
+ { n_words= b_chars::n_words
+ , ulong_n_bits= b_chars::ulong_n_bits
+ , ullong_n_bits= b_chars::ullong_n_bits
+ , base_t_n_bits= b_chars::base_t_n_bits
+ };
+ enum : ULONG_t
+ { ulong_max= b_chars::ulong_max };
+ enum : base_t
+ { low_bit_pattern= b_chars::low_bit_pattern
+ , hgh_bit_pattern= b_chars::hgh_bit_pattern
+ , all_one= b_chars::all_one
+ };
+
+ template<size_t n_arr_src, class Tsrc>
+ using a2a= detail::array2array<n_array, n_arr_src,T,Tsrc>;
+
+
+ /* ----------------------------------------------------------------------- */
+ constexpr
+ bitset2_impl() noexcept
+ {}
+
+ constexpr
+ bitset2_impl( bitset2_impl const & ) noexcept= default;
+
+ constexpr
+ bitset2_impl( bitset2_impl && ) noexcept= default;
+
+ constexpr
+ bitset2_impl &
+ operator=( bitset2_impl const & ) noexcept= default;
+
+ constexpr
+ bitset2_impl &
+ operator=( bitset2_impl && ) noexcept= default;
+
+ explicit
+ constexpr
+ bitset2_impl( ULLONG_t v ) noexcept
+ : m_value( ullong2array<N,T>()( v ) )
+ {}
+
+ template<size_t n,class Tsrc>
+ explicit
+ constexpr
+ bitset2_impl( std::array<Tsrc,n> const & value ) noexcept
+ : m_value( a2a<n,Tsrc>()( hgh_bit_pattern, value ) )
+ {}
+
+ explicit
+ bitset2_impl( const std::bitset<N> &bs ) noexcept
+ {
+ if( N == 0 ) return;
+ if( ullong_n_bits <= base_t_n_bits && n_words == 1 )
+ {
+ m_value[0]= bs.to_ullong();
+ return;
+ }
+
+ size_t offset= 0;
+ for( size_t ct= 0; ct < n_words; ++ct )
+ {
+ base_t val= base_t(0);
+ auto const bit_limit=
+ ( ct < n_words - 1 ) ? base_t_n_bits : N - offset;
+ for( size_t bit_ct= 0; bit_ct < bit_limit; ++bit_ct )
+ {
+ auto const test_bit= offset + bit_limit - bit_ct - 1;
+ val <<= 1;
+ if( bs.test( test_bit ) ) val |= base_t(1);
+ } // for bit_ct
+ m_value[ct]= val;
+ offset += base_t_n_bits;
+ } // for ct
+ } // bitset2_impl( const std::bitset<N> &bs )
+
+
+ template< class CharT, class Traits, class Alloc >
+ explicit
+ bitset2_impl( std::basic_string<CharT,Traits,Alloc> const &str,
+ typename
+ std::basic_string<CharT,Traits,Alloc>::size_type pos,
+ typename
+ std::basic_string<CharT,Traits,Alloc>::size_type n,
+ CharT zero,
+ CharT one )
+ {
+ auto const str_sz= str.size();
+ if( pos > str_sz )
+ throw std::out_of_range( "bitset2: String submitted to "
+ "constructor smaller than pos" );
+ auto const n_bits= std::min( N, std::min( n, str_sz - pos ) );
+
+ for( size_t bit_ct= 0; bit_ct < n_bits; ++bit_ct )
+ {
+ auto const chr= str[bit_ct+pos];
+ if( Traits::eq( one, chr ) ) set( n_bits - bit_ct - 1 );
+ else if( !Traits::eq( zero, chr ) )
+ throw std::invalid_argument( "bitset2: Invalid argument in "
+ "string submitted to constructor" );
+ } // for bit_ct
+ }
+ /* ----------------------------------------------------------------------- */
+
+
+ //**********************************************************
+
+
+ constexpr
+ array_t &
+ get_data() noexcept
+ { return m_value; }
+
+ constexpr
+ bool
+ operator[]( size_t bit ) const noexcept
+ { return test_noexcept( bit ); }
+
+ constexpr
+ bool
+ test_noexcept( size_t bit ) const noexcept
+ { return m_value[bit / base_t_n_bits] & ( T(1) << ( bit % base_t_n_bits ) ); }
+
+ constexpr
+ bitset2_impl &
+ set( size_t bit, bool value= true )
+ {
+ if( bit >= N )
+ throw std::out_of_range( "bitset2: Setting of bit out of range" );
+ set_noexcept( bit, value );
+ return *this;
+ } // set
+
+ constexpr
+ bitset2_impl &
+ set() noexcept
+ {
+ if( N > 0 )
+ {
+ size_t c= 0;
+ for( ; c < n_words - 1; ++c ) m_value[c]= ~base_t(0);
+ m_value[c]= hgh_bit_pattern;
+ }
+ return *this;
+ } // set
+
+ constexpr
+ bitset2_impl &
+ reset() noexcept
+ {
+ for( size_t c= 0; c < n_array; ++c ) m_value[c]= base_t(0);
+ return *this;
+ }
+
+ constexpr
+ bool
+ test_set( size_t bit, bool value= true )
+ {
+ if( bit >= N )
+ throw std::out_of_range( "bitset2: test_set out of range" );
+ return test_set_noexcept( bit, value );
+ } // test_set
+
+ constexpr
+ bitset2_impl &
+ flip_noexcept( size_t bit ) noexcept
+ {
+ m_value[bit / base_t_n_bits] ^= ( base_t(1) << ( bit % base_t_n_bits ) );
+ return *this;
+ }
+
+ constexpr
+ bitset2_impl &
+ flip( size_t bit )
+ {
+ if( bit >= N )
+ throw std::out_of_range( "bitset2: Flipping of bit out of range" );
+ return flip_noexcept( bit );
+ } // flip
+
+ constexpr
+ bitset2_impl &
+ flip() noexcept
+ {
+ if( N > 0 )
+ {
+ size_t c= 0;
+ for( ; c < n_words - 1; ++c ) m_value[c] ^= ~base_t(0);
+ m_value[c] ^= hgh_bit_pattern;
+ }
+ return *this;
+ } // flip
+
+public:
+ constexpr
+ array_t const &
+ data() const noexcept
+ { return m_value; }
+
+ constexpr
+ ULONG_t
+ to_ulong() const
+ {
+ using a2l= array2u_long_t<N,T,ULONG_t>;
+ return ( N == 0 ) ? 0ul
+ : a2l().check_overflow( m_value )
+ ? throw std::overflow_error( "Cannot convert bitset2 "
+ "to unsigned long" )
+ : a2l()( m_value );
+ } // to_ulong
+
+ constexpr
+ ULLONG_t
+ to_ullong() const
+ {
+ using a2l= array2u_long_t<N,T,ULLONG_t>;
+ return ( N == 0 ) ? 0ull
+ : a2l().check_overflow( m_value )
+ ? throw std::overflow_error( "Cannot convert bitset2 "
+ "to unsigned long long" )
+ : a2l()( m_value );
+ } // to_ullong
+
+ constexpr
+ bool
+ test( size_t bit ) const
+ {
+ return ( bit >= N )
+ ? throw std::out_of_range( "bitset2: Testing of bit out of range" )
+ : operator[]( bit );
+ }
+
+ constexpr
+ void
+ set_noexcept( size_t bit, bool value= true ) noexcept
+ {
+ if( value ) m_value[bit / base_t_n_bits]
+ |= base_t( base_t(1) << ( bit % base_t_n_bits ) );
+ else m_value[bit / base_t_n_bits]
+ &= base_t(~( base_t(1) << ( bit % base_t_n_bits ) ));
+ }
+
+ constexpr
+ bool
+ test_set_noexcept( size_t bit, bool value= true ) noexcept
+ {
+ auto const dv= bit / base_t_n_bits;
+ auto const md= bit % base_t_n_bits;
+ auto const pttrn= ( base_t(1) << md );
+ auto const ret_val= bool( m_value[dv] & pttrn );
+
+ if( value ) m_value[dv] |= pttrn;
+ else m_value[dv] &= ~pttrn;
+
+ return ret_val;
+ } // test_set_noexcept
+
+ constexpr
+ bool
+ none() const noexcept
+ { return detail::array_funcs<n_array,T>().none( m_value ); }
+
+ constexpr
+ bool
+ any() const noexcept
+ { return ( N > 0 ) && !none(); }
+
+ constexpr
+ bool
+ all() const noexcept
+ { return ( N > 0 ) && detail::array_ops<N,T>( 0 ).all( m_value ); }
+
+ constexpr
+ size_t
+ count() const noexcept
+ { return detail::array_funcs<n_array,T>().count( m_value ); }
+
+ /// \brief Returns index of first (least significant) bit set.
+ /// Returns npos if all bits are zero.
+ constexpr
+ size_t
+ find_first() const noexcept
+ {
+ return detail::array_funcs<n_array,T>().idx_lsb_set(m_value, m_value[0], 0);
+ }
+
+ /// \brief Returns index of next (> idx) bit set.
+ /// Returns npos if no more bits set.
+ /// Throws out_of_range if idx >= N.
+ constexpr
+ size_t
+ find_next( size_t idx ) const
+ {
+ return idx >= N
+ ? throw std::out_of_range( "bitset2: find_next index out of range" )
+ : idx + 1 == N
+ ? npos
+ : detail::array_funcs<n_array,T>()
+ .idx_lsb_set( m_value,
+ base_t( m_value[(idx+1) / base_t_n_bits]
+ & ce_left_shift(T(~T(0)),(idx+1) % base_t_n_bits) ),
+ (idx+1) / base_t_n_bits );
+ }
+
+ constexpr
+ bool
+ operator==( bitset2_impl const &v2 ) const noexcept
+ { return detail::array_funcs<n_array,T>().equal( m_value, v2.m_value ); }
+
+ constexpr
+ bool
+ operator!=( bitset2_impl const &v2 ) const noexcept
+ { return !( *this == v2 ); }
+
+ constexpr
+ bool
+ operator<( bitset2_impl const &v2 ) const noexcept
+ { return detail::array_funcs<n_array,T>().less_than( m_value, v2.m_value ); }
+
+ constexpr
+ bool
+ operator<=( bitset2_impl const &v2 ) const noexcept
+ { return ! ( *this > v2 ); }
+
+ constexpr
+ bool
+ operator>( bitset2_impl const &v2 ) const noexcept
+ { return detail::array_funcs<n_array,T>().less_than(v2.m_value, m_value); }
+
+ constexpr
+ bool
+ operator>=( bitset2_impl const &v2 ) const noexcept
+ { return ! ( *this < v2 ); }
+
+ explicit
+ operator std::bitset<N>() const
+ {
+ using b_t= std::bitset<N>;
+ if( N == 0 ) return b_t{};
+ if( n_words == 1 ) return b_t( to_ullong() );
+
+ b_t ret_val;
+ for( size_t ct= 0; ct < N; ++ct ) ret_val[ct]= operator[](ct);
+
+ return ret_val;
+ }
+private:
+ array_t m_value= (detail::gen_empty_array<n_array,T>)();
+}; // class bitset2_impl
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+#endif // BITSET2_IMPL_CB_HPP
diff --git a/ThirdParty/bitset2/detail/count_bits.hpp b/ThirdParty/bitset2/detail/count_bits.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..221e7b05bdf21dd837992c43cd0284b3416c98cb
--- /dev/null
+++ b/ThirdParty/bitset2/detail/count_bits.hpp
@@ -0,0 +1,45 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_COUNT_BITS_CB_HPP
+#define BITSET2_COUNT_BITS_CB_HPP
+
+
+#include "h_types.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ /// Returns the number of bits set in val
+ template<class T>
+ constexpr
+ inline
+ size_t
+ count_bits( T val, size_t count= 0 ) noexcept
+ {
+ return
+ ( val == T(0) )
+ ? count
+ : count_bits( T(val & T( val - T(1) )), // clears lowest set bit
+ count + 1 );
+ }
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_COUNT_BITS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/h_types.hpp b/ThirdParty/bitset2/detail/h_types.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..94b9d9eed1279ecdd32ab2b1132c85ed441db838
--- /dev/null
+++ b/ThirdParty/bitset2/detail/h_types.hpp
@@ -0,0 +1,107 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_H_TYPES_CB_HPP
+#define BITSET2_H_TYPES_CB_HPP
+
+#include <array>
+#include <utility>
+#include <climits>
+#include <type_traits>
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ template<class T,class Enabled=void> struct h_types;
+
+ template<class T>
+ struct h_types<T,
+ typename std::enable_if< std::is_integral<T>::value
+ && std::is_unsigned<T>::value>::type>
+ {
+ using ULONG_t= unsigned long;
+ using ULLONG_t= unsigned long long;
+ using base_t= T;
+
+ template<size_t n_array>
+ using array_t= std::array<base_t,n_array>;
+
+ enum : size_t
+ { ulong_n_bits= sizeof(ULONG_t) * CHAR_BIT ///< #bits in ULONG_t
+ , ullong_n_bits= sizeof(ULLONG_t) * CHAR_BIT ///< #bits in ULLONG_t
+ , base_t_n_bits= sizeof(base_t) * CHAR_BIT ///< #bits in base_t
+ , npos= ~size_t(0)
+ };
+ }; // struct h_types
+
+
+ template<class T>
+ constexpr
+ T
+ ce_min( T v1, T v2 ) noexcept
+ { return ( v1 < v2 ) ? v1 : v2; }
+
+
+
+ /// http://stackoverflow.com/q/29136207/3876684
+ template<class T>
+ constexpr
+ T
+ ce_left_shift( T v1, size_t n_shift ) noexcept
+ {
+ return ( n_shift == 0 ) ? v1
+ : ( ( n_shift >= h_types<T>::base_t_n_bits ) ? T(0)
+ : T( v1 << n_shift ) );
+ }
+
+ template<class T>
+ constexpr
+ T
+ ce_right_shift( T v1, size_t n_shift ) noexcept
+ {
+ return ( n_shift == 0 ) ? v1
+ : ( ( n_shift >= h_types<T>::base_t_n_bits ) ? T(0)
+ : T( v1 >> n_shift ) );
+ }
+
+
+
+ template<size_t n_array,class T,size_t ... S>
+ inline constexpr
+ typename h_types<T>::template array_t<n_array>
+ gen_empty_array_impl( std::index_sequence<S...> ) noexcept
+ {
+ return
+ typename h_types<T>::template array_t<n_array>{{ ( T(S) & T(0) ) ... }};
+ }
+
+
+
+ template<size_t n_array,class T>
+ inline constexpr
+ typename h_types<T>::template array_t<n_array>
+ gen_empty_array() noexcept
+ {
+ return
+ gen_empty_array_impl<n_array,T>( std::make_index_sequence<n_array>() );
+ } // gen_empty_array
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_H_TYPES_CB_HPP
diff --git a/ThirdParty/bitset2/detail/hash.hpp b/ThirdParty/bitset2/detail/hash.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..6248737c8e54f0def420e2eb6a145de34ea2eba3
--- /dev/null
+++ b/ThirdParty/bitset2/detail/hash.hpp
@@ -0,0 +1,126 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_HASH_CB_HPP
+#define BITSET2_HASH_CB_HPP
+
+#include "h_types.hpp"
+
+#include <functional>
+#include <array>
+#include <climits>
+#include <algorithm>
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+
+template<size_t n_words,class T>
+struct hash_impl
+{
+ using base_t= T;
+ using result_type= std::size_t;
+ using array_t= typename h_types<T>::template array_t<n_words>;
+
+ enum : size_t
+ { size_t_bits= sizeof(result_type) * CHAR_BIT ///< #bits in result_type
+ , base_t_n_bits= h_types<T>::base_t_n_bits ///< #bits in T
+ , bits_mod= base_t_n_bits % size_t_bits
+ , bits_div= base_t_n_bits / size_t_bits + ( bits_mod > 0 )
+ , size_t_mod= size_t_bits % base_t_n_bits
+ , size_t_div= size_t_bits / base_t_n_bits
+ };
+
+ enum : bool
+ { easy_bits= ( size_t_bits >= base_t_n_bits )
+ , easy_ratio= ( size_t_mod == 0 )
+ };
+
+ result_type
+ operator()( array_t const & arr ) const noexcept
+ {
+ if( n_words == 0 ) return 0;
+ if( n_words == 1 )
+ {
+ if( easy_bits ) return arr[0];
+ return to_result_t( arr[0] );
+ } // if n_words == 1
+
+ return cmpsd_hash( arr );
+ }
+
+ result_type
+ to_result_t( base_t a ) const noexcept
+ {
+ result_type ret_val= 0;
+ size_t shft= 0;
+ for( size_t c= 0; c < bits_div; ++c, shft += size_t_bits )
+ {
+ auto const crrnt= result_type( a >> shft );
+ do_combine( ret_val, crrnt, c );
+ }
+ return ret_val;
+ } // to_result_t
+
+ result_type
+ cmpsd_hash( array_t const & arr ) const noexcept
+ {
+ result_type ret_val= 0;
+
+ if( easy_ratio )
+ {
+ for( size_t c= 0; c < n_words; c += size_t_div )
+ {
+ result_type r= 0;
+ auto const uppr= std::min( n_words, c + size_t_div );
+ for( size_t w= c; w < uppr; ++w )
+ r |= ( result_type(arr[w]) << ((w-c)*base_t_n_bits) );
+ do_combine( ret_val, r, c / size_t_div );
+ }
+ }
+ else
+ {
+ for( size_t c= 0; c < n_words; ++c )
+ {
+ auto const crrnt= easy_bits
+ ? result_type(arr[c]) : to_result_t(arr[c]);
+ do_combine( ret_val, crrnt, c );
+ }
+ }
+
+ return ret_val;
+ } // cmpsd_hash
+
+ void
+ do_combine( result_type &r, result_type crrnt, size_t cnt ) const noexcept
+ {
+ crrnt += cnt;
+ auto const n_rot= cnt % size_t_bits;
+ if( n_rot > 0 )
+ crrnt= ( crrnt << n_rot ) | ( crrnt >> (size_t_bits-n_rot) );
+
+ r ^= crrnt;
+ } // do_combine
+}; // struct hash_impl
+
+
+
+
+} } // namespace Bitset2::detail
+
+
+
+
+#endif // BITSET2_HASH_CB_HPP
diff --git a/ThirdParty/bitset2/detail/hex_params.hpp b/ThirdParty/bitset2/detail/hex_params.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..66e21f6646324ed08d067adb93aa6b6ca9a08b60
--- /dev/null
+++ b/ThirdParty/bitset2/detail/hex_params.hpp
@@ -0,0 +1,54 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_HEX_PARAMS_CB_HPP
+#define BITSET2_HEX_PARAMS_CB_HPP
+
+#include <string>
+
+
+namespace Bitset2
+{
+
+
+template< class CharT = char,
+ class Traits = std::char_traits<CharT>,
+ class Allocator = std::allocator<CharT> >
+struct hex_params
+{
+ using str_t= std::basic_string<CharT,Traits,Allocator>;
+
+ hex_params( CharT zero_ch= CharT('0'),
+ CharT a_ch= CharT('a'),
+ bool leading_zeroes= true,
+ bool non_empty= true,
+ str_t const & prfx= str_t{} )
+ : zeroCh{ zero_ch }
+ , aCh{ a_ch }
+ , leadingZeroes{ leading_zeroes }
+ , nonEmpty{ non_empty }
+ , prefix{ prfx }
+ {}
+
+ CharT zeroCh= CharT( '0' );
+ CharT aCh= CharT( 'a' );
+ bool leadingZeroes= true;
+ bool nonEmpty= true;
+ str_t prefix;
+}; // struct hex_params
+
+
+
+} // namespace Bitset2
+
+
+#endif // BITSET2_HEX_PARAMS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/index_lsb_set.hpp b/ThirdParty/bitset2/detail/index_lsb_set.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..5c986ca64e654d3a7e9a0f53fa07e1720c8e6e32
--- /dev/null
+++ b/ThirdParty/bitset2/detail/index_lsb_set.hpp
@@ -0,0 +1,73 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#ifndef BITSET2_INDEX_LSB_SET_CB_HPP
+#define BITSET2_INDEX_LSB_SET_CB_HPP
+
+
+#include <limits>
+#include <climits>
+#include <cstddef>
+
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+
+/// https://graphics.stanford.edu/~seander/bithacks.html#ZerosOnRightBinSearch
+template<class T>
+struct index_lsb_set
+{
+ enum : size_t { npos= std::numeric_limits<size_t>::max()
+ , n_bits= sizeof(T) * CHAR_BIT };
+
+ constexpr
+ index_lsb_set() noexcept
+ {
+ static_assert( ( n_bits & ( n_bits - 1 ) ) == 0,
+ "Number of bits in data type is not a power of 2" );
+ }
+
+ /// \brief Returns index of first (least significant) bit set in val.
+ /// Returns npos if all bits are zero.
+ constexpr
+ size_t
+ operator()( T val ) const noexcept
+ {
+ return ( T(0) == val ) ? npos
+ : find_idx( val, T( T(~T(0)) >> (n_bits >> 1) ), n_bits >> 1, 1 );
+ }
+
+private:
+ constexpr
+ size_t
+ find_idx( T val, T pttrn, size_t sh_rght, size_t ct ) const noexcept
+ {
+ return ( sh_rght == 1 ) ? ( ct - size_t( T(val & T(0x1)) ) )
+ : T( val & pttrn ) == T(0)
+ ? find_idx( T(val >> sh_rght), T( pttrn >> ( sh_rght >> 1 )),
+ sh_rght >> 1, ct + sh_rght )
+ : find_idx( val, T(pttrn >> ( sh_rght >> 1 )), sh_rght >> 1, ct );
+ }
+}; // struct index_lsb_set
+
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+#endif // BITSET2_INDEX_LSB_SET_CB_HPP
diff --git a/ThirdParty/bitset2/detail/reverse_bits.hpp b/ThirdParty/bitset2/detail/reverse_bits.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..f4e8db66d9744d9bfca5a80ff9e27a6ceb140039
--- /dev/null
+++ b/ThirdParty/bitset2/detail/reverse_bits.hpp
@@ -0,0 +1,66 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_REVERSE_BITS_CB_HPP
+#define BITSET2_REVERSE_BITS_CB_HPP
+
+#include <limits>
+#include <climits>
+#include <cstddef>
+
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+
+/// https://graphics.stanford.edu/~seander/bithacks.html#ReverseParallel
+template<class T>
+struct reverse_bits
+{
+ enum : size_t { n_bits= sizeof(T) * CHAR_BIT
+ , n_bits_h= n_bits >> 1 };
+
+ constexpr
+ reverse_bits() noexcept
+ {
+ static_assert( ( n_bits & ( n_bits - 1 ) ) == 0,
+ "Number of bits in data type is not a power of 2" );
+ }
+
+ /// \brief Reverses bits in val.
+ constexpr
+ T
+ operator()( T val ) const noexcept { return rvrs( val ); }
+
+private:
+ constexpr
+ T
+ rvrs( T val,
+ T mask= T( ~T(0) ) >> n_bits_h,
+ size_t s= n_bits_h ) const noexcept
+ {
+ return s == 0 ? val
+ : rvrs( ( (val >> s) & mask ) | ( (val << s) & ~mask ),
+ mask ^ ( mask << ( s >> 1 ) ),
+ s >> 1 );
+ }
+}; // struct reverse_bits
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+#endif // BITSET2_REVERSE_BITS_CB_HPP
diff --git a/ThirdParty/bitset2/detail/select_base_t.hpp b/ThirdParty/bitset2/detail/select_base_t.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..abfe92744e1f72dc5fec9a06816bc210ec6dcab5
--- /dev/null
+++ b/ThirdParty/bitset2/detail/select_base_t.hpp
@@ -0,0 +1,82 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#ifndef BITSET2_SELECT_BASE_T_CB_HPP
+#define BITSET2_SELECT_BASE_T_CB_HPP
+
+#include <cstdint>
+#include <cstddef>
+
+namespace Bitset2
+{
+namespace detail
+{
+
+
+template<bool b,class T1, class T2>
+struct if_else { using type= T1; };
+
+template<class T1, class T2>
+struct if_else<false,T1,T2> { using type= T2; };
+
+template<bool b,class T1, class T2>
+using if_else_t= typename if_else<b,T1,T2>::type ;
+
+
+/// \brief Select any of uint8_t, uint16_t, uint32_t or
+/// unsigned long long. Result depends on N and on provision
+/// of these types by compiler.
+template<size_t N>
+struct select_base
+{
+#ifdef INT8_MIN
+ enum : bool { has_int8= true };
+ using UI8= uint8_t;
+#else
+ enum : bool { has_int8= false };
+ using UI8= void;
+#endif
+#ifdef INT16_MIN
+ enum : bool { has_int16= true };
+ using UI16= uint16_t;
+#else
+ enum : bool { has_int16= false };
+ using UI16= void;
+#endif
+#ifdef INT32_MIN
+ enum : bool { has_int32= true };
+ using UI32= uint32_t;
+#else
+ enum : bool { has_int32= false };
+ using UI32= void;
+#endif
+
+ using type=
+ if_else_t< has_int8 && (N<=8), UI8,
+ if_else_t< has_int16 && (N<=16), UI16,
+ if_else_t< has_int32 && (N<=32), UI32,
+ unsigned long long > > >;
+}; // struct select_base
+
+
+template<size_t N>
+using select_base_t= typename select_base<N>::type;
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+
+#endif // BITSET2_SELECT_BASE_T_CB_HPP
diff --git a/ThirdParty/bitset2/detail/ullong2array.hpp b/ThirdParty/bitset2/detail/ullong2array.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..41559858d2ff049d2e5211c0d5ddb5729647c320
--- /dev/null
+++ b/ThirdParty/bitset2/detail/ullong2array.hpp
@@ -0,0 +1,80 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#ifndef BITSET2_ULLONG2ARRAY_CB_HPP
+#define BITSET2_ULLONG2ARRAY_CB_HPP
+
+#include "bit_chars.hpp"
+
+
+namespace Bitset2
+{
+namespace detail
+{
+
+ /// \brief Takes a variable 'v' of type unsigned long long
+ /// and returns a std::array 'a' equivalent to v. 'a' represents
+ /// an N bit bitset2 with base_t == T.
+ template<size_t N,class T>
+ struct ullong2array
+ {
+ using base_t= T;
+ using b_c= bit_chars<N,T>;
+ using ULLONG_t= typename b_c::ULLONG_t;
+
+ enum : size_t
+ { n_bits= N
+ , base_t_n_bits= b_c::base_t_n_bits
+ , ullong_n_bits= b_c::ullong_n_bits
+ , n_array= b_c::n_array
+ , centrl_i= ce_min( (ullong_n_bits-1) / base_t_n_bits, n_array - 1 )
+ , n_empty_vals= n_array - centrl_i - 1
+ };
+
+ enum : base_t
+ { hgh_bit_pattern= b_c::hgh_bit_pattern
+ , use_pattern= (n_empty_vals==0) ? hgh_bit_pattern : base_t(~base_t(0))
+ };
+
+ using array_t= typename h_types<T>::template array_t<n_array>;
+
+ constexpr
+ array_t
+ operator()( ULLONG_t v ) const noexcept
+ {
+ return fill( gen_empty_array<n_array,T>(), v,
+ std::make_index_sequence<n_empty_vals>(),
+ std::make_index_sequence<centrl_i>() );
+ }
+
+ template<size_t ... S1,size_t ... S2>
+ constexpr
+ array_t
+ fill( array_t const & empty, ULLONG_t v,
+ std::index_sequence<S1...>,
+ std::index_sequence<S2...> ) const noexcept
+ {
+ return {{ base_t(ce_right_shift(v, S2 * base_t_n_bits))...,
+ base_t(ce_right_shift(v, centrl_i * base_t_n_bits)&use_pattern),
+ empty[S1]... }};
+ }
+ }; // struct ullong2array
+
+
+} // namespace detail
+} // namespace Bitset2
+
+
+
+
+#endif // BITSET2_ULLONG2ARRAY_CB_HPP
diff --git a/ThirdParty/bitset2/tests/bench01.cpp b/ThirdParty/bitset2/tests/bench01.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..5e5e0071657af83a9032a53fb4a462f2e4c00817
--- /dev/null
+++ b/ThirdParty/bitset2/tests/bench01.cpp
@@ -0,0 +1,131 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "../bitset2.hpp"
+#include "gen_randoms.hpp"
+#include <iostream>
+#include <cassert>
+#include <chrono>
+
+
+
+using ULLONG= unsigned long long;
+
+template<size_t N>
+using t1= Bitset2::bitset2<N>;
+
+template<size_t N>
+using vec_t= std::vector<t1<N> >;
+
+
+constexpr size_t n_loops= 1000000;
+
+template<size_t N>
+vec_t<N>
+gen_bs_vec( size_t n )
+{
+ std::vector<t1<N> > ret_val;
+ gen_random_bitset2<N,ULLONG> gen_rand;
+ ret_val.reserve( n );
+ for( size_t c= 0; c < n; ++c ) ret_val.push_back( gen_rand() );
+
+ return ret_val;
+} // gen_bs_vec
+
+
+template<size_t N>
+void
+apply_or_equal( vec_t<N> & v1, vec_t<N> const & v2 )
+{
+ auto it2= v2.begin();
+ for( auto & bs: v1 ) bs |= *(it2++);
+} // apply_or_equal
+
+
+template<size_t n>
+std::array<ULLONG,n> &
+rm_const( std::array<ULLONG,n> const & a )
+{ return const_cast<std::array<ULLONG,n> &>(a); }
+
+
+template<size_t N>
+void
+array_or_equal( vec_t<N> & v1, vec_t<N> const & v2 )
+{
+ auto const n_array= v1[0].data().size();
+ auto it2= v2.begin();
+ for( auto & bs: v1 )
+ {
+ auto & a1= rm_const( bs.data() );
+ auto & a2= it2->data();
+ for( size_t c= 0; c < n_array; ++c ) a1[c] |= a2[c];
+
+ ++it2;
+ }
+}
+
+
+int main()
+{
+ auto const vec1= gen_bs_vec<2048>( 128 );
+ auto const vec2= gen_bs_vec<2048>( 128 );
+
+ std::cout << "Running computations\n";
+
+ auto const t1 = std::chrono::high_resolution_clock::now();
+
+ auto v1= vec1;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ v1= vec1;
+ apply_or_equal( v1, vec2 );
+ }
+
+ auto const t2 = std::chrono::high_resolution_clock::now();
+
+ auto v1a= vec1;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ v1a= vec1;
+ array_or_equal( v1a, vec2 );
+ }
+
+ auto const t3 = std::chrono::high_resolution_clock::now();
+
+ assert( v1 == v1a );
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ v1a= vec1;
+ array_or_equal( v1a, vec2 );
+ }
+
+ auto const t4 = std::chrono::high_resolution_clock::now();
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ v1= vec1;
+ apply_or_equal( v1, vec2 );
+ }
+
+ auto const t5 = std::chrono::high_resolution_clock::now();
+ const std::chrono::duration<double> dt21 = t2 -t1;
+ const std::chrono::duration<double> dt32 = t3 -t2;
+ const std::chrono::duration<double> dt43 = t4 -t3;
+ const std::chrono::duration<double> dt54 = t5 -t4;
+
+ std::cout << "dt21= " << dt21.count() * 1.0e3 << "ms\n";
+ std::cout << "dt32= " << dt32.count() * 1.0e3 << "ms\n";
+ std::cout << "dt43= " << dt43.count() * 1.0e3 << "ms\n";
+ std::cout << "dt54= " << dt54.count() * 1.0e3 << "ms\n";
+} // main
diff --git a/ThirdParty/bitset2/tests/counter128.cpp b/ThirdParty/bitset2/tests/counter128.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..8adbb698322f764fa3974909b2c8f2c0caac656f
--- /dev/null
+++ b/ThirdParty/bitset2/tests/counter128.cpp
@@ -0,0 +1,29 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+
+#include <iostream>
+#include "bitset2.hpp"
+
+
+int main()
+{
+ Bitset2::bitset2<128> c;
+ constexpr Bitset2::bitset2<128> tst{ 0xFFFFFFFFull };
+
+ for( ;; ++c )
+ {
+ if( ( c & tst) == tst )
+ std::cout << c.to_hex_string() << "\n";
+ }
+} // main
diff --git a/ThirdParty/bitset2/tests/example01.cpp b/ThirdParty/bitset2/tests/example01.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..af1aa2b3e26854c116fa6d0b702cd6fb216f5f61
--- /dev/null
+++ b/ThirdParty/bitset2/tests/example01.cpp
@@ -0,0 +1,52 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+#include <iostream>
+#include <array>
+#include <cassert>
+#include "bitset2.hpp"
+
+template<size_t n_bits>
+using BS2= Bitset2::bitset2<n_bits>;
+
+int main()
+{
+ using bs_128= BS2<128>;
+ using base_t_128= bs_128::base_t;
+ constexpr std::array<base_t_128,2>
+ ar1{{ ~(base_t_128(0)), base_t_128(0xFEDCBA) }};
+ constexpr bs_128 b1{ ar1 };
+ constexpr auto b1_add= b1 + b1;
+ constexpr auto b1_shft= b1 << 1; // binary shift
+ static_assert( b1_add == b1_shft, "" );
+
+ std::cout << b1.to_hex_string() // 0000000000fedcbaffffffffffffffff
+ << "\n"
+ << b1_add.to_hex_string() // 0000000001fdb975fffffffffffffffe
+ << "\n";
+
+ BS2<12> b2;
+ for( size_t c= 0; c < 12; c += 2 ) b2[c]= true;
+ auto b3= ~b2;
+ std::cout << b2 << "\n"; // 010101010101
+ std::cout << b2.flip() << "\n"; // 101010101010
+ assert( b2 == b3 );
+
+ BS2<7> const b4{ "1110000" };
+ auto const b5= Bitset2::rotate_left( b4, 3 );
+ std::cout << b4 << "\n" // 1110000
+ << b5 << "\n"; // 0000111
+
+ BS2<7> b6{ "1010010" };
+ b6.reverse();
+ std::cout << b6 << "\n"; // 0100101
+} // main
diff --git a/ThirdParty/bitset2/tests/gen_randoms.hpp b/ThirdParty/bitset2/tests/gen_randoms.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..9a95e27d2d0d2ef2760195cdc3e2d029fca4b134
--- /dev/null
+++ b/ThirdParty/bitset2/tests/gen_randoms.hpp
@@ -0,0 +1,108 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#ifndef BITSET2_GEN_RANDOMS_CB_HPP
+#define BITSET2_GEN_RANDOMS_CB_HPP
+
+#include "../bitset2.hpp"
+#include <random>
+#include <climits>
+#include <array>
+#include <vector>
+
+
+
+template<class T>
+class gen_randoms
+{
+public:
+ gen_randoms( T max_val, T min_val= 0 )
+ : m_generator( std::random_device{}() )
+ , m_distri( min_val, max_val )
+ {}
+ //
+ T
+ operator()()
+ { return m_distri( m_generator ); }
+ //
+private:
+ std::mt19937 m_generator;
+ std::uniform_int_distribution<T> m_distri;
+}; // class gen_randoms
+
+
+
+
+/// Generate N-bit sized bitset2 randomly
+template<size_t N,class T>
+class gen_random_bitset2
+{
+ //
+ enum : size_t
+ { base_t_n_bits= sizeof(T) * CHAR_BIT
+ , div_val= N / base_t_n_bits
+ , mod_val= N % base_t_n_bits
+ , n_words= mod_val ? div_val + 1 : div_val
+ };
+ enum : T
+ { max_ullong= T(~T(0))
+ , hgh_bit_pattern=
+ N == 0 ? T(0)
+ : mod_val == 0
+ ? max_ullong
+ : max_ullong >> T(base_t_n_bits-mod_val)
+ };
+ //
+ using arr_t= std::array<T,n_words>;
+ //
+public:
+ using b_t= Bitset2::bitset2<N,T>;
+ //
+ gen_random_bitset2()
+ : m_gen{ gen_generators() }
+ {}
+ //
+ b_t
+ operator()()
+ {
+ arr_t a;
+ for( size_t c= 0; c < n_words; ++c ) a[c]= m_gen[c]();
+ return b_t( a );
+ }
+ //
+private:
+ using gen_rand_t= gen_randoms<T>;
+
+ std::vector<gen_rand_t> m_gen;
+ //
+ std::vector<gen_rand_t>
+ gen_generators()
+ {
+ std::vector<gen_rand_t> ret_val;
+
+ if( n_words > 0 )
+ {
+ ret_val.reserve( n_words );
+ for( size_t c= 0; c < n_words - 1; ++c )
+ ret_val.push_back( gen_rand_t{ max_ullong } );
+ ret_val.push_back( gen_rand_t{ hgh_bit_pattern } );
+ }
+
+ return ret_val;
+ }
+}; // gen_random_bitset2
+
+
+
+
+#endif // BITSET2_GEN_RANDOMS_CB_HPP
diff --git a/ThirdParty/bitset2/tests/gray_code.cpp b/ThirdParty/bitset2/tests/gray_code.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..72765bb92ccc69251a86fff3a712a6912ad01af3
--- /dev/null
+++ b/ThirdParty/bitset2/tests/gray_code.cpp
@@ -0,0 +1,50 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "../bitset2.hpp"
+#include <cassert>
+#include <iostream>
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+binary_to_gray( Bitset2::bitset2<N,T> const &bs )
+{ return bs ^ (bs >> 1); }
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+gray_to_binary( Bitset2::bitset2<N,T> bs )
+{
+ Bitset2::bitset2<N,T> mask= bs >> 1;
+ for( ; !mask.none(); mask >>= 1 ) bs ^= mask;
+ return bs;
+} // gray_to_binary
+
+
+int main()
+{
+ using ULLONG= unsigned long long;
+ constexpr std::array<ULLONG,2> arr_01a{{ 0xFEFDFCFBFAF9F8F7ull, 1ull }};
+ constexpr Bitset2::bitset2<129> bs_01a{ arr_01a };
+ constexpr auto gray_01a= binary_to_gray( bs_01a );
+ constexpr auto bin_01a= gray_to_binary( gray_01a );
+
+ static_assert( bs_01a == bin_01a );
+
+ std::cout << bs_01a << '\n' << gray_01a << '\n';
+
+ return 0;
+} // main
diff --git a/ThirdParty/bitset2/tests/mk.sh b/ThirdParty/bitset2/tests/mk.sh
new file mode 100755
index 0000000000000000000000000000000000000000..45d30d119a2aada0a3fe3e3e541689c4ae869e5d
--- /dev/null
+++ b/ThirdParty/bitset2/tests/mk.sh
@@ -0,0 +1,43 @@
+cc=g++-7
+#cc=clang++
+
+
+p=gray_code
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -I../detail -fdiagnostics-color=auto $p.cpp -o $p
+
+p=test_nonconst_constexpr01
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -I../detail -fdiagnostics-color=auto $p.cpp -o $p
+
+p=test_array2array
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -I../detail -fdiagnostics-color=auto $p.cpp -o $p
+
+p=tests01
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -fdiagnostics-color=auto $p.cpp -o $p
+
+p=test_bitset2_01
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -Wno-unused-but-set-variable -std=c++1z -I.. -fdiagnostics-color=auto $p.cpp -o $p
+
+p=test_bitset2_02
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -fdiagnostics-color=auto $p.cpp -o $p
+
+p=counter128
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -fdiagnostics-color=auto $p.cpp -o $p
+
+p=bench01
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -fdiagnostics-color=auto -D_GLIBCXX_USE_NANOSLEEP $p.cpp -o $p
+
+p=example01
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -fdiagnostics-color=auto $p.cpp -o $p
+
+p=test_ullong2array
+echo "Compiling $p"
+$cc -O2 -Wall -Wextra -std=c++1z -I.. -I../detail -fdiagnostics-color=auto $p.cpp -o $p
diff --git a/ThirdParty/bitset2/tests/test_array2array.cpp b/ThirdParty/bitset2/tests/test_array2array.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..70bb3e5ab4d7705679a0496f7d73a5a00d88c690
--- /dev/null
+++ b/ThirdParty/bitset2/tests/test_array2array.cpp
@@ -0,0 +1,111 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "array2array.hpp"
+#include "gen_randoms.hpp"
+#include <iostream>
+#include <cstdint>
+#include <cassert>
+
+
+
+constexpr size_t n_loops= 100000;
+
+
+
+template<class T1,class T2>
+void
+fwd_bckwd()
+{
+ constexpr size_t bits_T1= sizeof(T1) * CHAR_BIT;
+ constexpr size_t bits_T2= sizeof(T2) * CHAR_BIT;
+
+ constexpr size_t t_n1= 8, s_n1= 1;
+ constexpr size_t t_n2= 24, s_n2= 3;
+
+ using a2a_t1a= Bitset2::detail::array2array<t_n1,s_n1,T2,T1>;
+ using a2a_t1b= Bitset2::detail::array2array<s_n1,t_n1,T1,T2>;
+ using a2a_t2a= Bitset2::detail::array2array<t_n1,s_n1,T1,T2>;
+ using a2a_t2b= Bitset2::detail::array2array<s_n1,t_n1,T2,T1>;
+
+ using a2a_t3a= Bitset2::detail::array2array<t_n2,s_n2,T2,T1>;
+ using a2a_t3b= Bitset2::detail::array2array<s_n2,t_n2,T1,T2>;
+ using a2a_t4a= Bitset2::detail::array2array<t_n2,s_n2,T1,T2>;
+ using a2a_t4b= Bitset2::detail::array2array<s_n2,t_n2,T2,T1>;
+
+ gen_random_bitset2<s_n1*bits_T1,T1> gen_rand1a;
+ gen_random_bitset2<s_n1*bits_T2,T2> gen_rand1b;
+
+ gen_random_bitset2<s_n2*bits_T1-bits_T1/2,T1> gen_rand2a;
+ gen_random_bitset2<s_n2*bits_T2-bits_T2/2,T2> gen_rand2b;
+
+ for( size_t ct= 0; ct < n_loops; ++ct )
+ {
+ // if( (ct+1) % 1000 == 0 ) std::cout << (ct+1) << '\n';
+
+ auto const bs1= gen_rand1a();
+ auto const a1a= a2a_t1a()( ~T2(0), bs1.data() );
+ auto const a1b= a2a_t1b()( ~T1(0), a1a );
+ assert( bs1.data() == a1b );
+
+ auto const bs2= gen_rand1b();
+ auto const a2a= a2a_t2a()( ~T1(0), bs2.data() );
+ auto const a2b= a2a_t2b()( ~T2(0), a2a );
+ assert( bs2.data() == a2b );
+
+ auto const bs3= gen_rand2a();
+ auto const a3a= a2a_t3a()( ~T2(0), bs3.data() );
+ auto const a3b= a2a_t3b()( T1(T1(~T1(0)) >> (bits_T1/2)), a3a );
+ assert( bs3.data() == a3b );
+
+ auto const bs4= gen_rand2b();
+ auto const a4a= a2a_t4a()( ~T1(0), bs4.data() );
+ auto const a4b= a2a_t4b()( T2(T2(~T2(0)) >> (bits_T2/2)), a4a );
+ assert( bs4.data() == a4b );
+ } // for ct
+} // fwd_bckwd
+
+
+int main()
+{
+
+ constexpr size_t t_n1= 2, s_n1= 2;
+
+ std::cout << Bitset2::detail::array2array<t_n1,s_n1,uint16_t,uint8_t>::h_all_set
+ << " "
+ // << Bitset2::detail::array2array<t_n1,s_n1,uint8_t,uint16_t>::h_all_set
+ // << " "
+ << Bitset2::detail::array2array<t_n1,s_n1,uint8_t,uint32_t>::h_all_set
+ << " "
+ << Bitset2::detail::array2array<t_n1,s_n1,uint16_t,uint32_t>::h_all_set
+ << " "
+ << Bitset2::detail::array2array<t_n1,s_n1,uint16_t,uint64_t>::h_all_set
+ << " "
+ << Bitset2::detail::array2array<t_n1,s_n1,uint32_t,uint64_t>::h_all_set
+ << '\n';
+
+ std::cout << " 8 <-> 64\n";
+ fwd_bckwd<uint8_t,uint64_t>();
+ std::cout << "16 <-> 64\n";
+ fwd_bckwd<uint16_t,uint64_t>();
+ std::cout << "32 <-> 64\n";
+ fwd_bckwd<uint32_t,uint64_t>();
+
+ std::cout << "\n 8 <-> 32\n";
+ fwd_bckwd<uint8_t,uint32_t>();
+ std::cout << "16 <-> 32\n";
+ fwd_bckwd<uint16_t,uint32_t>();
+
+ std::cout << "\n 8 <-> 16\n";
+ fwd_bckwd<uint8_t,uint16_t>();
+} // main
diff --git a/ThirdParty/bitset2/tests/test_bitset2_01.cpp b/ThirdParty/bitset2/tests/test_bitset2_01.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..2113e96f53a4c4193e87825188f9a0de7a773c78
--- /dev/null
+++ b/ThirdParty/bitset2/tests/test_bitset2_01.cpp
@@ -0,0 +1,420 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include <iostream>
+#include <sstream>
+#include <cassert>
+#include "bitset2.hpp"
+
+
+template<size_t N,class T>
+constexpr
+bool
+is_subset_of( Bitset2::bitset2<N,T> const &bs1,
+ Bitset2::bitset2<N,T> const &bs2 ) noexcept
+{
+ using base_t= T;
+ return Bitset2::zip_fold_and( bs1, bs2,
+ []( base_t v1, base_t v2 ) noexcept
+ { return (v1 & ~v2) == 0; } );
+} // is_subset_of
+
+
+template<size_t N,class T>
+constexpr
+bool
+unequal( Bitset2::bitset2<N,T> const &bs1,
+ Bitset2::bitset2<N,T> const &bs2 ) noexcept
+{
+ using base_t= T;
+ return Bitset2::zip_fold_or( bs1, bs2,
+ []( base_t v1, base_t v2 ) noexcept
+ { return v1 != v2; } );
+} // unequal
+
+
+
+int main()
+{
+ using namespace Bitset2;
+ using ULLONG= unsigned long long;
+
+ constexpr bitset2<32> b1;
+ constexpr auto v1= b1.to_ullong();
+ constexpr auto b1_n= ~b1;
+ constexpr bool b1_n_none= b1_n.none();
+ constexpr bool b1_n_all= b1_n.all();
+ constexpr bool b1_n_any= b1_n.any();
+
+ bitset2<63> b_63;
+ bitset2<64> b_64;
+ bitset2<65> b_65;
+ auto b1a= b1;
+ b1a.set();
+ b_63.set();
+ b_64.set();
+ b_65.set();
+
+ std::bitset<65> sb1;
+ auto sb2= std::bitset<32>( b1 );
+ sb1[64]= 1;
+
+ bitset2<65> b2( sb1 );
+
+ std::cout << v1 << "\n"
+ << b2 << "\n"
+ << sb2 << "\n"
+ << b1_n << "\n"
+ << "b1.none()= " << b1.none() << " "
+ << "b1.any()= " << b1.any() << " "
+ << "b1.all()= " << b1.all() << "\n"
+ << "b1a.none()= " << b1a.none() << " "
+ << "b1a.any()= " << b1a.any() << " "
+ << "b1a.all()= " << b1a.all() << "\n"
+ << "b2.none()= " << b2.none() << " "
+ << "b2.any()= " << b2.any() << " "
+ << "b2.all()= " << b2.all() << "\n"
+ << "b1_n.none()= " << b1_n_none << " "
+ << "b1_n.any()= " << b1_n_any << " "
+ << "b1_n.all()= " << b1_n_all << "\n"
+ << "b_63.all()= " << b_63.all() << " "
+ << "b_64.all()= " << b_64.all() << " "
+ << "b_65.all()= " << b_65.all() << "\n";
+ std::cout << "b_63.flip()= " << b_63.flip() << "\n"
+ << "b_64.flip()= " << b_64.flip() << "\n"
+ << "b_65.flip()= " << b_65.flip() << "\n";
+ std::cout << "b_63.flip()= " << b_63.flip() << "\n"
+ << "b_64.flip()= " << b_64.flip() << "\n"
+ << "b_65.flip()= " << b_65.flip() << "\n";
+ std::cout << "b_63.reset()= " << b_63.reset() << "\n"
+ << "b_64.reset()= " << b_64.reset() << "\n"
+ << "b_65.reset()= " << b_65.reset() << "\n";
+
+ detail::bit_chars<4,ULLONG> bc1;
+ detail::bit_chars<64,ULLONG> bc2;
+ detail::bit_chars<65,ULLONG> bc3;
+ detail::bit_chars<63,ULLONG> bc4;
+
+ bitset2<64> lbp1( bc1.low_bit_pattern );
+ bitset2<64> lbp2( bc2.low_bit_pattern );
+ bitset2<64> lbp3( bc3.low_bit_pattern );
+ bitset2<64> lbp4( bc4.low_bit_pattern );
+
+ std::cout << bc1.low_bit_pattern << " " << bc1.mod_val << "\n"
+ << " " << lbp1 << "\n"
+ << bc2.low_bit_pattern << " " << bc2.mod_val << "\n"
+ << " " << lbp2 << "\n"
+ << bc3.low_bit_pattern << " " << bc3.mod_val << "\n"
+ << " " << lbp3 << "\n"
+ << bc4.low_bit_pattern << " " << bc4.mod_val << "\n"
+ << " " << lbp4 << "\n";
+
+ constexpr
+ std::array<unsigned long long,2> ar1{{ ~(0ull), 1 }};
+
+ constexpr
+ auto s_ar1= detail::array_ops<128,ULLONG>( 63 ).shift_left( ar1 );
+
+ std::cout << "\n" << ar1[1] << " " << ar1[0] << "\n";
+ std::cout << "\n" << s_ar1[1] << " " << s_ar1[0] << "\n";
+
+ bitset2<63> bc5{ 1ull };
+ bitset2<64> bc6{ 1ull };
+ bitset2<65> bc7{ 1ull };
+ constexpr bitset2<63> bc5a{ 1ull };
+ constexpr bitset2<64> bc6a{ 1ull };
+ constexpr bitset2<65> bc7a{ 1ull };
+ constexpr bitset2<127> bc8a{ 1ull };
+ constexpr bitset2<128> bc9a{ 1ull };
+ constexpr bitset2<129> bc10a{ 1ull };
+ constexpr auto bc5b= bc5a << 62;
+ constexpr auto bc6b= bc6a << 63;
+ constexpr auto bc7b= bc7a << 64;
+ constexpr auto bc8b= bc8a << 62;
+ constexpr auto bc8c= bc8a << 63;
+ constexpr auto bc8d= bc8a << 64;
+ constexpr auto bc9b= bc9a << 62;
+ constexpr auto bc9c= bc9a << 63;
+ constexpr auto bc9d= bc9a << 64;
+ constexpr auto bc10b= bc10a << 62;
+ constexpr auto bc10c= bc10a << 63;
+ constexpr auto bc10d= bc10a << 64;
+ std::cout << " " << bc8b << "\n " << bc8c << "\n " << bc8d << "\n";
+ std::cout << " " << bc9b << "\n " << bc9c << "\n " << bc9d << "\n";
+ std::cout << bc10b << "\n" << bc10c << "\n" << bc10d << "\n";
+ std::cout << bc5b << " " << bc6b << " " << bc7b << "\n";
+ for( size_t c= 0; c < 66; ++c )
+ {
+ std::cout << bc5 << " " << bc6 << " " << bc7 << "\n";
+ bc5 <<= 1; bc6 <<= 1; bc7 <<= 1;
+ }
+
+ std::cout << "\n";
+ constexpr auto bc5c= bc5b >> 62;
+ constexpr auto bc6c= bc6b >> 63;
+ constexpr auto bc7c= bc7b >> 64;
+ std::cout << bc5c << " " << bc6c << " " << bc7c << "\n";
+
+ constexpr auto bc5d= bc5a | bc5b;
+ constexpr auto bc5e= bc5d & bc5a;
+ constexpr auto bc5f= bc5d & bc5b;
+ constexpr auto bc5g= bc5a ^ bc5b;
+ constexpr auto bc5h= bc5d ^ bc5a;
+ constexpr auto bc5i= bc5d ^ bc5b;
+ constexpr auto bc5j= bc5a << 1;
+ std::cout << "\n" << bc5a << " |\n" << bc5b << " =\n" << bc5d << "\n";
+ std::cout << "\n" << bc5d << " &\n" << bc5a << " =\n" << bc5e << "\n";
+ std::cout << "\n" << bc5d << " &\n" << bc5b << " =\n" << bc5f << "\n";
+ std::cout << "\n" << bc5a << " ^\n" << bc5b << " =\n" << bc5g << "\n";
+ std::cout << "\n" << bc5d << " ^\n" << bc5a << " =\n" << bc5h << "\n";
+ std::cout << "\n" << bc5d << " ^\n" << bc5b << " =\n" << bc5i << "\n";
+ std::cout << "\n" << bc5a << " << 1 = " << bc5j << "\n";
+
+ constexpr auto bc7d= bc7a | bc7b;
+ constexpr auto bc7e= bc7d & bc7a;
+ constexpr auto bc7f= bc7d & bc7b;
+ constexpr auto bc7g= bc7a ^ bc7b;
+ constexpr auto bc7h= bc7d ^ bc7a;
+ constexpr auto bc7i= bc7d ^ bc7b;
+ std::cout << "\n" << bc7a << " |\n" << bc7b << " =\n" << bc7d << "\n";
+ std::cout << "\n" << bc7d << " &\n" << bc7a << " =\n" << bc7e << "\n";
+ std::cout << "\n" << bc7d << " &\n" << bc7b << " =\n" << bc7f << "\n";
+ std::cout << "\n" << bc7a << " ^\n" << bc7b << " =\n" << bc7g << "\n";
+ std::cout << "\n" << bc7d << " ^\n" << bc7a << " =\n" << bc7h << "\n";
+ std::cout << "\n" << bc7d << " ^\n" << bc7b << " =\n" << bc7i << "\n";
+
+ constexpr auto bc5a_f= ~bc5a;
+ constexpr auto bc5d_f= ~bc5d;
+ constexpr auto bc7a_f= ~bc7a;
+ constexpr auto bc7d_f= ~bc7d;
+ std::cout << "\n~" << bc5a << " =\n " << bc5a_f << "\n";
+ std::cout << "\n~" << bc5d << " =\n " << bc5d_f << "\n";
+ std::cout << "\n~" << bc7a << " =\n " << bc7a_f << "\n";
+ std::cout << "\n~" << bc7d << " =\n " << bc7d_f << "\n";
+ std::cout << "\n";
+ bitset2<65> bc11a{ 1ull };
+ bitset2<65> bc11b{ 1ull };
+ bc11b <<= 64;
+ bc11b |= ( bc11a << 1 );
+ std::cout << bc11b << "\n";
+ bc11b >>= 1;
+ std::cout << bc11b << "\n";
+ std::cout << bc11b.to_string( '.', 'x' ) << "\n";
+
+ constexpr auto n_5a= bc5a.count();
+ constexpr auto n_5a_f= bc5a_f.count();
+ constexpr auto n_7a= bc7a.count();
+ constexpr auto n_7a_f= bc7a_f.count();
+ std::cout << "count( " << bc5a << " )= " << n_5a << "\n";
+ std::cout << "count( " << bc5a_f << " )= " << n_5a_f << "\n";
+ std::cout << "count( " << bc7a << " )= " << n_7a << "\n";
+ std::cout << "count( " << bc7a_f << " )= " << n_7a_f << "\n";
+ std::cout << "\n";
+ b_63.reset();
+ b_64.reset();
+ b_65.reset();
+ auto b_63a= b_63;
+ auto b_64a= b_64;
+ auto b_65a= b_65;
+ for( size_t c= 0; c < 64; c += 2 )
+ {
+ if( c < 63 ) b_63[c]= true;
+ if( c < 64 ) b_64[c]= true;
+ if( c < 65 ) b_65[c]= true;
+ b_63a[c/2]= true; b_64a[c/2]= true; b_65a[c/2]= true;
+ }
+ std::cout << "Hash values:\n";
+ std::cout << " " << b_63 << " " << std::hash<bitset2<63>>()( b_63 ) << "\n"
+ << " " << b_64 << " " << std::hash<bitset2<64>>()( b_64 ) << "\n"
+ << b_65 << " " << std::hash<bitset2<65>>()( b_65 ) << "\n";
+
+ bitset2<0> b_0a, b_0b;
+ constexpr auto bl_c7d= bc7d == bc7d;
+ std::cout << "\n" << ( b_63 == b_63 ) << " "
+ << ( b_64 == b_64 ) << " "
+ << ( b_65 == b_65 ) << "\n"
+ << ( b_63 != b_63a ) << " "
+ << ( b_64 != b_64a ) << " "
+ << ( b_65 != b_65a ) << " "
+ << bl_c7d << "\n"
+ << ( b_0a == b_0b ) << "\n";
+
+ constexpr bitset2<65> bs33a( 0xFFFFFFFFFFFFFFFFull );
+ // constexpr auto bs33b= ( bs33a << 1 );
+ //constexpr
+ auto bs33a_v= bs33a.to_ulong();
+ std::cout << bs33a << " == " << bs33a_v << " == " << bs33a.to_hex_string() << "\n";
+ // auto bs33b_v= bs33b.to_ulong(); // throws
+ // std::cout << bs33b << " == " << bs33b_v << "\n";
+
+ bitset2<63> bc2_63{ 0x700000000000000Eull };
+ constexpr bitset2<63> bc2_63a{ 0x700000000000000Eull };
+ constexpr auto bc2_63b= rotate_right( bc2_63a, 5 );
+ bitset2<65> bc2_65{ 0x700000000000000Eull };
+ constexpr bitset2<65> bc2_65a{ 0x700000000000000Eull };
+ constexpr auto bc2_65b= rotate_right( bc2_65a, 5 );
+ std::cout << " bc2_63= " << bc2_63
+ << " == " << bc2_63.to_hex_string() << "\n";
+ bc2_63.rotate_left( 5 );
+ std::cout << "rot_left( bc2_63, 5) = " << bc2_63 << "\n";
+ std::cout << "rot_right( bc2_63a,5)= " << bc2_63b << "\n";
+
+ std::cout << " bc2_65= " << bc2_65
+ << " == " << bc2_65.to_hex_string() << "\n";
+ bc2_65.rotate_left( 5 );
+ std::cout << "rot_left( bc2_65, 5) = " << bc2_65 << "\n";
+ std::cout << "rot_right( bc2_65a,5)= " << bc2_65b << "\n";
+
+ constexpr auto add_b5a= bc5a + bc5j;
+ constexpr auto add_b5b= bc5a + bc5a;
+ std::cout << bc5a << " +\n" << bc5j << " =\n" << add_b5a << "\n";
+ std::cout << bc5a << " +\n" << bc5a << " =\n" << add_b5b << "\n";
+
+ constexpr std::array<ULLONG,2> arr_add_01a{{ 0xFFFFFFFFFFFFFFFFull, 0ull }};
+ std::array<ULLONG,2> arr_add_01ap{{ 0xFFFFFFFFFFFFFFFFull, 0ull }};
+ constexpr std::array<ULLONG,2> arr_add_01b{{ 0xFFFFFFFFFFFFFFFFull, 1ull }};
+ constexpr bitset2<64> b_a_01a( 0xFFFFFFFFFFFFFFFFull );
+ constexpr bitset2<128> b_a_02a( arr_add_01a );
+ bitset2<128> b_a_02ap( arr_add_01ap );
+ constexpr bitset2<128> b_a_02b( arr_add_01b );
+
+ std::cout << b_a_02ap.to_hex_string() << "\n";
+
+ constexpr auto add_b_a_01a= b_a_01a + b_a_01a;
+ constexpr auto add_b_a_02a= b_a_02a + b_a_02a;
+ constexpr auto add_b_a_02b= b_a_02a + b_a_02b;
+ constexpr auto add_b_a_02c= b_a_02b + b_a_02b;
+ std::cout << b_a_01a << " +\n" << b_a_01a << " =\n" << add_b_a_01a << "\n\n";
+ std::cout << b_a_02a << " +\n" << b_a_02a << " =\n" << add_b_a_02a << "\n\n";
+ std::cout << b_a_02a << " +\n" << b_a_02b << " =\n" << add_b_a_02b << "\n\n";
+ std::cout << b_a_02b << " +\n" << b_a_02b << " =\n" << add_b_a_02c << "\n\n";
+
+ bitset2<65> bc2_65c{ 0xF00000000000000Eull };
+ std::cout << bc2_65c << " +\n" << bc2_65a << " =\n";
+ bc2_65c += bc2_65a;
+ std::cout << bc2_65c << "\n\n";
+
+ bitset2<65> bc2_65d{ 0xFFFFFFFFFFFFFFFEull };
+ std::cout << "++" << bc2_65d << "=\n ";
+ std::cout << (++bc2_65d) << "\n";
+
+ bitset2<65> bc2_65e = bc2_65d << 1;
+
+ std::cout << "++" << bc2_65d << "=\n ";
+ std::cout << (++bc2_65d) << "\n";
+
+ std::cout << "++" << bc2_65e << "=\n ";
+ std::cout << (++bc2_65e) << "\n";
+ std::cout << " " << bc2_65e << "++ =\n ";
+ bc2_65e++;
+ std::cout << bc2_65e << "\n";
+
+ bitset2<65> bc2_65f= bitset2<65>{1ull} << 64;
+ bitset2<65> bc2_65g;
+ std::cout << "\n--" << bc2_65f << "=\n ";
+ std::cout << (--bc2_65f) << "\n";
+ std::cout << " " << bc2_65f << "-- =\n ";
+ bc2_65f--;
+ std::cout << bc2_65f << "\n";
+ std::cout << "--" << bc2_65g << "=\n ";
+ std::cout << (--bc2_65g) << "\n";
+
+ std::string bit_string = "101110";
+ std::istringstream bit_stream( bit_string );
+ bitset2<3> b_from_stream1;
+ bitset2<3> b_from_str2( bit_string, 3 );
+ bitset2<4> b_from_str3( bit_string.c_str() + 1, 3 );
+ bit_stream >> b_from_stream1;
+ std::cout << b_from_stream1
+ << "= 0x" << b_from_stream1.to_hex_string() << '\n';
+ std::cout << b_from_str2
+ << "= 0x" << b_from_str2.to_hex_string() << '\n';
+ std::cout << b_from_str3
+ << "= 0x" << b_from_str3.to_hex_string() << '\n';
+
+
+ constexpr std::array<ULLONG,1> s_arr_01a{{ 1ull }};
+ constexpr std::array<ULLONG,2> s_arr_01b{{ 0xFFFFFFFFFFFFFFFFull, 1ull }};
+ constexpr std::array<ULLONG,3> s_arr_01c{{ 0x1ull, 0xFFFFFFFFFFFFFFFFull, 0x3ull }};
+ constexpr std::array<ULLONG,4> s_arr_01d{{ 0xEEEEEEEEEEEEEEEEull, 0xDull, 1ull, 0xFFFFFFFFFFFFFFFFull }};
+ constexpr bitset2<129> b_from_s_arr01a{ s_arr_01a };
+ constexpr bitset2<129> b_from_s_arr01b{ s_arr_01b };
+ constexpr bitset2<129> b_from_s_arr01c{ s_arr_01c };
+ constexpr bitset2<129> b_from_s_arr01d{ s_arr_01d };
+ std::cout << "b_from_s_arr01a= " << b_from_s_arr01a.to_hex_string() << "\n";
+ std::cout << "b_from_s_arr01b= " << b_from_s_arr01b.to_hex_string() << "\n";
+ std::cout << "b_from_s_arr01c= " << b_from_s_arr01c.to_hex_string() << "\n";
+ std::cout << "b_from_s_arr01d= " << b_from_s_arr01d.to_hex_string() << "\n";
+
+ constexpr bitset2<24> b24_empty{ 0ull };
+ constexpr bitset2<24> b24_full= ~b24_empty;
+ constexpr bitset2<23> b23_a= convert_to<23>( b24_full );
+ constexpr bitset2<25> b25_a= convert_to<25>( b24_full );
+ constexpr auto b24_full_ui8= convert_to<24,uint8_t>( b24_full );
+ std::cout << "b24_full= " << b24_full << "\n";
+ std::cout << "b23_a= " << b23_a << "\n";
+ std::cout << "b25_a= " << b25_a << "\n";
+ std::cout << "b24_full_ui8= " << b24_full_ui8 << '\n';
+
+ bitset2<7> b7_a( "1010101" );
+ bitset2<7> b7_b( "1000101" );
+ bitset2<7> b7_c( "1110101" );
+ bitset2<7> b7_d( "0110101" );
+ bitset2<7> b7_e( "1010101" );
+
+ constexpr bitset2<7> b7_a_ce( 0b1010101ull );
+ constexpr bitset2<7> b7_b_ce( 0b1000101ull );
+
+ assert( is_subset_of( b7_b, b7_a ) );
+ assert( !is_subset_of( b7_c, b7_a ) );
+ assert( !is_subset_of( b7_d, b7_a ) );
+ assert( !is_subset_of( b7_a, b7_d ) );
+
+ assert( unequal( b7_a, b7_b ) );
+ assert( !unequal( b7_e, b7_a ) );
+
+ static_assert( is_subset_of( b7_b_ce, b7_a_ce ), "" );
+ static_assert( unequal( b7_a_ce, b7_b_ce ), "" );
+
+ assert( b7_b < b7_a );
+ assert( b7_c > b7_a );
+ assert( b7_e <= b7_a );
+ assert( b7_a >= b7_d );
+
+ bitset2<2047> b2047_a( 1ull );
+ auto b2047_b= b2047_a << 999;
+ auto b2047_c= b2047_a + b2047_b;
+ auto b2047_d= b2047_a << 1999;
+ std::cout << "b2047_a= " << b2047_a.to_hex_string() << "\n"
+ << "b2047_b= " << b2047_b.to_hex_string() << "\n"
+ << "b2047_c= " << b2047_c.to_hex_string() << "\n";
+ std::cout << "bitset2<2047>::n_array= " << bitset2<2047>::n_array << '\n';
+ assert( unequal( b2047_a, b2047_b ) );
+ assert( unequal( b2047_b, b2047_d ) );
+ assert( is_subset_of( b2047_a, b2047_c ) );
+ assert( !is_subset_of( b2047_b, b2047_d ) );
+
+ bitset2<16> b16_a( "0000101000011111" );
+ bitset2<16> b16_b;
+ hex_params<> hp1;
+ hp1.aCh= 'A';
+ hp1.leadingZeroes= false;
+ hp1.prefix= "0x";
+ std::cout << '\n'
+ << b16_a.to_hex_string() << '\n' // 0a1f
+ << b16_a.to_hex_string( hp1 ) // 0xA1F
+ << '\n'
+ << b16_b.to_hex_string() << '\n' // 0000
+ << b16_b.to_hex_string( hex_params<>{'0', 'a', false, false, "0X"}) // 0X
+ << '\n';
+} // main
diff --git a/ThirdParty/bitset2/tests/test_bitset2_02.cpp b/ThirdParty/bitset2/tests/test_bitset2_02.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..9c8de9c842027b3199b549a5380b0f45c90d9864
--- /dev/null
+++ b/ThirdParty/bitset2/tests/test_bitset2_02.cpp
@@ -0,0 +1,49 @@
+
+#include <iostream>
+#include "bitset2.hpp"
+
+
+int main()
+{
+ using namespace Bitset2;
+
+ using ULLONG= unsigned long long;
+
+ constexpr
+ std::array<ULLONG,1> a01{{1ull}};
+
+ constexpr
+ std::array<ULLONG,0> a02{};
+
+ constexpr auto a_app01= detail::array_funcs<1,ULLONG>().prepend( 2ull, a01 );
+ constexpr auto a_app02= detail::array_funcs<0,ULLONG>().prepend( 3ull, a02 );
+ std::cout << a_app01[0] << "\t" << a_app01[1] << "\n";
+ std::cout << a_app02[0] << "\n";
+
+ //constexpr
+ auto aop0= detail::array_ops<65,ULLONG>( 0 );
+ //constexpr
+ auto aop65= detail::array_ops<65,ULLONG>( 65 );
+ //constexpr
+ auto slp65= Bitset2::bitset2<64>{ aop65.m_shft_left_pattern };
+
+ std::cout << "(aop0) m_n_shift_mod= " << aop0.m_n_shift_mod
+ << "\n m_shft_div= " << aop0.m_shft_div
+ << "\n m_shft_mod= " << aop0.m_shft_mod
+ << "\n m_shft_leftright_shift= " << aop0.m_shft_leftright_shift
+ << "\n m_shft_left_pattern= " << aop0.m_shft_left_pattern
+ << "\n m_shft_right_pattern= " << aop0.m_shft_right_pattern
+ << "\n n_words= " << aop0.n_words
+ << "\n n_array= " << aop0.n_array
+ << "\n";
+ std::cout << "(aop65) m_n_shift_mod= " << aop65.m_n_shift_mod
+ << "\n m_shft_div= " << aop65.m_shft_div
+ << "\n m_shft_mod= " << aop65.m_shft_mod
+ << "\n m_shft_leftright_shift= " << aop65.m_shft_leftright_shift
+ << "\n m_shft_left_pattern= " << aop65.m_shft_left_pattern
+ << "\n = " << slp65
+ << "\n m_shft_right_pattern= " << aop65.m_shft_right_pattern
+ << "\n n_words= " << aop65.n_words
+ << "\n n_array= " << aop65.n_array
+ << "\n";
+}
diff --git a/ThirdParty/bitset2/tests/test_nonconst_constexpr01.cpp b/ThirdParty/bitset2/tests/test_nonconst_constexpr01.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..03a2aa1bc22d5048a2044ff70a77c1b864c52c6f
--- /dev/null
+++ b/ThirdParty/bitset2/tests/test_nonconst_constexpr01.cpp
@@ -0,0 +1,172 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "../bitset2.hpp"
+#include <iostream>
+#include <array>
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+ce_op( Bitset2::bitset2<N,T> const &bs, size_t n, size_t op_t )
+{
+ auto ret_val= bs;
+ for( size_t c= 0; c < n; c++ )
+ {
+ switch( op_t )
+ {
+ case 1: ++ret_val; break;
+ case 2: ret_val++; break;
+ case 3: --ret_val; break;
+ case 4: ret_val--; break;
+ }
+ }
+ return ret_val;
+} // ce_op
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+ce_opequal( Bitset2::bitset2<N,T> const &bs1,
+ Bitset2::bitset2<N,T> const &bs2,
+ size_t op_t )
+{
+ auto ret_val= bs1;
+
+ switch( op_t )
+ {
+ case 1: ret_val += bs2; break;
+ case 2: ret_val |= bs2; break;
+ case 3: ret_val &= bs2; break;
+ case 4: ret_val ^= bs2; break;
+ case 5: ret_val.difference( bs2 ); break;
+ }
+ return ret_val;
+} // ce_opequal
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+ce_shftequal( Bitset2::bitset2<N,T> const &bs1,
+ size_t shft,
+ size_t op_t )
+{
+ auto ret_val= bs1;
+
+ switch( op_t )
+ {
+ case 1: ret_val <<= shft; break;
+ case 2: ret_val >>= shft; break;
+ case 3: ret_val.rotate_left( shft ); break;
+ case 4: ret_val.rotate_right( shft ); break;
+ }
+ return ret_val;
+} // ce_shftequal
+
+
+template<size_t N,class T>
+constexpr
+Bitset2::bitset2<N,T>
+ce_sme_fncs( Bitset2::bitset2<N,T> const &bs1 )
+{
+ auto ret_val= bs1;
+ Bitset2::bitset2<N,T> b2;
+ b2.set();
+ b2.set( 12, false );
+ b2.test_set( 15, false );
+
+ ret_val.reverse();
+ ret_val.complement2();
+ ret_val ^= b2;
+
+ ret_val.flip();
+ ret_val.flip( 42 );
+ ret_val.flip();
+
+ return ret_val;
+} // ce_sme_fncs
+
+
+int main()
+{
+ using ULLONG= unsigned long long;
+ using namespace Bitset2;
+
+ constexpr std::array<ULLONG,2> s_arr_01a{{ 0xFFFFFFFFFFFFFFFFull, 1ull }};
+ constexpr std::array<ULLONG,2> s_arr_01b{{ 5ull, 0ull }};
+ constexpr std::array<ULLONG,2> bit12{{ 1ull << 12, 0ull }};
+ constexpr std::array<ULLONG,2> bit15{{ 1ull << 15, 0ull }};
+ constexpr std::array<ULLONG,2> bit42{{ 1ull << 42, 0ull }};
+ constexpr bitset2<129> zero;
+ constexpr bitset2<129> all_set= ~zero;
+ constexpr bitset2<129> sme_set1=
+ all_set ^ bitset2<129>{ bit12 } ^ bitset2<129>{ bit15 };
+ constexpr bitset2<129> b_from_s_arr01a{ s_arr_01a };
+ constexpr bitset2<129> b_from_s_arr01b{ s_arr_01b };
+ constexpr auto minus_s_arr_01b= complement2( b_from_s_arr01b );
+ constexpr auto add_01a_b= b_from_s_arr01a + b_from_s_arr01b;
+ constexpr auto sub_01a_b= b_from_s_arr01a + minus_s_arr_01b;
+ constexpr auto inc_01a_5= ce_op( b_from_s_arr01a, 5, 1 );
+ constexpr auto inc_01b_5= ce_op( b_from_s_arr01a, 5, 2 );
+ constexpr auto dec_01c_5= ce_op( b_from_s_arr01a, 5, 3 );
+ constexpr auto dec_01d_5= ce_op( b_from_s_arr01a, 5, 4 );
+
+ constexpr auto or_01a_b= b_from_s_arr01a | b_from_s_arr01b;
+ constexpr auto and_01a_b= b_from_s_arr01a & b_from_s_arr01b;
+ constexpr auto xor_01a_b= b_from_s_arr01a ^ b_from_s_arr01b;
+ constexpr auto sdi_01a_b= difference( b_from_s_arr01a, b_from_s_arr01b );
+ constexpr auto shl4_01a= b_from_s_arr01a << 4;
+ constexpr auto shr4_01a= b_from_s_arr01a >> 4;
+ constexpr auto rol4_01a= rotate_left( b_from_s_arr01a, 4 );
+ constexpr auto ror4_01a= rotate_right( b_from_s_arr01a, 4 );
+
+ constexpr auto rev_01a= reverse( b_from_s_arr01a );
+ constexpr auto cpl2_01a= complement2( rev_01a );
+ constexpr auto xor12_01a= cpl2_01a ^ sme_set1;
+ constexpr auto xor42_01a= xor12_01a ^ bitset2<129>{ bit42 };
+
+ constexpr auto pe1= ce_opequal( b_from_s_arr01a, b_from_s_arr01b, 1 );
+ constexpr auto oe1= ce_opequal( b_from_s_arr01a, b_from_s_arr01b, 2 );
+ constexpr auto ae1= ce_opequal( b_from_s_arr01a, b_from_s_arr01b, 3 );
+ constexpr auto xe1= ce_opequal( b_from_s_arr01a, b_from_s_arr01b, 4 );
+ constexpr auto de1= ce_opequal( b_from_s_arr01a, b_from_s_arr01b, 5 );
+
+ constexpr auto sl4_1= ce_shftequal( b_from_s_arr01a, 4, 1 );
+ constexpr auto sr4_1= ce_shftequal( b_from_s_arr01a, 4, 2 );
+ constexpr auto rl4_1= ce_shftequal( b_from_s_arr01a, 4, 3 );
+ constexpr auto rr4_1= ce_shftequal( b_from_s_arr01a, 4, 4 );
+ constexpr auto smf_a= ce_sme_fncs( b_from_s_arr01a );
+
+ static_assert( add_01a_b == inc_01a_5, "" );
+ static_assert( add_01a_b == inc_01b_5, "" );
+ static_assert( sub_01a_b == dec_01c_5, "" );
+ static_assert( sub_01a_b == dec_01d_5, "" );
+ static_assert( add_01a_b == pe1, "" );
+ static_assert( or_01a_b == oe1, "" );
+ static_assert( and_01a_b == ae1, "" );
+ static_assert( xor_01a_b == xe1, "" );
+ static_assert( sdi_01a_b == de1, "" );
+ static_assert( shl4_01a == sl4_1, "" );
+ static_assert( shr4_01a == sr4_1, "" );
+ static_assert( rol4_01a == rl4_1, "" );
+ static_assert( ror4_01a == rr4_1, "" );
+ static_assert( xor42_01a == smf_a, "" );
+
+ std::cout << inc_01a_5 << '\n' << inc_01b_5.to_hex_string() << "\n";
+ std::cout << sub_01a_b << '\n' << dec_01c_5.to_hex_string() << "\n";
+
+ return 0;
+} // main
diff --git a/ThirdParty/bitset2/tests/test_ullong2array.cpp b/ThirdParty/bitset2/tests/test_ullong2array.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..7649f6abe9e85a7f69f709eedd062bcbcad9bfa5
--- /dev/null
+++ b/ThirdParty/bitset2/tests/test_ullong2array.cpp
@@ -0,0 +1,127 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "ullong2array.hpp"
+#include "array2u_long_t.hpp"
+#include <iostream>
+#include <cstdint>
+#include <cassert>
+
+
+int main()
+{
+ using ULLONG= unsigned long long;
+
+ auto const all_set= ~ULLONG(0);
+
+ using namespace Bitset2::detail;
+
+ using a2l_65ll= Bitset2::detail::array2u_long_t<65,ULLONG,ULLONG>;
+
+ auto const a1= ullong2array<18,uint32_t>()( all_set );
+ std::array<uint32_t,1> const expt1{{ uint32_t((1ull << 18) - 1) }};
+ size_t ct= 0;
+ for( auto v: a1 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt1[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 1 );
+
+
+ auto const a2= ullong2array<34,uint32_t>()( all_set );
+ std::array<uint32_t,2> const
+ expt2{{ uint32_t(~uint32_t(0)), uint32_t((1ull << 2) - 1) }};
+ ct= 0;
+ for( auto v: a2 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt2[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 2 );
+
+
+ auto const a3= ullong2array<18,uint16_t>()( all_set );
+ std::array<uint32_t,2> const
+ expt3{{ uint16_t(~uint16_t(0)), uint16_t((1ull << 2) - 1) }};
+ ct= 0;
+ for( auto v: a3 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt3[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 2 );
+
+
+ auto const a4= ullong2array<18,uint8_t>()( all_set );
+ std::array<uint8_t,3> const
+ expt4{{uint8_t(~uint8_t(0)),uint8_t(~uint8_t(0)),uint8_t((1ull << 2) - 1)}};
+ ct= 0;
+ for( auto v: a4 )
+ {
+ std::cout << int(v) << ", ";
+ assert( v == expt4[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 3 );
+
+
+ auto const a5= ullong2array<18,uint64_t>()( all_set );
+ std::array<uint64_t,1> const expt5{{ uint64_t((1ull << 18) - 1) }};
+ ct= 0;
+ for( auto v: a5 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt5[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 1 );
+
+
+ auto const a6= ullong2array<34,uint64_t>()( all_set );
+ std::array<uint64_t,1> const expt6{{ uint64_t((1ull << 34) - 1) }};
+ ct= 0;
+ for( auto v: a6 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt6[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 1 );
+
+
+ auto const a7= ullong2array<66,uint64_t>()( all_set );
+ std::array<uint64_t,2> const
+ expt7{{ uint64_t(~uint64_t(0)), uint64_t(0) }};
+ ct= 0;
+ for( auto v: a7 )
+ {
+ std::cout << v << ", ";
+ assert( v == expt7[ct] ); ct++;
+ }
+ std::cout << "\n";
+ assert( ct == 2 );
+
+
+ a2l_65ll::array_t arr1{{ all_set, 0ull }};
+
+ std::cout << '\n' << a2l_65ll::i_pttrn << '\n';
+ std::cout << a2l_65ll::h_pttrn << '\n';
+ std::cout << a2l_65ll::allset << '\n';
+ std::cout << a2l_65ll::n_array << '\n';
+ std::cout << a2l_65ll::use_vals << '\n';
+ std::cout << a2l_65ll().check_overflow( arr1 ) << '\n';
+}
diff --git a/ThirdParty/bitset2/tests/tests01.cpp b/ThirdParty/bitset2/tests/tests01.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..040e578f5c49d8caed9b28e363e288bb3eeca93b
--- /dev/null
+++ b/ThirdParty/bitset2/tests/tests01.cpp
@@ -0,0 +1,903 @@
+// BITSET2
+//
+// Copyright Claas Bontus
+//
+// Use, modification and distribution is subject to the
+// Boost Software License, Version 1.0. (See accompanying
+// file LICENSE.txt or copy at
+// http://www.boost.org/LICENSE_1_0.txt)
+//
+// Project home: https://github.com/ClaasBontus/bitset2
+//
+
+
+#include "../bitset2.hpp"
+#include "gen_randoms.hpp"
+#include <bitset>
+#include <cassert>
+#include <cstdint>
+#include <iostream>
+
+#define TESTMANY(F) \
+ F <7 >(); \
+ F <8 >(); \
+ F <9 >(); \
+ F <63 >(); \
+ F <64 >(); \
+ F <65 >(); \
+ F <95 >(); \
+ F <96 >(); \
+ F <97 >(); \
+ F <127>(); \
+ F <128>(); \
+ F <129>(); \
+ F <255>(); \
+ F <256>(); \
+ F <257>();
+
+#define TESTMANY2(F,T,S) \
+ F <7, T>(S); \
+ F <8, T>(S); \
+ F <9, T>(S); \
+ F <63, T>(S); \
+ F <64, T>(S); \
+ F <65, T>(S); \
+ F <95, T>(S); \
+ F <96, T>(S); \
+ F <97, T>(S); \
+ F <127,T>(S); \
+ F <128,T>(S); \
+ F <129,T>(S); \
+ F <255,T>(S); \
+ F <256,T>(S); \
+ F <257,T>(S);
+
+
+#define TESTMNY(F) \
+ TESTMANY2(F,uint8_t, "uint8_t" ) \
+ TESTMANY2(F,uint16_t,"uint16_t") \
+ TESTMANY2(F,uint32_t,"uint32_t") \
+ TESTMANY2(F,unsigned long long,"U_L_LONG")
+
+
+template<size_t N,class T=unsigned long long>
+using t1= Bitset2::bitset2<N,T>;
+
+template<size_t N>
+using t1a= Bitset2::bitset2<N>;
+
+template<size_t N>
+using t2= std::bitset<N>;
+
+
+constexpr size_t n_loops= 100000;
+
+constexpr bool verbose= false;
+
+
+template<size_t N,class T>
+struct dummy_add
+{
+ enum : size_t
+ { ull_bits= sizeof(T) * CHAR_BIT
+ , div_val= N / ull_bits
+ , mod_val= N % ull_bits
+ , n_ull= ( mod_val != 0 ) ? (div_val+1) : div_val
+ , n_array= ( N == 0 ) ? 1 : n_ull
+ };
+ //
+ enum : T
+ { all_one= T(~T(0))
+ , hgh_pattern= (N==0) ? T(0)
+ : (mod_val==0) ? T(all_one)
+ : T(all_one >> (ull_bits-mod_val))
+ };
+ //
+ using array_t= std::array<T,n_array>;
+ //
+ array_t
+ add( array_t const &a1, array_t const &a2 ) const
+ {
+ array_t ret_val;
+ T crry= T(0);
+
+ for( size_t c= 0; c < n_ull; ++c )
+ {
+ T const v= T( a1[c] + a2[c] + crry );
+ if( v < a1[c] || v < a2[c] ||
+ ( a1[c] == all_one && a2[c] == all_one ) ) crry= T(1);
+ else crry= T(0);
+ ret_val[c]= v;
+ }
+ if( n_ull > 0 ) ret_val[n_ull-1] &= hgh_pattern;
+
+ return ret_val;
+ } // add
+ //
+ // Returns false if a1 != a2
+ bool
+ compare( array_t const &a1, array_t const &a2 )
+ {
+ for( size_t c= 0; c < n_array; ++c )
+ {
+ if( a1[c] != a2[c] ) return false;
+ }
+ return true;
+ }
+}; // struct dummy_add
+
+
+template<size_t N,class T>
+t1<N,T>
+dummy_reverse( t1<N,T> const & bs )
+{
+ t1<N,T> ret_val;
+ for( size_t c= 0; c < N; ++c ) ret_val[c]= bs[N-c-1];
+
+ return ret_val;
+}
+
+
+
+template<size_t N,class T>
+void
+test_any_all_none( char const * type_str )
+{
+ std::cout << "Entering test_any_all_none N= " << N << " type= " << type_str << "\n";
+
+ t1<N,T> const empty1;
+ t2<N> const empty2;
+ auto const full1= ~empty1;
+ auto const full2= ~empty2;
+
+ auto const empty1a= t1<N,T>( empty2 );
+ auto const empty2a= t2<N>( empty1 );
+ auto const full1a= t1<N,T>( full2 );
+ auto const full2a= t2<N>( full1 );
+
+ assert( empty1.none() && !empty1.all() && !empty1.any() );
+ assert( empty1a.none() && !empty1a.all() && !empty1a.any() );
+ assert( empty2a.none() && !empty2a.all() && !empty2a.any() );
+ assert( !full1.none() && full1.all() && full1.any() );
+ assert( !full1a.none() && full1a.all() && full1a.any() );
+ assert( !full2a.none() && full2a.all() && full2a.any() );
+
+
+ constexpr t1<N,T> ce_empty1;
+ constexpr auto ce_full1= ~ce_empty1;
+ static_assert( ce_empty1.none() && !ce_empty1.all() && !ce_empty1.any(), "" );
+ static_assert( !ce_full1.none() && ce_full1.all() && ce_full1.any(), "" );
+
+
+ gen_random_bitset2<N,T> gen_rand;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2= t2<N>( bs1 );
+ auto const bs1a= t1<N,T>( bs2 );
+
+ if( verbose ) std::cout << bs1.to_hex_string() << "\t" << c << "\n";
+
+ assert( bs1 == bs1a );
+ assert( bs1.none() == bs2.none() );
+ assert( bs1.all() == bs2.all() );
+ assert( bs1.any() == bs2.any() );
+ } // for c
+} // test_any_all_none
+
+
+
+
+template<size_t N,class T>
+void
+test_set_count_size( char const * type_str )
+{
+ std::cout << "Entering test_set_count_size N= " << N << " type= " << type_str << "\n";
+
+ t1<N,T> const empty1;
+ constexpr t1<N,T> ce_empty1;
+ constexpr t1<N,T> ce_full1= ~ce_empty1;
+ assert( empty1.size() == N );
+ static_assert( ce_empty1.size() == N, "" );
+ static_assert( ce_full1.count() == N, "" );
+ static_assert( !ce_empty1.test( N - 3 ), "" );
+ static_assert( ce_full1.test( N - 2 ), "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const cnt1= bs1.count();
+ size_t n_set1= 0, n_set2= 0;
+ for( size_t b_c= 0; b_c < N; ++b_c )
+ {
+ if( bs1.test( b_c ) ) ++n_set1;
+ if( bs1[b_c] ) ++n_set2;
+ }
+
+ if( verbose ) std::cout << bs1.to_hex_string() << "\t" << n_set1
+ << "\t" << c << "\t" << bs1 << "\n";
+
+ auto bs2= bs1;
+ bs2.flip();
+ auto const cnt2= bs2.count();
+
+ assert( n_set1 == cnt1 );
+ assert( n_set1 == n_set2 );
+ assert( cnt2 == N - cnt1 );
+ } // for c
+} // test_set_count_size
+
+
+
+
+template<size_t N,class T>
+void
+test_set( char const * type_str )
+{
+ std::cout << "Entering test_set N= " << N << " type= " << type_str << "\n";
+
+ gen_random_bitset2<N,T> gen_rand;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto bs1= gen_rand();
+ auto bs2= bs1;
+ auto bs3= t2<N>( bs1 );
+ bool flag= false;
+ for( size_t b= 0; b < N; ++ b )
+ {
+ bool const bt1= bs1[b];
+ bs1.set( b, flag );
+ auto const bt2= bs2.test_set( b, flag);
+ assert( bt1 == bt2 );
+ bs3.set( b, flag );
+
+ flag= !flag;
+ }
+ assert( bs1 == bs2 );
+ assert( bs1 == (t1<N,T>( bs3 )) );
+ } // for c
+} // test_set
+
+
+
+
+template<size_t N,class T>
+void
+test_rotate( char const * type_str )
+{
+ std::cout << "Entering test_rotate N= " << N << " type= " << type_str << "\n";
+
+ constexpr std::array<T,2> ce_arr1{{ T(2), T(5) }};
+ constexpr std::array<T,2> ce_arr2{{ T(4), T(10) }};
+ constexpr t1<74,T> ce_bs1( ce_arr1 );
+ constexpr t1<74,T> ce_bs1_r= Bitset2::rotate_left( ce_bs1, 1 );
+ constexpr t1<74,T> ce_bs2( ce_arr2 );
+ static_assert( ce_bs1_r == ce_bs2, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const cnt1= bs1.count();
+
+ for( size_t b_c= 0; b_c < 2 * N; ++b_c )
+ {
+ auto const b_c_mod= b_c % N;
+ auto const bs2_r= Bitset2::rotate_right( bs1, b_c );
+ auto const bs2_l= Bitset2::rotate_left( bs1, b_c );
+ auto const bs2a= Bitset2::rotate_left( bs2_r, b_c );
+ auto const bs2b= Bitset2::rotate_right( bs2_l, b_c );
+ auto const bs2_r2= ( bs1 >> b_c_mod ) | ( bs1 << (N-b_c_mod) );
+ auto const bs2_l2= ( bs1 << b_c_mod ) | ( bs1 >> (N-b_c_mod) );
+
+ auto bc1_c1= bs1;
+ auto bc1_c2= bs1;
+ bc1_c1.rotate_left( b_c );
+ bc1_c2.rotate_right( b_c );
+
+ if( verbose )
+ std::cout << bs1 << "\t"
+ << b_c << "\t"
+ << bs2_l << "\t"
+ << bs2_r << "\n";
+ assert( cnt1 == bs2_r.count() );
+ assert( cnt1 == bs2_l.count() );
+ assert( bs2a == bs1 );
+ assert( bs2b == bs1 );
+ assert( bs2_r2 == bs2_r );
+ assert( bs2_l2 == bs2_l );
+ assert( bc1_c1 == bs2_l );
+ assert( bc1_c2 == bs2_r );
+ }
+ } // for c
+} // test_rotate
+
+
+
+
+template<size_t N,class T>
+void
+test_shift( char const * type_str )
+{
+ std::cout << "Entering test_shift N= " << N << " type= " << type_str << "\n";
+
+ gen_random_bitset2<N,T> gen_rand;
+ t1<N,T> const empty1;
+
+ constexpr size_t n_bts_m= sizeof(T) * CHAR_BIT - 1;
+ constexpr std::array<T,2> ce_arr1{{ T(2), T(5) }};
+ constexpr std::array<T,2> ce_arr2{{ T(4), T(10) }};
+ constexpr std::array<T,2> ce_arr3{{ T(1) + T(T(1) << n_bts_m), T(2) }};
+ constexpr t1<74,T> ce_bs1( ce_arr1 );
+ constexpr t1<74,T> ce_bs1_s1= ce_bs1 << 1;
+ constexpr t1<74,T> ce_bs1_s2= ce_bs1 >> 1;
+ constexpr t1<74,T> ce_bs2( ce_arr2 );
+ constexpr t1<74,T> ce_bs3( ce_arr3 );
+ static_assert( ce_bs1_s1 == ce_bs2, "" );
+ static_assert( ce_bs1_s2 == ce_bs3, "" );
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+
+ for( size_t b_c= 0; b_c <= N + 5; ++b_c )
+ {
+ auto const bs1_l= bs1 << b_c;
+ auto const bs1_r= bs1 >> b_c;
+ auto bs1_c1= bs1;
+ auto bs1_c2= bs1;
+ bs1_c1 <<= b_c;
+ bs1_c2 >>= b_c;
+ if( verbose )
+ std::cout << bs1 << "\t"
+ << bs1_l << "\t"
+ << bs1_r << "\n";
+ if( b_c < N )
+ {
+ t2<N> const bs2{ bs1 };
+ auto const bs2_l= bs2 << b_c;
+ auto const bs2_r= bs2 >> b_c;
+ assert( bs2_l == t2<N>( bs1_l ) );
+ assert( bs2_r == t2<N>( bs1_r ) );
+ assert( bs1_c1 == bs1_l );
+ assert( bs1_c2 == bs1_r );
+ }
+ else
+ {
+ assert( bs1_l == empty1 );
+ assert( bs1_r == empty1 );
+ assert( bs1_c1 == empty1 );
+ assert( bs1_c2 == empty1 );
+ }
+ } // for b_c
+ } // for c
+} // test_shift
+
+
+
+
+template<size_t N,class T>
+void
+test_add( const char * type_str )
+{
+ std::cout << "Entering test_add N= " << N << " type= " << type_str << "\n";
+
+ gen_random_bitset2<N,T> gen_rand;
+ dummy_add<N,T> adder;
+ t1<N,T> const zero;
+ t1<N,T> const one{{ T(1) }};
+ t1<N,T> const all= t1<N,T>().set();
+
+ auto const all_twice= all + all;
+ auto all_twice2= all;
+ all_twice2 += all;
+ auto a_m1= all;
+ a_m1--;
+ auto a_m2= a_m1;
+ a_m2--;
+ auto all_twice_m1= all + a_m1;
+ assert( all_twice == a_m1 );
+ assert( all_twice2 == a_m1 );
+ assert( all_twice_m1 == a_m2 );
+
+ constexpr t1<N,T> ce_one{{ T(1) }};
+ constexpr t1<N,T> ce_empty;
+ constexpr t1<N,T> ce_all= ~ce_empty;
+ constexpr t1<N,T> ce_all_but_one= ~ce_one;
+ constexpr auto ce_all_twice= ce_all + ce_all;
+ static_assert( ce_all_twice == ce_all_but_one, "" );
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2= gen_rand();
+ auto bs3= bs1;
+ auto bs4= bs1;
+ auto bs5= bs1;
+ ++bs3; --bs4;
+ bs5 += bs2;
+
+ auto const add1= bs1 + bs2;
+ auto const add2= adder.add( bs1.data(), bs2.data() );
+ auto const add3= adder.add( bs1.data(), one.data() );
+ auto const add4= adder.add( bs1.data(), all.data() );
+ if( verbose )
+ std::cout << " " << bs1 << "\n+ " << bs2
+ << "\n= " << add1
+ << "\n, " << t1<N,T>(add2) << "\n\n";
+ auto const cmp1= adder.compare( add2, add1.data() );
+ auto const cmp2= adder.compare( add3, bs3.data() );
+ auto const cmp3= adder.compare( add4, bs4.data() );
+ auto const cmp4= adder.compare( add2, bs5.data() );
+
+ auto const exp_zero= bs1 + (~bs1 + one);
+
+ assert( cmp1 );
+ assert( cmp2 );
+ assert( cmp3 );
+ assert( cmp4 );
+ assert( exp_zero == zero );
+ } // for c
+} // test_add
+
+
+
+
+template<size_t N,class T>
+void
+test_difference( char const * type_str )
+{
+ std::cout << "Entering test_difference N= " << N << " type= " << type_str << "\n";
+
+ constexpr std::array<T,2> ce_arr1{{ T(3), T(5) }};
+ constexpr std::array<T,2> ce_arr2{{ T(6), T(1) }};
+ constexpr t1<74,T> ce_bs1( ce_arr1 );
+ constexpr t1<74,T> ce_bs2( ce_arr2 );
+ constexpr auto ce_diff1= Bitset2::difference( ce_bs1, ce_bs2 );
+ constexpr auto ce_ref1= ce_bs1 & ~ce_bs2;
+ static_assert( ce_diff1 == ce_ref1, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2= gen_rand();
+ auto bs3= bs1;
+
+ auto const d1= Bitset2::difference( bs1, bs2 );
+ auto const d2= bs1 & ~bs2;
+ bs3.difference( bs2 );
+
+ assert( d2 == d1 );
+ assert( bs3 == d1 );
+ } // for c
+} // test_difference
+
+
+
+
+
+template<size_t N,class T>
+void
+test_not( char const * type_str )
+{
+ std::cout << "Entering test_not N= " << N << " type= " << type_str << "\n";
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2= ~bs1;
+ for( size_t b_c= 0; b_c < N; ++b_c )
+ {
+ if( verbose ) std::cout << "~" << bs1 << "\n=" << bs2 << "\n";
+ assert( bs1[b_c] != bs2[b_c] );
+ }
+ } // for c
+} // test_not
+
+
+template<size_t N,class T>
+std::vector<size_t>
+idx_lst( t1<N,T> const &bs )
+{
+ std::vector<size_t> ret_val;
+ for( size_t c= 0; c < N; ++c )
+ if( bs[c] ) ret_val.push_back( c );
+ return ret_val;
+} // idx_lst
+
+
+
+template<size_t N,class T>
+void
+test_find( char const * type_str )
+{
+ std::cout << "Entering test_find N= " << N << " type= " << type_str << "\n";
+
+ constexpr t1<N,T> ce_bs1( 12ull );
+ static_assert( ce_bs1.find_first() == 2, "" );
+ static_assert( ce_bs1.find_next( 2 ) == 3, "" );
+ static_assert( ce_bs1.find_next( 3 ) == t1<N,T>::npos, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < N; ++ c)
+ {
+ auto bs1= t1<N,T>();
+
+ assert( bs1.find_first() == (Bitset2::bitset2<N,T>::npos) );
+ assert( bs1.find_next(0) == (Bitset2::bitset2<N,T>::npos) );
+
+ bs1[c]= true;
+ assert( bs1.find_first() == c );
+ if( c > 0 )
+ {
+ assert( bs1.find_next( c - 1 ) == c );
+
+ bs1[0]= true;
+ bs1[N-1]= true;
+ assert( bs1.find_first() == 0 );
+ auto idx= bs1.find_next( c );
+ if( c < N - 1 ) assert( idx == N - 1 );
+ else assert( idx == (Bitset2::bitset2<N,T>::npos) );
+
+ for( size_t b= 0; b < c; ++b ) bs1[b]= true;
+ idx= bs1.find_next( c );
+ if( c < N - 1 ) assert( idx == N - 1 );
+ else assert( idx == (Bitset2::bitset2<N,T>::npos) );
+ }
+ } // for c
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const lst= idx_lst( bs1 );
+ if( lst.empty() ) assert( bs1.find_first() == (Bitset2::bitset2<N,T>::npos) );
+ else
+ {
+ auto b_it= lst.begin();
+ auto e_it= lst.end();
+ auto idx= bs1.find_first();
+ assert( idx == *(b_it++) );
+ for( ; b_it != e_it; ++b_it )
+ {
+ idx= bs1.find_next( idx );
+ assert( idx == *b_it );
+ }
+ idx= bs1.find_next( idx );
+ assert( idx == (Bitset2::bitset2<N,T>::npos) );
+ }
+ } // for c
+
+} // test_find
+
+
+
+
+template<size_t N,class T>
+void
+test_bitwise_ops( char const * type_str )
+{
+ std::cout << "Entering test_bitwise_ops N= " << N << " type= " << type_str << "\n";
+
+ constexpr std::array<T,2> ce_arr1{{ T(3), T(5) }};
+ constexpr std::array<T,2> ce_arr2{{ T(5), T(1) }};
+ constexpr std::array<T,2> ce_e_or{{ T(7), T(5) }};
+ constexpr std::array<T,2> ce_e_and{{ T(1), T(1) }};
+ constexpr std::array<T,2> ce_e_xor{{ T(6), T(4) }};
+ constexpr t1<74,T> ce_bs1( ce_arr1 );
+ constexpr t1<74,T> ce_bs2( ce_arr2 );
+ constexpr t1<74,T> ce_bs_e_or( ce_e_or );
+ constexpr t1<74,T> ce_bs_e_and( ce_e_and );
+ constexpr t1<74,T> ce_bs_e_xor( ce_e_xor );
+ constexpr auto ce_or= ce_bs1 | ce_bs2;
+ constexpr auto ce_and= ce_bs1 & ce_bs2;
+ constexpr auto ce_xor= ce_bs1 ^ ce_bs2;
+ static_assert( ce_or == ce_bs_e_or, "" );
+ static_assert( ce_and == ce_bs_e_and, "" );
+ static_assert( ce_xor == ce_bs_e_xor, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2= gen_rand();
+ auto const b_or= bs1 | bs2;
+ auto const b_and= bs1 & bs2;
+ auto const b_xor= bs1 ^ bs2;
+
+ auto const sbs1= t2<N>( bs1 );
+ auto const sbs2= t2<N>( bs2 );
+ auto const sb_or= sbs1 | sbs2;
+ auto const sb_and= sbs1 & sbs2;
+ auto const sb_xor= sbs1 ^ sbs2;
+
+ if( verbose )
+ std::cout << " " << bs1 << " op " << bs2
+ << "\nop= |: " << b_or
+ << "\nop= &: " << b_and
+ << "\nop= ^: " << b_xor << "\n";
+
+ assert( sb_or == t2<N>( b_or ) );
+ assert( sb_and == t2<N>( b_and ) );
+ assert( sb_xor == t2<N>( b_xor ) );
+ } // for c
+} // test_bitwise_ops
+
+
+
+
+template<size_t N,class T>
+void
+test_reverse( char const * type_str )
+{
+ std::cout << "Entering test_reverse N= " << N << " type= " << type_str << "\n";
+
+ constexpr t1<N,T> ce_bs1( 3ull );
+ constexpr auto ce_bs1_rev= Bitset2::reverse( ce_bs1 );
+ constexpr auto ce_bs1_rot= Bitset2::rotate_right( ce_bs1, 2 );
+ static_assert( ce_bs1_rev == ce_bs1_rot, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto bs2= bs1;
+ auto const bs3= dummy_reverse( bs1 );
+ auto const bs4= Bitset2::reverse( bs1 );
+ bs2.reverse();
+ if( verbose )
+ std::cout << " " << bs1
+ << "\n2 " << bs2
+ << "\n3 " << bs3 << '\n';
+ assert( bs2 == bs3 );
+ assert( bs4 == bs3 );
+ bs2.reverse();
+ assert( bs2 == bs1 );
+ } // for c
+} // test_reverse
+
+
+
+template<size_t N,class T>
+void
+test_convert( char const * type_str )
+{
+ std::cout << "Entering test_convert N= " << N << " type= " << type_str << "\n";
+
+ constexpr t1<N,T> ce_bs1( 0ull );
+ constexpr auto ce_bs2= ~ce_bs1;
+ constexpr auto ce_bs2a= ce_bs2 >> 1;
+ constexpr auto ce_bs2b= Bitset2::convert_to<N-1>( ce_bs2 );
+ constexpr auto ce_bs2c= Bitset2::convert_to<N>( ce_bs2b );
+ constexpr auto ce_bs2d= Bitset2::convert_to<N+1>( ce_bs2 );
+ constexpr auto ce_bs2e= Bitset2::convert_to<N>( ce_bs2d );
+ static_assert( ce_bs2c == ce_bs2a, "" );
+ static_assert( ce_bs2e == ce_bs2, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto const bs2a= bs1 & ce_bs2a;
+ auto const bs2b= Bitset2::convert_to<N-1>( bs1 );
+ auto const bs2c= Bitset2::convert_to<N>( bs2b );
+ auto const bs2d= Bitset2::convert_to<N+1>( bs1 );
+ auto const bs2e= Bitset2::convert_to<N>( bs2d );
+ assert( bs2c == bs2a );
+ assert( bs2e == bs1 );
+
+ auto const bs3a= Bitset2::convert_to<N,uint8_t>( bs1 );
+ auto const bs3b= Bitset2::convert_to<N,T>( bs3a );
+ auto const bs3c= Bitset2::convert_to<N,uint32_t>( bs3a );
+ auto const bs4a= Bitset2::convert_to<N,uint64_t>( bs1 );
+ auto const bs4b= Bitset2::convert_to<N,T>( bs4a );
+ auto const bs5a= Bitset2::convert_to<N,uint64_t>( bs3a );
+ auto const bs5b= Bitset2::convert_to<N,T>( bs5a );
+ auto const bs5c= Bitset2::convert_to<N,uint32_t>( bs5a );
+ assert( bs3b == bs1 );
+ assert( bs4b == bs1 );
+ assert( bs5b == bs1 );
+ assert( bs3c == bs5c );
+
+ const Bitset2::bitset2<N,uint8_t> bs_1a{ bs1.data() };
+ const Bitset2::bitset2<N,uint64_t> bs_1b{ bs1.data() };
+ assert( bs_1a == bs3a );
+ assert( bs_1b == bs4a );
+ } // for c
+} // test_convert
+
+
+
+
+template<size_t N,class T>
+void
+test_compare( char const * type_str )
+{
+ std::cout << "Entering test_compare N= " << N << " type= " << type_str << "\n";
+
+ constexpr t1<N,T> ce_bs1( 0ull );
+ constexpr auto ce_bs2= ~ce_bs1;
+ constexpr auto ce_bs2a= ce_bs2 >> 1;
+ constexpr auto ce_bs2b= ce_bs2a;
+ static_assert( ce_bs2a < ce_bs2, "" );
+ static_assert( ce_bs2b <= ce_bs2a, "" );
+ static_assert( ce_bs2 > ce_bs2a, "" );
+ static_assert( ce_bs2a >= ce_bs2b, "" );
+ static_assert( ce_bs2a != ce_bs2, "" );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1= gen_rand();
+ auto bs2= bs1;
+ auto const bs3= bs1;
+ --bs2;
+ if( bs1 != ce_bs1 )
+ {
+ assert( bs2 < bs1 );
+ assert( bs2 <= bs1 );
+ assert( bs1 > bs2 );
+ assert( bs1 >= bs1 );
+ }
+ else
+ {
+ assert( bs1 == ce_bs1 );
+ }
+ assert( bs3 <= bs1 );
+ assert( bs3 >= bs1 );
+ } // for c
+} // test_compare
+
+
+
+
+template<size_t N,class T>
+void
+test_complement2( char const * type_str )
+{
+ std::cout << "Entering test_complement2 N= " << N << " type= " << type_str << "\n";
+
+ constexpr t1<N,T> zero( 0ull );
+ constexpr auto allset= ~zero;
+ auto one= zero;
+ ++one;
+
+ constexpr auto ce_bs1= Bitset2::complement2( zero );
+ constexpr auto ce_bs2= Bitset2::complement2( allset );
+ auto bs1= zero;
+ auto bs2= allset;
+ bs1.complement2();
+ bs2.complement2();
+ static_assert( ce_bs1 == zero, "" );
+ assert( bs1 == zero );
+ assert( bs2 == one );
+ assert( ce_bs2 == one );
+
+ gen_random_bitset2<N,T> gen_rand;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs_1a= gen_rand();
+ auto bs_1b= bs_1a;
+ auto const bs_1c= ~bs_1a + one;
+ auto const bs_2a= Bitset2::complement2( bs_1a );
+ bs_1b.complement2();
+ assert( bs_1a + bs_2a == zero );
+ assert( bs_1a + bs_1b == zero );
+ assert( bs_1b == bs_1c );
+ } // for c
+} // test_complement2
+
+
+
+template<size_t N>
+void
+test_hash()
+{
+ std::cout << "Entering test_hash N= " << N << "\n";
+
+ gen_random_bitset2<N,uint8_t> gen_rand8;
+ gen_random_bitset2<N,uint16_t> gen_rand16;
+ gen_random_bitset2<N,uint32_t> gen_rand32;
+ gen_random_bitset2<N,uint64_t> gen_rand64;
+
+ for( size_t c= 0; c < n_loops; ++c )
+ {
+ auto const bs1_8= gen_rand8();
+ auto const bs1a_8= t2<N>( bs1_8 );
+ auto const bs2_8= t1<N,uint16_t>( bs1a_8 );
+ auto const bs3_8= t1<N,uint32_t>( bs1a_8 );
+ auto const bs4_8= t1<N,uint64_t>( bs1a_8 );
+
+ auto const hs1_8= std::hash<std::remove_cv_t<decltype(bs1_8)> >{}( bs1_8 );
+ auto const hs2_8= std::hash<std::remove_cv_t<decltype(bs2_8)> >{}( bs2_8 );
+ auto const hs3_8= std::hash<std::remove_cv_t<decltype(bs3_8)> >{}( bs3_8 );
+ auto const hs4_8= std::hash<std::remove_cv_t<decltype(bs4_8)> >{}( bs4_8 );
+ assert( hs1_8 == hs2_8 );
+ assert( hs1_8 == hs3_8 );
+ assert( hs1_8 == hs4_8 );
+
+
+ auto const bs1_16= gen_rand16();
+ auto const bs1a_16= t2<N>( bs1_16 );
+ auto const bs2_16= t1<N,uint8_t>( bs1a_16 );
+ auto const bs3_16= t1<N,uint32_t>( bs1a_16 );
+ auto const bs4_16= t1<N,uint64_t>( bs1a_16 );
+
+ auto const hs1_16= std::hash<std::remove_cv_t<decltype(bs1_16)> >{}( bs1_16 );
+ auto const hs2_16= std::hash<std::remove_cv_t<decltype(bs2_16)> >{}( bs2_16 );
+ auto const hs3_16= std::hash<std::remove_cv_t<decltype(bs3_16)> >{}( bs3_16 );
+ auto const hs4_16= std::hash<std::remove_cv_t<decltype(bs4_16)> >{}( bs4_16 );
+ assert( hs1_16 == hs2_16 );
+ assert( hs1_16 == hs3_16 );
+ assert( hs1_16 == hs4_16 );
+
+
+ auto const bs1_32= gen_rand32();
+ auto const bs1a_32= t2<N>( bs1_32 );
+ auto const bs2_32= t1<N,uint8_t>( bs1a_32 );
+ auto const bs3_32= t1<N,uint16_t>( bs1a_32 );
+ auto const bs4_32= t1<N,uint64_t>( bs1a_32 );
+
+ auto const hs1_32= std::hash<std::remove_cv_t<decltype(bs1_32)> >{}( bs1_32 );
+ auto const hs2_32= std::hash<std::remove_cv_t<decltype(bs2_32)> >{}( bs2_32 );
+ auto const hs3_32= std::hash<std::remove_cv_t<decltype(bs3_32)> >{}( bs3_32 );
+ auto const hs4_32= std::hash<std::remove_cv_t<decltype(bs4_32)> >{}( bs4_32 );
+ assert( hs1_32 == hs2_32 );
+ assert( hs1_32 == hs3_32 );
+ assert( hs1_32 == hs4_32 );
+
+
+ auto const bs1_64= gen_rand64();
+ auto const bs1a_64= t2<N>( bs1_64 );
+ auto const bs2_64= t1<N,uint8_t>( bs1a_64 );
+ auto const bs3_64= t1<N,uint16_t>( bs1a_64 );
+ auto const bs4_64= t1<N,uint32_t>( bs1a_64 );
+
+ auto const hs1_64= std::hash<std::remove_cv_t<decltype(bs1_64)> >{}( bs1_64 );
+ auto const hs2_64= std::hash<std::remove_cv_t<decltype(bs2_64)> >{}( bs2_64 );
+ auto const hs3_64= std::hash<std::remove_cv_t<decltype(bs3_64)> >{}( bs3_64 );
+ auto const hs4_64= std::hash<std::remove_cv_t<decltype(bs4_64)> >{}( bs4_64 );
+ assert( hs1_64 == hs2_64 );
+ assert( hs1_64 == hs3_64 );
+ assert( hs1_64 == hs4_64 );
+ } // for c
+} // test_hash
+
+
+
+int
+main()
+{
+ std::cout << "sizeof( bitset2<8> )= " << sizeof( t1a<8> ) << '\n';
+ std::cout << "sizeof( bitset2<16> )= " << sizeof( t1a<16> ) << '\n';
+ std::cout << "sizeof( bitset2<32> )= " << sizeof( t1a<32> ) << '\n';
+ std::cout << "sizeof( bitset2<64> )= " << sizeof( t1a<64> ) << '\n';
+ std::cout << "sizeof( bitset2<65> )= " << sizeof( t1a<65> ) << '\n';
+
+ TESTMNY(test_complement2)
+ TESTMNY(test_convert)
+ TESTMNY(test_add)
+ TESTMNY(test_compare)
+ TESTMNY(test_reverse)
+ TESTMNY(test_find)
+ TESTMNY(test_difference)
+ TESTMNY(test_any_all_none)
+ TESTMNY(test_set_count_size)
+ TESTMNY(test_set)
+ TESTMNY(test_not)
+ TESTMNY(test_bitwise_ops)
+ TESTMNY(test_shift)
+ TESTMNY(test_rotate)
+
+ TESTMANY(test_hash)
+} // main
diff --git a/do-copyright.py b/do-copyright.py
new file mode 100755
index 0000000000000000000000000000000000000000..c771a570f5908067ea89c4ef2e8c934ac9c79b61
--- /dev/null
+++ b/do-copyright.py
@@ -0,0 +1,94 @@
+#!/usr/bin/python
+
+import os.path
+
+text = """
+/**
+ * (c) Copyright 2018 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.
+*/\n
+"""
+
+excludeDirs = ["ThirdParty", "git"]
+excludeFiles = ['PhysicalConstants.h']
+
+extensions = [".cc", ".h", ".test"]
+
+def checkNote(filename):
+
+ startNote = -1
+ endNote = -1
+ isCopyright = False
+ lines = []
+
+ with open(filename, "r") as file:
+ for line in file.readlines():
+ lines.append(line)
+ file.close()
+
+
+ for iLine in range(len(lines)):
+ line = lines[iLine]
+ if "/**" in line and startNote == -1:
+ startNote = iLine
+ if "copyright" in line.lower() and startNote>=0 and endNote==-1:
+ isCopyright = True
+ if "*/" in line and startNote>=0 and endNote==-1:
+ endNote = iLine
+ iLine += 1
+
+ # now check if copyright notice is already there and identical...
+ isSame = False
+ if startNote>=0 and endNote>=0 and isCopyright:
+ isSame = True
+ noteLines = text.split('\n')
+ for iLine in range(len(noteLines)-2):
+ if startNote+iLine >= len(lines):
+ isSame = False
+ break
+ if noteLines[iLine+1].strip(" \n") != lines[startNote+iLine].strip(" \n"):
+ isSame = False
+ print "not same: " + filename + " new=\'" + noteLines[iLine+1] + "\' vs old=\'" + lines[startNote+iLine].rstrip('\n') + "\'"
+ break
+
+ # check if notice is the same
+ if isSame:
+ return
+
+ # add (new) copyright notice here:
+
+ os.rename(filename, filename+".bak")
+
+ with open(filename, "w") as file:
+
+ file.write(text)
+
+ firstLine = 0
+ if startNote>=0 and endNote>=0 and isCopyright:
+ firstLine = endNote + 2
+
+ for iLine in range(firstLine, len(lines)):
+ file.write(lines[iLine])
+
+ file.close()
+
+
+def next_file(x, dir_name, files):
+ for check in excludeDirs :
+ if check in dir_name:
+ return
+ for check in files :
+ filename, file_extension = os.path.splitext(check)
+ for check2 in excludeFiles :
+ if check2 in check:
+ return
+ if file_extension in extensions:
+ checkNote(dir_name + "/" + check)
+
+
+os.path.walk("./", next_file, 0)