diff --git a/CMakeLists.txt b/CMakeLists.txt
index 2fd59736e161af2d4f53e57e75613e8d6fe667f6..6bc1fb3ccf888f1fcf9e5846fed54ca519759ebc 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -21,6 +21,8 @@ set (CMAKE_CXX_STANDARD 17)
enable_testing ()
set (CTEST_OUTPUT_ON_FAILURE 1)
+ENABLE_LANGUAGE (Fortran)
+
# unit testing coverage, does not work yet
#include (CodeCoverage)
##set(COVERAGE_LCOV_EXCLUDES 'Documentation/*')
diff --git a/Documentation/Examples/CMakeLists.txt b/Documentation/Examples/CMakeLists.txt
index 237e7a0b218718a34373fa3f503c12a5486e53f3..35b9908c94473ee9137ba4413e362c0509ea856d 100644
--- a/Documentation/Examples/CMakeLists.txt
+++ b/Documentation/Examples/CMakeLists.txt
@@ -14,6 +14,19 @@ 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
diff --git a/Documentation/Examples/cascade_example.cc b/Documentation/Examples/cascade_example.cc
new file mode 100644
index 0000000000000000000000000000000000000000..08a55e7621e8a00481439180beb806be178ddb6c
--- /dev/null
+++ b/Documentation/Examples/cascade_example.cc
@@ -0,0 +1,149 @@
+
+/**
+ * (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/setup/SetupStack.h>
+#include <corsika/setup/SetupTrajectory.h>
+
+#include <corsika/random/RNGManager.h>
+#include <corsika/cascade/sibyll2.3c.h>
+
+using namespace corsika;
+using namespace corsika::process;
+using namespace corsika::units;
+using namespace corsika::particles;
+using namespace corsika::random;
+
+#include <iostream>
+using namespace std;
+
+static int fCount = 0;
+
+class ProcessSplit : public corsika::process::BaseProcess<ProcessSplit> {
+public:
+ ProcessSplit() {}
+
+ template <typename Particle>
+ double MinStepLength(Particle& p) const {
+ // beam particles for sibyll : 1, 2, 3 for p, pi, k
+ int kBeam = 1;
+ // target nuclei: A < 18
+ int kTarget = 0.4*16 + 0.6*14;
+ double beamEnergy = p.GetEnergy() / 1_GeV;
+ std::cout << "ProcessSplit: " << "MinStep: en: " << beamEnergy << " pid:" << kBeam << std::endl;
+ double prodCrossSection,dummy;
+ sib_sigma_hnuc_(kBeam, kTarget, beamEnergy, prodCrossSection, dummy );
+ std::cout << "ProcessSplit: " << "MinStep: sibyll return: " << prodCrossSection << std::endl;
+ CrossSectionType sig = prodCrossSection / 1000. * barn;
+ std::cout << "ProcessSplit: " << "MinStep: CrossSection= " << sig << std::endl;
+
+ // calculate interaction length in medium
+
+ // pick random step lenth
+
+ return prodCrossSection;
+ }
+
+ template <typename Particle, typename Trajectory, 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 {
+ // get energy of particle from stack
+ // stack is in GeV in lab. frame
+ // convert to GeV in cm. frame
+ EnergyType E = p.GetEnergy();
+ double Ecm = sqrt( 2. * E * 0.93827_GeV ) / 1_GeV ;
+ // FOR NOW: set beam to proton
+ int kBeam = 13; //p.GetPID();
+ // FOR NOW: set target to proton
+ int kTarget = 1; //p.GetPID();
+ std::cout << "ProcessSplit: " << " DoDiscrete: E(GeV):" << E / 1_GeV << " Ecm(GeV): " << Ecm << std::endl;
+ if (E < 8.5_GeV || Ecm < 10. ) {
+ std::cout << "ProcessSplit: " << " DoDiscrete: dropping particle.." << std::endl;
+ p.Delete();
+ fCount++;
+ } else {
+ //p.SetEnergy(E / 2);
+ //s.NewParticle().SetEnergy(E / 2);
+
+ // running sibyll
+ sibyll_( kBeam, kTarget, Ecm);
+ int print_unit = 6;
+ sib_list_( print_unit );
+
+ // delete current particle
+ p.Delete();
+
+ // add particles from sibyll to stack
+ for(int i=0; i<s_plist_.np; ++i){
+
+ s.NewParticle().SetEnergy( s_plist_.p[3][i] * 1_GeV );
+ }
+ }
+ }
+
+ void Init() //{ fCount = 0; }
+ {
+ fCount = 0;
+
+ // initialize random numbers for sibyll
+ // FOR NOW USE SIBYLL INTERNAL !!!
+ rnd_ini_();
+
+ // corsika::random::RNGManager rmng;
+ // 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<5; ++i)
+ std::cout << i << " " << s_rndm_(a) << std::endl;
+
+ //initialize Sibyll
+ sibyll_ini_();
+ }
+
+ int GetCount() { return fCount; }
+
+private:
+};
+
+int main(){
+
+ stack_inspector::StackInspector<setup::Stack, setup::Trajectory> p0(true);
+ ProcessSplit p1;
+ const auto sequence = p0 + p1;
+ setup::Stack stack;
+
+ corsika::cascade::Cascade EAS(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/Framework/Cascade/CMakeLists.txt b/Framework/Cascade/CMakeLists.txt
index 5dbb843bc79e6b181e47489f331490bb87c495a6..e1f771f7a4643e0ebc7efa6f3c9bdf980f8520bd 100644
--- a/Framework/Cascade/CMakeLists.txt
+++ b/Framework/Cascade/CMakeLists.txt
@@ -9,6 +9,7 @@ set (
set (
CORSIKAcascade_HEADERS
Cascade.h
+ sibyll2.3c.h
)
#set (
@@ -16,9 +17,23 @@ set (
# Cascade.cc
# )
+set (
+ CORSIKAsibyll_NAMESPACE
+ corsika/cascade
+ )
+
+set (
+ CORSIKAsibyll_SOURCES
+ sibyll2.3c.f
+ rndm_dbl.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,7 +66,9 @@ add_executable (
target_link_libraries (
testCascade
-# CORSIKAutls
+ # CORSIKAutls
+ CORSIKArandom
+ CORSIKAsibyll
CORSIKAcascade
ProcessStackInspector
CORSIKAprocesses
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..4a00010fcbcf29003921cea384864be521286b50
--- /dev/null
+++ b/Framework/Cascade/sibyll2.3c.h
@@ -0,0 +1,87 @@
+#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_;
+
+
+ // 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&);
+
+ double s_rndm_(int&);
+
+ // phojet random generator setup
+ void pho_rndin_(int&,int&,int&,int&);
+}
+#endif
+
diff --git a/Framework/Units/PhysicalConstants.h b/Framework/Units/PhysicalConstants.h
index 7add499dd5b000172de38da22074e5427ce36b76..915f2d59cf7f418255574218f1530b09f1ff37e5 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};
+ // millibarn
+ 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 23dbbb871dc7d5b2cd2d8538c2bbe7c6197c6812..adaa004d30592edd91bf0a2ae154d8906e1841ff 100644
--- a/Framework/Units/PhysicalUnits.h
+++ b/Framework/Units/PhysicalUnits.h
@@ -38,6 +38,8 @@ namespace corsika::units::si {
using EnergyType = phys::units::quantity<phys::units::energy_d, double>;
using MassType = phys::units::quantity<phys::units::mass_d, double>;
+ using CrossSectionType = phys::units::quantity<phys::units::area_d, double>;
+
} // end namespace corsika::units::si
// we want to call the operator<< without namespace... I think