From 13f1d8187dbd31850e9b371e4fd9c621c2ebe91d Mon Sep 17 00:00:00 2001
From: pierog <tanguy.pierog@kit.edu>
Date: Mon, 6 Jul 2020 15:01:40 +0200
Subject: [PATCH] add conex source files : conex_cors8.F for CONEX source
without any hadronic model dependency conex_mod8.F to be linked with the used
hadronic model
---
Processes/CONEXSourceCut/conex_cors8.F | 45330 +++++++++++++++++++++++
Processes/CONEXSourceCut/conex_mod8.F | 7188 ++++
2 files changed, 52518 insertions(+)
create mode 100644 Processes/CONEXSourceCut/conex_cors8.F
create mode 100644 Processes/CONEXSourceCut/conex_mod8.F
diff --git a/Processes/CONEXSourceCut/conex_cors8.F b/Processes/CONEXSourceCut/conex_cors8.F
new file mode 100644
index 000000000..880b34077
--- /dev/null
+++ b/Processes/CONEXSourceCut/conex_cors8.F
@@ -0,0 +1,45330 @@
+c Preprocessed Standard Conex subroutine in 2 file s
+c conex_cors8.F for all hadronic model independent part of Conex
+c (conex_mod8.F for all hadronic model independent part of Conex)
+c Last modifications : 03.07.2020 <tanguy.pierog@kit.edu>
+c
+c Conex (git master)
+c by V. Chernatkin, N.N. Kalmykov, T. Pierog, S. Ostapchenko and K. Werner
+c with the collaboration of R. Engel and D. Heck.
+c Paper to be cited if you use this program : [1] ([2])
+c Ref. :
+c@Article{Bergmann:2006yz,
+c author = "Bergmann, T. and others",
+c title = "One-dimensional hybrid approach to extensive air shower
+c simulation",
+c journal = "Astropart. Phys.",
+c volume = "26",
+c year = "2007",
+c pages = "420-432",
+c eprint = "astro-ph/0606564",
+c SLACcitation = "%%CITATION = ASTRO-PH/0606564;%%"
+c}
+c@Article{Pierog:2004re,
+c author = "Pierog, T. and others",
+c title = "First Results of Fast One-dimensional Hybrid Simulation of
+c EAS Using CONEX",
+c journal = "Nucl. Phys. Proc. Suppl.",
+c volume = "151",
+c year = "2006",
+c pages = "159-162",
+c eprint = "astro-ph/0411260",
+c SLACcitation = "%%CITATION = ASTRO-PH/0411260;%%"
+c}
+c Original work : CONEX 1.0 (2003)
+c by the Nantes-Moscow collaboration
+c (H.J. Drescher, N.N. Kalmykov, S. Ostapchenko, and K. Werner)
+c@Article{Bossard:2000jh,
+c author = "Bossard, G. and others",
+c title = "Cosmic ray air shower characteristics in the framework of
+c the parton-based Gribov-Regge model NEXUS",
+c journal = "Phys. Rev.",
+c volume = "D63",
+c year = "2001",
+c pages = "054030",
+c eprint = "hep-ph/0009119",
+c SLACcitation = "%%CITATION = HEP-PH/0009119;%%"
+c}
+c
+c options to be prepocessed by cpp are :
+c -D__QGSJET__ to compile with QGSJet MC model
+c -D__GHEISHA__ to compile with Gheisha MC model
+c -D__NEXUS__ to compile with Nexus model
+c -D__SIBYLL21__ to compile with Sibyll model
+c -D__QGSJETII__ to compile with QGSJet-II-3 model
+c -D__EPOS__ to compile with EPOS model
+c -D__FLUKA__ to compile with FLUKA model
+c -D__URQMD__ to compile with URQMD model
+c -D__DPMJET__ to compile with DPMJET model
+c
+c -D__CXDEBUG__ to allow debugging commands (print ...)
+c -D__ANALYSIS__ to allow analysis tools from CONEX (into histo file)
+c -D__MC3D__ to allow 3D simulations and low energy MC (moments, etc...)
+c -D__CXLATCE__ to allow 3D calculations in CE (moments, etc...)
+c -D__COAST__ to allow linking to ROOT (for plotting ...)
+c
+c -D__CXSUB__ to set conex as a subroutine
+c -D__CXCORSIKA__ to compile in CORSIKA 7
+c -D__CORSIKA8__ to compile with CORSIKA 8
+c
+c -D__PRESHOW__ to include preshowering for Gamma induced Shower
+c
+c -D__STD__ to have the minimum for plots : qgsjet+gheisha+analysis
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+#ifdef __CXSUB__
+
+c-----------------------------------------------------------------------
+ subroutine ConexRun(ipart,energy,theta,phi,dimpact,ioseed)
+c-----------------------------------------------------------------------
+c Conex can be called by an other program through this subroutine.
+c inputs are : - ipart : PDG code (or A*100 for nuclei and 0 for gamma)
+c of the primary particle
+c - energy (double precision) : primary total energy in GeV
+c - theta (double precision) : zenith angle in degree
+c - phi (double precision) : azimuth angle in degree
+c input/ouput is : - ioseed (integer*3) : initial seed for the first call
+c and then, seed before each shower
+c
+c see srt ConexInit() for intialization!!
+c
+c Author T. Pierog - 25.06.2004
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ common /XmaximumSave/Xmaximum
+ dimension ioseed(3)
+ integer nshtot
+ data nshtot/0/
+ save nshtot
+ common/cxNnucleon/aNbrNucl
+ common/cxransto/diu0(100),iiseed(3,2)
+
+#ifdef LEADING_INTERACTIONS_TREE
+ countInt = 1
+#endif
+
+ id=InitialParticle(ipart) !conex particle id
+
+ if(isx.ge.2)write(ifck,*)'CONEX called with :'
+ &,ipart,energy,theta,phi,ioseed
+
+
+ nshtot=nshtot+1
+ eprima=energy
+ ehcut=max(enymin,min(1.d10,eprima/aNbrNucl*fehcut))
+ emcut=max(enymin,min(1.d10,eprima/aNbrNucl*femcut))
+ eecut=max(emin,min(1.d8,eprima/aNbrNucl*feecut)) !limitation due to LPM effect (not in CE)
+#ifdef __CXCORSIKA__
+ ighe=ioseed(1)
+ if(ighe.eq.0)ehcut=max(EgyHiLoLim,ehcut) !to avoid problems with different low energy models in CONEX and CORSIKA
+#endif
+c To give priority to CE for hadrons, if elow > ecut, ecut is used as the low energy MC limit
+ if(ehcut.le.ehlowi)then
+ ehlow=ehcut
+ cx2corsha=.true. !hadrons go directly from CONEX MC to CORSIKA stack (no CE)
+ else
+ ehlow=min(eprima+1d0,ehlowi)
+ ehcut=min(1.d10,ehcut) !limitation due to table size
+ cx2corsha=.false.
+ endif
+c To give priority to CE for muons, if elow > ecut, ecut is used as the low energy MC limit
+ if(emcut.le.emlowi)then
+ emlow=emcut
+ cx2corsmu=.true. !muons go directly from CONEX MC to CORSIKA stack (no CE)
+ else
+ emlow=min(eprima+1d0,emlowi)
+ emcut=min(1.d10,emcut) !limitation due to table size
+ cx2corsmu=.false.
+ endif
+c To give priority to CE for EM (same results in hybrid or MC mode), if elow > ecut, ecut is used as the low energy MC limit
+ if(eecut.le.eelowi)then
+ eelow=eecut
+ cx2corsem=.true. !EM go directly from CONEX MC to CORSIKA stack (no CE)
+ else
+ eelow=min(eprima+1d0,eelowi)
+ eecut=min(1.d8,eecut) !limitation due to LPM effect
+ cx2corsem=.false.
+ endif
+ thetas=theta
+ phisho=phi
+ XmaxP=Xmaximum
+ altitude=dimpact
+ call ranfgt(seed) !get seed before shower
+#ifdef __CXCORSIKA__
+ if(mode.eq.5)then
+ call Initialize2
+ call IniHadCas(id)
+ call IniProfile(-1,10,nshtot)
+ call IniHadSource
+ call InitialParticleSho(id)
+ call HadronShower(nshtot,iCEmode)
+ call HadronCascade(id,nshtot,nshower,iCEmode)
+ call AddProfile(-1,10,nshtot)
+ else
+#else
+ do i=1,3
+ ioseed(i)=iiseed(i,1)
+ enddo
+#endif
+ call Initialize2
+ call IniHadCas(id)
+ call IniEMCE
+ call InitializeEphCas2
+ call CrossSections
+#if __CXCORSIKA__ || __CORSIKA8__
+ call IniProfile(-1,10,nshtot)
+#else
+ call IniProfile(0,10,nshtot)
+#endif
+ call IniHadSource
+ call IniElePhoSource
+#ifdef __CORSIKA8__
+c CORSIKA 8 treat the hadronic shower, so only cascade equations are computed
+ call InitialParticleSho(id) !called only to setup stacks
+ iCEmode=1
+ lxfirst=.true. !first interaction in CORSIKA 8
+ lxfirstIn=.false. !do not fix first interaction
+
+#else
+#ifdef CONEX_EXTENSIONS
+c RU Mon Oct 23 09:02:37 CEST 2006
+ isFirstInt=.true.
+ if(particleListMode.eq.1)then
+ call InitialParticleShoList()
+ else
+ call InitialParticleSho(id)
+ endif
+c RU end
+#else
+ call InitialParticleSho(id)
+c CONEX_EXTENSIONS
+#endif
+ call HadronShower(nshtot,iCEmode)
+#endif
+ call HadronCascade(id,nshtot,0,iCEmode)
+ call SolveMomentEquations(0)
+#if __CXCORSIKA__ || __CORSIKA8__
+ call AddProfile(-1,10,nshtot)
+#else
+ call AddProfile(0,10,nshtot)
+#endif
+#ifdef __CXCORSIKA__
+ endif
+#else
+#if __COAST__ && !__CORSIKA8__
+ if(nshtot.eq.ntot)then
+ CALL CLODA ()
+ endif
+#endif
+#endif
+
+ return
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ConexInit(ntot,nMaxDetail,iin,iout,ioseed)
+c-----------------------------------------------------------------------
+c the following inputs should not change:
+c - iin (integer) : unit number of the input file containing
+c information for Conex (file name, options...)
+c - iout (integer) : unit number of the output file
+c - ntot (integer) : total number of shower that will be
+c called.
+c Note : -all the standard option of Conex can be used by setting them in
+c the input file as usual (all the simulations with the same options).
+c -Conex will run in Hybrid mode with threshold energies depending
+c on "energy" thanks to the parameters "fehcut" and "feecut" as :
+c ehcut=fehcut*energy for hadrons
+c emcut=femcut*energy for muons
+c eecut=feecut*energy for electromagnetic particles
+c -Minimum primary energy to run Conex is 0.1 GeV and maximum is
+c 10^13 GeV. If you ask for an energy outside this range, the progam
+c will stop.
+c -unit number can not be : 1,2,8,12,20-29,31,35,36,37,51,52,53,54
+c (if nexus is not compiled, 20-29,31,51,52 are free)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /XmaximumSave/Xmaximum
+ integer iegs, iolo
+ data iegs/1/,iolo/0/
+ save iegs,iolo
+#include "conex.h"
+#include "conexep.h"
+ dimension ioseed(3)
+#ifndef __CXCORSIKA__
+ dimension iseedi(3)
+#endif
+
+#ifdef LEADING_INTERACTIONS_TREE
+ maxDetail = nMaxDetail
+c write(*,*) 'first_interaction_tree: ',maxDetail
+#endif
+
+ call Initialize
+ call InitializeMC
+ call InitializeEphCas
+#ifdef __MC3D__
+#ifdef __ANALYSIS__
+ call InitializeTripleIndex
+#endif
+#endif
+ isubin=iin !input unit
+ ifda=iout !output unit
+ ifho=iout !output unit (histo)
+ iseed(1,1)=ioseed(1) !initial seed
+ if(ioseed(1).lt.99999999)then
+ iseed(1,2)=ioseed(1)+1 !initial 2d seed
+ else
+ iseed(1,2)=ioseed(1)-1 !initial 2d seed
+ endif
+ call getw('init ')
+ call ConexRead !read input parameters
+#ifdef LEADING_INTERACTIONS_TREE
+ if (ihthin.ne.0) then
+ stop'LEADING_INTERACTIONS_TREE and thinning (ERROR)'
+ endif
+#endif
+#ifdef __CXCORSIKA__
+ ighe=ioseed(1)
+ lseq=7
+#else
+ do i=1,3
+ iseedi(i)=iseed(i,1)
+ enddo
+ call rmmaqd(iseedi,1,'S') !reinitialize random number generator
+ do i=1,3
+ iseedi(i)=iseed(i,2)
+ enddo
+ call rmmaqd(iseedi,2,'S') !reinitialize 2d random number generator
+ do i=1,3
+ iseedi(i)=0
+ enddo
+ lseq=1
+ mode=8
+#endif
+ eprima=enymax
+ call InitializeOnce(iegs,iolo)
+ call InitializeMC2
+ call IniHadCasSub
+ call InitializeEphCasSub
+ if(iwrt.ne.0)call IniMeanProfile
+ lheader=.false.
+ nshower=ntot
+ Xmaximum=xmaxp
+
+ end
+
+#else
+
+c-----------------------------------------------------------------------
+ program bas
+c-----------------------------------------------------------------------
+ call Initialize
+ call InitializeMC
+ call InitializeEphCas
+#if __MC3D__ || __CXLATCE__
+#ifdef __ANALYSIS__
+ call InitializeTripleIndex
+#endif
+#endif
+ call getw('init ')
+
+ call ConexRead
+
+ end
+
+
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine ConexRead
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ character word*500
+#ifndef __CXCORSIKA__
+ data iegs/1/,iolo/0/
+ save iegs,iolo
+#endif
+
+ 1 call getw(word)
+
+c Write in "histo" or "data" (just number), mean or all depth profile of produced particles
+c (optional but to be place at the very beginning of .optns file (at least before run))
+ if(word.eq.'output')then
+ call ConexOutput
+
+c To read a list of particles to replace the primary particle.
+
+ elseif(word.eq.'input')then
+ call ConexInput
+
+c To write (or not) on the screen what is given as input in CONEX
+
+ elseif(word.eq.'echo')then
+ call getw(word)
+ if(word.eq.'off')then
+ lwrite=.false.
+ else
+ lwrite=.true.
+ endif
+
+c define primary paticle (photon, electron, positron, proton, helium, oxygen, iron, or id number)
+
+#ifndef __CXSUB__
+ elseif(word.eq.'initial')then
+ call getw(word)
+ call InitialParticle(word,id)
+#endif
+c define model used for low energy part (in both MC and numeric part)
+
+ elseif(word.eq.'lemodel')then
+ call getw(word)
+#ifdef __MODEL__
+ if(word.ne.'gheisha'
+#ifdef __FLUKA__
+ * .and.word.ne.'fluka'
+#endif
+#ifdef __URQMD__
+ * .and.word.ne.'urqmd'
+#endif
+ * )then
+c mixed high energy models, cannot use high energy model at low energy
+ stop'Please select a real low energy model !'
+ endif
+#endif
+ if(word.eq.'nexus')then
+#if __NEXUS__ || __CORSIKA8__
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ call aaset(0)
+#endif
+ MCleModel=1
+#else
+ stop 'CONEX compiled without __ NEXUS __, can not run !'
+#endif
+ elseif(word.eq.'qgsjet')then
+#if defined ( __QGSJET__) || __CORSIKA8__
+ MCleModel=2
+#else
+ stop 'CONEX compiled without __ QGSJET __, can not run !'
+#endif
+ elseif(word.eq.'gheisha')then
+#if defined (__GHEISHA__) || __CORSIKA8__
+ MCleModel=3
+#else
+ stop 'CONEX compiled without __ GHEISHA __, can not run !'
+#endif
+ elseif(word.eq.'epos')then
+#if __EPOS__ || __CORSIKA8__
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ call aaset(0)
+ call LHCparameters
+#endif
+ MCleModel=4
+#else
+ stop 'CONEX compiled without __ EPOS __, can not run !'
+#endif
+ elseif(word.eq.'sibyll')then
+ stop 'CONEX cannot run at low energy with Sibyll !'
+ elseif(word.eq.'IIqgsjet')then
+#if __QGSJETII__ || __CORSIKA8__
+ MCleModel=6
+#else
+ stop 'CONEX compiled without __ QGSJETII __, can not run !'
+#endif
+ elseif(word.eq.'fluka')then
+#if __FLUKA__ || __CORSIKA8__
+ MCleModel=7
+#else
+ stop 'CONEX compiled without __ FLUKA __, can not run !'
+#endif
+ elseif(word.eq.'urqmd')then
+#if __URQMD__ || __CORSIKA8__
+ MCleModel=8
+#else
+ stop 'CONEX compiled without __ URQMD __, can not run !'
+#endif
+ elseif(word.eq.'dpmjet')then
+#if __DPMJET__ || __CORSIKA8__
+ MCleModel=9
+#else
+ stop 'CONEX compiled without __ DPMJET __, can not run !'
+#endif
+ else
+ write(6,*)"Do not know this model !",word
+ stop 'stop !!!!'
+ endif
+
+c define model used for high energy part (in both MC and numeric part)
+
+ elseif(word.eq.'model')then
+ call getw(word)
+#ifdef __MODEL__
+c mixed high energy models
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ call aaset(0)
+ call LHCparameters
+#endif
+ MCModel=0
+#else
+ if(word.eq.'nexus')then
+#if __NEXUS__ || __CORSIKA8__
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ call aaset(0)
+#endif
+ MCModel=1
+#else
+ stop 'CONEX compiled without __NEXUS__, can not run !'
+#endif
+ elseif(word.eq.'qgsjet')then
+#if defined (__QGSJET__) || __CORSIKA8__
+ MCModel=2
+#else
+ stop 'CONEX compiled without __QGSJET__, can not run !'
+#endif
+ elseif(word.eq.'gheisha')then
+ stop 'CONEX cannot run at high energy with Gheisha !'
+ elseif(word.eq.'epos')then
+#if __EPOS__ || __CORSIKA8__
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ call aaset(0)
+ call LHCparameters
+#endif
+ MCModel=4
+#else
+ stop 'CONEX compiled without __EPOS__, can not run !'
+#endif
+ elseif(word.eq.'sibyll')then
+#if __SIBYLL21__ || __CORSIKA8__
+ MCModel=5
+#else
+ stop 'CONEX compiled without __SIBYLL21__, can not run !'
+#endif
+ elseif(word.eq.'IIqgsjet')then
+#if __QGSJETII__ || __CORSIKA8__
+ MCModel=6
+#else
+ stop 'CONEX compiled without __QGSJETII__, can not run !'
+#endif
+ elseif(word.eq.'dpmjet')then
+#if __DPMJET__ || __CORSIKA8__
+ MCModel=9
+#else
+ stop 'CONEX compiled without __DPMJET__, can not run !'
+#endif
+ elseif(word.eq.'fluka')then
+ stop 'CONEX cannot run at high energy with FLUKA !'
+ elseif(word.eq.'urqmd')then
+ stop 'CONEX cannot run at high energy with UrQMD !'
+ else
+ write(6,*)"Do not know this model !",word
+ stop 'stop !!!!'
+ endif
+#endif
+
+c stop program
+ elseif(word.eq.'stop')then
+
+#ifdef __CXSUB__
+ return !end of file for subroutine
+#else
+
+#ifdef __COAST__
+ CALL CLODA ()
+#endif
+
+ stop
+
+c run different mode of conex
+
+ elseif(word.eq.'run')then
+ call getw(word)
+ lheader=.false.
+
+ if(word.eq.'ElectronPhotonShower')then !MC e/m shower (egs4)
+ mode=1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ do n=1,nshower
+ call IniProfile(0,3,n)
+ call InitialParticleSho(id)
+ call cegs4(n,mshow)
+ call AddProfile(0,2,n)
+ enddo
+
+
+ elseif(word.eq.'ElectronPhotonCascade')then !numerical e/m cascade
+ mode=2
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeEphCas2
+ call IniProfile(0,2,0)
+ call IniEMCE
+ call InitialParticleSho(id)
+ call InitialParticleEphCas
+ call CrossSections
+ write(6,'(a)')'solve cascade equations'
+ call SolveMomentEquations(0) !s0210503
+ call AddProfile(0,2,nshower)
+
+
+ elseif(word.eq.'ElectronPhotonHybrid')then !MC e/m shower (egs4)for e>eecut,
+ !numerical e/m cascade for e<eecut
+ mode=3
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeEphCas2
+ call CrossSections
+ do n=1,nshower
+ call IniProfile(0,2,n)
+ call IniEMCE
+ call IniElePhoSource
+ call InitialParticleSho(id)
+ call cegs4(n,1)
+ write(6,'(a)')'solve cascade equations'
+ call SolveMomentEquations(n)
+ call AddProfile(0,2,n)
+ enddo
+
+
+ elseif(word.eq.'HadronShower')then !MC hadron shower
+ mode=4
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+ do n=1,nshower
+ call IniProfile(3,10,n)
+ call InitialParticleSho(id)
+ call HadronShower(n,idum)
+ call AddProfile(3,10,n)
+ enddo
+
+
+ elseif(word.eq.'HadronHybrid')then !MC hadron shower for e>ehcut,
+ !numerical hadron cascade for e<ehcut
+ mode=5
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+ call IniHadCas(id)
+ do n=1,nshower
+ call IniProfile(3,10,n)
+ call IniHadSource
+ call InitialParticleSho(id)
+ call HadronShower(n,iCEmode)
+ call HadronCascade(id,n,nshower,iCEmode)
+ call AddProfile(3,10,n)
+ enddo
+
+
+ elseif(word.eq.'HadronCascade')then !numerical hadron cascade
+ mode=6
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+ call IniProfile(3,10,0)
+ call IniHadCas(id)
+ call IniHadSource
+ call InitialParticleSho(id)
+ call HadronCascade(id,0,0,0)
+ call AddProfile(3,10,nshower)
+
+
+ elseif(word.eq.'Cascade')then !numerical hadron cascade +
+ !numerical lepton cascade
+ mode=7
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+ call IniProfile(0,10,0)
+ call IniHadCas(id)
+ call IniEMCE
+ call InitializeEphCas2
+ call IniElePhoSource
+ call IniHadSource
+ call CrossSections
+ call InitialParticleSho(id)
+ write(6,'(a)')'solve cascade equations'
+ call HadronCascade(id,0,0,0)
+ call SolveMomentEquations(0)
+ call AddProfile(0,10,nshower)
+
+
+ elseif(word.eq.'Hybrid')then !MC hadron shower for e>ehcut,
+ !MC e/m shower (egs4)for e>eecut,
+ !numerical hadron cascade for e<ehcut,
+ !numerical e/m cascade for e<eecut
+ mode=8
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+ call IniHadCas(id)
+ call InitializeEphCas2
+ call CrossSections
+ do n=1,nshower
+ call IniProfile(0,10,n)
+ call IniEMCE
+ call IniHadSource
+ call IniElePhoSource
+ call InitialParticleSho(id)
+ call HadronShower(n,iCEmode)
+ write(6,'(a)')'solve cascade equations'
+ call HadronCascade(id,n,nshower,iCEmode)
+ call SolveMomentEquations(n)
+ call AddProfile(0,10,n)
+ enddo
+
+
+ elseif(word.eq.'Shower')then !MC hadron shower,
+ !MC e/m shower (egs4),
+ mode=0
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeEphCas2
+ call InitializeMC2
+ do n=1,nshower
+ call IniProfile(0,10,n)
+ call InitialParticleSho(id)
+ call HadronShower(n,idum)
+ call AddProfile(0,10,n)
+ enddo
+
+ else
+
+ stop "I don't know this run type ..."
+
+ endif
+
+#endif
+c Write in histo analysis results
+
+ elseif(word.eq.'plot')then
+#ifdef __ANALYSIS__
+ call getw(word)
+ if(word.eq.'*')then !print mean spectra (depth, energy, moments, ...)
+ if(mode.ge.5)call xHadronCascade(1,7) !tp240903
+ if(mode.eq.2.or.mode.eq.3.or.mode.ge.7)
+ & call xElectronPhotonCascade
+ if(mode.eq.4)then
+ call xShower(4,12)
+ elseif(mode.eq.1)then
+ call xShower(1,3)
+ elseif(mode.eq.0)then
+ call xShower(1,12)
+ endif
+ elseif(word.eq.'table')then !print MC energy spectra used for CE
+ mode=-1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call InitializeMC2
+#ifdef __CXSUB__
+ call IniHadCasSub
+#else
+ call IniHadCas(0)
+#endif
+ call getw(word)
+ call xTableCascade(1,12,word)
+ elseif(word.eq.'greisen')then !print greisen distribution
+ mode=-1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call xgreisen
+ elseif(word.eq.'EGScomp')then !print spectra from EGS4
+ mode=-1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call xEGScomp
+ elseif(word.eq.'EGSangle')then !print mscat angle from EGS4
+ mode=-1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call xEGSangle
+ else !print interaction cross section (from MC)
+
+ mode=-1
+ call InitializeOnce(iegs,iolo)
+ call Initialize2
+ call xcross(word)
+ endif
+#else
+ write(*,*)'Warning : plot not available !'
+#endif
+
+c write text in histo file
+ elseif(word.eq.'write')then
+ call getw(word)
+ write(ifho,'(a)')word
+
+
+c define conex files
+ elseif(word.eq.'fconex')then
+ call NameConexFiles
+
+c open conex files
+ elseif(word.eq.'fopen')then
+ call OpenConexFiles
+
+c define nexus file
+ elseif(word.eq.'fnexus')then
+ call NameNexusFiles
+
+c define epos file
+ elseif(word.eq.'fepos')then
+ call NameNexusFiles
+
+c define qgsjet file
+ elseif(word.eq.'fqgsjet')then
+ call NameQGSJetFiles
+
+c define qgsjetII file
+ elseif(word.eq.'fqgsjetII')then
+ call NameQGSJetIIFiles
+
+c define DPMJET path
+ elseif(word.eq.'fdpmjet')then
+ call NameDPMJETPath
+
+c define EGS4 file
+ elseif(word.eq.'fegs')then
+ call NameEGSFiles
+
+c define UrQMD file
+ elseif(word.eq.'furqmd')then
+ call NameUrQMDFiles
+
+c set parameters for conex (energy, number of showers, seed, analysis, ...)
+ elseif(word.eq.'set')then
+ call SetConexParameters
+
+c set parameters for nexus (in between "NexusInput" and "EndNexusInput", use Nexus commands)
+ elseif(word.eq.'NexusInput')then
+#ifdef __NEXUS__
+ call NexusInput
+#else
+ do while(word.ne.'EndNexusInput')
+ call getw(word)
+ enddo
+#endif
+ elseif(word.eq.'EndNexusInput')then
+c set parameters for EPOS (in between "EposInput" and "EndEposInput", use EPOS commands)
+ elseif(word.eq.'EposInput')then
+#ifdef __EPOS__
+ call EposInput
+#else
+ do while(word.ne.'EndEposInput')
+ call getw(word)
+ enddo
+#endif
+ elseif(word.eq.'EndEposInput')then
+c print check outputs on "file" (default) or "screen"
+ elseif(word.eq.'printcheck')then
+ call Printcheck
+
+c define level and subroutines for check outputs (debbugging)
+ elseif(word.eq.'print')then
+ call print
+c end of file
+ elseif(word.eq.'stop')then
+ stop
+ else
+ write(6,'(//10x,a//)')
+ & 'STOP: unknown command "'//word(1:index(word,' ')-1)//'"'
+ stop
+ endif
+ goto 1
+ end
+
+c-----------------------------------------------------------------------
+ subroutine InitializeMC
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ real anquasiel
+ common/ghecsquel/anquasiel,iquasiel
+ write(6,'(a)')'initialize MC ...'
+
+ xsegymin=1d0
+ xsegymax=enymax+1.d0
+ xsbminim=0.d0
+ xsbmaxim=10000.d0
+ iquasiel=1 ! no (0) or (1) quasi-elastic event in gheisha
+ xsainfin=1d31
+ xspi=pi
+ call cxhdecin(.false.)
+ end
+
+c-----------------------------------------------------------------------
+ block data CONEXDATA
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+c atmosphere
+
+#ifndef __CXCORSIKA__
+ DATA AATM / -186.5562d0, -94.919d0, 0.61289d0,0.d0,.01128292d0 /
+ DATA BATM / 1222.6562d0,1144.9069d0,1305.5948d0,540.1778d0,1.d0 /
+ DATA CATM / 9941.8638d0,8781.5355d0,6361.4304d0,7721.7016d0,1d07/
+ data datm / 631.1d0,271.7d0,3.0396d0,0.00128292d0,0.d0/
+ data eatm / 0.d0,4.d3,1.d4,4.d4,1.d5,1.d5/
+#endif
+c bdeca=M(GeV)/(tau*c) for proton (1), c pion (2), c kaon (3), Kl (4), Ks (5)
+c pi0 (6), neutron (7), lambda (8), muon (9), sigma+ (10), sigma- (11)
+c xi0 (12), xi-(13), omega(14), D0 (15), D+ (16), Ds (17), lambdac (18)
+ data bdeca/ 0.d0,0.01781d0,0.132959d0,0.032087d0,18.5962d0,5.378d6
+ & ,0.35058d-11,14.1405d0,0.1604d-3,49.47d0,27.d0,15.09d0
+ & ,26.91d0,67.94d0,15.1d3,5.934d3,13.25d3,36.96d3/
+
+c gauss integration
+
+ data xgauss7/.9862838d0,.9284349d0,.8272013d0,.6872929d0
+ *,.5152486d0,.3191124d0,.1080549d0/
+ data wgauss7/.03511946d0,.08015809d0,.1215186d0,.1572032d0,
+ *.1855384d0,.2051985d0,.2152639d0/
+
+
+ data xgauss10/
+ & .765265211334973D-01,
+ & .227785851141645D+00,
+ & .373706088715420D+00,
+ & .510867001950827D+00,
+ & .636053680726515D+00,
+ & .746331906460151D+00,
+ & .839116971822219D+00,
+ & .912234428251326D+00,
+ & .963971927277914D+00,
+ & .993128599185095D+00/
+ data wgauss10/
+ & .152753387130726D+00,
+ & .149172986472604D+00,
+ & .142096109318382D+00,
+ & .131688638449177D+00,
+ & .118194531961518D+00,
+ & .101930119817233D+00,
+ & .832767415767047D-01,
+ & .626720483341090D-01,
+ & .406014298003871D-01,
+ & .176140071391506D-01/
+
+
+C --- ighenex(I)=neXus CODE CORRESPONDING TO Gheisha CODE I ---
+
+ common /cxighnx/ ighenexs(35)
+ data ighenexs/
+ $ 10, 11, -12, 12, -14, 14, 120, 110,
+ $ -120, 130, 20, -20, -130, 1120, -1120, 1220,
+ $ -1220, 2130, -2130, 1130, 1230, 2230, -1130, -1230,
+ $ -2230, 1330, 2330, -1330, -2330, 17, 18, 19,
+ $ 3331, -3331, 30/
+
+c constants
+
+ data avog /6.0221419947D-04/ ! Avogadro's constant
+ data cxlight/0.299792458d0/ !speed of light in m/ns
+ data pi/3.141592654d0/ !Pi
+ data radearth/6371315.D0/ !earth radius in meter
+ data fialpha/137.0359998D0/ !inverse of fine structure constant
+
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine Initialize
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#include "conexep.h"
+ character*500 fndat,fnncs
+ common/qgsfname/ fndat, fnncs, ifdat, ifncs
+ character*500 fnIIdat,fnIIncs
+ common/qgsIIfname/ fnIIdat, fnIIncs, ifIIdat, ifIIncs
+
+
+ ivers=7500 !conex version
+ lheader=.false.
+ lwrite=.true.
+
+c basics
+
+#ifdef __CXCORSIKA__
+c mode defined in CORSIKA
+#else
+ mode=8 !hybrid
+#endif
+ eprima=1.d+6 !e0
+ thetas=0.d0 !teta ! in degrees !!!
+ phisho=0.d0 ! in degrees !!!
+ zshmin=0.d0 !zmin !so241103
+ zshmax=1020.d0 !zmax
+ XminSlant=-1.d0 !minimum value of maximum slant depth (if >0)
+ delzsh=10.d0 !dz
+ irdelz=1 !dZZ/delzsh
+ hground=eatm(1) !0.0d0 !ground height above see level (m)
+ altitude=0.0d0 !height above hground of the closer shower point to the earth (m)
+ longitude=-69.3d0!AUGER site (Greenwich = 0., eastward is positive)
+ latitude=-35.3d0 !AUGER site (Northpole = +90., Southpole = -90.)
+ year=2013.
+c This value should not be change since it defines the first bin of hadronic tables
+ exmin=1.d-3 !minimum energy for the produced particle in spectra
+ !for the electromagnetic component it has to be around 1 MeV
+ !this value has to be the same for the tables (reference for binning)
+ emin=0.001d0 !emin for electromagnetic particles
+ enymin=1.d0 !emin for hadronic particles
+ enymax=1.d+15 !emax
+ decade=20.d0 !dn for hadrons and plots
+ emdecade=decade !dn for em CE
+ ehcut=-1.d0 !Transition energy MC -> CE for hadrons
+ eecut=.001d0 !Transition energy EGS -> CE for electrons
+ epcut=-1.d0 !Transition energy EGS -> CE for photons (if <0 = eecuti)
+ emcut=-1.d0 !Transition energy MC -> CE for muons (if <0 = ehcuti)
+ ehlowi=0.d0 !Transition energy CE -> MC for hadrons
+ eelowi=0.d0 !Transition energy CE -> EGS for electrons
+ emlowi=0.d0 !Transition energy CE -> MC for muons (if <0 = ehlowi)
+ fwhmax=-1.d0 !Factor for maximum weigth for low energy MC for hadrons (if >0 wshmax=fwhmax*eprima)
+ fwemax=-1.d0 !Factor for maximum weigth for low energy MC for electrons (if >0 wsemax=fwemax*eprima)
+ fwmmax=-1.d0 !Factor for maximum weigth for low energy MC for muons (if >0 wsmmax=fwmmax*eprima)
+ wshmax=1.d0 !Maximum weigth for low energy MC for hadrons
+ wsemax=1.d0 !Maximum weigth for low energy MC for e/m
+ wsmmax=1.d0 !Maximum weigth for low energy MC for muons
+ zshlow=400d0 !Minimum vertical depth to ground to start CE -> MC
+ zmclow=0d0 !Minimum slant depth to start CE -> MC for EM (from zshlow)
+ zmchlow=0d0 !Minimum slant depth to start CE -> MC for hadrons
+ fehcut=1.d-2 !Factor for Transition energy MC -> CE for hadrons in subroutine mode (ehcut=fehcut*eprima)
+ femcut=1.d-4 !Factor for Transition energy MC -> CE for muons in subroutine mode (emcut=femcut*eprima)
+ feecut=1.d-4 !Factor for Transition energy EGS -> CE for electrons in subroutine mode (eecut=feecut*eprima)
+ nshower=1 !shower number
+ mshow=1 !print shower number every mshow
+ mshowEGS=100000 !print EGS4 shower number every mshowEGS in Hybrid mode
+ lseq=1
+ iseed(1,1)=54217137
+ iseed(2,1)=0
+ iseed(3,1)=0
+ iseed(1,2)=12345678 !random numbers for MC after CE
+ iseed(2,2)=0
+ iseed(3,2)=0
+ ihthin=0 !Thinning in CONEX Hadronic MC (value from 0 (=no) to 1)
+ hthin=1.d-2 !Thinning value in CONEX (thinning start for E < hthin*Eprima)
+ whmax=1.d+2 !maximum weight of a particle in case of thinning in CONEX
+ iothin=0 !Thinning in EGS4 (value from 0 (=no) to 2)
+ thin=1.d-2 !Thinning value in EGS4 (thinning start for E < thin*Eprima)
+ wtmax=1.d+4 !maximum weight of a particle in case of thinning in EGS4
+
+c constants
+
+ radlth=36.61623d0 !radiation length of electron in air (value from egs4=rho*rlc=rldu from egs4.dat)
+c utilities
+ dphmin0=aatm(mxatm)-batm(mxatm)*eatm(mxatm+1)/catm(mxatm)
+ isx=0
+ nisx=0
+c modes=1
+
+c Files
+
+ ifho=0
+#ifdef __CXCORSIKA__
+c ifck=0 !defined in CORSIKA
+#else
+ ifck=0
+#endif
+ ifda=0
+ ifrt=0
+ ifout=0
+ ifwle=0
+ ifwhe=0
+ ifwgl=0
+ ifwgh=0
+ ifdkz=0
+ ifdks=0
+ ifdkl=0
+ ifdkm=0
+ ifdke=0
+ ifdkn=0
+ ifdkg=0
+ ifilo=0
+ ifdat=0
+ ifncs=0
+ ifIIdat=0
+ ifIIncs=0
+ ifemcs=0
+ ifinput=0
+ nfnho=0
+ nfnck=0
+ nfnda=0
+ nfnwle=0
+ nfnwgl=0
+ nfnwgh=0
+ nfndkz=0
+ nfndks=0
+ nfndkl=0
+ nfndkm=0
+ nfndke=0
+ nfndkn=0
+ nfndkg=0
+ nfnilo=0
+ nfnemcs=0
+ nfninput=0
+
+c model
+
+ MCModel=2 !default MC model = QGSJet
+ MCleModel=3 !default low energy MC model = Gheisha
+ i1DMC=0 !1D-treatment for MC to compare to 1D CE (0=no (3D), 1=yes (3D traced as 1D), 2=yes (real 1D : pt =0))
+ i1DEM=0 !1D-treatment for EM particles to compare EGS and CE (0=no (angle for inelastic interactions in EGS), 1=yes (angle=0))
+ imscat=1 !multiple scattering in EGS4 (0=no (no multiple scattering in EGS4 and no correction for CE), 1=yes (3D in EGS and correction in CE))
+ iphonu=1 !photonuclear effect in EGS4 (0=no, 1=yes)
+ iMagne=0 !Magnetic Field (1=yes, 0=no)
+ iMuScat=0 !Muon multiple scattering (1=yes, 0=no)
+ ionloss=1 !ionization loss (1=yes, 0=no)
+ ilowegy=1 !use MCModel for high energy int
+ !and MClemodel for very low energy (Ekin < EgyHiLoLim GeV)
+ EgyHiLoLim=80.d0
+ ilpmeffect=1 !LPM effect in EGS4
+ ipreshow=1 !preshowering effect for gamma shower
+ istern=1 !Sternheimer correction (1=on, 0=off)
+c SternHeimer Correction for air density dependence of electrons dE/dX
+c STERNCOR=0.d0 !if e > 3 MeV
+c STERNCOR=6.d0 !if e > 1 MeV
+c STERNCOR=10.d0 !if e > 0.4 MeV
+c STERNCOR=11.d0 !if e > 0.25 MeV
+ STERNCOR=12d0 !we use table of 0.2 MeV)
+c STERNCOR=12.5d0 !if e > 0.15 MeV
+c STERNCOR=15.d0 !if e > 0. MeV
+c where e is the minimum kinetic energy of the elecromagnetic part (Eo for EM CA,
+c min(ecut-amc2,pcut) for EGS4)
+ ifragm=2 ! 0 : all nucleon free
+ ! 1 : all spectators in one nucleus
+ ! 2 : uses realistic fragments
+ iMuInt=1 ! 0< : high energy muon interaction
+#if __MC3D__ || __CXLATCE__
+ iLatCE=1 ! 1 = calculation of higher moments for LDF or low MC
+#endif
+
+
+c moments
+
+#ifdef __ANALYSIS__
+#if __MC3D__ || __CXLATCE__
+ muso=maxo
+#endif
+#endif
+c analysis
+
+
+#ifdef __ANALYSIS__
+ do i=0,ngenmx
+ cntgen(i)=0d0
+ enddo
+ kfirsth=41 !first of 3 selected depth bins for hadronic CE energy spectra
+ modkh=30 !delta in between the 3 selected depth bins for hadronic CE energy spectra
+
+ zamin=-1.d0 !min depth for analysis
+ zamax=-1.d0 !max depth for analysis
+ delza=(zamax-zamin)/dble(numiz-1)
+ tamax=-1.d0 !max time for analysis
+ tamin=-eatm(mxatm+1)/cxlight !min time for analysis
+ ctime=exp(log(tamax/tamin)/dble(1-numiz))
+ izfirst=0 !first of 3 selected depth bins for MC energy spectra (if 0, adjusted to kfirsth)
+ modz=1 !delta in between the 3 selected depth bins for MC energy spectra (if 0, adjusted to modkh)
+ eamin(1)=0.d0 !minimum energy for leptons in MC analysis in GeV
+ eamax(1)=0.d0 !maximum energy for leptons in MC analysis in GeV (if 0, set to eprima)
+ eamin(2)=0.d0 !minimum energy for hadrons in MC analysis in GeV
+ eamax(2)=0.d0 !maximum energy for hadrons in MC analysis in GeV (if 0, set to eprima)
+ numie=120 !number of bins for energy in MC analysis
+#if __MC3D__ || __CXLATCE__
+ ramin=0.1d0 !moment analysis parameters
+ ramax=10000d0
+ numir=50
+ irfirst=20
+ modr=10
+ xamin(1)=-1.d0 !cos(phi)
+ xamax(1)=1.d0
+ numix(1)=40
+ xamin(2)=0d0 !sin2(theta)
+ xamax(2)=1d0
+ numix(2)=40
+ xamin(3)=-10d0 !time
+ xamax(3)=1990d0
+ numix(3)=100
+ xamin(4)=-pi !delta phi (position/direction)
+ xamax(4)=pi
+ numix(4)=40
+ xamin(5)=-10d0 !log10(sin2(theta))
+ xamax(5)=0d0
+ numix(5)=40
+ iefirst=10
+ moden=20
+#endif
+c Analyze for output
+
+ numiz=101 !number of bins for depth and time in histo
+#endif
+
+#ifndef __CXSUB__
+ iwrt=0 !output (0=no, 1=mean, 2=all)
+#else
+ iwrt=2 !output (0=no, 1=mean, 2=all)
+#endif
+ iXmax=1 !do the fit of Xmax (0=no, 1=yes (only sums), 2=yes(all))
+ XminP=0.d0 !minimum depth to print
+ XmaxP=0.d0 !maximum depth to print
+ EMCutP(1)=1.d-3 !1st energy cut for EM particles in GeV
+ HaCutP(1)=1.d0 !1st energy cut for haronic particles in GeV
+ if(mxExpro.ge.2)then
+ idx=2
+ EMCutP(idx)=10.d0 !2d energy cut for EM particles in GeV
+ HaCutP(idx)=10.d0 !2d energy cut for haronic particles in GeV
+ if(mxExpro.ge.3)then
+ idx=3
+ EMCutP(idx)=100.d0 !3d energy cut for EM particles in GeV
+ HaCutP(idx)=100.d0 !3d energy cut for haronic particles in GeV
+ endif
+ endif
+ musZ=maximZ
+ nminX=1 !first bin in Z
+ nmaxX=nint((zshmax-zshmin)/delzsh)+1 !last bin in Z
+ mZEMHa=irdelz !number of Z bins for EM CE for one Hadronic Z bin.
+
+c air
+
+ aira(1)=14.007d0 !Nitrogen
+ airz(1)=7.d0
+ airw(1)=0.7846d0
+ airi(1)=82.0d-09
+ aira(2)=15.999d0 !oxigen
+ airz(2)=8.d0
+ airi(2)=95.0d-09
+ airw(2)=.2107d0
+ aira(3)=39.948d0 !Argon
+ airz(3)=18.d0
+ airi(3)=188.d-9
+ airw(3)=0.0047d0
+ airava=aira(1)*airw(1)+aira(2)*airw(2)+aira(3)*airw(3)
+ airavz=airz(1)*airw(1)+airz(2)*airw(2)+airz(3)*airw(3)
+
+c Note : in EGS4, RHOZ of each component i correspond to the weight fraction=aira(i)*airw(i)/airava
+
+
+c masses
+
+ call cxidmass(1120,am) !proton mass
+ pmass(1)=dble(am)
+ call cxidmass(120,am) !pion ch mass
+ pmass(2)=dble(am)
+ call cxidmass(130,am) !kaon ch mass
+ pmass(3)=dble(am)
+ call cxidmass(20,am) !kaon 0 mass
+ pmass(4)=dble(am)
+ call cxidmass(110,am) !pion 0 mass
+ pmass(5)=dble(am)
+ call cxidmass(1220,am) !neutron mass
+ pmass(6)=dble(am)
+ pmass(7)=(pmass(1)+pmass(6))/2.d0!mean nucleon mass
+ call cxidmass(2130,am) !lambda mass
+ pmass(8)=dble(am)
+ call cxidmass(14,am) !muon mass
+ pmass(9)=dble(am)
+ call cxidmass(12,am) !electron mass
+ pmass(10)=dble(am)
+
+c target properties (air)
+
+ idtargxs=0 ! air
+ matargxs = 14 !not used but needed
+ latargxs = 7
+ call cxiclass(idtargxs,icltarxs)
+ iclproxs=2 !to be safe at the beginning
+
+c projectile properties (proton to be safe)
+
+ idprojxs=1120
+ maprojxs = 1
+ laprojxs = 1
+ call cxiclass(idprojxs,iclproxs)
+
+ end
+
+
+c------------------------------------------------------------------------------
+ subroutine InitializeEphCas
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ radle=radlth !radiation length of electron in air
+ amc2=pmass(10)
+ imaxE0=1 !maximum bin in the source
+ maxZ=maximumZ
+ lowZ=maxZ+1
+ jminZ0=1
+ imaxE0=maxE
+c This value should not be change since it defines the first bin of em tables
+ Eo=1.d-6 !Threshold energy (about 1 keV expressed in GeV)
+ Cem=10.D0**(1.d0/emdecade) !size of the energy bin
+ c2em=sqrt(Cem) !half size of the energy bin
+ dZZ=delzsh/dble(irdelz) !delzsh/dZZ must be an integer = irdelz
+ ZZo=zshmin !should be the same as zshmin
+ minE=1
+ lowE=0
+ maxE=maximumE
+ kfirst=0 !first of 3 selected depth bins for EM CE energy spectra (if 0, adjusted to kfirsth)
+ modk=1 !delta in between the 3 selected depth bins for EM CE energy spectra (if 0, adjusted to modkh)
+
+ end
+
+#if __MC3D__ || __CXLATCE__
+#ifdef __ANALYSIS__
+
+c---------------------------------------------------------------------------
+ subroutine InitializeTripleIndex
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#ifdef __CXDEBUG__
+ write(*,*)'Triple index: '
+#endif
+ ii=-1
+ do n=0,maxo !order
+#ifdef __CXDEBUG__
+ write(*,*)' order: ',n
+#endif
+#ifdef __CXLATCE__
+ do k=n,0,-1 !block
+#else
+ do k=n,n !block
+#endif
+ do i=n-k,0,-1
+ ii=ii+1
+ i1mom(ii)=k
+ i2mom(ii)=i
+ i3mom(ii)=n-k-i
+ iimom(k,i,n-k-i)=ii
+#ifdef __CXDEBUG__
+ write(*,'(5x,i4,5x,3i2)')ii,i1mom(ii),i2mom(ii),i3mom(ii)
+#endif
+ enddo
+ enddo
+ enddo
+ end
+#endif
+#endif
+c-----------------------------------------------------------------------
+ subroutine Initialize2
+c-----------------------------------------------------------------------
+c Initialization depending on eprima and thetas
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ common/cxNnucleon/aNbrNucl
+#if __CXCORSIKA__ || __CORSIKA8__
+ integer ifirst
+ data ifirst/0/
+ save ifirst
+#endif
+
+ costhet=cos(2.d0*pi*thetas/360.d0) !shower axis cosine
+ if(abs(costhet).lt.1.d-9)costhet=0.d0
+ if(abs(costhet).gt.1.d0)costhet=sign(1.d0,costhet)
+ sinthet=dsqrt(1.d0-costhet*costhet) !sin fo theta
+ cosphi=cos(2.d0*pi*phisho/360.d0)
+ sinphi=sin(2.d0*pi*phisho/360.d0)
+ xsaxis=cosphi*sinthet !projection into obser frame
+ ysaxis=sinphi*sinthet !projection into obser frame
+ zsaxis=costhet !projection into obser frame
+
+ if(ihthin.ge.1)then
+ ehthin=eprima*hthin
+ else
+ ehthin=0.d0
+ endif
+
+c Check altitude
+
+ if(altitude.lt.-0.02d0)then !not 0 because of CORSIKA offset
+ write(*,*)'Altitude < 0 : Cannot do underground shower !'
+ write(*,*)'If you want showers below see level, change hground'
+ stop
+ endif
+
+ do i=1,mxatm
+ ccatm(i)=log(batm(i)/catm(i))
+ bbatm(i)=1.d0/catm(i)
+ enddo
+
+ HGrd=hground
+ eatm(1)=HGrd
+ call IniInclined !minimum indice of atmospheric layers
+ dphmin0=aatm(mxatm)-batm(mxatm)*eatm(mxatm+1)/catm(mxatm)
+ RadGrd=radearth+HGrd
+ radtr0=(RadGrd+altitude)*sinthet !impact radius !so180903
+ DistAlt=distant(altitude+hground,radtr0) !slant distance to obs z-axis,m
+ if(mode.ge.0)then
+ depthmaxi0=depthmax(radtr0) !max slant depth
+ if(XminSlant.gt.0d0)then
+ do while (depthmaxi0.lt.XminSlant)
+ RadGrd=RadGrd-100d0
+ HGrd=RadGrd-radearth
+ eatm(1)=HGrd
+ call IniInclined
+ depthmaxi0=depthmax(radtr0)
+ enddo
+ endif
+ else
+ depthmaxi0=zshmax
+ endif
+
+#if __CXCORSIKA__ || __CORSIKA8__
+ H0=XminP !height
+ dist0=distant(H0,radtr0) !slant distance to obs level, m
+ if(zsaxis.ge.0d0)then !downward going shower
+ XminP=deptht(dist0,radtr0) !conversion to slant depth, g/cm^2
+ else !upward going shower
+ XminP=depthmaxi0-deptht(dist0,radtr0) !conversion to slant depth, g/cm^2
+ endif
+ zshmin=XminP
+c Test ground position in case of flat HGrd only for downward going showers
+ if(costhet.lt.0.d0)lFlat=.false.
+#endif
+
+ goOutGrd=radtr0.lt.RadGrd.and.costhet.lt.0.d0
+ if(goOutGrd)then
+ dphmaxi0=depthmaxi0
+ zshmin=max(0.d0,zshmin)
+ dphmin0=0.d0 !zmin
+ else
+ dphmaxi0=2.d0*depthmaxi0
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ zshmin=max(dphmin0,zshmin) !zmin
+#endif
+ endif
+ dphlim0=dphmaxi0-depthmaxi0-1.d-10
+ zshmax=depthmaxi0 !max slant depth
+ if(mode.ge.0.and.radtr0.gt.RadGrd)zshmax=2.d0*depthmaxi0 !tp240205
+
+c Calculate zmclow (slant depth) corresponding to a maximum of zshlow (vertical depth) and convert it to a CE slant bin for compatibility between CE and MC
+#ifdef __MC3D__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(cx2corsem)then
+ zmclow=0d0
+ if(isx.ge.1)then
+ write(*,*)'Low Energy EM MC on full slant depth range.'
+ endif
+ else
+#endif
+ zmclow=depthmaxi0-zshlow
+ if(zmclow.le.0d0)then
+#ifdef __CXDEBUG__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.1)then
+#endif
+ write(*,*)'Low Energy EM MC on full slant depth range.'
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#endif
+ zmclow=0d0
+ elseif(zmclow.ge.zshmax)then
+#ifdef __CXDEBUG__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.1)then
+#endif
+ write(*,*)'Low Energy EM MC only for the last slant depth bin.'
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#endif
+ zmclow=zshmax
+ else
+ depthmn=depth(HGrd)
+ if(zshlow.lt.depthmn)then
+c define zmclow as a function of theta (zshlow = vertical depth)
+ heightmin=height(depthmn-zshlow)
+ DistMin=distant(heightmin,radtr0)
+ zmclow=deptht(DistMin,radtr0)
+ endif
+#ifdef __CXDEBUG__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.1)then
+#endif
+ write(*,*)'Low Energy EM MC starting after ',zmclow
+ & ,' g/cm2 on shower axis.'
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#endif
+ endif
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(cx2corsha)then
+ zmchlow=0d0
+ if(isx.ge.1)then
+ write(*,*)'Low Energy Had MC on full slant depth range.'
+ endif
+ else
+#endif
+c if(delzsh.gt.1)then
+c heightmax=max(altitude,1d4) !above 10km, low energy MC should not be used to avoid precision problem
+c DistMax=distant(heightmax,radtr0)
+cc longer interaction path for hadrons than EM.
+c zmchlow=min(max(400d0,zmclow-1000d0),deptht(DistMax,radtr0))
+ zmchlow=max(0d0,zmclow-1000d0)
+c else
+c zmchlow=0d0
+c endif
+#ifdef __CXDEBUG__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.1)then
+#endif
+ write(*,*)'Low Energy Hadron MC starting after ',zmchlow
+ & ,' g/cm2 on shower axis.'
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#endif
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+
+#else
+c No low energy MC
+ zshlow=0d0
+ zmclow=depthmaxi0
+ zmchlow=depthmaxi0
+#endif
+
+
+#ifndef __CXSUB__
+! for pure CE, threshold=primary energy
+ if(mode.eq.2.or.mode.eq.7)then
+ eecut=eprima
+ eelow=0d0
+ else
+ eelow=min(eprima+1d0,eelowi)
+ endif
+ if(mode.eq.6.or.mode.eq.7)then
+ ehcut=eprima
+ emcut=eprima
+ ehlow=0d0
+ emlow=0d0
+ else
+ ehlow=min(eprima+1d0,ehlowi)
+ emlow=min(eprima+1d0,emlowi)
+ endif
+#endif
+
+
+c Maximum weight for low energy MC particles (the same for proton and iron)
+ if(fwhmax.gt.0d0)then
+ wshmax=max(1d0,eprima*fwhmax)
+#ifndef __CXCORSIKA__
+ whmax=wshmax
+#endif
+ endif
+ if(fwmmax.gt.0d0)wsmmax=max(1d0,eprima*fwmmax)
+ if(fwemax.gt.0d0)then
+ wsemax=max(1d0,eprima*fwemax)
+#ifndef __CXCORSIKA__
+ wtmax=wsemax
+#endif
+ endif
+
+! Update depth limits for output (if not changed by user in optns file)
+ if(iwrt.ne.0)then
+ if(XmaxP.le.0.d0.or.XmaxP.gt.zshmax)then
+ XmaxP=zshmax !maximum depth to print
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ else
+ zshmax=XmaxP !maximum depth to print
+#endif
+ endif
+#if __CXCORSIKA__ || __CORSIKA8__
+ nminX=1 !in CORSIKA XminP is used to fix the starting height
+#else
+ if(XminP.le.0.d0.or.XminP.lt.zshmin)then
+ XminP=zshmin !minimum depth to print
+ endif
+ nminX=max(1,int((XminP-zshmin)/delzsh)+1) !first bin in Z
+#endif
+ nmaxX=min(maximZ,int((XmaxP-zshmin)/delzsh)+1) !last bin in Z
+ if(nmaxX.eq.maximZ)XmaxP=zshmin+dble(nmaxX-1)*delzsh
+ mZEMHa=irdelz !number of Z bins for EM CE for one Hadronic Z bin.
+ if(nminX.gt.nmaxX)stop'Shower stops before it starts !'
+ else
+ XmaxP=zshmax !maximum depth to print
+ endif
+
+ if(zshmin.ge.zshmax)then
+ write(*,*)'Zmin :', zshmin,' Zmax :',zshmax
+ stop 'Zmin > Zmax ... can not run !'
+ endif
+ musZ=min(maximZ,int((zshmax-zshmin)/delzsh)+1)
+ if(mode.eq.8)then
+ Emaxi=min(max(ehcut,emcut,eecut,epcut),eprima)
+ elseif(mode.eq.5)then
+ Emaxi=min(max(ehcut,emcut),eprima)
+ elseif(mode.eq.6.or.mode.eq.7.or.mode.lt.0)then
+ Emaxi=eprima
+ else
+ Emaxi=enymin
+ endif
+ musE=int(1+int(log10(Emaxi*c2bas/enymin)*decade))
+ if(musE.gt.maximE)stop 'musE too big in Initialize2'
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(nmaxX.eq.maximZ)then
+ if(isx.ge.1)then
+ zcemax=zshmin+dble(nmaxX-1)*dzHa
+ write(*,'(a)')' Maximum slant depth reached for CE'
+ write(*,'(a,f9.0,a)')' Full MC for X >',zcemax,' g/cm2)'
+ if(zcemax.lt.zmclow)zmclow=zcemax-1d0
+ if(zcemax.lt.zmclow)zmchlow=zcemax-1d0
+ endif
+ endif
+#endif
+
+ zha(1)=zshmin
+ do j=2,min(maximZ,musZ+1)
+ zha(j)=zha(1)+delzsh*(j-1)
+ end do
+
+
+! Update em CE parameters
+
+ radle=radlth !radiation length of electron in air
+#ifdef __MC3D__
+ if(emlow.lt.0.d0)emlow=ehlow
+ if(ehlow.le.0d0)ehlow=1d-9
+ if(emlow.le.0d0)emlow=1d-9
+ if(eelow.le.0d0)eelow=1d-9
+#else
+c No low energy MC allowed
+ ehlow=1d-9
+ emlow=1d-9
+ eelow=1d-9
+#endif
+
+
+#ifdef __MC3D__
+
+c set CE threshold to the closest CE low bin edge
+ if(ehcut.gt.0.d0)then
+ if(ehcut.lt.0.99999d0*eprima)then
+ iehcet=max(0,int(log10(ehcut*c2ha/exmin)*dnHa))
+ if(iehcet.gt.0)then
+ ehcutn=exmin*10d0**((dble(iehcet)-0.499999d0)/dnHa)
+ if(isx.ge.1)then
+ if(abs(ehcutn-ehcut).gt.1d-5)
+ & write(*,*)'CE hadron threshold set to ',ehcutn,' GeV'
+ endif
+ ehcut=ehcutn
+ endif
+ endif
+ endif
+ if(emcut.gt.0.d0)then
+ if(emcut.lt.0.99999d0*eprima)then
+ iemcet=max(0,int(log10(emcut*c2ha/exmin)*dnHa))
+ if(iemcet.gt.0)then
+ emcutn=exmin*10d0**((dble(iemcet)-0.499999d0)/dnHa)
+ if(isx.ge.1)then
+ if(abs(emcutn-emcut).gt.1d-5)
+ & write(*,*)'CE muon threshold set to ',emcutn,' GeV'
+ endif
+ emcut=emcutn
+ endif
+ endif
+ endif
+ if(eecut.gt.0.d0)then
+ if(eecut.lt.0.99999d0*eprima)then
+ ieecet=max(0,int(log10(eecut/Eo*c2em)*emdecade))
+ if(ieecet.gt.0)then
+ eecutn=Eo*10d0**((dble(ieecet)-0.499999d0)/emdecade)
+ if(isx.ge.1)then
+ if(abs(eecutn-eecut).gt.1d-5)
+ & write(*,*)'CE EM threshold set to ',eecutn,' GeV'
+ endif
+ eecut=eecutn
+ endif
+ endif
+ endif
+ if(epcut.gt.0.d0)then
+ if(epcut.lt.0.99999d0*eprima)then
+ ieecet=max(0,int(log10(epcut/Eo*c2em)*emdecade))
+ if(ieecet.gt.0)then
+ epcutn=Eo*10d0**((dble(ieecet)-0.499999d0)/emdecade)
+ if(isx.ge.1)then
+ if(abs(epcutn-epcut).gt.1d-5)
+ & write(*,*)'CE Gam threshold set to ',epcutn,' GeV'
+ endif
+ epcut=epcutn
+ endif
+ endif
+ endif
+
+c set low energy MC threshold to the closest CE low bin edge
+ iehmct=max(0,int(log10(ehlow*c2ha/exmin)*dnHa))
+ if(iehmct.gt.0)then
+ if(ehlow.gt.eprima)then !sampling on full range
+ ehlown=exmin*10d0**(dble(iehmct+1)/dnHa)
+ else
+ ehlown=exmin*10d0**((dble(iehmct)-0.499999d0)/dnHa)
+ endif
+ if(isx.ge.1)then
+ if(abs(ehlown-ehlow).gt.1d-5)
+ & write(*,*)'Low Energy MC hadron threshold set to ',ehlown,' GeV'
+ endif
+ if(cx2corsha)ehcut=ehlown
+ ehlow=ehlown
+ endif
+ iemmct=max(0,int(log10(emlow*c2ha/exmin)*dnHa))
+ if(iemmct.gt.0)then
+ if(emlow.gt.eprima)then !sampling on full range
+ emlown=exmin*10d0**(dble(iemmct+1)/dnHa)
+ else
+ emlown=exmin*10d0**((dble(iemmct)-0.499999d0)/dnHa)
+ endif
+ if(isx.ge.1)then
+ if(abs(emlown-emlow).gt.1d-5)
+ & write(*,*)'Low Energy MC muon threshold set to ',emlown,' GeV'
+ endif
+ if(cx2corsmu)emcut=emlown
+ emlow=emlown
+ endif
+ lowE=max(0,int(log10(eelow/Eo*c2em)*emdecade))
+ if(lowE.gt.0)then
+ if(eelow.gt.eprima)then !sampling on full range
+ eelown=Eo*10d0**(dble(lowE+1)/emdecade)
+ else
+ eelown=Eo*10d0**((dble(lowE)-0.4999999d0)/emdecade)
+ endif
+ if(isx.ge.1)then
+ if(abs(eelown-eelow).gt.1d-5)
+ & write(*,*)'Low Energy MC EM threshold set to ',eelown,' GeV'
+ endif
+ if(cx2corsem)eecut=eelown
+ eelow=eelown
+ lowE=max(0,int(log10(eelow/Eo*c2em)*emdecade)+1)
+ endif
+
+ musLh=int(1+int(log10(ehlow*c2bas/enymin)*decade))
+ musLm=int(1+int(log10(emlow*c2bas/enymin)*decade))
+
+#endif
+
+#ifdef __CXSUB__
+ epcut=eecut
+#else
+ if(epcut.lt.0.d0)epcut=eecut
+ if(emcut.lt.0.d0)emcut=ehcut
+#endif
+
+
+ if(i1DMC.eq.2)i1DEM=0
+
+
+ ZZo=zshmin !should be the same as zshmin
+ maxZ=min(maximumZ,int((zshmax-ZZo)/dZZ)+1) !maximum depth bin
+ lowZ=min(maximumZ,int((zmclow-ZZo)/dZZ)+2) !minimum depth bin to start CE -> MC (+2 because zmclow is defined just before the bin edge)
+
+c parameter check for EM and hadronic shower compatibility
+
+ if(mode.ge.7)then
+ if(abs(dble(maxZ)*dZZ-dble(musZ)*delzsh).gt.max(delzsh,dZZ))then
+ write(*,*)
+ & 'EM CE and Hadronic CE do no reach the same maximum depth ...'
+ stop 'Please check maximZ in conex.h and maximumZ in conexep.h'
+ endif
+ endif
+
+
+ if(mode.eq.8)then
+ Emaxi=min(max(ehcut,emcut,eecut,epcut),eprima)
+ elseif(mode.eq.3)then
+ Emaxi=min(max(eecut,epcut),eprima)
+ elseif(mode.eq.2.or.mode.eq.7.or.mode.lt.0)then
+ Emaxi=eprima
+ else
+ Emaxi=Eo
+ endif
+ maxE=int(log10(Emaxi/Eo*c2em)*emdecade)+1 !maximum energy bin in e/m CE
+ if(Emaxi.gt.1.000001d0*Eo*Cem**(maxE-1))maxE=maxE+1
+
+ if(maxE.gt.maximumE)stop 'maxE too big in Initialize2'
+
+ emin=max(emin,Eo)
+ minE=int(log10(emin/Eo*c2em)*emdecade)+1
+
+
+!same analysis for MC and CE for hadrons and leptons (zamax should be = to n*delzsh+zamin
+#ifdef __ANALYSIS__
+ if(kfirsth.gt.musZ)then
+ kfirsth=musZ/3
+ write(*,*) 'Warning : kfirsth too big => autom. changed to '
+ & ,kfirsth
+ endif
+ if(kfirsth+2*modkh.gt.musZ)then
+ modkh=(musZ-kfirsth)/2
+ write(*,*) 'Warning : modkh too big => autom. changed to '
+ & ,modkh
+ endif
+#ifndef __CXSUB__
+ if(mode.eq.0)then
+ if(zamin.lt.0.d0.and.zamax.lt.0.d0)then
+ zamin=zshmin
+ zamax=zshmax
+ delza=max(0.1d0,dble(nint((zamax-zamin)/dble(numiz-1))))
+ zamax=zamin+dble(numiz-1)*delza
+ else
+ if(zamin.lt.0.d0)zamin=zshmin
+ if(zamax.lt.0.d0)zamax=zshmax
+ delza=(zamax-zamin)/dble(numiz-1)
+ endif
+ else
+#endif
+c fix limit according to CE
+ zamin=zshmin
+ zamax=zshmax
+ delza=(zamax-zamin)/dble(numiz-1)
+ delza=dble(1+int(delza/delzsh-0.5d0))*delzsh
+ numiz=min(int((zshmax-zamin)/delza)+1,maxiz)
+ zamax=zamin+dble(numiz-1)*delza
+#ifndef __CXSUB__
+ endif
+#endif
+ if(mode.ge.0)then
+ distmax=distance0(zshmax)
+ distmax=sign(max(1.d0,distmax),distmax)
+ tamax=-distmax/cxlight !maximum time < 0
+
+ distmin=distance0(zshmin)
+ tamin=-distmin/cxlight !minimum time < 0
+ if(tamin*tamax.le.0.d0)tamin=tamax
+ ctime=exp(log(tamax/tamin)/dble(1-numiz))
+ endif
+! For MC energy spectra
+#ifdef __CXSUB__
+ izfirst=nint(dble(kfirsth-1)*delzsh/delza)+1
+ modz=nint(dble(modkh)*delzsh/delza)
+ kfirst=nint((dble(kfirsth-1)*delzsh+zshmin-ZZo)
+ & /dZZ+1.d0)
+ modk=max(1,nint(dble(modkh)*delzsh/dZZ))
+#else
+ if(izfirst.le.0)izfirst=nint(dble(kfirsth-1)*delzsh/delza)+1
+ if(modz.le.1)modz=max(1,nint(dble(modkh)*delzsh/delza))
+
+! For CE em energy spectra
+ if(kfirst.le.0)kfirst=nint((dble(kfirsth-1)*delzsh+zshmin-ZZo)
+ & /dZZ+1.d0)
+ if(modk.le.1)modk=max(1,nint(dble(modkh)*delzsh/dZZ))
+#endif
+ if(izfirst.gt.numiz)then
+ izfirst=numiz/2
+ write(*,*) 'Warning : izfirst too big => autom. changed to '
+ & ,izfirst
+ endif
+ if(izfirst+2*modz.gt.numiz)then
+ modz=max(1,(numiz-izfirst)/3)
+ write(*,*) 'Warning : modz too big => autom. changed to '
+ & ,modz
+ endif
+ if(kfirst.gt.maxZ)then
+ kfirst=maxZ/2
+ write(*,*) 'Warning : kfirst too big => autom. changed to '
+ & ,kfirst
+ endif
+ if(kfirst+2*modk.gt.maxZ)then
+ modk=max(1,(maxZ-kfirst)/3)
+ write(*,*) 'Warning : modk too big => autom. changed to '
+ & ,modk
+ endif
+ dum=0.d0
+ call NormalizeTables(dum)
+#endif
+
+c moments
+
+#ifdef __ANALYSIS__
+#if __MC3D__ || __CXLATCE__
+#ifdef __CXLATCE__
+ musmm=(muso+1)*(muso**2+5*muso+6)/6-1
+#else
+ musmm=muso
+#endif
+#endif
+#endif
+
+
+c analysis
+ if(EMCutP(1).ne.1.d-3.and.iwrt.ge.2.and.iXmax.ne.0)then
+ write(*,*)'************************************************'
+ write(*,*)' Warning emcut1 not 1 MeV !!!!!'
+ write(*,*)' Effective total energy deposit will be wrong'
+ write(*,*)'************************************************'
+ endif
+
+#ifdef __ANALYSIS__
+ if(numiz.gt.maxiz) stop'maxiz too small'
+ if(numie.gt.maxie-1) stop'maxie too small'
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.ne.0.or.mode.eq.2.or.mode.eq.7)ilatCE=0
+ if(numir.gt.maxir) stop'maxir too small'
+ if(numix(1).gt.maxix)stop'maxix too small (1)'
+ if(numix(2).gt.maxix)stop'maxix too small (2)'
+ if(numix(3).gt.maxix)stop'maxix too small (3)'
+#endif
+ if(eamin(1).le.0.d0)eamin(1)=emin
+ if(eamin(2).le.0.d0)eamin(2)=enymin
+ if(eamax(1).le.0.d0)eamax(1)=eprima
+ if(eamax(2).le.0.d0)eamax(2)=eprima
+#endif
+#ifndef __CXSUB__
+ if(iwrt.ne.0)call IniMeanProfile
+#endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.1
+#if __CXCORSIKA__ || __CORSIKA8__
+ & .or.ifirst.eq.0
+#endif
+ & )then
+ write(*,*)
+ & 'Minimum Energies : enymin, emin'
+ write(*,'(23x,1p 2e9.2)') enymin, emin
+ write(*,*)
+ & 'Monte-Carlo high cuts : ehcut, emcut, eecut, epcut'
+ write(*,'(23x,1p 4e9.2)') ehcut, emcut, eecut, epcut
+ write(*,*)
+ & 'Monte-Carlo low cuts : ehlow, emlow, eelow'
+ write(*,'(23x,1p 3e9.2)') ehlow, emlow, eelow
+ write(*,*)
+ & 'Monte-Carlo sampling weights : wshmax, wsmmax, wsemax'
+ write(*,'(32x,1p 3e9.2)') wshmax, wsmmax, wsemax
+ write(*,*)
+ & 'Monte-Carlo thinning weights : whmax, wtmax'
+ write(*,'(32x,1p 2e9.2)') whmax, wtmax
+#if __CXCORSIKA__ || __CORSIKA8__
+ ifirst=1
+#endif
+ endif
+#endif
+
+ end
+
+c----------------------------------------------------------------------
+ subroutine IniMeanProfile
+c----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ if(iwrt.ge.2)then
+ do ip=1,4
+ do iz=1,musz
+ Ebalan1(iz,ip)=0.d0
+ Ebalan2(iz,ip)=0.d0
+ enddo
+ enddo
+ do ip=0,mxPxpro
+ do iz=1,musz
+ Edepo1(iz,ip)=0.d0
+ Edepo2(iz,ip)=0.d0
+ enddo
+ enddo
+ endif
+ do iz=1,musz
+ XdMuMean(iz)=0.d0
+ XdMuMean2(iz)=0.d0
+ enddo
+ do ip=0,mxPxpro
+ do it=1,5
+ XmaxMean(it,ip)=0.d0
+ enddo
+ XmaxMean(4,ip)=1.d100
+ do iz=1,musz
+ XmaxProf(iz,ip)=0.d0
+ enddo
+ do ic=1,mxExpro
+ do iz=1,musz
+ XmeanP(iz,ic,ip)=0.d0
+ XmeanP2(iz,ic,ip)=0.d0
+ enddo
+ enddo
+ enddo
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#if __MC3D__ || __CXLATCE__
+ do ip=0,4
+ SD1000m(ip)=0.d0
+ enddo
+#endif
+#endif
+ if(ifout.ne.0)call depthprofile(0,0,-1) !write model name
+
+ end
+
+c----------------------------------------------------------------------
+ subroutine IniProfile(k1,k2,n)
+c----------------------------------------------------------------------
+c Set to 0 profile array
+c k1 and k2 are the limits for the particle type.
+c n is shower number
+c----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ common/cxransto/diu0(100),iiseed(3,2)
+ parameter (maxbuf=39*8)
+ real a(maxbuf)
+ character*4 cevth
+ equivalence (a(1),cevth)
+ real corsrun
+ common/cxruncors/corsrun
+ do 1 i=1,maxbuf
+ 1 a(i)=0.
+ cevth='EVTH'
+ a(2)=float(n) !event number
+
+C PRIMARY PARTICLE
+ a(3)=sngl(dptl(10)) !particle id
+ a(4)=sngl(dptl(4)) !total energy in gev
+ a(5)=sngl(dptl(13)) !starting altitude in g/cm**2
+ a(6)=0. !number of first interaction target if fixed
+ a(7)=sngl(dptl(8)*100d0) !z- coordinate in cm of first interaction
+c (negativ if time starts at margin of atmosphere)
+ a(8)=sngl(dptl(1)) !px momentum in x direction
+ a(9)=sngl(dptl(2)) !py momentum in y direction
+ a(10)=sngl(dptl(3)) !pz momentum in -z direction
+ a(11)=sngl(acos(costhet)) !theta (zenith angle) in rad
+ a(12)=sngl(acos(cosphi)-pi)!phi (azimuth angle) in rad (CORSIKA def)
+
+C RANDOM NUMBER INITIALIZATION ( SUBROUT. RMMARD )
+ a(13)=3. !number of different sequences
+ a(14)=float(iiseed(1,1)) !integer seed
+ a(15)=float(iiseed(2,1)) !number of offset random calls ( mod 10**6 )
+ a(16)=float(iiseed(3,1)) !number of offset random calls ( billions )
+
+C GENERAL INFORMATION
+ a(44)=corsrun !run number (random)
+ a(45)=0. !date of begin run (yymmdd) (not available)
+ a(46)=float(ivers)/1000. !version of CONEX program
+
+C OBSERVATION LEVELS ( MAXIMAL 10 )
+ a(47)=1. !number of observation levels
+ a(48)=sngl(HGrd*100d0) !height of level 1 in cm
+
+C ENERGY SPECTRUM
+ a(58)=0. !slope of energy spectrum
+ a(59)=sngl(eprima) !lower energy limit
+ a(60)=sngl(eprima) !upper energy limit
+
+C CUTOFFS IN SIMULATION
+ a(61)=sngl(ehcut) !kin. energy cutoff for hadrons in gev
+ a(62)=sngl(emcut) !kin. energy cutoff for muons in gev
+ if(emcut.lt.0d0)a(62)=sngl(ehcut)
+ a(63)=sngl(eecut) !kin. energy cutoff for electrons in gev
+ a(64)=sngl(epcut) !kin. energy cutoff for gammas in gev
+ if(epcut.lt.0d0)a(64)=sngl(eecut)
+
+C EARTH''S MAGNETIC FIELD COMPONENT
+ a(71)=0. !bx in microtesla
+ a(72)=0. !bz in microtesla
+
+C ELECTROMAGNETIC PARTICLES
+ a(73)=1. !flag for egs4
+ a(74)=0. !flag for nkg
+
+C OTHER FLAGS
+ if(MClemodel.eq.3)then
+ a(75)=1. !GHEISHA
+ elseif(MClemodel.eq.8)then
+ a(75)=2. !UrQMD
+ elseif(MClemodel.eq.7)then
+ a(75)=3. !FLUKA
+ else
+ a(75)=0. !High energy model
+ endif
+ a(76)=0.
+ a(139)=0.
+ a(140)=0.
+ a(141)=0.
+ a(142)=0.
+ a(143)=0.
+ a(144)=0.
+ a(145)=0.
+ if(MCmodel.eq.1)then
+ a(76)=5. !NEXUS
+ a(145)=3.
+ elseif(MCmodel.eq.4)then
+ a(76)=6. !EPOS
+ a(145)=4.
+ elseif(MCmodel.eq.9)then
+ a(76)=4. !DPMJET
+ a(143)=2. !version III(2017)
+ a(144)=1. !DPMJET cross section
+ elseif(MCmodel.eq.2.or.MCmodel.eq.6)then
+ a(76)=3. !QGSJET01/II
+ if(MCmodel.eq.2)then !(2.=QGSJET01,3.=QGSJETII)
+ a(141)=2. !qgsjet interaction flag
+ a(142)=2. !qgsjet cross-section flag
+ else
+ a(141)=3. !qgsjet interaction flag
+ a(142)=3. !qgsjet cross-section flag
+ endif
+ elseif(MCmodel.eq.5)then
+ a(76)=2. !SIBYLL
+ a(139)=4. !sibyll interaction flag (4.=vers.2.3d)
+ a(140)=4. !sibyll cross-section flag
+ endif
+ a(77)=0. !cherenkov flag
+ a(78)=1. !neutrino flag
+ a(79)=2. !curved flag (2.=curved)
+
+C ANGULAR DISTRIBUTION OF PRIMARY PARTICLE
+ a(81)=sngl(thetas) !lower edge of primary theta selection (in degrees)
+ a(82)=sngl(thetas) !upper edge of primary theta selection (in degrees)
+ a(83)=sngl(phisho) !lower edge of primary phi selection (in degrees)
+ a(84)=sngl(phisho) !upper edge of primary phi selection (in degrees)
+
+ a(148)=sngl(hthin) !energy fraction of thinning level hadronic
+ a(149)=sngl(thin) !energy fraction of thinning level em-particles
+ a(150)=sngl(whmax) !actual weight limit for thinning hadronic
+ a(151)=sngl(wtmax) !actual weight limit for thinning em-particles
+ call wrida(a)
+#else
+ if(n.lt.0)write(*,*)'Problem in IniProfile',n
+#endif
+#endif
+ if(iwrt.ne.0)then
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ MuMia=0d0
+ do ic=1,mxExpro
+ MuTrunc(ic)=0d0
+ EHaSum(ic)=0d0
+ enddo
+ do ip=0,4
+ SD1000(ip)=0d0
+ enddo
+ EHaMax=0d0
+#endif
+ do iz=1,musz
+ XdMu(iz)=0.d0
+ enddo
+ do 2 npar=0,mxPxpro !parameter fit for ip=0
+ 2 XmaxShow(4,npar)=0.d0
+
+ do ip=k1,k2
+ do 5 j=1,3
+ 5 XmaxShow(j,ip)=0.d0
+ do ic=1,mxExpro
+ do iz=1,musz
+ XProf(iz,ic,ip)=0.d0
+ enddo
+ enddo
+ enddo
+ if(iwrt.ge.2)then
+ do ip=1,4
+ do iz=1,musz
+ Ebalan(iz,ip)=0.d0
+ enddo
+ enddo
+ do ip=0,k2
+ do iz=1,musz
+ Edepo(iz,ip)=0.d0
+ enddo
+ enddo
+ endif
+ endif
+
+
+#ifdef __ANALYSIS__
+#if __MC3D__ || __CXLATCE__
+ do ir=1,numir
+ do jz=1,maxjz
+ do in=1,maxin
+ yieldr1(in,jz,ir)=0.d0
+#ifdef __CXLATCE__
+ yieldrt1(in,jz,ir)=0.d0
+#endif
+ enddo
+ enddo
+ enddo
+#endif
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniInclined
+c-----------------------------------------------------------------------
+c Initialization of the tabulation of slant depth.
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+
+ mnatm=1
+ eatm(mnatm)=HGrd
+ do j=1,mxatm-1
+ if(eatm(j+1).le.eatm(j))then
+ eatm(j+1)=eatm(j)
+ mnatm=j+1
+ endif
+ enddo
+
+ end
+
+#ifdef __CXSUB__
+c-----------------------------------------------------------------------
+ function InitialParticle(idi)
+c-----------------------------------------------------------------------
+c Define CONEX particle id from input (PDG code or A*100 for nuclei)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common/cxNnucleon/aNbrNucl
+
+ id=idi
+ aNbrNucl=1.d0
+ if(id.eq.0)then
+ id=10
+ elseif(id.eq.100)then
+ id=1120
+ elseif(id.eq.41)then
+ id=41
+ elseif(id.eq.43)then
+ id=43
+ elseif(mod(id,100).eq.0)then
+ aNbrNucl=dble(abs(id))/100.d0
+ elseif(abs(id).lt.5000)then
+ id=idtrafocx('pdg','nxs',idi)
+ else
+ id=99
+ endif
+ if(abs(id).le.9.or.id.eq.99)stop'wrong argument for initial.'
+ InitialParticle=id
+ return
+ end
+#else
+c-----------------------------------------------------------------------
+ subroutine InitialParticle(word,id)
+c-----------------------------------------------------------------------
+c Define CONEX particle id from input (Conex format or A*100 for nuclei
+c and 0 for gamma)(PDG can be used instead of id to use PDG particle code)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ character word*500
+ common/cxNnucleon/aNbrNucl
+ aNbrNucl=1.d0
+ if(word.eq.'photon')then
+ id=10
+ elseif(word.eq.'electron')then
+ id=12
+ elseif(word.eq.'positron')then
+ id=-12
+ elseif(word.eq.'proton')then
+ id=1120
+ elseif(word.eq.'qball')then
+ id=41
+ elseif(word.eq.'monopole')then
+ id=43
+ elseif(word.eq.'helium')then
+ id=400
+ aNbrNucl=4.d0
+ elseif(word.eq.'oxygen')then
+ id=1600
+ aNbrNucl=16.d0
+ elseif(word.eq.'iron')then
+ id=5600
+ aNbrNucl=56.d0
+ elseif(word.eq.'id')then
+ id=nint(getvalue())
+ if(id.eq.0)then
+ id=10
+ elseif(id.eq.100)then
+ id=1120
+ elseif(id.eq.-10)then
+ id=41
+ elseif(id.eq.-20)then
+ id=42
+ elseif(id.eq.-30)then
+ id=43
+ elseif(mod(id,100).eq.0)then
+ aNbrNucl=dble(abs(id))/100.d0
+ endif
+ elseif(word.eq.'PDG')then
+ id=nint(getvalue())
+ if(id.eq.0)then
+ id=10
+ elseif(id.eq.100)then
+ id=1120
+ elseif(mod(id,100).eq.0)then
+ aNbrNucl=dble(abs(id))/100.d0
+ elseif(abs(id).lt.5000)then
+ id=idtrafocx('pdg','nxs',id)
+ else
+ id=99
+ endif
+ else
+ stop'wrong argument for initial. '
+ endif
+ if(abs(id).le.9.or.id.eq.99)stop'initial can not be used !'
+ end
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine InitialParticleEphCas
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ id=nint(dptl(10))
+ ida=iabs(id)
+ do k=1, maxZ
+ do j=minE, maxE
+ SFE(j,k)=0.0d0
+ SFG(j,k)=0.0d0
+ SFP(j,k)=0.0d0
+ enddo
+ enddo
+ imaxE0=maxE
+ jminZ0=1
+ if(eprima.gt.Eo)then
+ i=maxE-1
+ appp1=(eeEM(i+1)-eprima)/(eeEM(i+1)-eeEM(i))
+ appp2=1.d0-appp1
+ if(appp1.lt.0.d0.or.appp2.lt.0.d0
+ * .or.appp1.gt.1.d0.or.appp2.gt.1.d0)then
+ if(abs(appp1).gt.1.d-10)write(*,*)'appp-lept ini',eprima,i
+ * ,appp1,appp2
+ appp1=max(0.d0,appp1)
+ appp2=max(0.d0,appp2)
+ endif
+ else
+ appp1=0.d0
+ appp2=1.d0
+ endif
+ Einit=Eprima
+ if(ida.eq.10)then
+ SFG(maxE-1,1)=appp1
+ SFG(maxE,1)=appp2
+ elseif(id.eq.12)then
+ SFE(maxE-1,1)=appp1
+ SFE(maxE,1)=appp2
+ Einit=Einit+amc2
+ elseif(id.eq.-12)then
+ SFP(maxE-1,1)=appp1
+ SFP(maxE,1)=appp2
+ Einit=Einit+amc2
+ else
+ stop'wrong argument for InitialParticleEphCas. '
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine InitialParticleSho(idi)
+c-----------------------------------------------------------------------
+c Initialize first particles in the stack. If "input" is used in the steering
+c file to define a list of particles, particles are taken from this file,
+c otherwise we use id and eprima to define the primary particle.
+c
+c 3D : Local frame of the particle (where px,py, and pz are defined) is defined
+c by z axis pointing to earth center and y axis in the plane defined by z
+c axis and the vertical going through earth center and obs. point (frame is
+c right-handed).
+c 1D : Local frame of the particle = shower frame : (where p0x,p0y, and p0z
+c are defined) is defined by z axis pointing to impact point (shower axis) and
+c y axis in the plane defined by z axis and the vertical going through earth center
+c and obs. point (frame is right-handed).
+c(x,y,t) are the coordinates (m) (t=time) in the obs frame :
+c (0,0,0)=impact point (it does not follow earth curvature). If theta=90
+c and phi=0, shower comes from x=+xmax. h is altitude above see level in m
+c (so it does follow earth curvature). Total Energy and momentum are in GeV.
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#ifdef __PRESHOW__
+ dimension parout(8,0:99999)
+ real r0,rfpp,pthe,pphi
+c real To,Fo,BRo,BTo,BFo,Ts,Fs,BRs,BTs,BFs
+ logical go
+#endif
+ logical cont
+#ifdef __CXCORSIKA__
+ parameter (lstck=23) !STACKIN file unit
+ dimension ep(3)
+ CHARACTER LINE*132
+
+
+ if(lxfirst.and.abs(idi).ge.100)then !fix first interaction only for hadrons
+ lxfirstIn=.true. !in that case, used to force first interaction
+c XfirstIn defined in CORSIKA to be used as target id
+ H0=Xfirst !height of first interaction defined in CORSIKA
+ dist0=distant(H0,radtr0) !slant distance to obs level, m
+ if(zsaxis.ge.0d0)then !downward going shower
+ Xfirst=deptht(dist0,radtr0) !conversion to slant depth, g/cm^2
+ else !upward going shower
+ Xfirst=depthmaxi0-deptht(dist0,radtr0) !conversion to slant depth, g/cm^2
+ endif
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ else
+#else
+#if __MC3D__
+ lseq=1 !use lseq=1 for high energy MC
+#endif
+#endif
+ lxfirst=.false.
+ lxfirstIn=.false.
+ XfirstIn=-1d0 !inelasticity of the 1st hadronic interaction
+ Xfirst=1.d30 !first Interaction point
+#ifdef __CXCORSIKA__
+ endif
+#endif
+#ifdef __PRESHOW__
+ iipr=0
+#ifdef __CXDEBUG__
+ call utisx1('Start ',4)
+ if(isx.ge.8)iipr=1
+#endif
+#endif
+ knordm=.true. !random normal distribution
+ etotsta=0.d0
+ jstack=0
+ jrec=0
+ istack=0
+ irec=0
+c Open stack at the beginning of the shower
+ ifsa=86
+ jfsa=85
+c recl is the record length in byte : double precision = 16 Bytes
+ open(unit=ifsa,status='scratch',
+ * form='unformatted',access='direct',recl=mxstk*16)
+ open(unit=jfsa,status='scratch',
+ * form='unformatted',access='direct',recl=mxstkj*16)
+
+ Einit=0.d0
+
+#ifndef __CORSIKA8__
+
+ if(ifinput.ne.0)then
+#ifdef __CXCORSIKA__
+ READ(LSTCK,500) LINE
+ 500 FORMAT(A)
+ read(LINE,*)xninp,energy
+ ninp=nint(xninp)
+#else
+ open(ifinput,file=fninput(1:nfninput),status='old')
+ read(ifinput,end=9999)ninp,XminP
+ zz=max(dphmin0,XminP) !initial slant depth g/cm^2
+ if(iwrt.ne.0)then
+ nminX=max(1,int((XminP-zshmin)/delzsh)+1) !first bin in Z
+ if(nminX.gt.nmaxX)stop'Shower stops before it starts (2)!'
+ endif
+#endif
+ lxfirst=.true. !first interaction passed
+ lxfirstIn=.false. !not to force first interaction
+ else
+ ninp=1
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ zz=max(dphmin0,zshmin) !initial slant depth g/cm^2
+#endif
+ endif
+
+c Parameters common to all particles
+#ifdef __CXCORSIKA__
+ zz=max(dphmin0,XminP) !initial slant depth g/cm^2
+#endif
+ dl=distance0(zz) !slant distance to impact point, m
+ h=heightt(dl,radtr0) !height above sea level, m
+c x,y-coordinates with respect to the obs.
+ dl0=dl-sign(DistAlt,zsaxis)
+ distMaxi=2.d0*dl0
+ x=dl0*xsaxis !coordinates in obs frame, m
+ y=dl0*ysaxis
+ if(i1DMC.le.1)then
+#ifdef __CXCORSIKA__
+ rtr=sqrt(x*x+y*y)
+ if(rtr.gt.1.d-20)then
+ sinphiP=y/rtr
+ cosphiP=x/rtr
+ sintheP=rtr/(h+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+#else
+ sintet=sign(min(1.d0,radtr0/(h+radearth)),dl0) !sin angle between impact parameter and starting point
+ costet=sign(dsqrt(1.d0-sintet*sintet),dl-1.d-10)
+#endif
+ endif
+
+ do 1000 i=1,ninp
+
+ if(ifinput.ne.0)then
+#ifdef __CXCORSIKA__
+ READ(LSTCK,*) NN,NTYP,EN,PZ,PX,PY
+C FORMAT TO READ STACKIN FILE (EVENTUALLY TO BE CHANGED, SEE CORSIKA)
+C - - - - - - - - - - - - - -
+c 510 FORMAT(2I5,4(1X,E15.7))
+C - - - - - - - - - - - - - -
+ id=idtrafocx('cors','nxs',NTYP)
+ call cxidmass(id,am)
+ Einp=EN
+ EK=EN-am
+ cont=.true.
+ if(abs(id).gt.12)then
+ ecut=enymin !hadrons/muons
+ else
+ ecut=emin !photons/electrons
+ if(mode.eq.5)cont=.false. !had shower
+ endif
+ P=PX*PX+PY*PY+PZ*PZ
+ if(cont.and.P.gt.0d0.and.EK.ge.ecut)then
+ Pinv=1d0/sqrt(P)
+ px0=PX*Pinv
+ py0=PY*Pinv
+ pz0=PZ*Pinv
+ else
+ if(isx.ge.2)write(ifck,'(a,i5,a)')'Particle',i,' skipped...'
+ goto 1000
+ endif
+#else
+ read(ifinput,end=9999)id,px,py,pz,Einp
+ if(id.eq.0)then
+ id=10
+ am=0d0
+ elseif(id.eq.100)then
+ id=1120
+ am=pmass(1)
+ elseif(abs(id).lt.5000.and.mod(id,100).ne.0)then
+ id=idtrafocx('pdg','nxs',id)
+ call cxidmass(id,am)
+ else
+ id=99
+ am=0d0
+ endif
+ EK=Einp-am
+ cont=.true.
+ if(abs(id).gt.12)then
+ ecut=enymin !hadrons/muons
+ else
+ ecut=emin !photons/electrons
+ if(mode.eq.5)cont=.false. !had shower
+ endif
+ P=PX*PX+PY*PY+PZ*PZ
+ if(cont.and.P.gt.0d0.and.EK.ge.ecut)then
+ if(i1DMC.ne.2)then
+ Pinv=1d0/sqrt(P)
+ px0=PX*Pinv
+ py0=PY*Pinv
+ pz0=PZ*Pinv
+ else
+ px0=0.d0 !x relative momentum in shower frame
+ py0=0.d0 !y relative momentum in shower frame
+ pz0=1.d0 !z relative momentum in shower frame
+ endif
+ else
+ if(isx.ge.2)write(ifck,'(a,i5,a)')'Particle',i,' skipped...'
+ goto 1000
+ endif
+#endif
+ else
+ id=idi
+ Einp=eprima
+ call cxidmass(id,am)
+ if(am.gt.0d0)then
+ if(Einp/am.lt.10.)distMaxi=1.d30 !in case of exotic heavy particles don't do time cut
+ endif
+ px0=0.d0 !x relative momentum in shower frame
+ py0=0.d0 !y relative momentum in shower frame
+ pz0=1.d0 !z relative momentum in shower frame
+ endif
+
+#ifdef __PRESHOW__
+ npre=1
+ go=.false.
+ if(ipreshow.eq.1..and..not.goOutGrd.and.zz.le.dphmin0
+ & .and.id.eq.10.and.Einp.gt.1.d7)then
+ go=.true.
+ pthe=real(2.d0*pi*thetas/360.d0)
+ pphi=real(2.d0*pi*phisho/360.d0+0.5d0*pi) !to convert to preshower (CORSIKA) def.
+ call preshwveto(1,Einp,pthe,pphi,real(eatm(mxatm+1)*1.d-3)
+ & ,longitude,latitude,year,iipr,1,1
+ & ,parout,r0,rfpp,npre)
+ if(npre.gt.1)then
+ lxfirst=.true. !first interaction passed
+ XfirstIn=0.d0
+ Xfirst=0.d0
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+ endif
+ do j=0,npre-1
+ if(go)then
+ idout=nint(parout(1,j))
+ if(idout.eq.1)then !gamma
+ id=10
+ am=0d0
+ elseif(idout.eq.2)then !positron
+ id=-12
+ am=pmass(10)
+ elseif(idout.eq.3)then !electron
+ id=12
+ am=pmass(10)
+ else
+ stop "Wrong particle type from preshower !"
+ endif
+ Einp=parout(2,j)
+ XfirstIn=max(XfirstIn,parout(2,j))
+ endif
+
+#endif
+
+ if(lxfirst.and..not.lXfirstIn)then
+ Xfirst=min(Xfirst,zz) !first interaction point
+ lxfirst=.false.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+ E=Einp
+ Einit=Einit+E
+ P=sqrt((E+am)*(E-am))
+ if(i1DMC.le.1)then
+#ifdef __CXCORSIKA__
+ ep(1)=px0
+ ep(2)=py0
+ ep(3)=pz0
+ call ToObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P from shower frame to obs. frame
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in particle frame
+ do k=1,3
+ dptl(k)=ep(k)*P
+ enddo
+#else
+ sintet=sign(min(1.d0,radtr0/(h+radearth)),dl0) !sin angle between impact parameter and starting point
+ costet=sign(dsqrt(1.d0-sintet*sintet),dl-1.d-10)
+ dptl(1)=0.d0 ! local p_x
+ dptl(2)=P*sintet ! local p_y
+ dptl(3)=P*costet ! local p_z
+#endif
+ else
+ dptl(1)=px0*P
+ dptl(2)=py0*P
+ dptl(3)=pz0*P
+ endif
+ dptl(4)=E ! total energy
+ dptl(5)=am ! mass
+ dptl(6)=x
+ dptl(7)=y
+ dptl(8)=h
+ dptl(9)=-dl0 ! timing
+ dptl(10)=dble(id) ! id
+ dptl(11)=1.d0 ! weight
+ dptl(12)=0.d0 ! generation
+ dptl(13)=zz ! slant depth passed !so110903
+ dptl(14)=0.d0 ! x distance to shower axis !t1191104
+ dptl(15)=0.d0 ! y distance to shower axis !tp191104
+ dptl(16)=dl ! slant distance to impact point!tp110705
+
+ call cana2(dptl(8),dptl(14),dptl(15),dptl(6),dptl(7),dptl(16)
+ $,-1000.d0,dptl(9),E,dptl(8),dptl(14),dptl(15),dptl(6),dptl(7)
+ $,dptl(16),zz*1.0001d0,dptl(9),dptl(4),px0,py0,pz0,dptl(5),dptl(11)
+ $,dptl(12),id,4)
+#ifdef __CXDEBUG__
+#ifdef __CXCORSIKA__
+ if(isx.ge.2)write(ifck,100) i,dptl
+#else
+ if(isx.ge.4)write(ifck,100) i,dptl
+#endif
+ 100 format('CONEX primary:',i5,5(1x,e11.4),4(1x,e9.2),1x,f6.0
+ &,2(1x,f4.2),1x,4(1x,e9.2))
+#endif
+
+c if(iMagne.gt.0.and.(mode.le.0.or.mode.ge.4))then
+cc initialize magnetic field component along shower axis
+c To=(0.5d0-latitude/180.)*pi ! (colatitude is 90-latitude)
+c Fo=longitude/360.*2.*pi
+c call IGRF(2005,10,1.,To,Fo,BRo,BTo,BFo)
+c s=sin(To)
+c c=cos(To)
+c sf=sin(Fo)
+c cf=cos(Fo)
+c be=BRo*s+BTo*c
+c x=be*cf-BFo*sf
+c y=be*sf+BFo*cf
+c z=BRo*c-BTo*s
+c print *,'obs',BRo,BTo,BFo,x,y,z
+c Ts=To+y/radearth
+c Fs=Fo+x/radearth
+c print *,'coord',latitude,longitude,Ts/2./pi*360.,Fs/2./pi*360.
+c call IGRF(2005,10,1.015,Ts,Fs,BRs,BTs,BFs)
+c print *,'ini',BRs,BTs,BFs,BRs/Bro,BTs/BTo,BFs/BFo
+c endif
+
+ call d2a
+
+#ifdef __PRESHOW__
+ enddo
+ if(npre.gt.1)XfirstIn=1d0-XfirstIn/Einp
+#endif
+
+ 1000 continue
+
+#ifdef __CXCORSIKA__
+C TO SIMULATE MORE THAN ONE SHOWER WITH IDENTICAL INPUT REWIND
+C LSTCK TO READ THE INPUT FOR THE FOLLOWING SHOWERS
+ REWIND( LSTCK )
+#endif
+
+#endif
+
+ return
+
+ 9999 stop'You asked for more showers than available in input file !'
+
+ end
+
+
+#ifdef CONEX_EXTENSIONS
+c RU Mon Oct 23 09:34:32 CEST 2006
+c-----------------------------------------------------------------------
+ subroutine InitialParticleShoList()
+c-----------------------------------------------------------------------
+c Intialize first particles in the stack. If "input" is used in the steering
+c file to define a list of particles, particles are taken from this file,
+c otherwise we use id and eprima to define the primary particle.
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ common/cxransto/diu0(100),iiseed(3,2)
+#ifdef CONEX_EXTENSIONS
+ common/cossins/s0xs,c0xs,s0s,c0s ! need to save these...
+#endif
+ include 'conex.incnex'
+c RU Mon Oct 23 09:05:39 CEST 2006
+ logical goon
+ logical firstpart
+ dimension iseedi(3)
+c RU end
+
+ Einit=Eprima
+
+ Etot=0.d0
+ Emax=0.d0
+
+ Xfirst=1.d30 ! first Interaction point
+ XfirstIn=-1d0 ! inelasticity of the 1st hadronic interaction
+ lxfirst=.false. ! first interaction not passed ... hmmm ...
+ etotsta=0.d0
+ estack=0.d0
+ jstack=0
+ jrec=0
+ istack=0
+ irec=0
+ ifsa=86
+ jfsa=85
+ open(unit=ifsa,status='scratch',
+ * form='unformatted',access='direct',recl=mxstk*16)
+ open(unit=jfsa,status='scratch',
+ * form='unformatted',access='direct',recl=mxstkj*16)
+
+ call get_projectile(dptl, s0xs)
+ zz=dptl(13)
+ dl=distance0(zz) !slant distance to impact point, m
+ h=heightt(abs(dl),radtr0) !height above sea level, m
+
+ firstpart=.true.
+ goon=.true.
+ nptlxs=0
+ do while (goon)
+
+c fill nexus stack first, like in cnexus, cxfinal
+
+ nptlxs=nptlxs+1
+ call get_particle_from_list_cx(xsptl, nptlxs, goon)
+
+ if (goon) then
+
+c i=nptlxs
+c xsptl(1,i)=ruTmp(1) ! px
+c xsptl(2,i)=ruTmp(2) ! py
+c xsptl(3,i)=ruTmp(3) ! pz
+c xsptl(4,i)=ruTmp(4) ! e
+c xsptl(5,i)=ruTmp(5) ! m
+c xsorptl(1,i)=ruTmp(6) ! x
+c xsorptl(2,i)=ruTmp(7) ! y
+c xsorptl(3,i)=ruTmp(8) ! z
+c xsorptl(4,i)=ruTmp(9) ! time
+c idptlxs(i)=int(ruTmp(10)) ! id
+c xstivptl(1,i)=ruTmp(11) ! formation time (always in the pp-cms!)
+c xstivptl(2,i)=ruTmp(12) ! destruction time (always in the pp-cms!)
+c ityptlxs(i)=int(ruTmp(13)) ! type of particles origin:
+c iorptlxs(i)=int(ruTmp(14)) ! particle number of father (if .le. 0 : no father)
+c jorptlxs(i)=int(ruTmp(15)) ! particle number of mother (if .le. 0 : no mother)
+c istptlxs(i)=int(ruTmp(16)) ! status
+
+
+c call get_particle_from_list(dptl, goon)
+c call d2a
+c Epart=dptl(4)
+
+ Epart=xsptl(4,nptlxs)
+ Etot=Etot+Epart
+ Emax=max(Emax,Epart)
+
+ if(firstpart)then
+c Xfirst=dptl(13)
+ Xfirst=dptl(13)
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ lxfirst=.true.
+ lXfirstIn=.true.
+ firstpart=.false.
+ endif
+
+ endif ! not goon
+
+ enddo ! while reading particles
+
+ if(lxfirstIn.and.Etot.gt.0.d0)then
+ lxfirstIn=.false.
+ lxfirst=.false.
+ XfirstIn=1.d0-Emax/Etot
+ endif
+
+ call set_seed_cx(iseedi) ! set seed
+#ifndef __CXCORSIKA__
+ lseq=1 !1st random number sequence
+#else
+ lseq=7 !1st random number sequence
+#endif
+ write(*,*)'Update seeds from particle list: ',
+ * lseq,iseedi(1),iseedi(2),iseedi(3,)
+ call rmmaqd(iseedi,lseq,'S') ! reinitialize random number generator
+
+ imode=4 ! -> interaction, rotate particles into shower frame
+ call c2s(imode)
+
+
+ end
+c RU end
+c CONEX_EXTENSIONS
+#endif
+
+
+c-----------------------------------------------------------------------
+ subroutine transf(id,z1,z2,e0,e1,e2,ep,eh,elh,elm,zlo)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ cf=1.d0
+ if(abs(id).ge.100.and.mod(id,100).eq.0) !nuclei
+ &cf=1.d0/dble(int(abs(id)/100))
+ z1= zshmin
+ z2= zshmax
+ e0= emin
+ e1= enymin
+ e2= enymax
+ ep= eprima*cf !use primary energy instead of kinetic energy in that case
+c for hybrid mode, maximum egy for cascade equ. is cut energy
+ if(mode.eq.5.or.mode.eq.8)ep=min(ep,max(ehcut,emcut,eecut,epcut))
+ eh= EgyHiLoLim
+ maxE=int(log10(ep/Eo*c2em)*emdecade)+1 !maximum energy bin in e/m CE
+ if(ep.gt.1.000001d0*Eo*Cem**(maxE-1))maxE=maxE+1
+ if(maxE.gt.maximumE)stop 'maxE too big in transf'
+ elh= ehlow
+ elm= emlow
+ zlo= zmchlow
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine InitializeOnce(iegs,iolo)
+c-----------------------------------------------------------------------
+c Initialization which should be done only once (including EGS4 if
+c iegs=1).
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1)
+ *,MEKE(1),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ CHARACTER*4 MEDARR(24)
+ DATA MEDARR /'A','I','R','-','N','T','P',17*' '/
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/CXEGSDEB/ifckegs,isxegs
+#ifndef __CXSUB__
+ integer iseedi(3)
+#endif
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ parameter (maxbuf=39*8)
+ real a(maxbuf)
+ character*4 cevth
+ equivalence (a(1),cevth)
+ real corsrun
+ common/cxruncors/corsrun
+#endif
+#endif
+
+C-----------------------------------------------------------------------
+#ifndef __CXSUB__
+ do i=1,3
+ iseedi(i)=iseed(i,1)
+ enddo
+ call rmmaqd(iseedi,1,'S') !initialize random number generator
+ do i=1,3
+ iseedi(i)=iseed(i,2)
+ enddo
+ call rmmaqd(iseedi,2,'S') !initialize random number generator
+ do i=1,3
+ iseedi(i)=0
+ enddo
+ lseq=1
+#endif
+
+ if(MCModel.eq.5.and.ilowegy.eq.0)
+ & stop 'SIBYLL cannot be used for low energy int. (ilowegy=0)'
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ corsrun=sngl(drangen(eprima)*0.999999d6)
+ do 1 i=1,maxbuf
+ 1 a(i)=0.
+ cevth='RUNH'
+ a(2)=corsrun !run number
+ a(3)=0. !date (not known)
+ a(4)=float(ivers)/1000. !version number
+ a(5)=1. !number of observation level
+ a(6)=sngl(hground)*100. !height of observation level (in cm)
+ a(16)=0. !slope of energy spectrum
+ a(17)=sngl(eprima) !lower energy limit
+ a(18)=sngl(eprima) !upper energy limit
+ a(21)=sngl(ehcut) !kin. energy cutoff for hadrons in gev
+ a(22)=sngl(emcut) !kin. energy cutoff for muons in gev
+ if(emcut.lt.0d0)a(22)=sngl(ehcut)
+ a(23)=sngl(eecut) !kin. energy cutoff for electrons in gev
+ a(24)=sngl(epcut) !kin. energy cutoff for gammas in gev
+ if(epcut.lt.0d0)a(24)=sngl(eecut)
+ call wrida(a)
+#endif
+#endif
+
+ if(dble(maxime-1)/decade.lt.15.d0)
+ & enymax=min(enymax,exmin*10.d0**(dble(maxime-1)/decade))
+
+ c2bas=10.d0**(0.5d0/decade) ! 0.5 to get the right binning
+ c2Ha=c2bas
+ dnHa=decade
+ dzHa=delzsh
+
+
+c Ionization loss
+
+ if(ionloss.eq.1.and.iolo.ne.ionloss)iolo=ionloss
+
+
+c Initialize EGS4 if needed
+
+ if(iegs.eq.1)then
+ iegs=0
+
+ write(6,'(a)')'initialize EGS4 ...'
+c Mass initialization
+ RM=pmass(10)*1.d3
+ PRRMMU =pmass(9)*1.d3
+ RMMUT2 = 2.D0*PRRMMU
+ PICMS = pmass(2)*1.d3
+ PI0MS = pmass(5)*1.d3
+ AMSPR = pmass(1)*1.d3
+ AMSNT = pmass(6)*1.d3
+ PITHR = 152.D0 !from corsika for photonuclear effect
+ DO I=1,24
+ MEDIA(I,1)=MEDARR(I)
+ ENDDO
+ MED(1)=0
+ MED(2)=1
+ MED(3)=0
+ DUNIT=-2
+ ECUT(2)=.512d0 ! egs4 cut-off for electrons in MeV (updated in HATCHCX)
+ PCUT(2)=.001d0 ! egs4 cut-off for photons in MeV (updated in HATCHCX)
+ IAUSFL(2)=0 ! do not allow ausgab when particle is below EGS cut
+ IAUSFL(3)=0 ! do not allow ausgab when particle is below EGS cut
+ IAUSFL(4)=0 ! do not allow ausgab when particle reach ground
+ IAUSFL(7)=1 ! allow ausgab before bremstrahlung for LPM effect
+ IAUSFL(16)=1 ! allow ausgab before pair production for LPM effect
+ IAUSFL(8)=1 ! allow ausgab after bremstrahlung for LPM effect
+ IAUSFL(17)=1 ! allow ausgab after pair production for LPM effect
+ IFCKEGS=ifck
+
+
+ WRITE(6,*)'CALL HATCH TO GET CROSS-SECTION DATA'
+ CALL HATCHCX
+ WRITE(6,1030)ECUT(2)-0.511d0, PCUT(2)
+1030 FORMAT(' ANY ELECTRON CAN BE FOLLOWED DOWN TO ',F8.3
+ *,' MeV KINETIC ENERGY'/
+ *' ANY PHOTON CAN BE FOLLOWED DOWN TO ',F8.3,' MeV')
+
+ if(abs(radlth-RLDU(MED(2))).gt.0.00001d0)then !radiation length of electron in air
+ write(*,*)
+ & 'Warning : radiation length is different in Conex and EGS4'
+ write(*,*)'Conex: ',radlth,' EGS4: ',RLDU(MED(2))
+ write(*,*)
+ & 'The one from EGS4 is use, please update radlth in conex-bas'
+ radlth=RLDU(MED(2))
+ endif
+ Eo=max(Eo,(ECUT(2)-0.511d0)*1.d-3,PCUT(2)*1.d-3)
+
+ if(iMuInt.gt.0.and.(mode.le.0.or.mode.ge.4))then
+
+#ifndef __CXCORSIKA__
+ write(6,'(a)')'initialize Muon Cross Sections ...'
+
+ call CXMUPINI
+#endif
+
+ else !energy loss due to interactions for muons
+
+ do i=1,maximEd
+ dedxion(4,i)=0d0
+ enddo
+
+ endif
+
+
+
+ endif
+
+
+#ifndef __CXCORSIKA__
+c Uncomment here to run Exotic particles (initialization done in CORSIKA if linked together)
+ if(mode.le.0.or.mode.ge.4)then
+
+ write(6,'(a)')'initialize Monopole Cross Sections ...'
+
+ call CXMMPINI
+
+ endif
+#endif
+
+ if(iMuScat.gt.0.and.(mode.le.0.or.mode.ge.4))then
+c initialize constants for muon multiple scattering (moliere)
+c see subrout. gmoli of geant321 (cern)
+ eneper1 = exp(1.d0)
+ if ( iMuScat.eq.1 ) then
+ temp1 = airw(1) * 7.d0 * 8.d0
+ temp2 = airw(2) * 8.d0 * 9.d0
+ temp3 = airw(3) * 18.d0 * 19.d0
+ zs = temp1 + temp2 + temp3
+ ze = -0.666666666666666D0*(temp1*log(7.d0)+temp2*log(8.d0)
+ * +temp3*log(18.d0))
+ zx = temp1*log(1.d0 + 3.34d0 * ( 7.d0/fialpha)**2)
+ * +temp2*log(1.d0 + 3.34d0 * ( 8.d0/fialpha)**2)
+ * +temp3*log(1.d0 + 3.34d0 * (18.d0/fialpha)**2)
+c note: chc is defined different from geant without density
+ chc = 0.39612d-3 * sqrt( zs / airava )
+c note: omc is defined different from geant without density
+ omc = 6702.33d0 * (zs/airava) * exp( (ze-zx)/zs )
+ write(*,*) 'muon multiple scattering after moliere'
+ else
+ write(*,*)'muon multiple scattering in gauss approximation'
+ endif
+ endif
+
+
+c for run with e/m and hadronic particles together
+ if(mode.ge.7)then
+ if(abs(emdecade-decade).gt.1.d-5)
+ & write(*,*)'Full mode => emdecade=decade and irdelz=1 !!!'
+ emdecade=decade
+ Cem=10.D0**(1.d0/emdecade) !size of the bin
+ c2em=sqrt(Cem)
+ dZZ=delzsh !delzsh/dZZ must be 1
+ if(exmin.lt.Eo)then
+ minEhad=int(log10(Eo/exmin)*emdecade)
+ Eo=10.d0**(dble(minEhad)/emdecade)*exmin
+ minEhad=-minEhad
+ else
+ xminEhad=log10(exmin/Eo)*emdecade
+ minEhad=int(xminEhad)
+ Eo=10.d0**(dble(-minEhad)/emdecade)*exmin
+#ifdef __CXDEBUG__
+ if(abs(xminEhad-dble(minEhad)).gt.1.d-4)then
+ write(*,*)'Full mode => bins should match : '
+ & ,xminEhad+1.d0,minEhad+1,Eo
+ write(*,*)'Full mode => new Eo : ',Eo
+ endif
+#endif
+ endif
+#ifdef __CXDEBUG__
+ write(*,*)'Full mode => minEhad : ',minEhad,Eo
+#endif
+ else
+ minEhad=0
+ Cem=10.D0**(1.d0/emdecade) !size of the bin
+ c2em=sqrt(Cem)
+ dZZ=delzsh/dble(irdelz) !delzsh/dZZ must be an integer = irdelz
+ endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cegs4(n,i) !so110903
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ common/cxransto/diu0(100),iiseed(3,2)
+ dimension ep(3)
+
+ parameter (mtimx=30)
+ COMMON /NPTLC/ eleft(mtimx),iutime(5),itime(mtimx),mtime(mtimx)
+ & ,nptlc
+ COMMON/CGEOM/ZBOUND
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ logical mc2ce
+
+ nptlc=0
+ mc2ce=.false.
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.2)then
+#endif
+ if(n.gt.0.and.mod(n,i).eq.0)then
+ write(6,'(a,$)')'electron-photon shower'
+ write(6,*)n,' -- Energy:',dptl(4),' Depth:',dptl(13)
+#ifndef __CXCORSIKA__
+ call ranfgt(seed)
+ write(6,*)' seq ',lseq,' -- iseed(1) ',iiseed(1,lseq)
+ & ,' iseed(2) ',iiseed(2,lseq),' iseed(3) ',iiseed(3,lseq)
+#endif
+ endif
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+
+ if(mode.ne.0.and.mode.le.3.and.n.gt.0)call s2d(igo) !for pure EM showers
+ id=nint(dptl(10))
+ ekin=dptl(4)-dptl(5)
+ if(id.eq. 12)then !electron
+ if(mode.eq.3.and.ekin.le.eecut)mc2ce=.true.
+ IQIN=-1
+ elseif(id.eq.-12)then !positron
+ if(mode.eq.3.and.ekin.le.eecut)mc2ce=.true.
+ IQIN= 1
+ elseif(abs(id).eq. 10)then !photon
+ if(mode.eq.3.and.ekin.le.epcut)mc2ce=.true.
+ IQIN= 0
+ else !neutrino : lost energy
+ if(iwrt.ge.2)call Profana(dptl(13)-0.000001d0*dzHa,zshmax,
+ & dptl(4),dptl(4),dptl(11),999,2)
+#ifdef __CXDEBUG__
+ etotsource=etotsource-dptl(4)*dptl(11)
+#endif
+ return
+ endif
+
+
+c Angles initialization
+ estck(1)=0.d0 !egs4
+ ethin=thin*eprima !egs4
+ isxegs=isx
+
+ ZBOUND=zshmax
+
+c Particle initialization
+ EIN=dptl(4)*1000.d0
+ XMIN=dptl(6) !x
+ YMIN=dptl(7) !y
+ ZMIN=dptl(8) !h
+ TMIN=dptl(9)
+ WTIN=dptl(11)
+ ZIN=dptl(13) !slant depth along shower axis
+ XIN=dptl(14) !x to shower axis
+ YIN=dptl(15) !y to shower axis
+ DMIN=dptl(16) !slant distance along shower axis
+ if(ZIN.ge.ZBOUND) then
+ return
+ endif
+c Particle below cutoff and not low energy particle, only CE
+ if(mc2ce.and.n.gt.0)then
+ call ConvPartLept(ekin,ZIN,WTIN,IQIN)
+ return
+ endif
+
+ if(i1DMC.eq.0.and.i1DEM.eq.0)then !in case of 3D tp191104
+ rtr1=sqrt(XMIN*XMIN+YMIN*YMIN)
+ if(rtr1.gt.1.d-20)then
+ sinphiP=YMIN/rtr1
+ cosphiP=XMIN/rtr1
+ sintheP=rtr1/(ZMIN+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ pinv=1.d0/sqrt(dptl(1)**2+dptl(2)**2+dptl(3)**2)
+ ep(1)=dptl(1)*pinv
+ ep(2)=dptl(2)*pinv
+ ep(3)=dptl(3)*pinv
+ call ToObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in obs. frame
+ call FromObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P in shower frame
+ UIN=ep(2) !in EGS4, left-handed frame y->u
+ VIN=ep(1) !in EGS4, left-handed frame x->v
+ WIN=ep(3)
+ else !1D all particle along shower axis
+ UIN=0.d0
+ VIN=0.d0
+ WIN=1.d0 !direction towards the shower axis
+ endif !end 3D or 1D
+ IRIN=2 ! air
+ LATCHIN=int(dptl(12)) !generation
+#ifdef __CXDEBUG__
+ if(isx.ge.4)then
+ write(ifck,*)'----- entry EGS4 (IQ,E,Z,U,V,W,WT,GEN) :'
+ write(ifck,'(i2,6e12.4,i4)')IQIN,EIN,ZIN,UIN,VIN,WIN,WTIN
+ & ,LATCHIN
+ endif
+#endif
+ CALL SHOW(IQIN,EIN,XMIN,YMIN,ZMIN,DMIN,XIN,YIN,ZIN,TMIN,UIN,VIN,
+ & WIN,IRIN,WTIN,LATCHIN)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)then
+ write(ifck,*)'--------- exit EGS4 ----------'
+ endif
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine InitializeMC2
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+c define stable particles
+
+ nodyxs(1)= 120 ! pi+ - stable
+ nodyxs(2)=-120 ! pi- - stable
+ nodyxs(3)= 130 ! K+ - stable
+ nodyxs(4)=-130 ! K- - stable
+ nodyxs(5)= 20 ! Kshort - stable
+ nodyxs(6)= -20 ! Klong - stable
+ nodyxs(7)= 14 ! muon- - stable
+ nodyxs(8)=-14 ! muon+ - stable
+ nodyxs(9)= 2130 ! lambda - stable
+ nodyxs(10)=-2130 ! antilambda - stable
+ nodyxs(11)= 110 ! pi0 - stable
+ nodyxs(12)= 1220 ! neutron - stable
+ nodyxs(13)=-1220 ! aneutron - stable
+ nodyxs(14)= 1120 ! proton - stable
+ nodyxs(15)=-1120 ! aproton - stable
+ if(ifragm.ne.0)then !light fragment stable
+ nodyxs(16)= 17 ! deuterium - stable
+ nodyxs(17)= 18 ! tritium stable
+ nodyxs(18)= 19 ! alpha - stable
+ nrnodyxs=18
+ else !full fragmentation
+ nrnodyxs=15
+ endif
+ if(nrnodyxs.gt.mxnodyxs)stop'nrnodyxs too large'
+
+ iapplxs = 1
+ neventxs = 1
+#ifdef __MODEL__
+ call IniEpos
+ call IniQGSjetII
+ call IniModel(4) !EPOS
+ call IniModel(6) !QGSJETII
+#else
+ modelxs = MCModel
+ call IniModel(modelxs)
+#endif
+
+
+ EgyHiLoLim=max(xsegymin,EgyHiLoLim)
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine HadronShower(n,iCEmode)
+c-----------------------------------------------------------------------
+c iCEmode = 0 - Pure Cascade Equation
+c = 1 - Hybrid
+c = -1 - Low threshold higher than High threshold : pure MC
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ common/cxransto/diu0(100),iiseed(3,2)
+#ifdef CONEX_EXTENSIONS
+ dimension iseedi(3)
+#endif
+ save neph
+
+#ifdef __CXDEBUG__
+ call utisx1('HadronShower ',4)
+#endif
+
+
+ call s2d(igo)
+ id=nint(dptl(10))
+ Ek=dptl(4)-dptl(5)
+ iCEmode=1
+ if(abs(id).ge.100.and.mod(id,100).eq.0) !nuclei
+ &Ek=Ek/dble(int(abs(id)/100))
+ if(n.gt.0)then
+#ifndef __CXCORSIKA__
+ if(mod(n,mshow).eq.0)then
+ call ranfgt(seed)
+#ifndef __CXSUB__
+ write(6,*)
+ write(6,*)'----------------> Shower ',n,' <---------------'
+ write(6,*)' seq ',lseq,' -- iseed(1) ',iiseed(1,lseq)
+ & ,' iseed(2) ',iiseed(2,lseq),' iseed(3) ',iiseed(3,lseq)
+#endif
+ endif
+#endif
+ etotlost=0.d0 !calculate in profana
+ etotsource=0.d0 !calculate in had and egs4
+ if(abs(id).eq.14)then
+ ECEThr=emcut
+ ECELow=emlow
+ elseif(abs(id).eq.12)then
+ ECEThr=eecut
+ ECELow=eelow
+ elseif(abs(id).eq.10)then
+ ECEThr=epcut
+ ECELow=eelow
+ else
+ ECEThr=ehcut
+ ECELow=ehlow
+ endif
+ if(EK.le.ECEThr.and.istack.eq.0)then
+ iCEmode=0
+ else
+ iCEmode=1
+ endif
+ if(ECELow.ge.ECEThr.or.Ek.le.ECELow)then
+#ifndef __CXCORSIKA__
+ if(mode.le.1.and.mode.ne.4)
+ * write(6,*)'Threshold such that CE are not needed ...'
+#endif
+ iCEmode=-1
+ endif
+
+ endif
+
+ if(iCEmode.eq.0)return !pure CE
+
+ neph=0
+ imode=0
+ do while (igo.eq.1)
+ if(imode.ne.6)dptl(12)=dptl(12)+1.d0 !generation
+ id=nint(dptl(10)) !If not electromagnetic particle
+ if(abs(id).ge.14.or.
+ * (id.eq.10.and.(mode.eq.0.or.mode.eq.8)))then !gamma from hadrons
+
+ if(i1DMC.eq.2)then
+ call propagation1D(imode,iCEmode)
+ else
+ call propagation(imode,iCEmode)
+ endif
+
+ if(imode.eq.3)then
+ call cdecay
+ elseif(imode.eq.4)then
+
+#ifdef CONEX_EXTENSIONS
+
+ interactionCounter=interactionCounter+1
+
+c RU Sun Oct 16 21:37:51 CEST 2011
+c this is a construct useful for shower-disection, interaction-wise
+ if (particleListMode.ne.1) then
+ call cnexus
+ else
+ nptlxs=0
+ endif
+c RU-end
+
+ if (writeFirstIntPart.gt.0) then
+
+c >> RU Tue Oct 24 11:34:58 CEST 2006
+c if(isFirstInt)then
+c isFirstInt=.false.
+ call ranfgt(seedDummy) ! get seed into iiseed
+ do iii=1,3
+ iseedi(iii)=iiseed(iii,lseq)
+ enddo
+ call write_seed_cx(iseedi)
+c endif
+c << RU Tue Oct 24 11:35:06 CEST 2006
+ endif
+#else
+ call cnexus
+#endif
+ endif
+
+ call c2s(imode)
+ else
+#ifdef __CXDEBUG__
+ etotsource=etotsource+dptl(4)*dptl(11) !energy will disappear from stack
+#endif
+ if(n.ne.0)neph=neph+1
+ call cegs4(neph,mshowEGS)
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ etotbal=Einit-etotsta-etotlost-etotsource
+ write(ifck,*)'Energy balance (stack, lost, source, bal) :'
+ write(ifck,'(4e16.8)')etotsta,etotlost,etotsource,etotbal
+ if(abs(etotbal/Einit).gt.1.d-2)write(ifck,*)'Balance wrong !'
+ endif
+#endif
+ call s2d(igo)
+ enddo
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cnexus
+c-----------------------------------------------------------------------
+c Call nexus for MC interaction
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+#ifdef __CXDEBUG__
+ character namodel*8
+#endif
+ dimension pfive(5)
+ data encount/0.d0/
+ encount=encount+1.d0
+#ifdef __CXDEBUG__
+ if(mod(encount,5000.d0).eq.0.and.isx.ge.1)
+ & write(6,*)' Ha MC counts: ',encount
+#endif
+
+ call getptl(idprojxs,pfive) !get id and momentum of projectile
+ if(abs(idprojxs).eq.14)then !muon interaction
+ call MuInteraction(idprojxs)
+ elseif(idprojxs.eq.41)then !q-ball interaction
+ call QBallInteraction(pfive)
+ elseif(idprojxs.eq.43)then !magnetic monopole
+ call MonopoleInteraction(idprojxs,pfive)
+ else !hadronic interaction
+ xselab=pfive(4)
+ maprojxs = 1
+ laprojxs = -1
+ if(abs(idprojxs).ge.100.and.mod(idprojxs,100).eq.0)then
+ maprojxs= abs(idprojxs)/100
+ if(idprojxs.lt.0)then !strangelet
+ laprojxs= 0
+ idprojxs=2130
+ else
+ laprojxs= int(dble(maprojxs) / 2.15d0 + 0.7d0)
+ if(idprojxs.eq.300)laprojxs=1
+ idprojxs=1120
+ endif
+ call cxidmass(idprojxs,ampr)
+ xselab=xselab/maprojxs
+ if(xselab-ampr.lt.EgyHiLoLim.and.ilowegy.eq.1)then
+c if(maprojxs.le.1.or.(MCleModel.eq.3.and.maprojxs.le.4))then !only quasi eleastic events in gheisha
+ if(maprojxs.le.1)then
+ modelxs=MCleModel
+ xselab=xselab*maprojxs
+c if(maprojxs.eq.2)then
+c idprojxs=17 !deuteron
+c elseif(maprojxs.eq.3)then
+c idprojxs=18 !triton
+c elseif(maprojxs.eq.4)then
+c idprojxs=19 !alpha
+c endif
+ maprojxs= 1
+ laprojxs= 1
+ iframexs = 0 ! low energy models already in lab frame
+ else !low energy models cannot run nucleus, split it in nucleon
+ call cxlownuc
+ goto 10
+ endif
+ else
+#ifdef __MODEL__
+ modelxs=2+2*nint(1d0+drangen(encount))
+#else
+ modelxs=MCModel
+#endif
+ if(modelxs.eq.2.or.modelxs.eq.6)then
+ iframexs = 0 ! qgs and QII already in lab frame
+ else
+ iframexs = 12 ! calculation in cms frame (boost to lab frame needed)
+ endif
+ endif
+ else
+ call cxidmass(idprojxs,ampr)
+ if(xselab-ampr.lt.EgyHiLoLim.and.ilowegy.eq.1)then
+ modelxs=MCleModel
+ iframexs = 0 ! low energy models already in lab frame
+ else
+#ifdef __MODEL__
+ modelxs=2+2*nint(1d0+drangen(encount))
+#else
+ modelxs=MCModel
+#endif
+
+ if(modelxs.eq.2.or.modelxs.eq.6)then
+ iframexs = 0 ! qgs and QII already in lab frame
+ else
+ iframexs = 12 ! calculation in cms frame (boost to lab frame needed)
+ endif
+ endif
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)then
+ if(modelxs.eq.2)then
+ namodel='QGSJet '
+ elseif(modelxs.eq.3)then
+ namodel='GHEISHA '
+ elseif(modelxs.eq.4)then
+ namodel='EPOS '
+ elseif(modelxs.eq.5)then
+ namodel='Sibyll '
+ elseif(modelxs.eq.6)then
+ namodel='QGSJetII'
+ elseif(modelxs.eq.7)then
+ namodel='FLUKA'
+ elseif(modelxs.eq.8)then
+ namodel='UrQMD'
+ elseif(modelxs.eq.9)then
+ namodel='DPMJet'
+ else
+ namodel='neXus '
+ endif
+ if(isx.le.5)then
+ write(ifck,'(a,a,i5,a,g10.3,a,$)')
+ $ namodel,' interaction for'
+ $ ,idprojxs,' + air at ',xselab,' GeV'
+ else
+ write(ifck,'(a,a,i5,a,g10.3,a)')
+ $ namodel,' interaction for'
+ $ ,idprojxs,' + air at ',xselab,' GeV'
+ endif
+ endif
+#endif
+
+ call cxainit
+ call cxanexus
+ 10 continue
+ call cxafinal
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*)' --> ',nptlxs,' ptls'
+#endif
+
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine getptl(id,pfive)
+c-----------------------------------------------------------------------
+c Get id and momentum from conex code
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension pfive(5)
+ id = nint(dptl(10))
+ do i=1,5
+ pfive(i)=dptl(i)
+ enddo
+ end
+
+#ifdef __CXCORSIKA__
+c-----------------------------------------------------------------------
+ subroutine d2cors(iqq) !tp170108
+c-----------------------------------------------------------------------
+c Write particles into CORSIKA stack
+c iqq = 0 - from cascade equations
+c 1 - from hadronic propagation
+c 2 - from electromagnetic propagation
+c 3 - particle reach ground
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6.and.iqq.ne.3)then
+ id=nint(dptl(10))
+ ida=abs(id)
+ ebal=dptl(4)
+ if(ida.ge.100.and.mod(ida,100).eq.0)then
+ if(id.ge.0)then
+ ebal=ebal-pmass(7)*dble(id/100) !nucleus
+ else
+ ebal=ebal-pmass(8)*dble(abs(id)/100) !lambda
+ endif
+ elseif(ida.ge.1000)then
+ ebal=ebal-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice
+ endif
+ etotlost=etotlost+ebal*dptl(11)
+ endif
+ if(isx.ge.4)write(ifck,100) iqq,dptl
+ 100 format('d2cors:',i2,4(1x,e11.4),1x,f4.2,4(1x,e9.2),1x,f6.0,1x
+ &,e9.2,1x,f5.0,1x,4(1x,e9.2))
+#endif
+ call FROMCNX
+ end
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine d2a !so110903
+c-----------------------------------------------------------------------
+c Write particles into stack
+c A second stack is introduced to save high energy particles
+c (above ehcut) with a SEED for the random numbers used for the sub-
+c shower started from this particle (to have always the same Xmax
+c independent of low energy cuts and machine uncertainties)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ integer iseedi(3)
+
+ istacki=istack
+ jstacki=jstack
+
+ if(dptl(4)-dptl(5).le.ehcut.and.ehcut.gt.enymin)then !low energy stack
+
+ if(istack.eq.mxstk)then
+ write(ifsa,rec=irec+1) (stack(i),i=1,mxstk)
+ irec=irec+1
+ istack=0
+ endif
+ istacki=istack
+ do i=1,mxblk !so110903
+ stack(istack+i)=dptl(i)
+ enddo
+ seed=-1d0
+ istack=istack+mxblk
+
+ else !high energy stack
+
+ if(jstack.eq.mxstkj)then
+ write(jfsa,rec=jrec+1) (stackj(i),i=1,mxstkj)
+ jrec=jrec+1
+ jstack=0
+ endif
+ jstacki=jstack
+ do i=1,mxblk
+ stackj(jstack+i)=dptl(i)
+ enddo
+ if(dptl(12).le.0d0.and.jrec.eq.0.and.jstack.eq.0)then
+c use initial seed for primary particle
+ seed=-1d0
+ iseedi(2)=0
+ iseedi(3)=0
+#ifdef __CXCORSIKA__
+ lseq=7
+ iseedi(1)=int(drangen(dble(iseed(1,1)))*1.d9)+1
+ call rmmaqd(iseedi,9,'S') !initialize 3d random number generator
+#else
+ lseq=1
+ iseedi(1)=int(drangen(dble(iseed(1,1)))*1.d9)+1
+ call rmmaqd(iseedi,3,'S') !initialize 3d random number generator
+#endif
+ else
+#ifdef __CXCORSIKA__
+ call RMMARD(seed,1,9)
+#else
+ call RMMARD(seed,1,3)
+#endif
+ seed=int(seed*1.D9)+1
+ endif
+ stackj(jstack+mxblk+1)=seed
+ jstack=jstack+mxblk+1
+
+ endif
+
+#ifdef CONEX_EXTENSIONS
+cc RU Mon Oct 23 09:05:39 CEST 2006
+cc if(dptl(12).eq.writeFirstIntPart)then
+c if (interactionCounter.gt.0) then
+c call write_particle(interactionCounter, dptl)
+c endif
+cc endif
+cc RU end
+c CONEX_EXTENSIONS
+#endif
+
+#ifdef __CXDEBUG__
+#ifndef __CXCORSIKA__
+ if(isx.ge.6)then
+#endif
+ id=nint(dptl(10))
+ ida=abs(id)
+ ebal=dptl(4)
+ if(ida.ge.100.and.mod(ida,100).eq.0)then
+ if(id.ge.0)then
+ ebal=ebal-pmass(7)*dble(id/100) !nucleus
+ else
+ ebal=ebal-pmass(8)*dble(abs(id)/100) !lambda
+ endif
+ elseif(ida.ge.1000)then
+ ebal=ebal-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice
+ endif
+ etotsta=etotsta+ebal*dptl(11)
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ if(isx.ge.4)write(ifck,100) jrec,jstacki,irec,istacki,dptl,seed
+ 100 format('d2a:',2(i3,1x,i5),4(1x,e11.4),1x,f4.2,4(1x,e9.2),1x,f6.0
+ &,1x,e9.2,1x,f5.0,1x,4(1x,e9.2),1x,f10.0)
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine s2d(iret)
+c-----------------------------------------------------------------------
+c Read particles from stack
+c iret=0 if no more particles
+c-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ integer iseedi(3)
+
+#ifdef LEADING_INTERACTIONS_TREE
+ leadingParticle=.false.
+ if(jstack.gt.0.and.istack.eq.0)then
+ istackR=jstack-mxblk-1
+ krec=jrec
+ idxs=nint(stackj(10))
+ elseif(istack.gt.0.and.jstack.eq.0)then !use low energy stack only when high energy stack is empty
+ istackR=istack-mxblk
+ krec=irec
+ idxs=nint(stack(10))
+ else !not leading particle
+ istackR=jstack+istack
+ krec=irec+jrec
+ endif
+ if (isx.ge.3) then
+ write(ifck,*) 's2d: istackR, i/jrec, countInt, maxDetail',
+ + istackR, krec, countInt, maxDetail
+ endif
+c if last particle on stack
+ if(istackR.eq.0.and.krec.eq.0) then
+ if(idxs.eq.-9999.or.idxs.eq.111.or.idxs.eq.221)
+ * countInt=maxDetail+1 !to avoid to follow particles from photonuclear interactions
+ if(countInt.le.maxDetail) then
+ leadingParticle=.true.
+#ifdef LEADING_INTERACTIONS_CORSIKA
+ if(mod(idxs,100).ne.0)then !not a nucleus
+ xidxs=dble(idtrafocx("nxs","cor",idxs))
+ elseif(idxs.lt.0)then !strangelet
+ xidxs=dble(idxs)
+ else !nucleus
+ xidxs=dble(idxs+int(dble(idxs)/100d0/2.15d0+0.7d0))
+ endif
+#else
+ xidxs=dble(idxs)
+c LEADING_INTERACTIONS_CORSIKA
+#endif
+ if(jstack.gt.0)then
+ call outpart3(xidxs,stackj(12),stackj(4))
+ else
+ call outpart3(xidxs,stack(12),stack(4))
+ endif
+ endif
+ endif
+
+ if (isx.ge.3) then
+ if (leadingParticle)then
+ if(jstack.gt.0)then
+ write(ifck,*) 's2d: leadingParticle is TRUE: id, gen, X, E',
+ + stackj(10),stackj(12),stackj(13),stackj(4)
+ else
+ write(ifck,*) 's2d: leadingParticle is TRUE: id, gen, X, E',
+ + stack(10),stack(12),stack(13),stack(4)
+ endif
+ endif
+ endif
+c LEADING_INTERACTIONS_TREE
+#endif
+ if(istack.eq.0.and.irec.eq.0)then
+ if(jstack.eq.0)then
+ if(jrec.eq.0)then
+ iret=0
+#if __MC3D__ && !__CXCORSIKA__
+ lseq=1 !main random number sequence
+#elif __CXCORSIKA__
+ lseq=7 !main random number sequence
+#endif
+ return
+ endif
+ jrec=jrec-1
+ read(jfsa,rec=jrec+1) (stackj(i),i=1,mxstkj)
+ jstack=mxstkj
+ endif
+ jstack=jstack-mxblk-1
+ do i=1,mxblk
+ dptl(i)=stackj(jstack+i)
+ enddo
+ seed=stackj(jstack+mxblk+1)
+ else
+ if(istack.eq.0)then
+ irec=irec-1
+ read(ifsa,rec=irec+1) (stack(i),i=1,mxstk)
+ istack=mxstk
+ endif
+ istack=istack-mxblk
+ do i=1,mxblk
+ dptl(i)=stack(istack+i)
+ enddo
+ seed=-1d0
+ endif
+ iret=1
+
+#if __MC3D__ && !__CXCORSIKA__
+ if(dptl(12).lt.500d0)then
+ lseq=1 !1st random number sequence
+ else !particles for low energy MC
+ lseq=2 !2nd random number sequence
+ endif
+#elif __CXCORSIKA__
+ if(dptl(4)-dptl(5).gt.EgyHiLoLim)then
+ lseq=7 !1st random number sequence
+ else
+c particles for MC with low energy model
+c (to reproduce shower in case of instability in low energy hadronic interaction model)
+ lseq=8 !2nd random number sequence
+ endif
+#endif
+
+ if(seed.gt.0d0)then
+C INITIALIZE RANDOM NUMBER SEQUENCE FROM SEED SAVED IN PARTICLE STACK
+ iseedi(1)=int(seed)
+ iseedi(2)=0
+ iseedi(3)=0
+ call rmmaqd(iseedi(1),lseq,'S' )
+ endif
+
+
+#ifdef __CXDEBUG__
+#ifndef __CXCORSIKA__
+ if(isx.ge.6)then
+#endif
+ id=nint(dptl(10))
+ ida=abs(id)
+ ebal=dptl(4)
+ if(ida.ge.100.and.mod(ida,100).eq.0)then
+ if(id.ge.0)then
+ ebal=ebal-pmass(7)*dble(id/100) !nucleus
+ else
+ ebal=ebal-pmass(8)*dble(ida/100) !lambda
+ endif
+ elseif(ida.ge.1000)then
+ ebal=ebal-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice
+ endif
+ etotsta=etotsta-ebal*dptl(11)
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ if(isx.ge.4)write(ifck,100) jrec,jstack,irec,istack,dptl,seed
+ 100 format('s2d:',2(i3,1x,i5),4(1x,e11.4),1x,f4.2,4(1x,e9.2),1x,f6.0
+ &,1x,e9.2,1x,f5.0,1x,4(1x,e9.2),1x,f10.0)
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine c2s(imode) !so110903
+c-----------------------------------------------------------------------
+c Check whether a particle is below the cut off or not. if not -> stack
+c ist=-1 ... list empty
+c 0 ... ptl ok -> hadron stack if energy big enought (hadr limit)
+c 1 ... ptl is lepton -> lepton stack
+c 2 ... ptl is gamma -> hadron stack just for counting
+c 3 ... ptl is a target spectator -> nothing (forget)
+c 4 ... ptl is lost by thinning -> nothing (forget)
+c 5 ... ptl is pi0 -> hadron stack if energy big enought (EM limit)
+c 10 ... ptl is not last generation -> nothing (forget)
+c Treatment depends on the way the particle has been produced (imode)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension p(6)
+ dimension ep(3)
+ common/cossins/s0xs,c0xs,s0s,c0s
+ ist=0
+ if(imode.ne.3.and.imode.ne.4)then
+ ist=-1
+#ifdef __CXCORSIKA__
+ if(imode.eq.7.or.imode.eq.1)then !if energy cut is lower in corsika, propagation should continue there.
+ call d2cors(1)
+ elseif(imode.eq.2)then
+ call d2cors(3)
+ endif
+#else
+ if(imode.eq.7)then
+ dptl(12)=dptl(12)+500d0 !generation > 500 to use 2d sequence of random numbers
+ call d2a
+ endif
+#endif
+ else
+ wtini=dptl(11)
+ nump=0
+ if(ihthin.ge.1.and.wtini.lt.whmax)
+ & call getthin(nump,wtini,wt) !thinning (only nump under threshold)
+ endif
+
+ do while(ist.ge.0)
+
+ call getcptl(p,nump,ist) !get particle from nexus
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,100) p,ist
+ 100 format('get:',6(1x,e11.4),' ist',1x,i3)
+#endif
+
+ if(ist.eq.5)then !if full simulation :
+ ist=0
+ if(mode.eq.0.or.mode.eq.8)ist=1 !energy limit for pi0 = gamma limit
+ endif
+
+ if(ist.eq.0.or.ist.eq.1)then
+ do j=1,5
+ dptl(j)=p(j)
+ enddo
+ dptl(10)=p(6)
+ dptl(11)=wtini
+ ekin=dptl(4)-dptl(5)
+ z=dptl(13)
+
+c write(*,*)'rudebug id,e,z=',dptl(10),dptl(4),z
+
+c Send to stack
+ iimode=imode
+ id=nint(dptl(10))
+ ida=abs(id)
+ if(ist.eq.0.and.(
+ & (ekin.ge.enymin.and.ida.ne.11.and.ida.ne.13.and.ida.ne.15
+ & .and.ida.lt.100)
+ & .or.(ekin.ge.max(enymin,xsegymin).and.ida.ge.100)))then
+
+c define momenta in local shower frame
+c(only for particle from interacting particle frame, so not for decaying particle)
+ if(i1DMC.ne.2.and.imode.eq.4)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+
+c Muon production rate
+ if(iwrt.ne.0.and.ida.eq.14)
+ & call Profana(z,z,ekin,ekin,wtini,14,10)
+
+ call d2a
+
+ elseif(ist.eq.1.and.ekin.ge.emin.and.ida.ne.11
+ & .and.(mode.eq.0.or.mode.eq.8))then
+
+c define momenta in local shower frame
+c(only for particle from interacting particle frame, so not for decaying particle)
+ if(i1DMC.ne.2.and.imode.eq.4)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+
+ call d2a
+
+ elseif(iwrt.ge.2)then
+ if(ida.eq.11.or.ida.eq.13.or.ida.eq.15)then !neutrino under threshold
+ ebal=dptl(4)
+ edep=ebal
+ iimode=2 !all energy is lost
+ else
+ if(ida.ge.100.and.mod(ida,100).eq.0)then !nucleus
+ if(id.ge.0)then
+ ebal=dptl(4)-pmass(7)*dble(id/100) !nucleus
+ else
+ ebal=dptl(4)-pmass(8)*dble(ida/100) !lambda
+ endif
+ edep=ebal
+ iimode=1 !edep is deposed
+ elseif(ida.ge.1000)then
+ ebal=dptl(4)-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice otherwise count kinetic energy
+ if(id.lt.0.or.id.ne.1220)then
+ edep=ebal
+ else !neutron do not depose energy
+ edep=0d0
+ endif
+ iimode=-1 !edep is deposed
+ elseif(ida.eq.12)then
+ ebal=dptl(4) !for electrons from hadronic int, count total energy for energy balance
+ edep=dptl(4)-sign(dptl(5),dble(id)) !if positron, count mass twice otherwise count kinetic energy
+ iimode=-1 !edep is deposed and ebal for energy balance
+ elseif(ida.eq.10)then !gammas
+ ebal=dptl(4)
+ edep=dptl(4)
+ iimode=-1 !edep is deposed and ebal for energy balance
+ elseif(ida.eq.14)then
+ ebal=dptl(4) !for muons from hadronic int, count total energy for energy balance
+ edep=dptl(4)/3.d0 !only one third of the total energy will be deposed
+ iimode=-1 !edep is deposed and ebal for energy balance
+ else
+ ebal=dptl(4) !if not baryon or electron or nucleus or muon count total energy
+ edep=ebal/4.d0
+ iimode=-1 !edep is deposed
+ endif
+ endif
+ call Profana(dptl(13)-0.0000001d0*dzHa,zshmax
+ & ,ebal,edep,dptl(11),999,iimode) !count energy
+ endif
+
+ elseif(ist.eq.100)then !thinned particle
+
+ do j=1,5
+ dptl(j)=dble(p(j))
+ enddo
+ dptl(10)=p(6)
+ dptl(11)=wt
+
+c define momenta in local shower frame
+c(only for particle from interacting particle frame, so not for decaying particle)
+ if(i1DMC.ne.2.and.imode.eq.4)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+
+ call d2a
+
+
+ endif
+
+ enddo
+
+ end
+
+
+
+#ifdef __SORT_FOR_ENERGY__
+
+c-----------------------------------------------------------------------
+ subroutine getcptl(p,nump,ist)
+c-----------------------------------------------------------------------
+c Transfert MC particle into conex code and set its status (ist)
+c in: energy kinetic cutoff
+c out: p(6)= 5-momentum + id of last ptl in list (if ist .ne. -1)
+c ist=-1 ... list empty
+c 0 ... ptl ok
+c 1 ... ptl is lepton
+c 3 ... ptl is a target spectator
+c 4 ... ptl is lost by thinning
+c 5 ... ptl is pi0
+c 10 ... ptl is not last generation
+c 100 ... ptl is a weighted one
+c-----------------------------------------------------------------------
+c
+c Always retrieves particle with maximum energy from MC stack !!!!!!!!!!
+c
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension p(6)
+ ist=-1
+ if(nptlxs.eq.0)return ! stack empty
+
+c look for highest energy on MC stack
+ iptlMaxE=nptlxs
+ eptlMaxE=xsptl(4,iptlMaxE)
+ do i=1,nptlxs
+ if(xsptl(4,i).gt.eptlMaxE) then
+ eptlMaxE=xsptl(4,i)
+ iptlMaxE=i
+ endif ! if(xsptl(4,i).gt.eptlMaxE) then
+ enddo
+
+c return found particle
+ do j=1,5
+ p(j)=xsptl(j,iptlMaxE)
+ enddo
+ if(i1DMC.eq.2)then !set pt to 0
+ p(3)=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
+ p(2)=0.d0
+ p(1)=0.d0
+ endif
+ id=idptlxs(iptlMaxE)
+ ida=iabs(id)
+ p(6)=dble(id)
+ ek=p(4)-p(5)
+ if(ida.eq.17)then
+ p(6)=sign(200,id) !deuteron
+ elseif(ida.eq.18)then
+ p(6)=sign(300,id) !triton
+ elseif(ida.eq.19)then
+ p(6)=sign(400,id) !alpha
+ endif
+ ist=istptlxs(iptlMaxE)
+ if(ist.gt.0)then
+ ist=10
+ elseif(iptlMaxE.eq.nump)then
+ ist=100
+ elseif(id.eq.110)then
+ ist=5
+ elseif(ida.ge.10.and.ida.le.12)then
+ ist=1
+ elseif((id.eq.1120.or.id.eq.1220).and.ek.lt.0.002d0)then
+ ist=3 !for target spectator
+ elseif(nump.ne.0.and.ida.gt.19.and.p(4).lt.ehthin
+ & .and.ek.ge.enymin)then
+ ist=4 !particle lost by thinning
+ endif
+
+
+c copy last particle on stack into the place of return particle
+ if (iptlMaxE.ne.nptlxs) then
+ idptlxs(iptlMaxE)=idptlxs(nptlxs)
+ do i=1,5
+ xsptl(i,iptlMaxE)=xsptl(i,nptlxs)
+ enddo
+ iorptlxs(iptlMaxE)=iorptlxs(nptlxs)
+ jorptlxs(iptlMaxE)=jorptlxs(nptlxs)
+ istptlxs(iptlMaxE)=istptlxs(nptlxs)
+ do i=1,4
+ xsorptl(i,iptlMaxE)=xsorptl(i,nptlxs)
+ enddo
+ xstivptl(1,iptlMaxE)=xstivptl(1,nptlxs)
+ xstivptl(2,iptlMaxE)=xstivptl(2,nptlxs)
+ ityptlxs(iptlMaxE)=ityptlxs(nptlxs)
+ if(nump.eq.iptlMaxE)nump=nptlxs !selected particle for thinning used once
+ endif
+
+
+ if (isx.ge.5) then
+ write(ifck,*) 'getcptl: iptlMaxE, id, ist, eptlMaxE, nptlxs',
+ + iptlMaxE, id, ist, eptlMaxE, nptlxs
+ endif
+
+
+c shrink stack by 1
+ nptlxs=nptlxs-1
+
+ end
+
+#else
+
+c-----------------------------------------------------------------------
+ subroutine getcptl(p,nump,ist)
+c-----------------------------------------------------------------------
+c Transfert MC particle into conex code and set its status (ist)
+c in: energy kinetic cutoff
+c out: p(6)= 5-momentum + id of last ptl in list (if ist .ne. -1)
+c ist=-1 ... list empty
+c 0 ... ptl ok
+c 1 ... ptl is lepton
+c 3 ... ptl is a target spectator
+c 4 ... ptl is lost by thinning
+c 5 ... ptl is pi0
+c 10 ... ptl is not last generation
+c 100 ... ptl is a weighted one
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension p(6)
+ ist=-1
+ if(nptlxs.eq.0)return
+ do j=1,5
+ p(j)=xsptl(j,nptlxs)
+ enddo
+ if(i1DMC.eq.2)then !set pt to 0
+ p(3)=sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
+ p(2)=0.d0
+ p(1)=0.d0
+ endif
+ id=idptlxs(nptlxs)
+ ida=iabs(id)
+ p(6)=dble(id)
+ ek=p(4)-p(5)
+ if(ida.eq.17)then
+ p(6)=sign(200,id) !deuteron
+ elseif(ida.eq.18)then
+ p(6)=sign(300,id) !triton
+ elseif(ida.eq.19)then
+ p(6)=sign(400,id) !alpha
+ endif
+ ist=istptlxs(nptlxs)
+ if(ist.gt.0)then
+ ist=10
+ elseif(nptlxs.eq.nump)then
+ ist=100
+ elseif(id.eq.110)then
+ ist=5
+ elseif(ida.ge.10.and.ida.le.12)then
+ ist=1
+ elseif((id.eq.1120.or.id.eq.1220).and.ek.lt.0.002d0)then
+ ist=3 !for target spectator
+ elseif(nump.ne.0.and.ida.gt.19.and.p(4).lt.ehthin
+ & .and.ek.ge.enymin)then
+ ist=4 !particle lost by thinning
+ endif
+ if (isx.ge.7) then
+ write(ifck,*) 'getcptl: id, ist ini, ist, nptlxs ,nump'
+ & ,id, istptlxs(nptlxs), ist, nptlxs, nump
+ endif
+ nptlxs=nptlxs-1
+ end
+c __SORT_FOR_ENERGY__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine getthin(nump,wein,weout)
+c-----------------------------------------------------------------------
+c In case of hadron thinning, select the particle which will be kept (nump)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+ weout=wein
+ nump=0
+ if(nptlxs.eq.0)return
+ etot=0.d0
+ do i=1,nptlxs
+ e=xsptl(4,i)
+ ek=xsptl(4,i)-xsptl(5,i) !hadron above em and below threshold
+ if(istptlxs(i).eq.0.and.abs(idptlxs(i)).gt.19 !exclude em particles and light nuclei
+ & .and.idptlxs(i).ne.110 !exclude pi0
+ & .and.e.lt.ehthin.and.ek.ge.enymin)then
+ etot=etot+e
+ endif
+ enddo
+ if(etot.le.0.d0)return
+ eran=drangen(dummy)*etot
+ i=0
+ e2=0.d0
+ do while (e2.lt.eran)
+ i=i+1
+ e=xsptl(4,i)
+ ek=xsptl(4,i)-xsptl(5,i)
+ et=xsptl(4,i)
+ if(istptlxs(i).eq.0.and.abs(idptlxs(i)).gt.19
+ & .and.idptlxs(i).ne.110
+ & .and.e.lt.ehthin.and.ek.ge.enymin)e2=e2+et
+ enddo
+ weight=wein*etot/et
+ if(i.le.nptlxs)then
+ nump=i
+ weout=weight
+ else
+ write(*,*)'Problem in CONEX thinning !',nptlxs,i,etot,eran,e2,et
+ endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cdecay
+c-----------------------------------------------------------------------
+c Decay current particle with nexus decay subroutine (hdecay)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension p(6)
+ call getdptl(p)
+ id=nint(p(6))
+ ida=abs(id)
+ nptlxs=nptlxs+1
+ nptl0=nptlxs
+ do i=1,5
+ xsptl(i,nptlxs)=p(i)
+ enddo
+ idptlxs(nptlxs)=id
+ istptlxs(nptlxs)=0
+ iptl=nptlxs
+ do i=iptl,iptl+10
+ istptlxs(i)=0
+ enddo
+
+ if(ida.eq.1120.or.ida.eq.1220) then
+ write(*,*) id,p
+ stop'ayyyyyyyyyyyy'
+ endif
+ if(id.eq.110) then
+ call cxhdecay(iptl,iret) !
+ elseif(ida.eq.120) then
+ call cxhdecay(iptl,iret)
+ elseif(ida.eq.130) then
+ call cxhdecay(iptl,iret)
+ elseif(ida.eq.14) then
+ call cxhdecay(iptl,iret)
+ dptl(12)=dptl(12)+500d0 !generation > 500 to keep EM subshower in MC
+ elseif(ida.eq.20) then
+ call cxhdecay(iptl,iret)
+ elseif(id.eq.111) then
+ call cxhdecay(iptl,iret)
+ elseif(id.eq.220) then
+ call cxhdecay(iptl,iret)
+ elseif(id.eq.221) then
+ call cxhdecay(iptl,iret)
+ elseif(ida.eq.2130) then
+ call cxhdecay(iptl,iret)
+ else
+ call cxhdecay(iptl,iret)
+ if(iret.ne.0)nptlxs=0 !do nothing, particle is lost
+ endif
+ istptlxs(nptl0)=1
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*)'decay ',id,' --> ',nptlxs-nptl0,' ptls'
+#endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine getdptl(p)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension p(6)
+ do j=1,5
+ p(j)=dptl(j)
+ enddo
+ p(6)=dptl(10)
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine propagation(imode,iCEmode) !tp241104 !so110903
+c-----------------------------------------------------------------------
+c select decay or collision mode for current particle
+c input: dptl
+c iCEmode = 0 - Pure Cascade Equation
+c = 1 - Hybrid
+c = -1 - Low threshold higher than High threshold : pure MC
+c output: imode = 1 (disappear), 2 (ground), 3 (decay), 4 (collision)
+c 5 (source function) 6 (egs4) 7 (corsika)
+c dptl(1-9),dptl(13-15) will be updated
+c Local frame of the particle (where px,py, and pz are defined) is defined
+c by z axis pointing to earth center and y axis in the plane defined by z
+c axis and the vertical going through earth center and obs. point (frame is
+c right-handed).
+c Shower frame (where p0x,p0y, and p0z are defined) is defined
+c by z axis pointing to impact point (shower axis) and y axis in the plane
+c defined by z axis and the vertical going through earth center and obs.
+c point (frame is right-handed).
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension ep(3),rlmin(3)
+ logical go,cont,mc2ce,ioloss,mc2cemu,magnet,muscat
+#ifndef __CXCORSIKA__
+ logical axispro
+#endif
+ common /cxexoticdz/dXotic
+ double precision dXotic
+
+
+ common/cossins/s0xs,c0xs,s0s,c0s !so110903
+ data rlmin /0.843D+02,0.844D+02,0.125D+03/ !nucl, pion, kaon : rlam max for gheisha
+
+#ifdef __CXDEBUG__
+ if(isx.eq.3)then
+ write(ifck,'(a,$)')' propagation: '
+ elseif(isx.gt.3)then
+ write(ifck,*)
+ write(ifck,'(a)')' propagation: '
+ endif
+#endif
+
+c Initial position
+
+ jinv=0
+ jinvm=0
+ id=nint(dptl(10)) !particle id
+ wt=dptl(11) !particle weight
+ EK=dptl(4)-dptl(5) !kinetic energy
+ ida=abs(id)
+ x1=dptl(6) !x-coordinate
+ y1=dptl(7) !y-coordinate
+ h1=dptl(8) !height, m
+ t1=dptl(9) !time
+ E1=dptl(4) !initial energy
+ z1=dptl(13) !slant depth along shower axis
+ x01=dptl(14) !x-coordinate in shower frame
+ y01=dptl(15) !y-coordinate in shower frame
+ dist01=dptl(16) !slant distance along shower axis
+ h01=heightt(dist01,radtr0)
+ px0=0.d0 !temporary for cana2 for pi0 and gamma
+ py0=0.d0 !temporary for cana2 for pi0 and gamma
+ pz0=1.d0 !temporary for cana2 for pi0 and gamma
+
+ egycut=ehcut !threshold for CE
+ np=0
+ dld=1d30 ! initialize decay length
+ dli=1d30 ! initialize interaction length
+ rzi=0.d0
+ mc2ce=.false. ! if true and E<egycut, particle goes into source
+ ioloss=.false. !ionization loss
+ magnet=.false. !magnetic field
+ muscat=.false. !muon multiple scattering
+ zmcl=zmchlow
+ egylow=ehlow !low energy MC threshold for CORSIKA instead of source function
+ imode=4 !default value
+
+c Check particle type
+ if(ida.eq.14)then ! muon
+ np=9
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=7
+ egycut=emcut !threshold for CE
+ zmcl=0d0 !only energy cut for muons (no magnetic field in conex)
+ egylow=emlow
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ if(iMagne.ge.1)magnet=.true. !magnetic field
+ if(iMuScat.ge.1)muscat=.true. !muon multiple scattering
+ elseif(id.eq.41)then !q-ball
+ np=-1
+ B = -1.d0
+ mc2ce=.false.
+ elseif(id.eq.43)then !magnetic monopole
+ np=-3
+ B = -1.d0
+ mc2ce=.false.
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.eq.10)then ! gamma
+ mc2ce=.false. ! particle can not be used in CE as source
+ lXfirstIn=.false. !cannot fix first interaction for gammas
+ imode=6 ! goes in EGS
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+ z2=zshmin+(delzsh*(j-1)) !just for counting
+ z2=z2+0.001d0*min(delzsh,z2-z1) !to be sure to go throught the bin edge
+ id=-10
+ if(EK.ge.enymin.and.lxfirst)
+ $ call cana2(h1,x01,y01,x1,y1,dist01,z1,t1,E1,h1,x01,y01,x1,y1
+ $ ,dist01,z2,t1,dptl(4),px0,py0,pz0,dptl(5),wt/delzsh
+ $ ,dptl(12),id,imode)
+ dptl(10)=dble(id)
+ call d2a !send to egs stack after counting
+ goto 9999
+ elseif(id.eq.110)then ! pi0
+ mc2ce=.false. ! particle can not be used in CE as source
+ np=2
+ B= bdeca(6)
+c imode=3 ! decay immediatly (no propagation)
+c call cana2(h1,x01,y01,dist01,z1,t1,E1,h1,x01,y01,dist01,z1,t1,dptl(4)
+c $ ,px0,py0,pz0,dptl(5),wt,dptl(12),id,imode)
+c goto 9999
+ elseif(ida.eq.1120.or.ida.eq.1220)then ! proton
+ np=1
+ B = -1.d0 ! negative means stable
+ mc2ce=.true. ! particle can be used in CE
+ ns=sign(1,id)
+ if(ida.eq.1220)then ! neutron
+ ns=sign(6,id)
+ elseif(ionloss.eq.1)then
+ ioloss=.true. !ionization loss
+ endif
+ elseif(ida.eq.120)then ! Charged pion
+ np=2
+ B = bdeca(np) ! B=m/c/tau0
+ mc2ce=.true. ! particle can be used in CE
+ ns=2
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(ida.eq.130)then ! Charged kaon
+ np=3
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=3
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.eq.-20.or.id.eq.-230)then ! kaon long
+ np=4
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=4
+ elseif(id.eq.20.or.id.eq.230)then ! kaon short
+ np=5
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=5
+ elseif(id.eq.111.or.id.eq.221.or.id.eq.220)then !rho or omega from photonuclear effect
+ imode=3 ! decay immediatly (no counting or propagation)
+ if(.not.lXfirstIn)then ! fixed first interaction : propagate until interaction point
+ goto 9999
+ endif
+ elseif(id.eq.-9999)then ! particle from EGS4 to mimic photonuclear int.
+ imode=4 ! interact immediatly (no counting or propagation)
+ if(EK.le.EgyHiLoLim)then !low energy models
+ dptl(10)=sign(120.d0,drangen(dptl(10))-0.5d0) ! use charge pion as projectile
+ elseif(MCModel.eq.9)then !DPMJET
+ dptl(10)=110 ! use pi0 as projectile (as in CORSIKA)
+ elseif(MCModel.eq.4.or.MCModel.eq.5)then !EPOS, SIBYLL
+ dptl(10)=111 ! use rho0 as projectile
+ else
+ dptl(10)=sign(120.d0,drangen(dptl(10))-0.5d0) ! use charge pion as projectile
+ endif
+ do i=1,3
+ ep(i)=dptl(i)
+ enddo
+ call cxdefrot(ep,s0xs,c0xs,s0s,c0s)
+ goto 9999
+ elseif(ida.eq.2130)then ! lambda
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(8) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(MCModel.eq.6)then !only decay for QGSJETII (as in CORSIKA)
+ imode=3 ! decay immediatly (no propagation)
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(.not.lXfirstIn)then ! fixed first interaction : propagate until interaction point
+ goto 9999
+ endif
+ endif
+ elseif(ida.eq.1130)then ! sigma+
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(10) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.1230)then ! sigma0
+ imode=3 ! decay immediatly (no propagation)
+ call cana2(h1,x01,y01,x1,y1,dist01,z1,t1,E1,h1,x01,y01,x1,y1
+ $ ,dist01,z1,t1,dptl(4),px0,py0,pz0,dptl(5),wt,dptl(12),id,imode)
+ goto 9999
+ elseif(ida.eq.2230)then ! sigma-
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(11) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.1330)then ! Xi0
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(12) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.2330)then ! Xi-
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(13) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.3331)then ! Omega
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(14) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.140)then ! D0
+ np=4 ! same inter length and energy loss as neutral kaons
+ B = bdeca(15) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.240)then ! D+
+ np=3 ! same inter length and energy loss as charged kaons
+ B = bdeca(16) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.340)then ! Ds+
+ np=3 ! same inter length and energy loss as charged kaons
+ B = bdeca(17) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(ida.eq.2140)then ! Lambda c
+ np=1 ! same inter length and energy loss as charged kaons
+ B = bdeca(18) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ elseif(id.ge.100.and.mod(id,100).eq.0)then !nuclei
+ B=-1.d0
+ np=10
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.le.-100.and.mod(id,100).eq.0)then !strangelet
+ B=-1.d0
+ np=-10
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ else
+ write(*,*)'propagate unknown id:',id,' decay !'
+#ifdef __CXDEBUG__
+ write(ifck,*)'propagate unknown id:',id,' decay !'
+#endif
+ imode=3 ! decay immediatly (no propagation)
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(.not.lXfirstIn)then ! fixed first interaction : propagate until interaction point
+ goto 9999
+ endif
+c stop'propagate: id not recognized. '
+ endif
+
+c if particle below low cut before ground, source is used for CORSIKA stack (if used)
+#ifndef __CXCORSIKA__
+ axispro=.true. !stop propagation if particle projection on shower axis reached ground
+ if(iCEmode.eq.-1.or..not.mc2ce)then
+ mc2ce=.false. !no CE because threshold too low
+c axispro=.false. !do not check particle projection on axis
+ endif
+ if(dptl(12).ge.200d0)then
+ mc2ce=.false. !particle coming from had CE should not go back to CE
+c axispro=.false.
+ endif
+#endif
+
+#ifdef __CXCORSIKA__
+ if(.not.lXfirst)mc2ce=.false. !do not send particle to CORSIKA before first interaction
+#endif
+c Geometrical initialization if propagation
+
+
+ P=sqrt(dptl(1)**2+dptl(2)**2+dptl(3)**2) !momentum
+ Pinv=1.d0/P !inverse momentum
+ ct=dptl(3)*Pinv !local cosine
+ if(abs(ct).gt.1.d0)ct=sign(1.d0,ct)
+ st=dsqrt(1.d0-ct*ct) !local sin
+
+ radtr=(radearth+h1)*st !local impact radius
+ dist1=distant(h1,radtr) !local slant distance to obs level, m
+ sz1=deptht(dist1,radtr) !local slant depth, g/cm^2
+ depthmaxi=depthmax(radtr) !local maximum depth
+
+
+ rtr1=dsqrt(x1*x1+y1*y1) !radial distance to obs point
+
+c cosine and sine of the angles between the obs frame and the particle frame
+ if(rtr1.gt.1.d-20)then
+ sinphiP=y1/rtr1
+ cosphiP=x1/rtr1
+ sintheP=rtr1/(h1+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ rho=rhoair(h1)
+
+ ep(1)=dptl(1)*Pinv !direction of P in particle frame
+ ep(2)=dptl(2)*Pinv
+ ep(3)=ct
+ call ToObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in obs. frame
+ px=ep(1)
+ py=ep(2)
+ pz=ep(3)
+ call FromObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P in shower frame
+ px0=ep(1)
+ py0=ep(2)
+ pz0=ep(3)
+ costhi=1.d0/pz0 !for projection from shower axis to particle direction
+
+ if(pZ0.le.0d0)then
+#ifdef __CXCORSIKA__
+ if(mc2ce)then
+c light backward going particles should go directly to CORSIKA for better
+c tracking in magnetic field
+ imode=7
+ goto 9999
+ endif
+#else
+ mc2ce=.false. !backward going particle should not go in CE
+#endif
+ endif
+c source depth bin
+
+ if(mc2ce.and.(mode.eq.5.or.mode.eq.8))then
+#ifndef __CXCORSIKA__
+ if(z1.eq.zshmin)then
+ j=1 !for primary particle
+ if(EK.le.egycut)then
+ imode=5
+ call d2hsource(ns,j,px0*P,py0*P)
+ goto 9999
+ endif
+ else
+#endif
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ call updateSource(zsource,distso,j,z1,dist01,h01,mc2ce)
+#ifdef __CXDEBUG__
+ if(isx.ge.5)
+ & write(ifck,*)'source bin:',j,zsource,distso,z1,dist01,h01,egycut
+#endif
+ else
+ mc2ce=.false. !source function only for hybrid mode
+ zsource=1d30
+ endif
+
+ EK0=EK
+
+ if(.not.lXfirstIn)then !not fixed first interaction point
+
+c.....decay ???.........
+ if(B.gt.0.d0)then
+ r=drangen(dummy)
+ dld= -log(r)*dptl(4)/B !s0270603
+ endif
+c.....or collision ???....
+ if(abs(np).lt.10)then
+ npn=1
+ dzi = rlam(np,EK,dptl(5)) !interaction length
+ elseif(id.ge.100.and.mod(id,100).eq.0)then
+ npn=int(id/100)
+ np=npn*10
+ dzi = rlam(np,EK/dble(npn),pmass(7)) !interaction length for nuclei
+ elseif(id.le.-100.and.mod(id,100).eq.0)then
+ npn=int(abs(id)/100)
+ np=-npn*10
+ dzi = rlam(np,EK/dble(npn),pmass(8)) !interaction length for strangelet
+ else
+ stop'propagation: unknown particle. '
+ endif
+
+ EK0=EK
+ if(ioloss)then !for charged particles
+ delx0=dedxIonMC(np,EK,rho)
+ if(MCleModel.eq.3.and.EK.le.EgyHiLoLim
+ & .and.np.le.3.and.np.gt.0)then
+ rlamin=rlmin(np) !use tabulation for gheisha
+ else
+ rlamin=dzi !rlam at current energy for others
+ endif
+ delx=delx0
+ EKp=EK
+ 10 drzi= -log(drangen(EKp)) * rlamin
+ EK0=Ekp
+ EKp=max(1.d-5,EKp-delx*drzi)
+ if(abs(np).lt.10)then
+ rlamax=rlam(np,EKp,dptl(5))
+ else
+ rlamax=rlam(np,EKp/dble(npn),pmass(7)) !for nuclei
+ endif
+ rzi=rzi+drzi
+ if(EKp.gt.1.d0)then
+ Pint=rlamin/rlamax !interaction probability
+ if(Pint.lt.drangen(EKp))then
+ delx=dedxIonMC(np,EKp,rho)
+ goto 10
+ endif
+ endif
+ else
+ rzi = -log(drangen(dummy)) * dzi
+ delx0=0.d0
+ endif
+
+ dz=sign(rzi,ct)
+ call dz2dl(dz,dl,h1,h2,radtr,jinvi)
+ dli=dl
+
+
+c..... choose one ............
+ if(dld.gt.dli)then
+ imode=4 ! interaction
+ dl=dli
+ else
+ imode=3 ! decay
+ dl=dld
+ endif
+
+ else !fixed first interaction point
+
+ dld=1d30
+ dli=1d30
+ delx0=0d0
+ dz=sign(abs(Xfirst-XminP),ct) !propagate directly to Xfirst
+ call dz2dl(dz,dl,h1,h2,radtr,jinvi)
+
+ endif
+
+ EKini=EK
+ szimu=sz1
+ zimu=z1
+ himu=h1
+ rhoimu=rho
+ h0imu=h01
+ d01mu=dist01
+ d1mu=dist1
+ delxmu=delx0
+ ctini=ct
+ dlin=0.d0
+ mc2cemu=mc2ce
+ go=.false.
+
+
+ 20 dls=sign(dl,ct)
+ call dl2dz(dls,dz,h1,h2,dist1,dist2,radtr)
+
+#ifdef __CXCORSIKA__
+c Test ground position in case of flat HGrd
+ if(lFlat)then
+ call updateFlat(x1,y1,h1,h2,dl,px,py,imode)
+ if(imode.eq.2)then
+ dls=sign(dl,ct)
+ call dl2dz(dls,dz,h1,h2,dist1,dist2,radtr)
+ endif
+ endif
+#endif
+
+ dl=abs(dls)
+
+ jinv=0
+ if(dist2.le.1.d-9)then !check propagation on trajectory
+ if(radtr.le.RadGrd)then
+ imode=2 ! particle reaches ground
+ h2=HGrd
+ else
+ jinv=1
+ dist2=-dist2
+ endif
+ endif
+
+ if(h2.ge..999999d0*eatm(mxatm+1))then
+ imode=2 ! particle leaves the atm.
+ endif
+
+ sz2=sz1+sign(dz,ct) !new local slant depth, g/cm^2
+
+
+ if(i1DMC.eq.1)then !z2-z1=projection of sz2-sz1
+ dz0=abs(sz2-sz1)*pz0
+ dz0s=dz0*sign(1.d0,dphlim0-z1)
+ call dz2dl(dz0s,dl,h01,h02,radtr0,idum)
+ dz0=sign(dz0s,pz0) !dz0s can be updated
+ dist02=dist01-dl
+ else
+ dl0=dl*pz0
+ dl0s=dl0*sign(1.d0,dphlim0-z1)
+ call dl2dz(dl0s,dz0,h01,h02,abs(dist01),dist02,radtr0)
+ dist02=dist02*sign(1.d0,dist01-sign(1.d-10,pz0))
+ dz0=sign(dz0,pz0)
+ endif
+ z2=z1+dz0
+
+
+#ifndef __CXCORSIKA__
+
+ if(axispro)then
+
+ if(z2.gt.1.000001d0*zshmax)then
+ jinv=0
+ imode=2
+ z2=1.000000001d0*zshmax
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ elseif(z2.lt.0.999999999d0*zshmin)then
+ jinv=0
+ imode=2
+ z2=zshmin
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ endif
+
+ endif
+
+#endif
+c slant depth crossed and energy lost
+
+ zini=sz1
+ if(jinv.eq.0)then
+ dzloss=abs(sz2-sz1)
+ else
+ dzloss=max(0.d0,2.d0*depthmaxi-sz1-sz2)
+ endif
+ dEloss=dzloss*delx0
+C Save total path for exotic primaries
+ dXotic=dzloss
+
+c Muons
+
+ if(np.eq.9.and.ioloss)then !begin muon propagation
+ dEmu=0.01d0*EK !if mu lose more than 1 % of his energy, do one more step
+ if(dEloss.ge.dEmu)then
+ imode=3
+ mc2ce=mc2cemu
+ go=.true.
+ delx=dedxionMC(np,EK,rho)
+ dlz=dEmu/delx
+ call updateDist(sz1,sz2,dlz,z1,z2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,h01,h02,pz0,ct,depthmaxi,radtr,jinvm2)
+ dlin=dlin+abs(dl)
+#ifdef __CXDEBUG__
+ if(isx.ge.5)
+ & write(ifck,*)'muon step:',sz1,sz2,dlz,z1,z2,dist2,dl,dlin
+ & ,h2,EK,dEmu
+#endif
+ if(dlin.ge.dli)then
+ imode=4
+ call updateDist(szimu,sz2,rzi,zimu,z2,dl,d01mu,dist02,d1mu
+ & ,dist2,himu,h2,h0imu,h02,pz0,ct,depthmaxi,radtr,jinvm2)
+#ifdef __CXDEBUG__
+ if(isx.ge.5) write(ifck,*)'muon inter. :',jinvm2,dist02,dist2,z2
+ & ,sz2,rzi,dl,dli
+#endif
+ endif
+ if(mc2ce.and.z2.ge.zsource.and.EK.le.egycut)then
+ goto 30 !muon will go in source function
+ elseif((jinvm2.eq.1.and.radtr.le.RadGrd)
+ & .or.h2.ge..999999d0*eatm(mxatm+1)
+#ifndef __CXCORSIKA__
+ & .or.(axispro.and.((z2.ge.zshmax)
+ & .or.(z2.lt.0.9999999d0*zshmin))))then !particle reaches the limits
+#else
+ & )then !particle reaches the limits
+#endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'muon lost:',jinvm2,dist02,dist2,z2
+ & ,zshmax
+#endif
+ imode=2
+#ifndef __CXCORSIKA__
+ if(axispro)then
+ if(z2.ge.zshmax)then
+ z2=1.000000001d0*zshmax
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,costhi,ct,depthmaxi,radtr,jinvm2)
+ elseif(z2.lt.0.9999999d0*zshmin)then
+ z2=zshmin
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,costhi,ct,depthmaxi,radtr,jinvm2)
+ endif
+ endif
+#endif
+ jinvm=max(jinvm,jinvm2)
+ goto 30
+ elseif(imode.eq.3)then
+ jinvm=max(jinvm,jinvm2)
+ EK=EK-dEmu
+ if(EK.le.enymin)goto 30 !if energy below cutoff, stop propagation here
+ sz1=sz2
+ z1=z2
+ h1=h2
+ rho=rhoair(h1)
+ h01=h02
+ dist01=dist02
+ dist1=dist2
+ delx0=delx
+ if(jinvm2.eq.1)ct=-ct
+ dl=-log(drangen(EK))*(EK+pmass(9))/B
+ dist2=dist1-sign(dl,ct) ! new local slant distance
+ goto 20
+ else !muon interact
+ goto 30
+ endif
+ endif
+
+ 30 if(go)then
+ jinv=jinvm
+ z1=zimu
+ sz1=szimu
+ h1=himu
+ rho=rhoimu
+ h01=h0imu
+ dist01=d01mu
+ dist1=d1mu
+ ct=ctini
+ zini=sz1
+ delx0=delxmu
+ if(jinv.eq.0)then
+ dl=abs(dist1-dist2)
+ dzloss=abs(sz2-sz1)
+ else
+ dl=abs(dist1+dist2)
+ dzloss=max(0.d0,2.d0*depthmaxi-sz1-sz2)
+ endif
+ dEloss=dzloss*delx0
+ EK=EKini
+#ifdef __CXDEBUG__
+ if(isx.ge.5) write(ifck,*)'end muon:',jinv,sz2,z2,dl,dEloss
+ & ,dzloss
+#endif
+ endif
+
+ endif !end muon propagation
+
+#ifdef __CXDEBUG__
+ x1i=x1
+ y1i=y1
+ h1i=h1
+ t1i=t1
+ z1i=z1
+ sz1i=sz1
+#endif
+
+c Ionization loss
+
+ go=.true.
+ if(ioloss)then
+ nstep=int(dEloss/(0.01d0*EK)) !lose max 1% of energy by step
+ if(magnet)then
+ j=int(((0.5d0*(z1+z2)-1d-9*delzsh)-zshmin)/delzsh)+1 !mean slant depth indice
+ RadB=P/Bfield(4,j)
+ alpha=dl/RadB
+ nstep2=int(10d0*alpha) !travel not more than alpha = dl/nstep = 0.1 * R
+ alpha=sign(1d0,dble(id))*alpha
+ else
+ nstep2=0
+ endif
+ nstep=max(nstep,nstep2)
+ if(nstep.le.0)then
+ EK0=EK
+ EK=max(1.d-5,EK-dEloss)
+ if(EK.le.enymin)then !particle below cut off
+ imode=1
+ dlz=(EK0-enymin)/delx0 !maximum slant depth with energy > enymin
+ call updateDist(zini,zfin,dlz,z1,z2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,h01,h02,pz0,ct,depthmaxi,radtr,idum)
+ Ek=enymin
+
+ endif
+ if(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !particle could go into source function
+ dlzn=abs(zsource-z1)*costhi
+ if(i1DMC.ne.1)then
+ dls=sign(abs((dist01-distso)*costhi),ctini)
+ call dl2dz(dls,dlzn,h1,h2so,dist1,dsoe,radtr)
+ endif
+ EKn=EK0-dlzn*delx0 !kinetic energy when crossing the border
+#ifdef __CXDEBUG__
+ if(EKn.le.0.d0)
+ & write(*,*)'Warning : precision problem in propagation (1)'
+#endif
+ if(EKn.le.egycut.and.EKn.gt.exmin)then !if this energy still below the cutoff (and not precision problem in the calculation ...)
+ imode=5
+ z2=zsource-0.001d0*min(delzsh,zsource-z1) !to be sure not to count the particle after zsource
+ call updateSlant(z1,z2,zini,zfin,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ if(jinv.eq.0)then
+ dlzn=abs(zfin-zini)
+ else
+ dlzn=max(0.d0,2.d0*depthmaxi-zfin-zini)
+ endif
+ EK=EK0-dlzn*delx0 !kinetic energy when crossing the border
+ if(EK.le.0.d0)then
+#ifdef __CXDEBUG__
+ write(*,*)'Warning : precision problem in propagation (2)'
+ write(*,*)'warning',jinv,z1,z2,zini,zfin,dlzn,delx0,EK0,EKn,EK
+#endif
+ EK=EKn
+ endif
+ endif
+ endif
+ dptl(4)=EK+dptl(5)
+ P=dsqrt(dptl(4)-dptl(5))*dsqrt(dptl(4)+dptl(5))
+ else
+ go=.false.
+ x02=x01
+ y02=y01
+ x2=x1
+ y2=y1
+ t2=t1
+ z2=z1
+ h2=h1
+ h02=h01
+ dist2=dist1
+ dist02=dist01
+ dlz=dzloss/dble(nstep)
+ delx=delx0
+ zfin=zini
+ cont=.true.
+ iz=1
+ iimode=imode
+ if(iimode.le.2)iimode=iimode+2
+
+ do while (iz.le.nstep.and.cont)
+ jinv=0
+ iz=iz+1
+ zini=zfin
+ z1=z2
+ h01=h02
+ h1=h2
+ dist01=dist02
+ dist1=dist2
+ EK0=EK
+ EK=max(1.d-5,EK-delx*dlz)
+ if(EK.le.enymin)then
+ imode=1
+ dlz=(EK0-enymin)/delx !maximum slant depth with energy > enymin
+ Ek=enymin
+ cont=.false.
+ else
+ delx0=delx
+ rho=rhoair(h1)
+ delx=dedxionMC(np,EK,rho)
+ endif
+ call updateDist(zini,zfin,dlz,z1,z2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,h01,h02,pz0,ct,depthmaxi,radtr,jinv)
+ 40 continue
+ if(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !particle could go into source function
+ dso0=dist01-distso
+ if(dso0.lt.0.d0)then !particle already pass the bin edge
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+ call updateSource(zsource,distso,j,zimu,d01mu,h0imu,mc2ce)
+ if(distso.lt.dist01)goto 40 !test again
+ else
+ dlzn=abs(zsource-z1)*costhi
+ if(i1DMC.ne.1)then
+ dls=sign(abs(dso0*costhi),ct)
+ call dl2dz(dls,dlzn,h1,h2so,dist1,dsoe,radtr)
+ endif
+
+ EKn=EK0-dlzn*delx0 !kinetic energy when crossing the border
+#ifdef __CXDEBUG__
+ if(EKn.le.0.d0)
+ & write(*,*)'Warning : precision problem in propagation (3)'
+#endif
+ if(EKn.le.egycut.and.EKn.gt.exmin)then !if this energy still below the cutoff (and not precision problem in the calculation ...)
+ cont=.false.
+ imode=5
+ z2=zsource-0.001d0*min(delzsh,zsource-z1) !to be sure not to count the particle after zsource
+ call updateSlant(z1,z2,zini,zfin,dl,dist01,dist02
+ & ,dist1,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ if(jinv.eq.0)then
+ dlzn=abs(zfin-zini)
+ else
+ dlzn=max(0.d0,2.d0*depthmaxi-zfin-zini)
+ endif
+ EK=EK0-dlzn*delx0 !kinetic energy when crossing the border
+ if(EK.le.0.d0)then
+ EK=EKn
+#ifdef __CXDEBUG__
+ write(*,*)'Warning : precision problem in propagation (4)'
+ write(*,*) jinv,z1,z2,zini,zfin,dlzn,delx0,EK0,EK,EKn
+#endif
+ endif
+ endif
+ endif
+ endif
+
+ dl=abs(dl)
+ dptl(4)=EK+dptl(5)
+ P=dsqrt(dptl(4)-dptl(5))*dsqrt(dptl(4)+dptl(5))
+ x01=x02
+ y01=y02
+ x1=x2
+ y1=y2
+ t1=t2
+ x02=x01+dl*px0 ! new x in shower frame
+ y02=y01+dl*py0 ! new y in shower frame
+ x2=x1+dl*px ! new x in obs. frame
+ y2=y1+dl*py ! new y in obs. frame
+ t2=t1 + dl * dptl(4) / P !P=beta*E -> beta=P/E
+
+#ifndef __CXCORSIKA__
+ if(axispro)then
+ if(z2.ge.zshmax)then
+ imode=2 !maximum slant depth reached
+ cont=.false.
+ endif
+ endif
+#endif
+ if(h2.ge.0.9999999d0*eatm(mxatm+1)
+ & .or.h2.le.1.0000001d0*HGrd)then
+ imode=2 !top of atmo
+ cont=.false.
+ endif
+
+c last point
+ if(iz.eq.nstep+1.or..not.cont)then
+ iimode=imode
+ rtr2=dsqrt(x2*x2+y2*y2) !new radial distance to obs point
+
+c new cosine and sine of the angles between the obs frame and the particle frame
+ if(rtr2.gt.1.d-20)then
+ sinphiP=y2/rtr2
+ cosphiP=x2/rtr2
+ sintheP=rtr2/(h2+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ ep(1)=px
+ ep(2)=py
+ ep(3)=pz
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !new direction of P in Particle frame
+ dptl(1) = ep(1)*P
+ dptl(2) = ep(2)*P
+ dptl(3) = ep(3)*P
+ dptl(6) = x2
+ dptl(7) = y2
+ dptl(8) = h2
+ dptl(9) = t2
+ dptl(13)= z2
+ dptl(14)= x02
+ dptl(15)= y02
+ dptl(16)= dist02
+ endif
+
+ call cana2(h1,x01,y01,x1,y1,dist01,z1,t1,E1,h2,x02,y02,x2,y2
+ $ ,dist02,z2,t2,dptl(4),px0,py0,pz0,dptl(5),wt,dptl(12),id,iimode)
+
+ E1=dptl(4)
+ if(jinv.eq.1)ct=-ct
+
+ enddo
+
+ endif
+
+ elseif(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !no ionization loss but below cutoff for MC
+ jinv=0 !ct is updated in updateSrc
+ imode=5
+ z2=zsource-0.001d0*min(delzsh,zsource-z1) !to be sure not to count the particle after zsource
+ call updateSlant(z1,z2,zini,zfin,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ endif
+
+ if(go)then
+
+ dl=abs(dl)
+ x02=x01+dl*px0 ! new x in shower frame
+ y02=y01+dl*py0 ! new y in shower frame
+ x2=x1+dl*px ! new x in obs. frame
+ y2=y1+dl*py ! new y in obs. frame
+ t2=t1 + dl * dptl(4) / P
+ rtr2=dsqrt(x2*x2+y2*y2) !new radial distance to obs point
+
+c new cosine and sine of the angles between the obs frame and the particle frame
+ if(rtr2.gt.1.d-20)then
+ sinphiP=y2/rtr2
+ cosphiP=x2/rtr2
+ sintheP=rtr2/(h2+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ ep(1)=px
+ ep(2)=py
+ ep(3)=pz
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !new direction of P in Particle frame
+ dptl(1) = ep(1)*P
+ dptl(2) = ep(2)*P
+ dptl(3) = ep(3)*P
+ dptl(6) = x2
+ dptl(7) = y2
+ dptl(8) = h2
+ dptl(9) = t2
+ dptl(13)= z2
+ dptl(14)= x02
+ dptl(15)= y02
+ dptl(16)= dist02
+
+#ifndef __CXCORSIKA__
+ if(axispro)then
+ if(z2.ge.zshmax)then
+ imode=2 !maximum slant depth reached
+ endif
+ endif
+#endif
+ if(h2.ge.0.9999999d0*eatm(mxatm+1)
+ & .or.h2.le.1.0000001d0*HGrd)then
+ imode=2 !limits
+ endif
+
+ call cana2(h1,x01,y01,x1,y1,dist01,z1,t1,E1,h2,x02,y02,x2,y2
+ $ ,dist02,z2,t2,dptl(4),px0,py0,pz0,dptl(5),wt,dptl(12),id,imode)
+
+#ifdef __CXDEBUG__
+ else
+
+ sz2=zfin
+#endif
+ endif
+
+c store angular information : spacial rotation to get pt=0
+ if(imode.eq.4)then
+ do i=1,3
+ ep(i)=dptl(i)
+ enddo
+ call cxdefrot(ep,s0xs,c0xs,s0s,c0s)
+ elseif(imode.eq.5)then
+c Particle has to be used with different random sequence (or CORSIKA) when last bin of CE is passed or below threshold
+ if((EK.le.egylow.and.z2.ge.zmcl).or.z2.ge.XmaxP)then
+ imode=7
+ else
+ call d2hsource(ns,j,px0*P,py0*P)
+ endif
+ endif
+
+ if(.not.lxfirst)then
+ Xfirst=min(Xfirst,z2)
+ lxfirst=.true.
+ if(imode.eq.4)lXfirstIn=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,'(/7(1x,e13.6),/25x,a/,7(1x,e13.6)/)')
+ & z1i,sz1i,x1i,y1i,h1i,t1i,EKini,' --(z,sz,x,y,h,t,Ek)--> '
+ & ,z2 ,sz2 ,x2 ,y2 ,h2 ,t2 ,EK
+#endif
+
+c stop propagation if time too long
+ if(distMaxi.gt.0)then
+ if(t2.gt.distMaxi)imode=1
+ else
+ if(t2.lt.distMaxi)imode=1
+ endif
+
+
+ 9999 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.3)then
+ write(ifck,'(a,i5,a,i1,$)')' id=',id,' imode=',imode
+ if(imode.eq.1) write(ifck,'(a,$)') ' (disappear (cut off))'
+ if(imode.eq.2) write(ifck,'(a,$)') ' (ground or leave atm)'
+ if(imode.eq.3) write(ifck,'(a,$)') ' (decay)'
+ if(imode.eq.4) write(ifck,'(a,$)') ' (collide)'
+ if(imode.eq.5) write(ifck,'(a,$)') ' (source function)'
+ if(imode.eq.6) write(ifck,'(a,$)') ' (egs)'
+#ifdef __CXCORSIKA__
+ if(imode.eq.7) write(ifck,'(a,$)') ' (corsika)'
+#else
+ if(imode.eq.7) write(ifck,'(a,$)') ' (low energy MC)'
+#endif
+ write(ifck,*) ' decay,coll length:',dld,dli
+ write(ifck,*)
+ endif
+#endif
+
+#ifdef __ANALYSIS__
+ if(np.eq.9.and.imode.eq.2)then
+ igen=int(dptl(12))
+ if(igen.le.ngenmx)then
+ cntgen(0)=cntgen(0)+1d0
+ cntgen(igen)=cntgen(igen)+1d0
+ endif
+ endif
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine updateDist(zini,zfin,dz,z1,z2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,h01,h02,pz0,ct,depthmaxi,radtr,jinv)
+c-----------------------------------------------------------------------
+c update zfin,z2,dl,dist02,dist2 and h2 for given zini,dz,dist01,dist1,h1,
+c pz0,ct,depthmaxi and radtr. Jinv=1 if we change the sign of ct
+c T.pierog, nov 2003 - last update aug. 2005
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision zini,zfin,z1,z2,dl,dist01,dist02,dist1,dist2
+ & ,h1,h2,pz0,ct,radtr,depthmaxi
+ double precision dz,dzs,dz0s,dl0,dl0s,h01,h02,dz0!,heightt
+ integer jinv,jinv0
+
+
+
+ jinv=0
+ dzs=sign(dz,ct)
+ call dz2dl(dzs,dl,h1,h2,radtr,jinv)
+ if(jinv.eq.1)then
+ dist2=dl-dist1
+ zfin=2.d0*depthmaxi-zini-dz
+ else
+ dist2=dist1-sign(dl,ct)
+ zfin=zini+dzs
+ if(abs(dist2).lt.1.d-10)jinv=1
+ endif
+c h01=heightt(dist01,radtr0)
+ if(i1DMC.eq.1)then !depth as projection of slant depth
+ dz0=abs(dzs)*pz0
+ dz0s=dz0*sign(1.d0,dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,jinv0)
+ dz0=sign(dz0s,pz0)
+ z2=z1+dz0 !new slant depth along shower axis
+ dist02=dist01-sign(dl0,pz0)
+ else
+ dl0=dl*pz0
+ dl0s=dl0*sign(1.d0,dphlim0-z1)
+ call dl2dz(dl0s,dz0,h01,h02,abs(dist01),dist02,radtr0)
+ dist02=dist02*sign(1.d0,dist01-sign(1.d-10,pz0))
+ z2=z1+sign(dz0,pz0)
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*)'updateDist',zini,zfin,dz,z1,z2,dl,dist01
+ & ,dist02,dist1,dist2,h1,h2,h01,h02,pz0,ct,depthmaxi,radtr,jinv
+#endif
+
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine updateSlant(zini,zfin,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+c-----------------------------------------------------------------------
+c update sz2,dl,dist02,dist2 and h2 for given zini,zfin,dist01,dist1,h1,
+c pz0,ct,depthmaxi and radtr. Jinv=1 means middle point of its trajectory
+c or ground is reached by the particle.
+c T.pierog, fev. 2005 - last update aug. 2005
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision zini,zfin,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,radtr,h01,h02,dz0,dz0s,dl0
+ & ,dz,dzs,dls,depthmaxi,heightt
+ integer jinv,jinv0
+
+ jinv=0
+ h01=heightt(dist01,radtr0)
+ dz0=zfin-zini !can be + or -
+
+ dz0s=dz0*sign(1.d0,dphlim0-zini) !if zini > depthmaxi0, dz0s=-dz0
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,jinv0)
+ dz0=sign(dz0s,dz0) !dz0s can be updated
+ dl0=sign(dl0,costhi) !dl0 is positive after dz2dl
+ dist02=dist01-dl0
+ zfin=zini+dz0
+
+
+ if(i1DMC.eq.1)then !z2-z1=projection of sz2-sz1
+ dz=abs(dz0)*costhi
+ dzs=dz*sign(1.d0,ct)
+ call dz2dl(dzs,dl,h1,h2,radtr,jinv)
+ dz=dzs
+ sz2=sz1+dz
+ if(jinv.eq.0)then
+ dist2=dist1-sign(dl,ct)
+ if(abs(dist2).lt.1.d-10)jinv=1
+ else
+ sz2=2.d0*depthmaxi-sz2
+ dist2=dl-dist1
+ endif
+ else !dist02-dist01=projection of dist2-dist1
+ dl=dl0*costhi
+ dls=dl*sign(1.d0,ct)
+ call dl2dz(dls,dz,h1,h2,dist1,dist2,radtr)
+ dl=abs(dls)
+ sz2=sz1+sign(dz,ct)
+ if(dist2.lt.0.d0)then
+ sz2=2.d0*depthmaxi-sz2
+ dist2=dl-dist1
+ jinv=1
+ elseif(dist2.lt.1.d-10)then
+ jinv=1
+ endif
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*)'updateSlant',zini,zfin,sz1,sz2,dl
+ & ,dist01,dist02,dist1,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine updateSource(zsource,distso,j,z1,dist01,h01,mc2ce)
+c-----------------------------------------------------------------------
+c return slant depth (zsource) and distance on the shower axis
+c (distso) of the jth bin for given z1,dist01,h01. update mc2ce
+c if necessary.
+c T.pierog, mar. 2005 - last update aug. 2005
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision zsource,distso,z1,dist01,h01,dz0,dz0s,h02,dl0
+ integer j,jinv0
+ logical mc2ce
+
+ zsource=zshmin+delzsh*(j-1)
+ if(zsource.ge.zshmax)then
+ mc2ce=.false.
+ distso=1d30
+ else
+ dz0=zsource-z1
+ dz0s=dz0*sign(1.d0,dphlim0-z1) !if zini > depthmaxi0, dz0s=-dz0
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,jinv0)
+ dz0s=abs(dz0s)
+ if(abs(dz0-dz0s).gt.0.d0)then !dz0s can not be updated
+ mc2ce=.false.
+ distso=1d30
+ else
+ distso=dist01-dl0
+ endif
+ endif
+
+ end
+
+#ifdef __CXCORSIKA__
+c-----------------------------------------------------------------------
+ subroutine updateFlat(x1,y1,h1,h2,dl,px,py,imode)
+c-----------------------------------------------------------------------
+c Update z2,x2,y2,h2,t2 for a particle going from z1,x1,y1,h1,t1 to
+c z2,x2,y2,h2,t2 and crossing HGrd. If so change imode to 2.
+c Only for downward going shower
+c T.pierog, Dec. 2009
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x1,y1,h1,x2,y2,h2,dl,px,py
+ double precision rdist,radh,hini,hfin,auxil
+ integer imode
+
+ x2=x1+dl*px ! new x in obs. frame
+ y2=y1+dl*py ! new y in obs. frame
+ rdist=sqrt(x2*x2+y2*y2)
+ radh=h2+radearth
+ if(radh.gt.rdist)then
+ hfin = sqrt((radh-rdist)*(radh+rdist))-radearth !h in obs frame
+ else
+ hfin = h2
+ endif
+ if(hfin.le.1.0000001d0*HGrd)then
+c Particle cross observation plane, use crossing point as final position
+ imode=2
+ rdist=sqrt(x1*x1+y1*y1)
+ radh=h1+radearth
+ if(radh.gt.rdist)then
+ hini = sqrt((radh-rdist)*(radh+rdist))-radearth !h in obs frame
+ else
+ hini = h1
+ endif
+ auxil = (HGrd-hini)/(hfin-hini)
+ dl=dl*abs(auxil)
+ endif
+
+ end
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine propagation1D(imode,iCEmode) !tp241104 !so110903
+c-----------------------------------------------------------------------
+c select decay or collision mode for current particle in full 1D (pt=0)
+c input: dptl
+c iCEmode = 0 - Pure Cascade Equation
+c = 1 - Hybrid
+c = -1 - Low threshold higher than High threshold : pure MC
+c output: imode = 1 (disappear), 2 (ground), 3 (decay), 4 (collision)
+c 5 (source function) 6 (egs4) 7 (corsika)
+c dptl(1-9),dptl(13) will be updated
+c Shower frame and local frame of particle (where p0x,p0y, and p0z are defines)
+c is defined by z axis pointing to impact point (shower axis) and y axis in the plane
+c defined by z axis and the vertical going through earth center and obs.
+c point (frame is right-handed). Particle always goes along shower axis (pt=0)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension rlmin(3)
+ logical go,cont,mc2ce,ioloss
+ data rlmin /0.843D+02,0.844D+02,0.125D+03/ !nucl, pion, kaon : rlam max for gheisha
+ common /cxexoticdz/dXotic
+ double precision dXotic
+
+
+#ifdef __CXDEBUG__
+ if(isx.eq.3)then
+ write(ifck,'(a,$)')' propagation: '
+ elseif(isx.gt.3)then
+ write(ifck,*)
+ write(ifck,'(a)')' propagation: '
+ endif
+#endif
+c Initial position
+
+ id=nint(dptl(10)) !particle id
+ wt=dptl(11) !particle weight
+ EK=dptl(4)-dptl(5) !kinetic energy
+ ida=abs(id)
+ x1=dptl(6) !x-coordinate
+ y1=dptl(7) !y-coordinate
+ h01=dptl(8) !height, m
+ t1=dptl(9) !time
+ E1=dptl(4) !initial energy
+ z1=dptl(13) !slant depth along shower axis
+ x01=0.d0 !x-coordinate in shower frame
+ y01=0.d0 !y-coordinate in shower frame
+ dist01=dptl(16) !slant distance along shower axis
+ px0=0.d0 !x relative momentum in shower frame and particle frame (the same in 1D)
+ py0=0.d0 !y relative momentum in shower frame and particle frame (the same in 1D)
+ pz0=1.d0 !z relative momentum in shower frame and particle frame (the same in 1D)
+
+ egycut=ehcut !threshold for CE
+ np=0
+ dld=1d30 ! initialize decay length
+ dli=1d30 ! initialize interaction length
+ rzi=0.d0
+ mc2ce=.false. ! if true and E<egycut, particle goes into source
+ ioloss=.false.
+ zmcl=zmchlow
+ egylow=ehlow !low energy MC threshold for CORSIKA instead of source function
+
+ if(ida.eq.14)then
+ np=9
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ zmcl=0d0 !only energy cut for muons (no magnetic field in conex)
+ lXfirstIn=.false. !cannot fix first interaction for muons
+ egylow=emlow !low energy MC threshold
+ ns=7
+ egycut=emcut !threshold for CE
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(ida.eq.1120.or.ida.eq.1220)then
+ np=1
+ B = -1 ! negative means stable
+ mc2ce=.true. ! particle can be used in CE
+ ns=sign(1,id)
+ if(ida.eq.1220)then !neutron
+ ns=sign(6,id)
+ elseif(ionloss.eq.1)then
+ ioloss=.true. !ionization loss
+ endif
+ elseif(ida.eq.120)then
+ np=2
+ B = bdeca(np) ! B=m/c/tau0
+ mc2ce=.true. ! particle can be used in CE
+ ns=2
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(ida.eq.130)then
+ np=3
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=3
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.eq.-20.or.id.eq.-230)then
+ np=4
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=4
+ elseif(id.eq.20.or.id.eq.230)then
+ np=5
+ B = bdeca(np)
+ mc2ce=.true. ! particle can be used in CE
+ ns=5
+ elseif(id.eq.41)then !q-ball
+ np=-1
+ B = -1.d0
+ mc2ce=.false.
+ elseif(id.eq.43)then !magnetic monopole
+ np=-3
+ B = -1.d0
+ mc2ce=.false.
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.eq.10)then ! gamma
+ mc2ce=.false. ! particle can not be used in CE as source
+ lXfirstIn=.false. !cannot fix first interaction for gammas
+ imode=6 ! disappear after one bin
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+ z2=zshmin+delzsh*(j-1) !just for counting
+ z2=z2+0.001d0*min(delzsh,z2-z1) !to be sure to go throught the bin edge
+ id=-10
+ if(EK.ge.enymin.and.lxfirst)
+ $ call cana2(h01,x01,y01,x1,y1,dist01,z1,t1,E1,h01,x01,y01,x1,y1
+ $ ,dist01,z2,t1,dptl(4),px0,py0,pz0,dptl(5),wt/delzsh
+ $ ,dptl(12),id,imode)
+
+ dptl(10)=dble(id)
+ call d2a !send to egs stack after counting
+ goto 9999
+ elseif(id.eq.110)then ! pi0
+ mc2ce=.false. ! particle can not be used in CE as source
+ np=2
+ B= bdeca(6)
+c imode=3 ! decay immediatly (no counting or propagation)
+c call cana2(h01,x01,y01,dist01,z1,t1,E1,h01,x01,y01,dist01,z1,t1,dptl(4)
+c $ ,px0,py0,pz0,dptl(5),wt,dptl(12),id,imode)
+c goto 9999
+ elseif(id.eq.111.or.id.eq.221.or.id.eq.220)then !rho or omega from photonuclear effect
+ imode=3 ! decay immediatly (no counting or propagation)
+ goto 9999
+ elseif(id.eq.-9999)then ! particle from EGS4 to mimic photonuclear int.
+ imode=4 ! interact immediatly (no counting or propagation)
+ if(EK.le.EgyHiLoLim)then !low energy models
+ dptl(10)=sign(120.d0,drangen(dptl(10))-0.5d0) ! use charge pion as projectile
+ elseif(MCModel.eq.9)then !DPMJET
+ dptl(10)=110 ! use pi0 as projectile (as in CORSIKA)
+ elseif(MCModel.eq.4.or.MCModel.eq.5)then !EPOS, SIBYLL
+ dptl(10)=111 ! use rho0 as projectile
+ else
+ dptl(10)=sign(120.d0,drangen(dptl(10))-0.5d0) ! use charge pion as projectile
+ endif
+ goto 9999
+ elseif(ida.eq.2130)then ! lambda
+ np=1 ! same inter length and energy loss as nucleon
+ B = bdeca(8) ! but can decay
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(MCModel.eq.6)then !only decay for QGSJETII (as in CORSIKA)
+ imode=3 ! decay immediatly (no propagation)
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(.not.lXfirstIn)then ! fixed first interaction : propagate until interaction point
+ goto 9999
+ endif
+ endif
+ elseif(id.ge.100.and.mod(id,100).eq.0)then
+ B=-1.d0
+ np=10
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ elseif(id.le.-100.and.mod(id,100).eq.0)then !strangelet
+ B=-1.d0
+ np=-10
+ mc2ce=.false. ! particle can not be used in CE as source
+ if(ionloss.eq.1)ioloss=.true. !ionization loss
+ else
+ write(*,*)'propagate unknown id:',id,' decay !'
+#ifdef __CXDEBUG__
+ write(ifck,*)'propagate unknown id:',id,' decay !'
+#endif
+ imode=3 ! decay immediatly (no propagation)
+ goto 9999
+c stop'propagate: id not recognized. '
+ endif
+c if particle below low cut before ground, source is used for CORSIKA stack (if used)
+#ifndef __CXCORSIKA__
+ if(iCEmode.eq.-1)mc2ce=.false. !no CE because threshold too low
+ if(dptl(12).ge.200d0)mc2ce=.false. !particle coming from had CE should not go back to CE
+#endif
+
+ P=dsqrt(dptl(4)-dptl(5))*dsqrt(dptl(4)+dptl(5))
+ rho=rhoair(h01)
+
+c source depth bin
+
+ if(mc2ce.and.(mode.eq.5.or.mode.eq.8))then
+#ifndef __CXCORSIKA__
+ if(z1.eq.zshmin)then
+ j=1 !for primary particle
+ if(EK.le.egycut)then
+ imode=5
+ call d2hsource(ns,j,px0*P,py0*P)
+ goto 9999
+ endif
+ else
+#endif
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ zsource=zshmin+delzsh*(j-1)
+ if(zsource.ge.zshmax)mc2ce=.false.
+#ifdef __CXDEBUG__
+ if(isx.ge.5)
+ & write(ifck,*)'source bin:',j,zsource,egycut
+#endif
+ else
+ mc2ce=.false. !source function only for hybrid mode
+ zsource=1d30
+ endif
+
+c.....decay ???.........
+ if(B.gt.0.d0)then
+ r=drangen(dummy)
+ dld= -log(r)*dptl(4)/B !s0270603
+ endif
+c.....or collision ???....
+ if(abs(np).lt.10)then
+ npn=1
+ dzi = rlam(np,EK,dptl(5)) !interaction length
+ elseif(id.ge.100.and.mod(id,100).eq.0)then
+ npn=int(id/100)
+ np=npn*10
+ dzi = rlam(np,EK/dble(npn),pmass(7)) !interaction length for nuclei
+ elseif(id.le.-100.and.mod(id,100).eq.0)then
+ npn=int(abs(id)/100)
+ np=-npn*10
+ dzi = rlam(np,EK/dble(npn),pmass(8)) !interaction length for strangelet
+ else
+ stop'propagation: unknown particle. '
+ endif
+
+
+ EK0=EK
+
+ if(.not.lXfirstIn)then !fixed first interaction point
+
+ if(ioloss)then !for charged particle
+ delx0=dedxIonMC(np,EK,rho)
+ if(MCleModel.eq.3.and.EK.le.EgyHiLoLim.and.np.le.3
+ & .and.np.gt.0)then
+ rlamin=rlmin(np) !use tabulation for gheisha
+ else
+ rlamin=dzi !rlam at current energy for others
+ endif
+ delx=delx0
+ EKp=EK
+ 10 drzi= -log(drangen(EKp)) * rlamin
+ EK0=Ekp
+ EKp=max(1.d-5,EKp-delx*drzi)
+ if(abs(np).lt.10)then
+ rlamax=rlam(np,EKp,dptl(5))
+ else
+ rlamax=rlam(np,EKp/dble(npn),pmass(7)) !for nuclei
+ endif
+ rzi=rzi+drzi
+ if(EKp.gt.1.d0)then
+ Pint=rlamin/rlamax !interaction probability
+ if(Pint.lt.drangen(EKp))then
+ delx=dedxIonMC(np,EKp,rho)
+ goto 10
+ endif
+ endif
+ else
+ rzi = -log(drangen(dummy)) * dzi
+ delx0=0.d0
+ endif
+
+ dz0=sign(rzi,dphlim0-z1)
+ call dz2dl(dz0,dl0,h01,h02,radtr0,jinvi)
+ dli=dl0
+
+c..... choose one ............
+ if(dld.gt.dli)then
+ imode=4 ! interaction
+ dl0=dli
+ else
+ imode=3 ! decay
+ dl0=dld
+ endif
+
+ else !fixed first interaction point
+
+ imode=4
+ dld=1d30
+ dli=1d30
+ delx0=0d0
+ dz0=sign(abs(Xfirst-XminP),dphlim0-z1) !propagate directly to Xfirst
+ call dz2dl(dz0,dl0,h01,h02,radtr0,jinvi)
+
+
+ endif
+
+ EKini=EK
+ zimu=z1
+ himu=h01
+ rhoimu=rho
+ d01mu=dist01
+ delxmu=delx0
+ dlin=0.d0
+ go=.false.
+
+ 20 dls=sign(dl0,dphlim0-z1)
+ call dl2dz(dls,dz0,h01,h02,abs(dist01),dist02,radtr0)
+ dist02=dist02*sign(1.d0,dist01-1.d-10)
+ dl0=abs(dls)
+ z2=z1+dz0
+
+ if(dist02.le.0.d0 !check propagation on axis
+ & .and..not.goOutGrd.and.radtr0.le.RadGrd)then
+ z2=1.000000001d0*depthmaxi0
+ imode=2
+ endif
+
+
+ if(z2.gt.1.000001d0*zshmax)then !check propagation on axis
+ imode=2
+ z2=1.000000001d0*zshmax
+ dz0=abs(z2-z1)
+ dz0s=sign(dz0,dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dist02=dist01-dl0
+ endif
+
+
+c slant depth crossed and energy lost
+
+ dzloss=z2-z1
+ dEloss=dzloss*delx0
+C Save total path for exotic primaries
+ dXotic=dzloss
+
+c Muons
+
+
+ if(np.eq.9.and.ioloss)then !begin muon propagation
+ dEmu=0.01d0*EK !if mu lose more than 1 % of his energy, do one more step
+ if(dEloss.ge.dEmu)then
+ imode=3
+ go=.true.
+ delx=dedxionMC(np,EK,rho)
+ dlz=dEmu/delx
+ dz0s=sign(dlz,dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dlz=abs(dz0s)
+ dist02=dist01-dl0
+ z2=z1+dlz
+#ifdef __CXDEBUG__
+ if(isx.ge.4)
+ & write(ifck,*)'muon step:',z1,z2,dist02,dl0,EK,dEmu,dEloss
+#endif
+ dlin=dlin+dl0
+ if(dlin.ge.dli)then
+ imode=4
+ dlz=rzi
+ z2=zimu+dlz
+ dist02=d01mu-dlin
+#ifdef __CXDEBUG__
+ if(isx.ge.5) write(ifck,*)'muon inter. :',dist02,z2,rzi,dlin
+#endif
+ endif
+
+ if(mc2ce.and.z2.ge.zsource.and.EK.le.egycut)then
+ goto 30 !muon will go in source function
+ elseif(z2.ge.zshmax)then !particle reaches the ground
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5) write(ifck,*)'muon lost:',dist02,z2,EK
+#endif
+ imode=2
+ z2=zshmax
+ dz0s=sign(abs(z2-z1),dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dist02=dist01-dl0
+ goto 30
+ elseif(imode.eq.3)then
+ EK=EK-dEmu
+ if(EK.le.enymin)goto 30 !if energy below cutoff, stop propagation here
+ z1=z2
+ dist01=dist02
+ h01=h02
+ rho=rhoair(h01)
+ dl0=-log(drangen(EK))*(EK+pmass(9))/B
+ delx0=delx
+ goto 20
+ else
+ goto 30
+ endif
+ endif
+
+ 30 if(go)then
+ z1=zimu
+ h01=himu
+ rho=rhoimu
+ dist01=d01mu
+ dl0=abs(dist01-dist02)
+ delx0=delxmu
+ dzloss=abs(z2-z1)
+ dEloss=dzloss*delx0
+ EK=EKini
+#ifdef __CXDEBUG__
+ if(isx.ge.5) write(ifck,*)'end muon:',z2,dl0,dEloss,dzloss
+#endif
+ endif
+
+
+ endif !end muon propagation
+
+#ifdef __CXDEBUG__
+ x1i=x1
+ y1i=y1
+ h01i=h01
+ t1i=t1
+ z1i=z1
+#endif
+
+c Ionization loss
+
+ go=.true.
+ dlz=0.d0
+ if(ioloss)then
+ nstep=int(dEloss/(0.01d0*EK)) !lose max 1% of energy by step
+ if(nstep.le.0)then
+ EK0=EK
+ EK=max(1.d-5,EK-dEloss)
+
+ if(EK.le.enymin)then !particle below cut off
+ imode=1
+ dlz=(EK0-enymin)/delx0 !maximum slant depth with energy > enymin
+ z2=z1+dlz
+ Ek=enymin
+ endif
+ if(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !particle could go into source function
+ dlzn=zsource-z1
+ EKn=EK0-dlzn*delx0 !kinetic energy when crossing the border
+ if(EKn.le.egycut.and.EKn.gt.exmin)then !if this energy still below the cutoff
+ imode=5
+ EK=EKn
+ dlz=dlzn-0.001d0*min(delzsh,dlzn) !to be sure not to count the particle after zsource
+ z2=z1+dlz
+ endif
+ endif
+ if(dlz.gt.0.d0)then
+ dz0s=sign(abs(dlz),dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dist02=dist01-dl0
+ endif
+ dl0=abs(dist01-dist02)
+ dptl(4)=EK+dptl(5)
+ P=dsqrt(dptl(4)-dptl(5))*dsqrt(dptl(4)+dptl(5))
+ else
+ go=.false.
+ x2=x1
+ y2=y1
+ h02=h01
+ t2=t1
+ z2=z1
+ delx=delx0
+ dist02=dist01
+ dlz=dzloss/dble(nstep)
+ cont=.true.
+ iz=1
+ iimode=imode
+ if(iimode.le.2)iimode=iimode+2
+ do while (iz.le.nstep.and.cont)
+ iz=iz+1
+ z1=z2
+ h01=h02
+ dist01=dist02
+ EK0=EK
+ EK=max(1.d-5,EK-delx*dlz)
+ if(EK.le.enymin)then
+ imode=1
+ dlz=(EK0-enymin)/delx !maximum slant depth with energy > enymin
+ Ek=enymin
+ cont=.false.
+ else
+ delx0=delx
+ rho=rhoair(h01)
+ delx=dedxIonMC(np,EK,rho)
+ endif
+ 40 z2=z1+dlz
+ if(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !particle could go into source function
+ dlzn=zsource-z1
+ if(dlzn.lt.0.d0)then !particle already pass the bin edge
+ j=int(((z1-1d-9*delzsh)-zshmin)/delzsh)+2 !next CE matrix depth bin
+ zsource=zshmin+delzsh*(j-1)
+ if(zsource.ge.zshmax)mc2ce=.false.
+ if(zsource.gt.z1)goto 40 !test again
+ else
+ EKn=EK0-dlzn*delx0 !kinetic energy when crossing the border
+ if(EKn.le.egycut.and.EKn.gt.exmin)then !if this energy still below the cutoff
+ cont=.false. !stop the loop
+ dlz=dlzn-0.001d0*min(delzsh,dlzn) !to be sure not to count the particle after zsource
+ z2=z1+dlz
+ EK=EKn
+ imode=5
+ endif
+ endif
+ endif
+ dz0s=sign(abs(dlz),dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dist02=dist01-dl0
+ dptl(4)=EK+dptl(5)
+ P=dsqrt(dptl(4)-dptl(5))*dsqrt(dptl(4)+dptl(5))
+ x1=x2
+ y1=y2
+ t1=t2
+ x02=0.d0
+ y02=0.d0
+ x2=dist02*xsaxis
+ y2=dist02*ysaxis
+ t2=t1 + dl0 * dptl(4) / P
+
+ if(z2.ge.zshmax)then
+ imode=2 !maximum slant depth reached
+ cont=.false.
+ endif
+ if(iz.eq.nstep+1.or..not.cont)then
+ iimode=imode
+ dptl(1) = px0*P
+ dptl(2) = py0*P
+ dptl(3) = pz0*P
+ dptl(6) = x2
+ dptl(7) = y2
+ dptl(8) = h02
+ dptl(9) = t2
+ dptl(13)= z2
+ dptl(14)= x02
+ dptl(15)= y02
+ dptl(16)= dist02
+ endif
+
+ call cana2(h01,x01,y01,x1,y1,dist01,z1,t1,E1,h02,x02,y02,x2
+ $ ,y2,dist02,z2,t2,dptl(4),px0,py0,pz0,dptl(5),wt
+ $ ,dptl(12),id,iimode)
+
+ E1=dptl(4)
+ enddo
+
+ endif
+
+ elseif(mc2ce.and.EK.le.egycut.and.z2.ge.zsource)then !no ionization loss but below cutoff for MC
+ imode=5
+ z2=zsource-0.001d0*min(delzsh,zsource-z1) !to be sure not to count the particle after zsource
+ dz=z2-z1
+ dz0s=sign(abs(dz),dphlim0-z1)
+ call dz2dl(dz0s,dl0,h01,h02,radtr0,idum)
+ dist02=dist01-dl0
+
+ endif
+
+ if(go)then
+
+ x02=0.d0
+ y02=0.d0
+ dist=dist02-sign(DistAlt,zsaxis)
+ x2=dist*xsaxis
+ y2=dist*ysaxis
+ t2=t1 + dl0 * dptl(4) / P
+
+ dptl(1) = px0*P
+ dptl(2) = py0*P
+ dptl(3) = pz0*P
+ dptl(6) = x2
+ dptl(7) = y2
+ dptl(8) = h02
+ dptl(9) = t2
+ dptl(13)= z2
+ dptl(14)= x02
+ dptl(15)= y02
+ dptl(16)= dist02
+
+
+ if(z2.ge.zshmax)imode=2 !maximum slant depth reached
+
+ call cana2(h01,x01,y01,x1,y1,dist01,z1,t1,E1,h02,x02,y02,x2,y2
+ $ ,dist02,z2,t2,dptl(4),px0,py0,pz0,dptl(5),wt,dptl(12),id,imode)
+
+ endif
+
+
+ if(imode.eq.5)then
+c Particle has to be used with different random sequence( or CORSIKA) when last bin of CE is past or below threshold
+ if((EK.le.egylow.and.z2.ge.zmcl).or.z2.ge.XmaxP)then
+ imode=7
+ else
+ call d2hsource(ns,j,px0*P,py0*P)
+ endif
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,'(/6(1x,e13.6),/27x,a/,6(1x,e13.6)/)')
+ & z1i,x1i,y1i,h01i,t1i,EKini,'--(z,x,y,h,t,Ek)-->'
+ & ,z2 ,x2 ,y2 ,h02 ,t2 ,EK
+#endif
+
+ if(.not.lxfirst)then
+ Xfirst=min(Xfirst,z2)
+ lxfirst=.true.
+ if(imode.eq.4)lXfirstIn=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+
+ 9999 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.3)then
+ write(ifck,'(a,i5,a,i1,$)')' id=',id,' imode=',imode
+ if(imode.eq.1) write(ifck,'(a,$)') ' (disappear (cut off))'
+ if(imode.eq.2) write(ifck,'(a,$)') ' (ground or leave atm)'
+ if(imode.eq.3) write(ifck,'(a,$)') ' (decay)'
+ if(imode.eq.4) write(ifck,'(a,$)') ' (collide)'
+ if(imode.eq.5) write(ifck,'(a,$)') ' (source function)'
+ if(imode.eq.6) write(ifck,'(a,$)') ' (egs)'
+#ifdef __CXCORSIKA__
+ if(imode.eq.7) write(ifck,'(a,$)') ' (corsika)'
+#else
+ if(imode.eq.7) write(ifck,'(a,$)') ' (low energy MC)'
+#endif
+ write(ifck,*) ' decay,coll length:',dld,dli
+ write(ifck,*)
+ endif
+#endif
+
+#ifdef __ANALYSIS__
+ if(np.eq.9.and.imode.eq.2)then
+ igen=int(dptl(12))
+ if(igen.le.ngenmx)then
+ cntgen(0)=cntgen(0)+1d0
+ cntgen(igen)=cntgen(igen)+1d0
+ endif
+ endif
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine AddProfile(k1,k2,n)
+c-----------------------------------------------------------------------
+c Add XProf to XmeanP and XmeanP2 to plot the mean depth profile
+c if output for all shower, write shower n into the file ifout.
+c After the last shower, write the mean shower.
+c k1 and k2 are the limits for the particle type.
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ parameter (maxbuf=39*8)
+ real a(maxbuf)
+ character*4 cevth
+ equivalence (a(1),cevth)
+#endif
+#endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ etotbal=Einit-etotsta-etotlost-etotsource
+ write(ifck,*)'Last Energy balance (stack, lost, source, bal) :'
+ write(ifck,'(4e16.8)')etotsta,etotlost,etotsource,etotbal
+ if(abs(etotbal/Einit).gt.1.d-3)write(ifck,*)'Balance wrong !'
+ endif
+#endif
+ if(iwrt.ne.0)then
+ if(iXmax.eq.1)then
+ if(k2.le.2)then
+ call Xmax_fit(0,0,n) !fit Xmax_mean for all leptons
+ elseif(k1.ge.3)then
+ call Xmax_fit(3,4,n) !fit Xmax_mean for all hadrons ans muons
+ else
+ call Xmax_fit(0,0,n) !fit Xmax_mean for all charged
+ call Xmax_fit(3,4,n) !fit Xmax_mean for all hadrons and muons
+ endif
+ elseif(iXmax.eq.2)then
+ call Xmax_fit(k1,k2,n) !fit Xmax_mean for all
+ endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ do 1 i=1,maxbuf
+ 1 a(i)=0.
+ cevth='EVTE'
+ a(2)=float(n)
+ do 10 i=1,6
+ 10 a(255+i)=sngl(XmaxShow(4,i))
+ a(262)=sngl(XmaxShow(2,0))
+ call wrida(a)
+#endif
+#if __MC3D__ || __CXLATCE__
+ do ip=0,4
+ SD1000m(ip)=SD1000m(ip)+SD1000(ip)
+ enddo
+#endif
+#endif
+
+c Sum Profile
+ do iz=1,musz
+ XdMuMean(iz)=XdMuMean(iz)+XdMu(iz)
+ XdMuMean2(iz)=XdMuMean2(iz)+XdMu(iz)**2
+ enddo
+ do ip=k1,k2
+ do ic=1,mxExpro
+ do iz=1,musz
+ XmeanP(iz,ic,ip)=XmeanP(iz,ic,ip)+XProf(iz,ic,ip)
+ XmeanP2(iz,ic,ip)=XmeanP2(iz,ic,ip)+XProf(iz,ic,ip)**2
+ enddo
+ enddo
+ enddo
+c print *,'nmu',XProf(101,1,3) !?????????????????
+c if(XProf(musz,1,3).le.100.d0)stop
+ if(iwrt.ge.2)then
+ do ip=1,4
+ do iz=1,musz
+ Ebalan1(iz,ip)=Ebalan1(iz,ip)+Ebalan(iz,ip)
+ Ebalan2(iz,ip)=Ebalan2(iz,ip)+Ebalan(iz,ip)**2
+ enddo
+ enddo
+ do ip=0,k2
+ do iz=1,musz
+ Edepo1(iz,ip)=Edepo1(iz,ip)+Edepo(iz,ip)
+ Edepo2(iz,ip)=Edepo2(iz,ip)+Edepo(iz,ip)**2
+ enddo
+ enddo
+ endif
+
+ if(ifout.ne.0)then
+ if(iwrt.eq.2)call depthprofile(k1,k2,n) !write individual shower profile
+ if(n.eq.nshower)call depthprofile(k1,k2,0) !write mean shower profile at the end
+ endif
+
+ endif
+
+#ifdef __ANALYSIS__
+#if __MC3D__ || __CXLATCE__
+ do ir=1,numir
+ do jz=1,maxjz
+ do in=1,maxin
+ yieldr(in,jz,ir)=yieldr(in,jz,ir)+yieldr1(in,jz,ir)
+ yieldr2(in,jz,ir)=yieldr2(in,jz,ir)+yieldr1(in,jz,ir)**2
+#ifdef __CXLATCE__
+ yieldrt(in,jz,ir)=yieldrt(in,jz,ir)+yieldrt1(in,jz,ir)
+ yieldrt2(in,jz,ir)=yieldrt2(in,jz,ir)+yieldrt1(in,jz,ir)**2
+#endif
+ enddo
+ enddo
+ enddo
+#endif
+#endif
+
+c Close stack at the end of the shower
+ close(unit=ifsa,status='delete')
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine OpenConexFiles
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+ logical tmpthn,tmpcrv,tmpsnt,tmpstk,tmppre
+ character*500 DSN
+#endif
+#endif
+
+c Histo file
+ if(nfnho.gt.1)then
+ open(ifho,file=fnho(1:nfnho),status='unknown')
+#ifdef __CXSUB__
+c no default histo file
+#else
+ elseif(ifho.gt.0)then
+ fnho='zzz.histo '
+ nfnho=index(fnho,' ')-1
+ open(ifho,file=fnho(1:nfnho),status='unknown')
+#endif
+ endif
+
+c Data file
+#ifdef __CXSUB__
+c no data file (given from outside)
+#else
+ if(nfnda.gt.1)then
+ open(ifda,file=fnda(1:nfnda),status='unknown')
+ elseif(ifda.gt.0)then
+ fnda='zzz.data '
+ nfnda=index(fnda,' ')-1
+ open(ifda,file=fnda(1:nfnda),status='unknown')
+ endif
+#endif
+c Check file
+ if(nfnck.gt.1)then
+ open(ifck,file=fnck(1:nfnck),status='unknown')
+#ifdef __CXSUB__
+c no default check file
+#else
+ elseif(ifck.gt.0)then
+ fnck='zzz.check '
+ nfnck=index(fnck,' ')-1
+ open(ifck,file=fnck(1:nfnck),status='unknown')
+#endif
+ endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+#ifdef __COAST__
+c ROOT file
+ if(ifrt.eq.0)then
+ fnrt='zzz'
+ nfnrt=index(fnrt,' ')-1
+ endif
+ tmpthn = .true.
+ tmpcrv = .true.
+ tmpsnt = .true.
+ tmpstk = .true.
+ tmppre = .true.
+ if(nfnrt.le.499)then
+ DSN=fnrt(1:nfnrt)
+ else
+ DSN=fnrt(1:499)
+ write(*,*)'Warning, truncated name for ROOT output file !'
+ endif
+ call inida( DSN,tmpthn,tmpcrv,tmpsnt,tmpstk,tmppre)
+c write(*,*)'ROOT output file : ', DSN(1:nfnrt),'.root'
+#endif
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameConexFiles
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character word*500
+ logical go
+
+ go=.false.
+ call getw(word)
+ if(word.eq.'wle')then
+ call getw(fnwle)
+ nfnwle=index(fnwle,' ')-1 !length of wle-file name
+ inquire(file=fnwle(1:nfnwle),exist=go)
+ if(go)ifwle=1
+ elseif(word.eq.'whe')then
+ call getw(fnwhe)
+ nfnwhe=index(fnwhe,' ')-1 !length of whe-file name
+ inquire(file=fnwhe(1:nfnwhe),exist=go)
+ if(go)ifwhe=1
+ elseif(word.eq.'p2le')then
+ call getw(fnp2le)
+ nfnp2le=index(fnp2le,' ')-1 !length of p2le-file name
+ inquire(file=fnp2le(1:nfnp2le),exist=go)
+ if(go)ifp2le=1
+ elseif(word.eq.'p2he')then
+ call getw(fnp2he)
+ nfnp2he=index(fnp2he,' ')-1 !length of p2he-file name
+ inquire(file=fnp2he(1:nfnp2he),exist=go)
+ if(go)ifp2he=1
+ elseif(word.eq.'p2d')then
+ call getw(fnp2d)
+ nfnp2d=index(fnp2d,' ')-1 !length of p2d-file name
+ inquire(file=fnp2d(1:nfnp2d),exist=go)
+ if(go)ifp2d=1
+c elseif(word.eq.'p4le')then
+c call getw(fnp4le)
+c nfnp4le=index(fnp4le,' ')-1 !length of p4le-file name
+c inquire(file=fnp4le(1:nfnp4le),exist=go)
+c if(go)ifp4le=1
+c elseif(word.eq.'p4he')then
+c call getw(fnp4he)
+c nfnp4he=index(fnp4he,' ')-1 !length of p4he-file name
+c inquire(file=fnp4he(1:nfnp4he),exist=go)
+c if(go)ifp4he=1
+c elseif(word.eq.'p4d')then
+c call getw(fnp4d)
+c nfnp4d=index(fnp4d,' ')-1 !length of p4d-file name
+c inquire(file=fnp4d(1:nfnp4d),exist=go)
+c if(go)ifp4d=1
+ elseif(word.eq.'dkz')then
+ call getw(fndkz)
+ nfndkz=index(fndkz,' ')-1 !length of dkz-file name
+ inquire(file=fndkz(1:nfndkz),exist=go)
+ if(go)ifdkz=1
+ elseif(word.eq.'dkl')then
+ call getw(fndkl)
+ nfndkl=index(fndkl,' ')-1 !length of dkl-file name
+ inquire(file=fndkl(1:nfndkl),exist=go)
+ if(go)ifdkl=1
+ elseif(word.eq.'dks')then
+ call getw(fndks)
+ nfndks=index(fndks,' ')-1 !length of dks-file name
+ inquire(file=fndks(1:nfndks),exist=go)
+ if(go)ifdks=1
+ elseif(word.eq.'dkm')then
+ call getw(fndkm)
+ nfndkm=index(fndkm,' ')-1 !length of dkm-file name
+ inquire(file=fndkm(1:nfndkm),exist=go)
+ if(go)ifdkm=1
+ elseif(word.eq.'dke')then
+ call getw(fndke)
+ nfndke=index(fndke,' ')-1 !length of dke-file name
+ inquire(file=fndke(1:nfndke),exist=go)
+ if(go)ifdke=1
+ elseif(word.eq.'dkn')then
+ call getw(fndkn)
+ nfndkn=index(fndkn,' ')-1 !length of dkn-file name
+ inquire(file=fndkn(1:nfndkn),exist=go)
+ if(go)ifdkn=1
+ elseif(word.eq.'dkg')then
+ call getw(fndkg)
+ nfndkg=index(fndkg,' ')-1 !length of dkg-file name
+ inquire(file=fndkg(1:nfndkg),exist=go)
+ if(go)ifdkg=1
+ elseif(word.eq.'emcs')then
+ call getw(fnemcs)
+ nfnemcs=index(fnemcs,' ')-1 !length of EM cross section-file name
+ if(nfnemcs.gt.1)ifemcs=1
+ elseif(word.eq.'histo')then
+ call getw(fnho)
+ nfnho=index(fnho,' ')-1 !length of histo-file name
+ ifho=35
+ elseif(word.eq.'check')then
+ call getw(fnck)
+ nfnck=index(fnck,' ')-1 !length of check-file name
+ ifck=36
+ elseif(word.eq.'data')then
+ call getw(fnda)
+ nfnda=index(fnda,' ')-1 !length of data-file name
+ ifda=37
+ elseif(word.eq.'root')then
+ call getw(fnrt)
+ nfnrt=index(fnrt,' ')-1 !length of root-file name
+ ifrt=99
+ else
+ stop'unknown filetype for Conex'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameNexusFiles
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ character*500 word
+ call getw(word)
+ if(word.eq.'initl')then
+ call getw(xsfnii)
+ nxsfnii=index(xsfnii,' ')-1 !length of initl-file name
+ elseif(word.eq.'inidi')then
+ call getw(xsfnid)
+ nxsfnid=index(xsfnid,' ')-1 !length of inidi-file name
+ elseif(word.eq.'iniev')then
+ call getw(xsfnie)
+ nxsfnie=index(xsfnie,' ')-1 !length of iniev-file name
+ elseif(word.eq.'inirj')then
+ call getw(xsfnrj)
+ nxsfnrj=index(xsfnrj,' ')-1 !length of inirj-file name
+ elseif(word.eq.'inics')then
+ call getw(xsfncs)
+ nxsfncs=index(xsfncs,' ')-1 !length of inics-file name
+ elseif(word.eq.'inihy')then
+ call getw(xsfnhy)
+ nxsfnhy=index(xsfnhy,' ')-1 !length of inihy-file name
+ elseif(word.eq.'check')then
+ call getw(xsfnch)
+ nxsfnch=index(xsfnch,' ')-1 !length of check-file name
+ else
+ stop'unknown filetype for neXus/EPOS'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameQGSJetFiles
+c-----------------------------------------------------------------------
+ character*500 fndat,fnncs
+ common/qgsfname/ fndat, fnncs, ifdat, ifncs
+ common/qgsnfname/ nfndat, nfnncs
+ character*500 word
+ call getw(word)
+ if(word.eq.'dat')then
+ call getw(fndat)
+ nfndat=index(fndat,' ')-1 !length of qgsdat01-file name
+ if(nfndat.gt.1)ifdat=1
+ elseif(word.eq.'ncs')then
+ call getw(fnncs)
+ nfnncs=index(fnncs,' ')-1 !length of sectnu-file name
+ if(nfnncs.gt.1)ifncs=2
+ else
+ stop'unknown filetype for QGSJet'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameQGSJetIIFiles
+c-----------------------------------------------------------------------
+ character*500 fnIIdat,fnIIncs
+ common/qgsIIfname/fnIIdat, fnIIncs, ifIIdat, ifIIncs
+ common/qgsIInfname/ nfnIIdat, nfnIIncs
+ character*500 word
+ call getw(word)
+ if(word.eq.'dat')then
+ call getw(fnIIdat)
+ nfnIIdat=index(fnIIdat,' ')-1 !length of qgsdat01-file name
+ if(nfnIIdat.gt.1)ifIIdat=1
+ elseif(word.eq.'ncs')then
+ call getw(fnIIncs)
+ nfnIIncs=index(fnIIncs,' ')-1 !length of sectnu-file name
+ if(nfnIIncs.gt.1)ifIIncs=2
+ else
+ stop'unknown filetype for QGSJetII'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameEGSFiles
+c-----------------------------------------------------------------------
+ character*500 fegsdat,fegsout
+ common/egsfname/ fegsdat, fegsout, ifegsdat, ifegsout
+ common/egsnfname/ nfegsdat, nfegsout
+ character*500 word
+ call getw(word)
+ if(word.eq.'dat')then
+ call getw(fegsdat)
+ nfegsdat=index(fegsdat,' ')-1 !length of egs4.dat-file name
+ if(nfegsdat.gt.1)ifegsdat=1
+ elseif(word.eq.'out')then
+ call getw(fegsout)
+ nfegsout=index(fegsout,' ')-1 !length of egs4.out-file name
+ if(nfegsout.gt.1)ifegsout=1
+ else
+ stop'unknown filetype for EGS4'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameURQMDFiles
+c-----------------------------------------------------------------------
+ character*500 furqdat
+ common/urqfname/ furqdat, ifurqdat, nfurqdat
+ character*500 word
+ call getw(word)
+ if(word.eq.'dat')then
+ call getw(furqdat)
+ nfurqdat=index(furqdat,' ')-1 !length of egs4.dat-file name
+ if(nfurqdat.gt.1)ifurqdat=1
+ else
+ stop'unknown filetype for URQMD'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine NameDPMJETPath
+c-----------------------------------------------------------------------
+cdh datadir for path to the data sets to be read in by dpmjet/phojet
+ implicit none
+ COMMON /DATADIR/ DATADIR
+ CHARACTER*132 DATADIR
+ integer nfdpmdat
+ character*500 word
+ call getw(word)
+ if(word.eq.'path')then
+ call getw(DATADIR)
+ nfdpmdat=index(DATADIR,' ')-1 !length of DATADIR-path name
+ if(nfdpmdat.le.0)stop'no path for DPMJET'
+ else
+ stop'unknown filetype for DPMJET'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ConexOutput
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character type*4
+ character word*500
+ call getw(word)
+ if(word.eq.'none')then
+ ifout=0
+ lheader=.false.
+ elseif(word.eq.'histo')then
+ ifout=ifho
+ elseif(word.eq.'data'.and.ifda.gt.0)then
+ ifout=ifda
+ else
+ lheader=.false.
+ write(*,'(77a1/a1,21x,a,22x,a1/77a1)')
+ & ('#',l=1,78),'Stop : output file not defined !',('#',l=1,78)
+ stop
+ endif
+
+ call getw(word)
+ if(word.eq.'mean')then
+ iwrt=1
+ type='mean'
+ elseif(word.eq.'all')then
+ iwrt=2
+ type='all '
+ elseif(word.eq.'engy')then
+ iwrt=3
+ type='engy'
+ else
+ write(*,'(77a1/a1,17x,a,17x,a1/77a1)')
+ & ('#',l=1,78),'Stop : output (mean or all) not defined !'
+ &,('#',l=1,78)
+ stop
+ endif
+
+ if(ifout.ne.0)then
+ ifo=6
+ call CXPRTIME(ifout)
+ write(ifout,'(77a1/a,18x,a,a4,a,18x,a1/a,a/a2
+ * ,29x,a10,f6.3,a3,26x,a1/a,15x,a,15x,a1/a
+ * ,11x,a,11x,a1/a,20x,a,20x,a1/77a1)')
+ *'!',('#',l=1,76),'!#','CONEX RUN : output of ',type,' X profiles '
+ *,'#','!# -- T.PIEROG,R.ENGEL,N.N.KALMYKOV,S.S.OSTAPCHENKO,'
+ *,'K.WERNER -- 03/2005 -- #'
+ *,'!#','-- version',dble(ivers)/1000.d0,' --','#'
+ *,'!# ','Paper to be cited if you use this program :','#'
+ *,'!# ','Bergmann et al., Astropart. Phys. 26, 420-432, 2007','#'
+ *,'!# ','e-Print Archive: astro-ph/0606564','#'
+ *,'!',('#',l=1,76)
+ write(ifout,'(a19,3i11)')'! 1st Random seed :',iseed(1,1)
+ * ,iseed(2,1),iseed(3,1)
+ write(ifout,'(a19,3i11)')'! 2nd Random seed :',iseed(1,2)
+ * ,iseed(2,2),iseed(3,2)
+ lheader=.true. !to allow writing commands from .optns file in output file
+ endif
+ if(ifout.ne.ifda.and.ifda.gt.0)then
+ call CXPRTIME(ifda)
+ write(ifda,'(77a1/a,18x,a,a4,a,18x,a1/a,a/a2
+ * ,29x,a10,f6.3,a3,26x,a1/a,15x,a,15x,a1/a
+ * ,11x,a,11x,a1/a,20x,a,20x,a1/77a1)')
+ *'!',('#',l=1,76),'!#','CONEX RUN : output of ',type,' X profiles '
+ *,'#','!# -- T.PIEROG,R.ENGEL,N.N.KALMYKOV,S.S.OSTAPCHENKO,'
+ *,'K.WERNER -- 03/2005 -- #'
+ *,'!#','-- version',dble(ivers)/1000.d0,' --','#'
+ *,'!# ','Paper to be cited if you use this program :','#'
+ *,'!# ','Bergmann et al., Astropart. Phys. 26, 420-432, 2007','#'
+ *,'!# ','e-Print Archive: astro-ph/0606564','#'
+ *,'!',('#',l=1,76)
+ write(ifda,'(a19,3i11)')'! 1st Random seed :',iseed(1,1)
+ * ,iseed(2,1),iseed(3,1)
+ write(ifda,'(a19,3i11)')'! 2nd Random seed :',iseed(1,2)
+ * ,iseed(2,2),iseed(3,2)
+ endif
+
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ConexInput
+c-----------------------------------------------------------------------
+c Define the input file to get a particle list from another program.
+c (all particles in on shower axis at zshmin)
+c Format of the file (ASCII) :
+c 1st line : number of particle in the list and injection point
+c nth lint : id (PDG code, integer) PX PY PZ Etot (GeV, float)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ call getw(fninput)
+ nfninput=index(fninput,' ')-1 !length of input-file name
+ if(nfninput.gt.0)ifinput=23
+ return
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine SetConexParameters
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ character word*500
+ call getw(word)
+
+c Main random number sequence for CONEX MC and CE
+ if(word.eq.'iseed(1)') iseed(1,1)=nint(getvalue()) !seed for rmmaq (from Corsika)
+ if(word.eq.'iseed(2)') iseed(2,1)=nint(getvalue()) !number of call (below the billion)
+ if(word.eq.'iseed(3)') iseed(3,1)=nint(getvalue()) !number of billion of call
+c Second random number sequence for low energy MC
+ if(word.eq.'iseedl(1)') iseed(1,2)=nint(getvalue()) !seed for rmmaq (from Corsika)
+ if(word.eq.'iseedl(2)') iseed(2,2)=nint(getvalue()) !number of call (below the billion)
+ if(word.eq.'iseedl(3)') iseed(3,2)=nint(getvalue()) !number of billion of call
+ if(word.eq.'minE') minE=nint(getvalue()) !first energy bin in EM CE
+ if(word.eq.'emin') emin=getvalue() !minimum energy bin in EM calculations
+
+c basics
+
+ if(word.eq.'mode') mode=nint(getvalue())
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ if(word.eq.'zshmin') zshmin=getvalue()
+#endif
+ if(word.eq.'zshmax') zshmax=getvalue()
+ if(word.eq.'delzsh') delzsh=getvalue()
+ if(word.eq.'irdelz') irdelz=nint(getvalue())
+ if(word.eq.'enymin') enymin=getvalue()
+ if(word.eq.'enymax') enymax=getvalue()
+ if(word.eq.'decade') decade=getvalue()
+ if(word.eq.'emdecade')emdecade=getvalue()
+ if(word.eq.'eprima') eprima=getvalue()
+ if(word.eq.'thetas') thetas=getvalue()
+ if(word.eq.'phisho') phisho=getvalue()
+ if(word.eq.'hground')hground=getvalue()
+ if(word.eq.'altitude')altitude=getvalue()
+ if(word.eq.'latitude')latitude=getvalue()
+ if(word.eq.'longitude')longitude=getvalue()
+ if(word.eq.'year') year=real(getvalue())
+ if(word.eq.'fehcut') fehcut=getvalue()
+ if(word.eq.'femcut') femcut=getvalue()
+ if(word.eq.'feecut') feecut=getvalue()
+ if(word.eq.'ehcut') ehcut=getvalue()
+ if(word.eq.'eecut') eecut=getvalue()
+ if(word.eq.'epcut') epcut=getvalue()
+ if(word.eq.'emcut') emcut=getvalue()
+ if(word.eq.'ehlow') ehlowi=getvalue()
+ if(word.eq.'eelow') eelowi=getvalue()
+ if(word.eq.'emlow') emlowi=getvalue()
+ if(word.eq.'fwhmax') fwhmax=getvalue()
+ if(word.eq.'fwemax') fwemax=getvalue()
+ if(word.eq.'fwmmax') fwmmax=getvalue()
+ if(word.eq.'wshmax') wshmax=getvalue()
+ if(word.eq.'wsemax') wsemax=getvalue()
+ if(word.eq.'wsmmax') wsmmax=getvalue()
+ if(word.eq.'whmax') whmax=getvalue()
+ if(word.eq.'wtmax') wtmax=getvalue()
+ if(word.eq.'zshlow') zshlow=getvalue()
+ if(word.eq.'nshower')nshower=nint(getvalue())
+ if(word.eq.'mshow') mshow=nint(getvalue())
+ if(word.eq.'mshowegs')mshowEGS=nint(getvalue())
+ if(word.eq.'i1DMC') i1DMC=nint(getvalue())
+ if(word.eq.'i1DEM') i1DEM=nint(getvalue())
+ if(word.eq.'imscat') imscat=nint(getvalue())
+ if(word.eq.'iphonu') iphonu=nint(getvalue())
+#ifdef __MODEL__
+ if(word.eq.'ilowegy')idummy=nint(getvalue())
+#else
+ if(word.eq.'ilowegy')ilowegy=nint(getvalue())
+#endif
+ if(word.eq.'ionloss')ionloss=nint(getvalue())
+ if(word.eq.'hilowegy')EgyHiLoLim=getvalue()
+ if(word.eq.'ilpmeff')ilpmeffect=nint(getvalue())
+ if(word.eq.'iothin') iothin=nint(getvalue())
+ if(word.eq.'thin') thin=getvalue()
+ if(word.eq.'ihthin') ihthin=nint(getvalue())
+ if(word.eq.'hthin') hthin=getvalue()
+ if(word.eq.'istern') istern=nint(getvalue())
+ if(word.eq.'ifragm') ifragm=nint(getvalue())
+ if(word.eq.'imuint') iMuInt=nint(getvalue())
+ if(word.eq.'imuscat')iMuScat=nint(getvalue())
+ if(word.eq.'ilatce') iLatCE=nint(getvalue())
+ if(word.eq.'imagne') iMagne=nint(getvalue())
+#ifdef __PRESHOW__
+ if(word.eq.'ipreshow')ipreshow=nint(getvalue())
+#endif
+c moments
+
+c if(word.eq.'muso') muso=nint(getvalue())
+
+c analysis
+
+#ifdef __ANALYSIS__
+ if(word.eq.'numiz') numiz=nint(getvalue())
+ if(word.eq.'zamin') zamin=getvalue()
+ if(word.eq.'zamax') zamax=getvalue()
+ if(word.eq.'izfirst')izfirst=nint(getvalue())
+ if(word.eq.'modz') modz=nint(getvalue())
+ if(word.eq.'eamin1') eamin(1)=getvalue()
+ if(word.eq.'eamax1') eamax(1)=getvalue()
+ if(word.eq.'eamin2') eamin(2)=getvalue()
+ if(word.eq.'eamax2') eamax(2)=getvalue()
+ if(word.eq.'tamin') tamin=getvalue()
+ if(word.eq.'tamax') tamax=getvalue()
+ if(word.eq.'numie') numie=nint(getvalue())
+#if __MC3D__ || __CXLATCE__
+ if(word.eq.'ramin') ramin=getvalue()
+ if(word.eq.'ramax') ramax=getvalue()
+ if(word.eq.'numir') numir=nint(getvalue())
+ if(word.eq.'irfirst')irfirst=nint(getvalue())
+ if(word.eq.'modr') modr=nint(getvalue())
+ if(word.eq.'xamin1') xamin(1)=getvalue()
+ if(word.eq.'xamax1') xamax(1)=getvalue()
+ if(word.eq.'numix1') numix(1)=nint(getvalue())
+ if(word.eq.'xamin2') xamin(2)=getvalue()
+ if(word.eq.'xamax2') xamax(2)=getvalue()
+ if(word.eq.'numix2') numix(2)=nint(getvalue())
+ if(word.eq.'xamin3') xamin(3)=getvalue()
+ if(word.eq.'xamax3') xamax(3)=getvalue()
+ if(word.eq.'numix3') numix(3)=nint(getvalue())
+ if(word.eq.'xamin4') xamin(4)=getvalue()
+ if(word.eq.'xamax4') xamax(4)=getvalue()
+ if(word.eq.'numix4') numix(4)=nint(getvalue())
+ if(word.eq.'xamin5') xamin(5)=getvalue()
+ if(word.eq.'xamax5') xamax(5)=getvalue()
+ if(word.eq.'numix5') numix(5)=nint(getvalue())
+ if(word.eq.'iefirst')iefirst=nint(getvalue())
+ if(word.eq.'moden') moden=nint(getvalue())
+#endif
+ if(word.eq.'modk') modk=nint(getvalue())
+ if(word.eq.'kfirst') kfirst=nint(getvalue())
+ if(word.eq.'kfirsth')kfirsth=nint(getvalue())
+ if(word.eq.'modkh') modkh=nint(getvalue())
+#endif
+
+c output
+#if !__CXCORSIKA__ && !__CORSIKA8__
+ if(word.eq.'xminp') XminP=getvalue()
+#endif
+ if(word.eq.'xmaxp') XmaxP=getvalue()
+ if(word.eq.'xminslant') XminSlant=getvalue()
+ if(word.eq.'emcut1') EMCutP(1)=getvalue()
+ if(word.eq.'hacut1') HaCutP(1)=getvalue()
+ if(mxExpro.ge.2)then
+ idx=2
+ if(word.eq.'emcut2') EMCutP(idx)=getvalue()
+ if(word.eq.'hacut2') HaCutP(idx)=getvalue()
+ if(mxExpro.ge.3)then
+ idx=3
+ if(word.eq.'emcut3') EMCutP(idx)=getvalue()
+ if(word.eq.'hacut3') HaCutP(idx)=getvalue()
+ endif
+ endif
+ if(word.eq.'ixmax') iXmax=nint(getvalue())
+ if(word.eq.'ivers') ivers=nint(getvalue())
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine print
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character word*500
+ call getw(word)
+ if(word.eq.'*')then
+ nisx=0
+ isx=nint(getvalue())
+ else
+ nisx=nisx+1
+ subisx(nisx)=word
+ isxsub(nisx)=nint(getvalue())
+ endif
+
+ end
+
+
+
+
+c-----------------------------------------------------------------------
+ subroutine PrintCheck
+c-----------------------------------------------------------------------
+c Command to define the output of the check file
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character word*500
+ call getw(word)
+ if(word.eq.'screen')ifck=6
+ if(word.eq.'file'.and.nfnck.gt.1)ifck=36
+ if(word.ne.'screen'.and.word.ne.'file')
+ *write(6,'(a)')'invalid optionin PrintCheck; command ignored'
+ end
+c Electro-magnetic cascade routines
+c (created by N. Kalmykov; updated by S. Ostapchenko and T. Pierog)
+c last modification: 28.06.17 correction for energy deposit by T. Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+c---------------------------------------------------------------------------
+ subroutine IniElePhoSource !so110204
+c---------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+
+ imaxE0=1 !maximum used energy bin in the source
+ jminZ0=maxZ !minimum used depth bin in the source
+ do k=1, maximumZ
+ do j=1, maximumE
+ SFE(j,k)=0.0D0
+ SFG(j,k)=0.0D0
+ SFP(j,k)=0.0D0
+ enddo
+ enddo
+ do j=1, maximumE
+ do np=1, 3
+ SF2HAD(np,j)=0.0D0
+ enddo
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+
+
+ do ip=1,3
+ do k=1, maximumZ
+ do j=mine, maxe
+ do ialpha=0, n4mreal-1 !return to start position
+ source3d(ialpha,j,k,ip)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+
+#endif
+
+ return
+ end
+
+c-------------------------------------------------------------------------
+ subroutine ConvPartLept(Eparti,Zpart,Wpart,id) !so110204
+c-------------------------------------------------------------------------
+c ConvPartLept - form initial conditions for e/m cascade
+c called by AUSGAB (in egs4_conex)
+c Epart -lepton kinetic energy,
+c Zpart -lepton depth,
+c Wpart -lepton weight,
+c id -lepton id ( 0 - gamma, -1 - e-, +1 - e+ )
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+#include "conex.h"
+ logical go
+
+ go=.false.
+ Epart=Eparti
+
+c Each particle of energy Epart is splitted between two e-bins with weights
+c appp1, appp2 ( appp1 + appp2 = 1, E_i * appp1 + E_(i+1) * appp2 = Epart)
+ if(Epart.gt.Eo.and.Zpart.lt.ZZEM(maxZ))then
+ i=min(int(1.d0+log10(Epart/Eo)*emdecade),maxE-1)
+ appp1=(eeEM(i+1)-Epart)/(eeEM(i+1)-eeEM(i))
+ appp2=1.d0-appp1
+ if(appp1.lt.-1.d-10.or.appp2.lt.-1.d-10
+ * .or.appp1.gt.1.000000001d0.or.appp2.gt.1.000000001d0)then
+ write(*,*)'appp-lept',i,eeEM(i),epart,eeEM(i+1),appp1,appp2
+ * ,zpart,id
+ appp1=max(0.d0,appp1)
+ appp2=max(0.d0,appp2)
+ endif
+
+ imaxE0=max(imaxE0,i+1)
+
+ if(Zpart.le.ZZo)then
+ j=1
+ else
+ j=int((Zpart-ZZo)/dZZ)+2 !correspond to the next bin (tp171203)
+ if(j.gt.maxZ)return
+ endif
+
+ jminZ0=min(jminZ0,j)
+
+ if(id.eq.0)then !gammas
+ SFG(i,j)=SFG(i,j) + Wpart*appp1
+ SFG(i+1,j)=SFG(i+1,j) + Wpart*appp2
+ elseif(id.eq.-1)then !e-
+ SFE(i,j)=SFE(i,j) + Wpart*appp1
+ SFE(i+1,j)=SFE(i+1,j) + Wpart*appp2
+ elseif(id.eq.1)then !e+
+ SFP(i,j)=SFP(i,j) + Wpart*appp1
+ SFP(i+1,j)=SFP(i+1,j) + Wpart*appp2
+ else
+ go=.true.
+ endif
+ elseif(Eo.gt.emin.and.Zpart.lt.ZZEM(maxZ))then
+ go=.true.
+ endif
+ if(go.and.iwrt.ge.2)then
+ if(id.eq.1)Epart=Epart+2.d0*amc2 !to count properly the rest mass of e-
+ Ebal=Epart
+ imode=1
+ call Profana(Zpart-0.1d0*dzHa,zshmax,Ebal,Epart
+ & ,Wpart,999,imode) !count it for energy depo
+ etotsource=etotsource-ebal*Wpart
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)
+ * write (ifck,'(a,5(i6),2e13.4)') 'ConvPartLept: added particle :'
+ * ,i,j,id,imaxE0,jminZ0,eeem(i),eeem(imaxE0)
+#endif
+
+ return
+ end
+
+c-------------------------------------------------------------------------
+ subroutine ConvHaEM(ih,j,Wpart,id) !tp140205
+c-------------------------------------------------------------------------
+c ConvHaEM - form initial conditions for e/m cascade from hadronic cascade
+c called by HadronCascade (in conex-had)
+c ih -hadronic kinetic energy bin,
+c j -lepton depth bin,
+c Wpart -lepton weight,
+c id -lepton id ( 0 - gamma, -1 - e-, +1 - e+ )
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+#include "conex.h"
+
+ i=ih+minEHad
+
+
+ imaxE0=max(imaxE0,i)
+ jminZ0=min(jminZ0,j)
+
+ if(id.eq.0)then !gammas
+ SFG(i,j)=SFG(i,j) + wsf2noint(1,i)*Wpart
+ SF2HAD(1,i)=SF2HAD(1,i) + (1.d0-wsf2noint(1,i))*Wpart
+ elseif(id.eq.-1)then !e-
+ SFE(i,j)=SFE(i,j) + wsf2noint(2,i)*Wpart
+ SF2HAD(2,i)=SF2HAD(2,i) + (1.d0-wsf2noint(2,i))*Wpart
+ elseif(id.eq.1)then !e+
+ SFP(i,j)=SFP(i,j) + wsf2noint(3,i)*Wpart
+ SF2HAD(3,i)=SF2HAD(3,i) + (1.d0-wsf2noint(3,i))*Wpart
+ elseif(id.eq.2)then !gammas from photonuclear effect
+ SFG(i,j)=SFG(i,j) + Wpart
+ endif
+
+ return
+ end
+
+#ifdef __MC3D__
+c-----------------------------------------------------------------------
+ subroutine ElectronPhotonLowShower(ki)
+c-----------------------------------------------------------------------
+c Sample current CE particles below low energy cut off into MC stack
+c and simulate low energy subshower (not to fill stack too much)
+c ki : slant depth bin
+c loop on np if k is large enough
+c np : 1 ... gamma
+c 2 ... electron
+c 3 ... positron
+c Author : T. Pierog, last modifications 13.09.07
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conexep.h"
+ double precision x(0:maximumE),y(maximumE),x1(maximumE)
+ & ,y1(maximumE),y2(maximumE)
+ double precision Eout,Eini,Sum,Efin,dl,sintet,costet,am,P,h,dl0
+ double precision heightt,drangen,Xout,rhoair,xNpart,ebal,wmax,zz
+ &,distance0,yNtry,xi,fmin,fminem,Ediff
+ external heightt,drangen,rhoair,distance0
+ integer np,Ibin,i,Itab,id,npmin,npmax,k,imx,icut,nstck
+ &,npt,imn,istep,istp,ki
+ double precision ep(3),the2em(2),rsin2th,frac
+ &,s0xs,c0xs,s0s,c0s,phi,pt
+ integer m2,m4,ifindindexs,j,l,ialpha
+ logical go,cont,cut
+#ifndef __CXCORSIKA__
+ double precision dptlsave(mxblk)
+ integer idum,isave
+#endif
+
+
+ if(ki.lt.0)then
+ k=-ki
+ else
+ k=ki
+ if(k.lt.lowZ.or.lowE.le.minE)return
+ endif
+ npmin=1
+ npmax=3
+
+ frac=1.d0
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)then
+ write(ifck,*) '--------------------------------------------'
+ if(ki.lt.0)write(ifck,*) 'Final sampling'
+ write(ifck,*) 'Sample EM particle at depth k ',k,zzem(k)
+ endif
+#endif
+
+
+ m2=ifindindexs(2,0,0,0) !moment number for F_2000
+ m4=ifindindexs(4,0,0,0) !moment number for F_4000
+
+
+C fix common particle variables
+ if(ki.lt.0)then
+ zz=zzem(k)
+ else
+#ifdef __CXCORSIKA__
+ zz=zzem(k)-0.06d0*(1.d0+0.66d0*sinthet)*min(1d0,0.1d0*dzz) !slant depth along shower axis
+#else
+ zz=zzem(k)-0.0001d0*min(1d0,0.1d0*dzz) !slant depth along shower axis
+#endif
+ endif
+ dl=distance0(zz)
+ if(dl.lt.distzem(k))
+ & write(*,*)'Warning for dl in ElectronLowShower'
+ & ,k,zz,dl,distzem(k)
+ h=heightt(dl,radtr0)
+ dptl(1)=0d0
+ dptl(2)=0d0
+c x,y-coordinates with respect to the obs.
+ dl0=dl-sign(DistAlt,zsaxis)
+ dptl(6)=dl0*xsaxis !x-coordinate
+ dptl(7)=dl0*ysaxis !y-coordinate
+ dptl(8)=h !height, m
+c beta=sqrt((1.d0-pmass(7)/Eprima)*(1.d0+pmass(7)/Eprima))*cxlight
+ dptl(9)=-dl0 !time
+ if(ki.ge.maxZ)then
+ dptl(12)=1000d0
+ cut=.false.
+ if(lowE.lt.maxE.and.lowE.ne.0)then !sample above lowE with weight 1
+ istep=2
+ else
+ istep=1
+ endif
+ elseif(ki.lt.0)then
+ cut=.false.
+ dptl(12)=1000d0
+ istep=1
+ else
+ dptl(12)=700d0 !generation
+ cut=iothin.eq.1 !use variable weight and energy conservation only with thinning
+ istep=1
+ endif
+ dptl(13)=zz !slant depth along shower axis
+ dptl(14)=0d0 !x-coordinate in shower frame
+ dptl(15)=0d0 !y-coordinate in shower frame
+ dptl(16)=dl !slant distance along shower axis
+ sintet=sign(min(1.d0,radtr0/(h+radearth)),dl0) !sin angle between impact parameter and starting point
+ costet=sign(dsqrt(1.d0-sintet*sintet),dl-1.d-10)
+ if(cut)then
+ fminem=0.4d1/(emdecade*log10(eelow/emin)) !at minimum, # particles = 0.5 * # bin per decade
+ else
+ fminem=1d10
+ endif
+
+ do np=npmin,npmax
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*) 'Sample EM particle type ',np
+#endif
+
+ fmin=fminem
+ imn=minE
+
+ do istp=1,istep
+
+ if(istp.eq.2)then
+c last depth bin : sample all particles with weight 1 above elow(maxE is half a bin) with a maximum of 100000 particles
+ imn=imx+1
+ imx=maxE
+ fmin=min(fmin,1d-5)
+ elseif(ki.gt.0)then
+c by definition (in bas), eelow is defined as the lower bin edge of lowE
+ imx=min(lowE-1,maxE)
+ else !if no CE, sample 100000 particles per type to get energy distributions
+ imx=maxE
+ fmin=min(fmin,1d-5)
+ endif
+
+ go=.false.
+
+ cont=.false.
+
+C fill array to be converted
+ Ibin=0
+ Sum=0d0
+ Eini=0d0
+ wmax=wsemax
+ if(np.eq.1)then
+ do i=imn,imx
+ if(.not.cont.and.ag(i,k).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeem(i))
+ y(Ibin)=ag(i,k)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*eeem(i)
+ ag(i,k)=0d0
+ do l=0,maximom
+ AAGm(l,i,k)=0d0
+ enddo
+ enddo
+ id=10
+ npt=2
+ am=0d0
+ elseif(np.eq.2)then
+ am=amc2
+ do i=imn,imx
+ if(.not.cont.and.ae(i,k).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeem(i))
+ y(Ibin)=ae(i,k)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeem(i)-am)
+ ae(i,k)=0d0
+ do l=0,maximom
+ AAEm(l,i,k)=0d0
+ enddo
+ enddo
+ npt=1
+ id=12
+ elseif(np.eq.3)then
+ am=amc2
+ do i=imn,imx
+ if(.not.cont.and.ap(i,k).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeem(i))
+ y(Ibin)=ap(i,k)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeem(i)+2.d0*am)
+ ap(i,k)=0d0
+ do l=0,maximom
+ AAPm(l,i,k)=0d0
+ enddo
+ enddo
+ npt=3
+ id=-12
+ endif
+ if(.not.cont)goto 100 !array empty, nothing to sample
+c minimum and maximum bin are half size for sampling (like energy bin definition)
+c first bin is half
+ if(np.eq.1)Sum=Sum-y(1)*0.5d0 !for the integral
+c y(1)=y(1)*2.d0 !half a bin
+c last bin is half only if maximum energy
+ if(imx.lt.maxE)then
+ icut=0
+ else
+c Sum=Sum-y(Ibin)*0.5d0 !for the integral
+ y(Ibin)=y(Ibin)*2.d0 !half a bin
+ icut=1
+ endif
+ x(0)=x(1)-log10(Cem)
+
+c if(ki.gt.0)then
+
+ wmax=max(1d0,min(wmax,Sum*fmin)) !at minimum, 20 particles
+
+C convert histogram to function
+ call CXHI2FUN(x,y,Ibin,x1,y1,Itab)
+C prepare sampling
+ call CXSAMP1D(-1,x1,y1,y2,Itab,Xout)
+
+C fix the number of sampled particle according to the maximum weight
+c (poissonian distribution)
+c call CXMPOISS( Sum,xNpart )
+c xNpart=xNpart/wmax
+ xNpart=Sum/wmax
+ yNtry=aint(xNpart) !AINT take the whole number but keep variable type (double : important because integer are limited to ~2e9 !!!)
+c yNtry=max(1,anint(Sum/wmax))
+ if(drangen(xNpart).le.xNpart-yNtry)yNtry=yNtry+1d0
+ if(yNtry.lt.1d0)then
+ if(Sum.lt.1d0) goto 100
+ wmax=Sum
+ yNtry=1.d0
+ go=.true.
+ else
+ go=.true.
+ endif
+c else
+c wmax=Sum
+c yNtry=1.d0
+c go=.true.
+c endif
+
+C fix common variables for this particle
+ dptl(11)=wmax !particle weight
+ dptl(5)=am
+
+C loop to sample particles
+ Efin=0d0
+ nstck=0
+ xi=1d0
+ do while (xi.le.yNtry)
+ xi=xi+1d0
+ nstck=nstck+1
+ call CXSAMP1D(icut,x1,y1,y2,Itab,Xout) !sampling with cut on last bin
+ Eout=10d0**Xout
+ dptl(10)=dble(id) !particle id
+ dptl(4)=Eout+am !kinetic energy
+ ebal=dptl(4)
+ if(id.ne.10)ebal=ebal-sign(am,dble(id)) !if positron, count mass twice
+c to conserve energy give to the last particle the remaining energy
+ Ediff=(Eini-Efin)/dptl(11)
+ if(Ediff-ebal.lt.0d0
+ & .or.abs(xi-yNtry-1d0).lt.1d-5)then
+ ebal=Ediff
+ if(id.ne.10)dptl(4)=ebal+sign(am,dble(id)) !if positron, count mass twice
+ Eout=dptl(4)-am
+ xi=yNtry+1d0
+ if(Eout.lt.emin)goto 100
+ endif
+ Efin=Efin+ebal*dptl(11)
+ P=sqrt((Eout+2d0*am)*Eout)
+ if(i1DMC.le.1)then
+ dptl(1)=0d0
+ dptl(2)=P*sintet ! local p_y
+ dptl(3)=P*costet ! local p_z
+c give pt to muons from pt2low
+ j=1+int(log10(Eout*c2em/Eo)*dnHa)
+ if(AF4m(0,j,3,npt).gt.0d0.and.ki.gt.0)then
+ the2em(1)=AF4m(m2,j,3,npt)/AF4m(0,j,3,npt)*2d0 !2=1/fkcoef(1)
+ the2em(2)=AF4m(m4,j,3,npt)/AF4m(0,j,3,npt)*2.66667d0 !2.66667=1/fkcoef(2)
+ do l=1,3
+ ep(l)=dptl(l)
+ enddo
+ call cxdefrot(ep,s0xs,c0xs,s0s,c0s)
+ pt=sqrt(rsin2th(the2em(1),the2em(2),frac))*P
+ phi=2d0*pi*drangen(pt)
+ ep(1)=pt*cos(phi)
+ ep(2)=pt*sin(phi)
+ ep(3)=sqrt(max(0d0,(P+pt)*(P-pt)))
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ do l=1,3
+ dptl(l)=ep(l)
+ enddo
+ endif
+ else
+ dptl(3)=P
+ endif
+
+#ifdef __CXCORSIKA__
+ call d2cors(0)
+#else
+ call d2a
+c if number of particles to large in stack propagate particles
+ if(nstck.ge.10*mxstk)then
+c store dptl block as it is because HadronShower will change it
+ do isave=1,mxblk
+ dptlsave(isave)=dptl(isave)
+ enddo
+c Simulate subshowers
+ call HadronShower(0,idum)
+ nstck=0
+c restore dptl block to continue sampling
+ do isave=1,mxblk
+ dptl(isave)=dptlsave(isave)
+ enddo
+ endif
+#endif
+ enddo
+
+100 continue
+
+#ifdef __CXDEBUG__
+ etotsource=etotsource-Eini
+ if(isx.ge.4)then
+ if(Sum.le.0d0.or.yNtry.lt.1d0)then
+ write (ifck,*) 'Particle skipped: ',np,Sum,yNtry
+ else
+ write (ifck,*) 'Sample done with (ini->fin): '
+ * ,yNtry,Sum,' ->',wmax*yNtry,Eini,' ->',Efin,Efin/Eini
+ endif
+ endif
+ if(isx.ge.6)then
+ etotlost=etotlost+Eini-Efin
+ endif
+#endif
+
+ enddo !istep
+
+ enddo !np
+
+c delete emptied moments
+ do npt=1,3
+ do j=1,3
+ do i=minE,imx
+ do ialpha=0,n4mreal
+ AF4m(ialpha,i,j,npt)=0d0
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+#ifndef __CXCORSIKA__
+C Simulate subshowers
+ if(go)call HadronShower(0,idum)
+#endif
+
+ end
+#endif
+
+
+#ifdef __CXSUB__
+
+c------------------------------------------------------------------------------
+ subroutine InitializeEphCasSub
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ eeem(1)=eo !energy binning
+ do j=2, maximumE
+ eeem(j)=eeem(j-1)*cem
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ if(imscat.eq.1.and.ilatCE.eq.0)then
+#else
+ if(imscat.eq.1)then
+#endif
+ etheef=.00095d0
+ ethgef=.00055d0
+ do j=1, maximumE !so010304 tp020205
+ dethe(j)=pi/2.d0*sqrt(1.d0-exp(-etheef/eeem(j)))
+ dethe(j)=1.d0/cos(dethe(j))
+ dethg(j)=pi/2.d0*sqrt(1.d0-exp(-(ethgef/eeem(j))**2))
+ dethg(j)=1.d0/cos(dethg(j))
+ enddo
+ else
+ do j=1, maximumE
+ dethe(j)=1.d0
+ dethg(j)=1.d0
+ enddo
+ endif
+
+#if __MC3D__ || __CXLATCE__
+ if(ilatCE.ne.0)then
+ call InitialQueue
+ endif
+#endif
+
+ do k=1,maxz
+ do j=1,maximumE
+#if __MC3D__ || __CXLATCE__
+ do l=0,maximom
+ aem(l,j,k)=0.d0
+ agm(l,j,k)=0.d0
+ apm(l,j,k)=0.d0
+ enddo
+#else
+ aem(0,j,k)=0.d0
+ agm(0,j,k)=0.d0
+ apm(0,j,k)=0.d0
+#endif
+ enddo
+ enddo
+
+ end
+
+c------------------------------------------------------------------------------
+ subroutine InitializeEphCas2
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ zzem(1)=zzo !depth binning
+ do k=2, maxz
+ zzem(k)=zzem(k-1)+dzz
+ enddo
+
+ if(ionloss.eq.0)then
+ do k=1,maxz !calculation of ionization loss influence
+ do j=1,maxe
+ dlt(j,k)=0.d0
+ dltp(j,k)=0.d0
+ enddo
+ enddo
+ else
+ do k=1,maxz !calculation of ionization loss influence
+ distzem(k)=distance0(zzem(k)) !slant distance to obs level
+ !for slant depth zzem(k)
+ hz=heightt(distzem(k),radtr0)
+ do j=1,maxe
+ eej=eeem(j)
+ dlt(j,k)=cem/(cem-1.d0)*dedzEM(eej,hz,-1)/eej
+ dltp(j,k)=cem/(cem-1.d0)*dedzEM(eej,hz,1)/eej
+ enddo
+ enddo
+ endif
+
+
+ end
+
+#else
+
+c------------------------------------------------------------------------------
+ subroutine InitializeEphCas2 !so010304 !tp160904
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ eeem(1)=eo !energy binning
+ do j=2, maxe
+ eeem(j)=eeem(j-1)*cem
+ enddo
+
+ zzem(1)=zzo !depth binning
+ do k=2, maxz
+ zzem(k)=zzem(k-1)+dzz
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ if(imscat.eq.1.and.ilatCE.eq.0)then
+#else
+ if(imscat.eq.1)then
+#endif
+ etheef=.00095d0
+ ethgef=.00055d0
+ do j=1, maxe !so010304 tp020205
+ dethe(j)=pi/2.d0*sqrt(1.d0-exp(-etheef/eeem(j)))
+ dethe(j)=1.d0/cos(dethe(j))
+ dethg(j)=pi/2.d0*sqrt(1.d0-exp(-(ethgef/eeem(j))**2))
+ dethg(j)=1.d0/cos(dethg(j))
+ enddo
+ else
+ do j=1, maxe
+ dethe(j)=1.d0
+ dethg(j)=1.d0
+ enddo
+ endif
+
+
+ if(ionloss.eq.0)then
+ do k=1,maxz !calculation of ionization loss influence
+ do j=1,maxe
+ dlt(j,k)=0.d0
+ dltp(j,k)=0.d0
+ enddo
+ enddo
+ else
+ do k=1,maxz !calculation of ionization loss influence
+ distzem(k)=distance0(zzem(k)) !slant distance to obs level
+ !for slant depth zzem(k)
+ hz=heightt(distzem(k),radtr0)
+ do j=1,maxe
+ eej=eeem(j)
+ dlt(j,k)=cem/(cem-1.d0)*dedzEM(eej,hz,-1)/eej
+ dltp(j,k)=cem/(cem-1.d0)*dedzEM(eej,hz,1)/eej
+ enddo
+ enddo
+ endif
+
+#if __MC3D__ || __CXLATCE__
+ if(ilatCE.ne.0)then
+ call InitialQueue
+ endif
+#endif
+
+ do k=1,maxz
+ do j=mine,maxe
+#if __MC3D__ || __CXLATCE__
+ do l=0,maximom
+ aem(l,j,k)=0.d0
+ agm(l,j,k)=0.d0
+ apm(l,j,k)=0.d0
+ enddo
+#else
+ aem(0,j,k)=0.d0
+ agm(0,j,k)=0.d0
+ apm(0,j,k)=0.d0
+#endif
+ enddo
+ enddo
+ end
+
+#endif
+
+c------------------------------------------------------------------------------
+ subroutine CrossSections !so110204 !tp061204
+c------------------------------------------------------------------------------
+c calculation of cross section matrices
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension wbrg(maximume,maximume),wbre(maximume,maximume)
+ *,sb(maximume)
+
+#ifdef __CXDEBUG__
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(isx.ge.2)then
+#endif
+ write(6,*)'initialize e/m cross section up to maxe :',maxe
+#if __CXCORSIKA__ || __CORSIKA8__
+ endif
+#endif
+#endif
+c--------------------------photon interaction----------------------------------
+ do j=1,maxe
+ eej=eeem(j)
+ se=sigphoel(eej) !photoelectric effect cross section (no electron prod)
+ sn=sigphonu(eej) !photonuclear effect cross section
+ sm=sigmupar(eej) !muon pair production cross section
+ sc=fcompt(eej) !compton cross section
+ sp=sigpar(eej) !pair production cross section
+ fnormc=f1cx(eej/(2.d0*eej/amc2+1.d0),eej,eej)
+ fnorm=spair(eej)
+ if(fnorm.gt.0.d0)fnorm=sp/fnorm
+ if(fnormc.gt.0.d0)fnormc=sc/fnormc
+ do i=1,j
+ wcog=wcompg(eej,eeem(i),cem)*fnormc!compton: photon spectrum
+ wcoe=wcompe(eej,eeem(i),cem)*fnormc!compton: electron spectrum
+ wpae=wpaire(eej,eeem(i),cem)*fnorm !pair production: electron
+
+ wge(j,i)=wcoe+wpae !total electron spectrum
+ wgp(j,i)=wpae !total positron spectrum
+ wgg(j,i)=wcog !total photon spectrum
+ enddo
+ wgg(j,j)=wgg(j,j)-sp-sc-sn-sm-se
+ wgh(j)=sn !photonuclear effect spectrum
+ wgm(j)=sm !muon pair production spectrum
+ enddo
+
+c--------------------------electron interaction--------------------------------
+ do j=1,maxe !--------delta-electron--------------------------------------
+ sb(j)=fbrem(eeem(j)) !bremsstrahlung cross section
+ fnormb=sbrem(eeem(j))
+ sd=fmoel(0,eo,eeem(j)-eo,eeem(j)) !delta-process cross section
+ fnormd=smoel(0,eo,eeem(j)-eo,eeem(j))
+ if(fnormb.gt.0.d0)fnormb=sb(j)/fnormb
+ if(fnormd.gt.0.d0)fnormd=sd/fnormd
+ do i=1,j
+ wdee=wdelta(eeem(j),eeem(i),cem)*fnormd !delta-process: electron spectrum
+ wbrg(j,i)=wbremg(eeem(j),eeem(i),cem)*fnormb !bremsstrahlung: photon spectrum
+ wbre(j,i)=wbreme(eeem(j),eeem(i),cem)*fnormb !bremsstrahlung: electron spectrum
+ wee(j,i)=wbre(j,i)+wdee !total electron spectrum
+ weg(j,i)=wbrg(j,i) !total photon spectrum
+ enddo
+ wee(j,j)=wee(j,j)-sd-sb(j)
+ enddo
+
+c--------------------------positron interaction--------------------------------
+ do j=1,maxe !--------delta-electron--------------------------------------
+ sdp=fbaba(eeem(j)) !e^+-delta-process cross section
+ fnormb=sbaba(0,eo,eeem(j),eeem(j))
+ sa=sheitl(eeem(j)) !annihilation cross section
+ fnorma=fann(0,0.d0,eeem(j)+2.d0*amc2,eeem(j))/2.d0
+ if(fnormb.gt.0.d0)fnormb=sdp/fnormb
+ if(fnorma.gt.0.d0)fnorma=sa/fnorma
+ do i=1,j
+ wdepe=wbhae(eeem(j),eeem(i),cem)*fnormb!delta-process: electron spectrum
+ wdepp=wbhap(eeem(j),eeem(i),cem)*fnormb!delta-process: positron spectrum
+ wang=wanng(eeem(j),eeem(i),cem)*fnorma!annihilation: photon spectrum
+ wpp(j,i)=wbre(j,i)+wdepp !total positron spectrum
+ wpg(j,i)=wbrg(j,i)+wang !total photon spectrum
+ wpe(j,i)=wdepe !total electron spectrum
+ enddo
+ wpp(j,j)=wpp(j,j)-sb(j)-sdp-sa
+ enddo
+
+ if(mode.ge.7)then
+c probability to go through two bins whitout interacting for source function
+ do j=1, maxe
+ wsf2noint(1,j)=exp(wgg(j,j)*dethg(j)*2.d0*dZZ)
+ wsf2noint(2,j)=exp(wee(j,j)*dethe(j)*2.d0*dZZ)
+ wsf2noint(3,j)=exp(wpp(j,j)*dethe(j)*2.d0*dZZ)
+ enddo
+ endif
+
+ end
+
+#ifndef __CXSUB__
+
+c------------------------------------------------------------------------------
+ subroutine SolveDiffEqu !so010304
+c------------------------------------------------------------------------------
+c Solving the differential equation with source term
+c the source has to be provided via SFE,SFG
+c The cross section tables have to be provided via WGG,WGE,WEG,WEE
+c all arrays to be defined via comon in conex.inc
+c------------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension enpart(2),fe(3),fg(3),fp(3),feg1(3),feg2(3),feg3(3)
+ *,agv(maximume),aev(maximume),apv(maximume)
+
+
+c initialize array used for lost energy calculation
+ enpart(1)=0.d0
+ enpart(2)=0.d0
+
+c----------------set initial energy distribution to be uniform-----------------
+
+c Full range initialization
+
+ do j=mine,maxe !so081203
+ aev(j)=0.0d0
+ agv(j)=0.0d0
+ apv(j)=0.0d0
+ enddo
+
+ do k=1, maxz
+ do j=mine, maxe
+ ae(j,k)=0.0d0
+ ag(j,k)=0.0d0
+ ap(j,k)=0.0d0
+#if __MC3D__ || __CXLATCE__
+ do l=0,maximom
+ aaem(l,j,k)=0.d0
+ aagm(l,j,k)=0.d0
+ aapm(l,j,k)=0.d0
+ enddo
+#endif
+ enddo
+ enddo
+
+c calculation on a limited range (given by the source)
+
+ ismaxe=maxe
+ minz=jminz0
+ maxe=imaxe0
+
+ do j=mine, maxe
+ ae(j,minz)=sfe(j,minz)
+ ag(j,minz)=sfg(j,minz)
+ ap(j,minz)=sfp(j,minz)
+ if(minz.le.lowZ.or.j.ge.lowE)then
+ enpart(2)=enpart(2)+eeem(j)*(ae(j,minz)+ag(j,minz)+ap(j,minz))
+c count mass in energy balance only if not primary particle
+ if(lxfirst)enpart(2)=enpart(2)+amc2*(ae(j,minz)+ap(j,minz))
+ endif
+ enddo
+ if(.not.lxfirst)then !first interaction
+ Xfirst=zzem(minz)
+ lxfirst=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+
+ if(minz+1.gt.maxz)goto 999
+
+ xxx1=1d30
+ xxx2=0d0
+ xpo=0d0
+
+ do k=minz+1, maxz
+ enpart(1)=enpart(2) !total energy for the previous depth
+ enpart(2)=0.d0
+ sumEloss=0d0
+
+ factk=1.d0
+ factkg=1.d0
+ if(imscat.eq.1)then
+ factk=1.d0-zzem(k)*1.d-5
+ factkg=1.d0+zzem(k)*4.d-5
+ endif
+
+ do j=mine,maxe !so081203c
+ delE=eeem(j)*(1.d0-1.d0/cem)
+ do i=mine,j
+ suu(j,i)=wee(j,i)*dethe(j)*factk
+ sww(j,i)=wpp(j,i)*dethe(j)*factk
+ svv(j,i)=wgg(j,i)*dethg(j)*factkg
+ suv(j,i)=weg(j,i)*dethe(j)*factk
+ svu(j,i)=wge(j,i)*dethg(j)*factkg
+ svw(j,i)=wgp(j,i)*dethg(j)*factkg
+ swu(j,i)=wpe(j,i)*dethe(j)*factk
+ swv(j,i)=wpg(j,i)*dethe(j)*factk
+ enddo
+ delE=eeem(j)*(1.d0-1.d0/cem)
+ betheb(1,j)=dlt(j,k)*dethe(j)*factk
+ suu(j,j)=suu(j,j)-betheb(1,j) !account for de/dz
+ betheb(2,j)=dltp(j,k)*dethe(j)*factk
+ sww(j,j)=sww(j,j)-betheb(2,j) !account for de/dz
+ if(j.gt.1)then
+ suu(j,j-1)=suu(j,j-1)+betheb(1,j)
+ sww(j,j-1)=sww(j,j-1)+betheb(2,j)
+ endif
+ betheb(1,j)=betheb(1,j)*dzz*delE !for edep
+ betheb(2,j)=betheb(2,j)*dzz*delE !for edep
+ enddo
+
+ do j=maxe, mine,-1
+ call homo(j,ce2,ce3,cg1,cg3,cp1,cp2,he1,he2,he3
+ * ,hg1,hg2,hg3,hp1,hp2,hp3,w1,w2,w3)
+
+c if(k.eq.2)write(*,*)'w1,w2,w3,cg1,cp1,ce2,cp2,ce3,cg3',j
+c * ,w1,w2,w3,cg1,cp1,ce2,cp2,ce3,cg3,suu(j,j),svv(j,j),sww(j,j)
+c * ,suv(j,j),svu(j,j),svw(j,j),swu(j,j),swv(j,j) !?????????
+
+ if(j.lt.maxe)then
+ do i=1,3
+ fe(i)=0.d0
+ fg(i)=0.d0
+ fp(i)=0.d0
+ enddo
+ imn=j+1
+ do i=imn, maxe
+ fe(1)=fe(1)+ae(i,k-1)*suu(i,j)+ag(i,k-1)*svu(i,j)
+ * +ap(i,k-1)*swu(i,j)
+ fg(1)=fg(1)+ae(i,k-1)*suv(i,j)+ag(i,k-1)*svv(i,j)
+ * +ap(i,k-1)*swv(i,j)
+ fp(1)=fp(1)+ag(i,k-1)*svw(i,j)+ap(i,k-1)*sww(i,j)
+ fe(2)=fe(2)+aev(i)*suu(i,j)+agv(i)*svu(i,j)
+ * +apv(i)*swu(i,j)
+ fg(2)=fg(2)+aev(i)*suv(i,j)+agv(i)*svv(i,j)
+ * +apv(i)*swv(i,j)
+ fp(2)=fp(2)+agv(i)*svw(i,j)+apv(i)*sww(i,j)
+ fe(3)=fe(3)+ae(i,k)*suu(i,j)+ag(i,k)*svu(i,j)
+ * +ap(i,k)*swu(i,j)
+ fg(3)=fg(3)+ae(i,k)*suv(i,j)+ag(i,k)*svv(i,j)
+ * +ap(i,k)*swv(i,j)
+ fp(3)=fp(3)+ag(i,k)*svw(i,j)+ap(i,k)*sww(i,j)
+ enddo
+ do i=1,3
+ feg1(i)=(fe(i)+cg1*fg(i)+cp1*fp(i))
+ feg2(i)=(ce2*fe(i)+fg(i)+cp2*fp(i))
+ feg3(i)=(ce3*fe(i)+cg3*fg(i)+fp(i))
+ enddo
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz)
+ * +blow(feg1,w1,dzz,1)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz)
+ * +blow(feg2,w2,dzz,1)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz)
+ * +blow(feg3,w3,dzz,1)
+ ae(j,k)=ae(j,k)+he1*ffeg1+he2*ffeg2+he3*ffeg3
+ ag(j,k)=ag(j,k)+hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ ap(j,k)=ap(j,k)+hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz/2.d0)
+ * +blow(feg1,w1,dzz,0)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz/2.d0)
+ * +blow(feg2,w2,dzz,0)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz/2.d0)
+ * +blow(feg3,w3,dzz,0)
+ aev(j)=he1*ffeg1+he2*ffeg2+he3*ffeg3
+ agv(j)=hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ apv(j)=hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ else
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz)
+ ae(j,k)=ae(j,k)+he1*ffeg1+he2*ffeg2+he3*ffeg3
+ ag(j,k)=ag(j,k)+hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ ap(j,k)=ap(j,k)+hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz/2.d0)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz/2.d0)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz/2.d0)
+ aev(j)=he1*ffeg1+he2*ffeg2+he3*ffeg3
+ agv(j)=hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ apv(j)=hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+ endif
+ sumEloss=sumEloss+aev(j)*betheb(1,j)+apv(j)*betheb(2,j)
+c sumEloss=sumEloss+ae(j,k)*betheb(1,j)+ap(j,k)*betheb(2,j)
+cc source inside the loop
+cc update counted energy
+c enpart(1)=enpart(1)+eeEM(j)*(sfe(j,k)+sfg(j,k))
+c & +amc2*(sfe(j,k)+sfp(j,k))
+c total mass for this depth
+c enpart(2)=enpart(2)+amc2*(sfe(j,k)+sfp(j,k)+2.d0*ap(j,k))
+
+c add source
+c ae(j,k)=ae(j,k)+sfe(j,k)
+c ag(j,k)=ag(j,k)+sfg(j,k)
+c ap(j,k)=ap(j,k)+sfp(j,k)
+
+c total energy for this depth
+c enpart(2)=enpart(2)+eeEM(j)*(AE(j,k)+AG(j,k)+AP(j,k))
+
+c source outside the loop
+c total energy for this depth
+ enpart(2)=enpart(2)+eeEM(j)*(AE(j,k)+AG(j,k)+AP(j,k))
+ & +amc2*2.d0*AP(j,k) !total energy for this depth
+
+ enddo ! cycle over j is completed
+
+ ebal=enpart(1)-enpart(2) !lost energy from k-1 to k
+ if(iwrt.ge.2)then
+ edep=max(0d0,ebal-sumEloss)
+ fact=0.2d0
+ if(xpo.gt.0d0.or.(ebal.gt.xxx1.and.edep.lt.fact*sumEloss
+ . .and.edep/sumEloss.lt.xxx2.and.edep.gt.0d0))then
+ xpo=1d0
+ else
+ xpo=0d0
+ xxx1=min(sumEloss,ebal)
+ xxx2=edep/sumEloss
+ edep=fact*sumEloss
+ endif
+c print *,'emd',k,xpo,edep,ebal-sumEloss,ebal,sumEloss
+c . ,edep/sumEloss
+ edep=max(sumEloss,0d0)+edep
+
+ call Profana(ZZEM(k)-0.1d0*dzHa,ZZEM(maxZ)+0.1d0*dzHa
+ & ,ebal,edep,1.d0,999,-1)
+ endif
+#ifdef __CXDEBUG__
+ etotsource=etotsource-ebal
+#endif
+
+cc source outside the loop
+ enpart(2)=0.d0
+
+ do j=mine,maxe !adding source contributions for depth zzem(k)
+ if(k.le.lowZ.or.j.ge.lowE)then
+ enpart(2)=enpart(2)+amc2*(sfe(j,k)+sfp(j,k)+2.d0*ap(j,k)) !count electron mass from source and twice positron mass for shower
+ endif
+ ae(j,k)=ae(j,k)+sfe(j,k)
+ ag(j,k)=ag(j,k)+sfg(j,k)
+ ap(j,k)=ap(j,k)+sfp(j,k)
+c total energy for this depth given back to MC should not be counted as deposed
+ if(k.le.lowZ.or.j.ge.lowE)then
+ enpart(2)=enpart(2)+eeem(j)*(ae(j,k)+ag(j,k)+ap(j,k))
+ endif
+ enddo
+
+#ifdef __MC3D__
+c do MC simulations for low energy particles
+ if(lowE.gt.minE)call ElectronPhotonLowShower(k)
+#endif
+
+ if(mod(k,100).eq.1)write(*,*)" k = ",k
+ enddo !cycle over k is completed
+
+
+ 999 maxe=ismaxe
+
+ return
+
+ end
+#endif
+
+c------------------------------------------------------------------------------
+ subroutine IniEMCE !tp141204
+c------------------------------------------------------------------------------
+c Initialization before Solving the differential equation
+c------------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ logical goCE
+ common/cxembaltmp/enpartem(2),goCE
+
+ goCE=.true.
+ enpartem(1)=0.d0
+ enpartem(2)=0.d0
+ do k=1, maximumZ
+ do j=1, maximumE
+ ae(j,k)=0.0d0
+ ag(j,k)=0.0d0
+ ap(j,k)=0.0d0
+#if __MC3D__ || __CXLATCE__
+ do l=0,maximom
+ aaem(l,j,k)=0.d0
+ aagm(l,j,k)=0.d0
+ aapm(l,j,k)=0.d0
+ enddo
+#endif
+ enddo
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ if(iLatCE.ne.0)then
+ call IniEMCEs
+ endif
+#endif
+
+ return
+
+ end
+
+
+c------------------------------------------------------------------------------
+ subroutine SolveEMCE(k) !tp141204
+c------------------------------------------------------------------------------
+c Solving the differential equation with source term for the depth bin k
+c the source has to be provided via SFE,SFG
+c The cross section tables have to be provided via WGG,WGE,WEG,WEE
+c all arrays to be defined via common in conex.inc
+c------------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension fe(3),fg(3),fp(3),feg1(3),feg2(3),feg3(3)
+ *,agv(maximume),aev(maximume),apv(maximume)
+ logical goCE
+ common/cxembaltmp/enpartem(2),goCE
+ save xxx1,xxx2,xpo
+
+
+#if __MC3D__ || __CXLATCE__
+ if(iLatCE.ne.0)then !CE with moments for LDF or low MC
+
+ call SolveEMCEs(k)
+#ifdef __ANALYSIS__
+ if (k.eq.maxZ) then
+ if(nshower.eq.1)call printcostm(0,0,2)
+#ifdef __CXLATCE__
+ if (iLatCE.eq.1.and.(imscat.ne.0.or.i1DEM.ne.1)) then
+ call Transverses
+ endif
+#endif
+ endif
+#endif
+
+ else
+#endif
+c calculation on a limited range (given by the source)
+
+ imaxe=imaxe0
+
+ if(goCE)then
+ if(k.eq.jminz0)then
+ goCE=.false.
+ elseif(k-1.eq.jminz0)then
+ goCE=.false.
+ minz=jminz0
+ enpartem(2)=0.d0
+ do j=mine, imaxe
+ ae(j,minz)=sfe(j,minz)
+ ag(j,minz)=sfg(j,minz)
+ ap(j,minz)=sfp(j,minz)
+ if(minz.le.lowZ.or.j.ge.lowE)then
+ enpartem(2)=enpartem(2)+eeem(j)*(ae(j,minz)+ag(j,minz)
+ & +ap(j,minz))
+c count mass in energy balance only if not primary particle
+ if(lxfirst)enpartem(2)=enpartem(2)+amc2*(ae(j,minz)+ap(j,minz))
+ endif
+ enddo
+ if(.not.lxfirst)then !first interaction
+ Xfirst=zzem(minz)
+ lxfirst=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+ endif
+ endif
+
+ if(k.gt.maxz)return
+ if(k.eq.minz.or.k.eq.jpHa+1)then
+ xpo=0d0
+ xxx1=1d30
+ xxx2=0d0
+ endif
+
+ enpartem(1)=enpartem(2) !total energy for the previous depth
+ enpartem(2)=0.d0
+ sumEloss=0d0
+ shad=0.d0 !send photonuclear and muon pair gammas in had CE
+
+ factk=1.d0
+ factkg=1.d0
+ if(imscat.eq.1)then
+ factk=1.d0-zzem(k)*1.d-5
+ factkg=1.d0+zzem(k)*4.d-5
+ endif
+
+ emsf2had=0.d0
+ do j=mine,imaxe
+ agv(j)=0.d0
+ aev(j)=0.d0
+ apv(j)=0.d0
+
+c add half of the source from Had CE
+ emsf2had=emsf2had+eeem(j)*(sf2had(1,j)+sf2had(2,j)+sf2had(3,j))
+ & +amc2*(sf2had(2,j)+sf2had(3,j)) !count electron mass from source
+ ag(j,k-1)=ag(j,k-1)+sf2had(1,j)
+ ae(j,k-1)=ae(j,k-1)+sf2had(2,j)
+ ap(j,k-1)=ap(j,k-1)+sf2had(3,j)
+
+ svh(j)=wgh(j)*dethg(j)*factkg
+ svm(j)=wgm(j)*dethg(j)*factkg
+ do i=mine,j
+ suu(j,i)=wee(j,i)*dethe(j)*factk
+ sww(j,i)=wpp(j,i)*dethe(j)*factk
+ svv(j,i)=wgg(j,i)*dethg(j)*factkg
+ suv(j,i)=weg(j,i)*dethe(j)*factk
+ svu(j,i)=wge(j,i)*dethg(j)*factkg
+ svw(j,i)=wgp(j,i)*dethg(j)*factkg
+ swu(j,i)=wpe(j,i)*dethe(j)*factk
+ swv(j,i)=wpg(j,i)*dethe(j)*factk
+ enddo
+ wsf2noint(1,j)=exp(svv(j,j)*2.d0*dZZ) !probability to go through 2 bins without interacting
+ wsf2noint(2,j)=exp(suu(j,j)*2.d0*dZZ)
+ wsf2noint(3,j)=exp(sww(j,j)*2.d0*dZZ)
+ delE=eeem(j)*(1.d0-1.d0/cem)
+ betheb(1,j)=dlt(j,k)*dethe(j)*factk
+ suu(j,j)=suu(j,j)-betheb(1,j) !account for de/dz
+ betheb(2,j)=dltp(j,k)*dethe(j)*factk
+ sww(j,j)=sww(j,j)-betheb(2,j) !account for de/dz
+ if(j.gt.1)then
+ suu(j,j-1)=suu(j,j-1)+betheb(1,j)
+ sww(j,j-1)=sww(j,j-1)+betheb(2,j)
+ endif
+ betheb(1,j)=betheb(1,j)*dzz*delE !for edep
+ betheb(2,j)=betheb(2,j)*dzz*delE !for edep
+ enddo
+ enpartem(1)=enpartem(1)+emsf2had
+
+ do j=imaxe, mine,-1
+ call homo(j,ce2,ce3,cg1,cg3,cp1,cp2,he1,he2,he3
+ * ,hg1,hg2,hg3,hp1,hp2,hp3,w1,w2,w3)
+
+ if(j.lt.imaxe)then
+ do i=1,3
+ fe(i)=0.d0
+ fg(i)=0.d0
+ fp(i)=0.d0
+ enddo
+ imn=j+1
+ do i=imn, imaxe
+ fe(1)=fe(1)+ae(i,k-1)*suu(i,j)+ag(i,k-1)*svu(i,j)
+ * +ap(i,k-1)*swu(i,j)
+ fg(1)=fg(1)+ae(i,k-1)*suv(i,j)+ag(i,k-1)*svv(i,j)
+ * +ap(i,k-1)*swv(i,j)
+ fp(1)=fp(1)+ag(i,k-1)*svw(i,j)+ap(i,k-1)*sww(i,j)
+ fe(2)=fe(2)+aev(i)*suu(i,j)+agv(i)*svu(i,j)
+ * +apv(i)*swu(i,j)
+ fg(2)=fg(2)+aev(i)*suv(i,j)+agv(i)*svv(i,j)
+ * +apv(i)*swv(i,j)
+ fp(2)=fp(2)+agv(i)*svw(i,j)+apv(i)*sww(i,j)
+ fe(3)=fe(3)+ae(i,k)*suu(i,j)+ag(i,k)*svu(i,j)
+ * +ap(i,k)*swu(i,j)
+ fg(3)=fg(3)+ae(i,k)*suv(i,j)+ag(i,k)*svv(i,j)
+ * +ap(i,k)*swv(i,j)
+ fp(3)=fp(3)+ag(i,k)*svw(i,j)+ap(i,k)*sww(i,j)
+ enddo
+ do i=1,3
+ feg1(i)=(fe(i)+cg1*fg(i)+cp1*fp(i))
+ feg2(i)=(ce2*fe(i)+fg(i)+cp2*fp(i))
+ feg3(i)=(ce3*fe(i)+cg3*fg(i)+fp(i))
+ enddo
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz)
+ * +blow(feg1,w1,dzz,1)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz)
+ * +blow(feg2,w2,dzz,1)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz)
+ * +blow(feg3,w3,dzz,1)
+ ae(j,k)=ae(j,k)+he1*ffeg1+he2*ffeg2+he3*ffeg3
+ ag(j,k)=ag(j,k)+hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ ap(j,k)=ap(j,k)+hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz*.5d0)
+ * +blow(feg1,w1,dzz,0)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz*.5d0)
+ * +blow(feg2,w2,dzz,0)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz*.5d0)
+ * +blow(feg3,w3,dzz,0)
+ aev(j)=he1*ffeg1+he2*ffeg2+he3*ffeg3
+ agv(j)=hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ apv(j)=hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ else
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz)
+ ae(j,k)=ae(j,k)+he1*ffeg1+he2*ffeg2+he3*ffeg3
+ ag(j,k)=ag(j,k)+hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ ap(j,k)=ap(j,k)+hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ ffeg1=(ae(j,k-1)+cg1*ag(j,k-1)+cp1*ap(j,k-1))*exp(w1*dzz*.5d0)
+ ffeg2=(ce2*ae(j,k-1)+ag(j,k-1)+cp2*ap(j,k-1))*exp(w2*dzz*.5d0)
+ ffeg3=(ce3*ae(j,k-1)+cg3*ag(j,k-1)+ap(j,k-1))*exp(w3*dzz*.5d0)
+ aev(j)=he1*ffeg1+he2*ffeg2+he3*ffeg3
+ agv(j)=hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ apv(j)=hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+ endif
+ sumEloss=sumEloss+aev(j)*betheb(1,j)+apv(j)*betheb(2,j)
+c sumEloss=sumEloss+ae(j,k)*betheb(1,j)+ap(j,k)*betheb(2,j)
+
+ wt=0.d0
+c if(iphonu.ne.0)then
+ do np=1,9
+ call eph2hsource(imaxe,j,k,np,wt)
+ shad=shad+wt !count energy converted into hadron
+ enddo
+c endif
+
+c total energy for this depth
+ enpartem(2)=enpartem(2)+eeEM(j)*(AE(j,k)+AG(j,k)+AP(j,k))
+ & +amc2*2.d0*AP(j,k) !total energy for this depth
+
+ enddo ! cycle over j is completed
+
+ enpartem(2)=enpartem(2)+shad !total energy for this depth
+
+ ebal=enpartem(1)-enpartem(2) !lost energy from k-1 to k
+ if(iwrt.ge.2)then
+ edep=max(0d0,ebal-sumEloss)
+ fact=0.2d0+0.008*sqrt(max(0d0,dzz-1d0))
+ if(xpo.gt.0d0.or.(ebal.gt.xxx1.and.edep.lt.fact*sumEloss
+ . .and.edep/sumEloss.lt.xxx2.and.edep.gt.0d0))then
+ xpo=1d0
+c edep=max(edep,fact*sumEloss)
+ else
+ xpo=0d0
+ xxx1=min(sumEloss,ebal)
+ xxx2=edep/sumEloss
+ edep=fact*sumEloss
+ endif
+c print *,'em',k,xpo,edep,ebal-sumEloss,ebal,sumEloss
+c .,edep/sumEloss!,shad
+ edep=max(0d0,sumEloss)+edep
+ call Profana(ZZEM(k)-0.1d0*dzHa,ZZEM(maxZ)+0.1d0*dzHa,ebal,edep
+ & ,1.d0,999,-1)
+ endif
+ etotsource=etotsource-ebal
+
+cc source outside the loop
+ enpartem(2)=0.d0
+
+ do j=mine,imaxe !adding source contributions for depth zzem(k)
+ if(k.le.lowZ.or.j.ge.lowE)then
+c count electron mass from source and twice positron mass for shower
+ enpartem(2)=enpartem(2)+amc2*(sfe(j,k)+sfp(j,k)+2.d0*ap(j,k))
+ endif
+ ag(j,k)=ag(j,k)+sfg(j,k)
+ ae(j,k)=ae(j,k)+sfe(j,k)
+ ap(j,k)=ap(j,k)+sfp(j,k)
+ ag(j,k-1)=ag(j,k-1)-sf2had(1,j)
+ ae(j,k-1)=ae(j,k-1)-sf2had(2,j)
+ ap(j,k-1)=ap(j,k-1)-sf2had(3,j)
+c total energy for this depth given back to MC should not be counted as deposed
+ if(k.le.lowZ.or.j.ge.lowE)then
+ enpartem(2)=enpartem(2)+eeem(j)*(ae(j,k)+ag(j,k)+ap(j,k))
+ endif
+ do np=1,3
+ SF2HAD(np,j)=0.0D0
+ enddo
+ enddo
+
+#ifdef __MC3D__
+c do MC simulations for low energy particles
+ if(lowE.gt.minE)call ElectronPhotonLowShower(k)
+#endif
+
+#ifndef __CXSUB__
+ if(mod(k,100).eq.1)write(*,*)" k = ",k
+#endif
+
+#if __MC3D__ || __CXLATCE__
+ endif
+#endif
+ return
+
+ end
+
+c-------------------subroutine integral over a source function-----------------
+ double precision function blow(aeg,w,adelt,intp)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer intp
+ dimension aeg(3)
+
+ if(abs(w).gt.1.d-20)then
+ if(intp.eq.1)then
+ xau=adelt*w
+ yau=(exp(xau)-1.d0)/xau
+ func0=yau*adelt
+ func1=2.d0*(yau-1.d0)/w
+ func2=(4.d0*(yau-1.d0)/xau-yau-1.d0)/w
+ else
+ xau=adelt*w/2.d0
+ yau=(exp(xau)-1.d0)/xau
+ func0=yau*adelt/2.d0
+ func1=(yau-1.d0)/w
+ func2=((yau-1.d0)/xau-yau/2.d0)/w
+ endif
+ else
+ if(intp.eq.1)then
+ func0=adelt
+ func1=adelt
+ func2=adelt/6.d0
+ else
+ func0=adelt/2.d0
+ func1=adelt/4.d0
+ func2=-adelt/24.d0
+ endif
+ endif
+ blow=aeg(1)*func0+(aeg(2)-aeg(1))*func1
+ *+(aeg(3)+aeg(1)-2.d0*aeg(2))*func2
+
+ return
+ end
+
+
+
+c-----------------------------------------------------------------------
+ subroutine SolveMomentEquations(n) !tp091003
+c-----------------------------------------------------------------------
+c solving differential equation for moments
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+
+#ifndef __CXSUB__
+
+ if(mode.lt.7)then
+
+#if __MC3D__ || __CXLATCE__
+ if (iLatCE.ne.0) then
+
+ write(*,*) 'Solving e/m CE'
+ call SolveDiffEqs
+ else
+#endif
+ WRITE(*,*)"SFG(imaxE0,jminZ0)=",SFG(imaxE0,jminZ0)
+ & ,imaxE0,jminZ0
+ call SolveDiffEqu
+
+#if __MC3D__ || __CXLATCE__
+ endif
+#endif
+ endif
+
+#endif
+
+#if __MC3D__ || __CXLATCE__
+ if (iLatCE.eq.0) then
+#endif
+
+ l=0
+ do k=1,maxZ
+ do j=minE,maxE
+ AEm(l,j,k)=AEm(l,j,k)+AE(j,k)
+ APm(l,j,k)=APm(l,j,k)+AP(j,k)
+ AGm(l,j,k)=AGm(l,j,k)+AG(j,k)
+ enddo
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ else
+ do k=1,maxZ
+ do j=minE,maxE
+ do l=0,maximom
+ AEm(l,j,k)=AEm(l,j,k)+AAEm(l,j,k)
+ APm(l,j,k)=APm(l,j,k)+AAPm(l,j,k)
+ AGm(l,j,k)=AGm(l,j,k)+AAGm(l,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+c Fill in output profile
+ if(iwrt.ne.0)then
+ do k=2,maxZ
+ if(mod(k-1,mZEMHa).eq.0)then
+ j=(k-1)/mZEMHa+1
+ zj=dble(j)
+ do i=minE,maxE
+ E=eeEM(i) !kinetic energy
+ wt=AG(i,k) !gammas
+ call Profana(zj,zj,E,E,wt,0,0)
+ wt=AE(i,k) !electrons
+ call Profana(zj,zj,E,E,wt,-1,0)
+ wt=AP(i,k) !positrons
+ call Profana(zj,zj,E,E,wt,1,0)
+ enddo
+ endif
+ enddo
+ endif
+
+#if __MC3D__
+
+#ifdef __CXCORSIKA__
+c empty CE stack into CORSIKA stack
+ call ElectronPhotonLowShower(-maxZ)
+#else
+c if particle still in CE stack (and low Energy MC for hadrons or muons) save particles at ground
+#ifdef __MC3D__
+ if(lowE.gt.minE)call ElectronPhotonLowShower(-maxZ)
+#endif
+#endif
+#endif
+
+ if(n.eq.nshower)then
+ if(nshower.gt.1)then
+ xnorm=1.d0/dble(nshower)
+ do k=1,maxZ
+ do j=minE,maxE
+#if __MC3D__ || __CXLATCE__
+ do l=0,maximom
+#else
+ l=0
+#endif
+ AEm(l,j,k)=AEm(l,j,k)*xnorm
+ APm(l,j,k)=APm(l,j,k)*xnorm
+ AGm(l,j,k)=AGm(l,j,k)*xnorm
+#if __MC3D__ || __CXLATCE__
+ enddo
+#endif
+ enddo
+ enddo
+ endif
+ endif
+
+
+
+ end
+
+c-----------------------------------------------------compton------------------
+ double precision function f1cx(egmin,egmax,eg) !so011203
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ d=0.075116d0
+ t1=egmin/amc2
+ t2=egmax/amc2
+ t=eg/amc2
+ f1cx=(dlog(t2/t1)*(1.d0-2.d0/t**2*(1.d0+t))+(t2**2-t1**2)/t**2/2d0
+ *+(t2-t1)/t**3*(2.d0*t+1.d0)+(t2-t1)/t/t1/t2)/t*d
+ return
+ end
+
+c-----------------------------------------------------compton------------------
+ double precision function f0(egmin,egmax,eg) !so011203
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ d=0.075116d0
+ t1=egmin/amc2
+ t2=egmax/amc2
+ t=eg/amc2
+ f0=((t2-t1)*(1.d0-2.d0/t**2*(1.d0+t))+(t2**3-t1**3)/t**2/3.d0
+ *+(t2**2-t1**2)/t**3*(2.d0*t+1.d0)/2.d0+dlog(t2/t1)/t)/t*d*amc2
+ return
+ end
+
+c-----------------photon spectrum for compton-process--------------------------
+ double precision function wcompg(eg,ej,cem) !so011203
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wcompg=0.d0
+ if(ej.lt..9999d0*eg.and.ej*cem.gt.eg/(2.d0*eg/amc2+1.d0))then
+ egmax=ej*cem
+ egmin=max(ej,eg/(2.d0*eg/amc2+1.d0))
+ wcompg=(cem*f1cx(egmin,egmax,eg)-f0(egmin,egmax,eg)/ej)/(cem-1d0)
+ endif
+
+ if(ej.gt.max(1.0001d0*eo,eg/(2.d0*eg/amc2+1.d0)))then
+ egmax=ej
+ egmin=max(ej/cem,eg/(2.d0*eg/amc2+1.d0))
+ wcompg=wcompg+(cem*f0(egmin,egmax,eg)/ej-f1cx(egmin,egmax,eg))
+ * /(cem-1.d0)
+ endif
+ wcompg=max(0d0,wcompg)
+ return
+ end
+
+c-----------------electron spectrum for compton-process--------------------------
+ double precision function wcompe(eg,ej,cem) !so011203
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wcompe=0.d0
+ if(ej.lt.eg-eg/(2.d0*eg/amc2+1.d0))then
+ egmax=eg-ej
+ egmin=max(eg-ej*cem,eg/(2.d0*eg/amc2+1.d0))
+ wcompe=((cem-eg/ej)*f1cx(egmin,egmax,eg)+f0(egmin,egmax,eg)/ej)
+ * /(cem-1.d0)
+ endif
+
+ if(ej.gt.1.0001d0*eo.and.eg-ej/cem.gt.eg/(2.d0*eg/amc2+1.d0))then
+ egmax=eg-ej/cem
+ egmin=max(eg-ej,eg/(2.d0*eg/amc2+1.d0))
+ wcompe=wcompe+((cem*eg/ej-1.d0)*f1cx(egmin,egmax,eg)
+ * -cem*f0(egmin,egmax,eg)/ej)/(cem-1.d0)
+ endif
+ wcompe=max(0.d0,wcompe)
+ return
+ end
+
+c-----------------electron spectrum for delta-process--------------------------
+ double precision function wdelta(eel,ej,cem) !so200204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wdelta=0.d0
+ if(eel.lt.2.d0*eo)return
+
+ if(ej.lt.eel-eo.and.ej*cem.gt.eo)then
+ eemax=min(ej*cem,eel-eo)
+ eemin=max(ej,eo)
+ wdelta=(cem*smoel(0,eemin,eemax,eel)
+ * -smoel(1,eemin,eemax,eel)/ej)/(cem-1.d0)*2.d0
+ endif
+
+ if(ej/cem.lt.eel-eo.and.ej.gt.1.0001d0*eo)then
+ eemax=min(ej,eel-eo)
+ eemin=max(ej/cem,eo)
+ wdelta=wdelta+(cem*smoel(1,eemin,eemax,eel)/ej
+ * -smoel(0,eemin,eemax,eel))/(cem-1.d0)*2.d0
+ endif
+ wdelta=max(0d0,wdelta)
+ return
+ end
+
+c-----------------electron spectrum for bhabha-process-------------------------
+ double precision function wbhae(eel,ej,cem) !so200204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wbhae=0.d0
+ if(eel.lt.eo)return
+
+ if(ej.lt.eel.and.ej*cem.gt.eo)then
+ eemax=min(ej*cem,eel)
+ eemin=max(ej,eo)
+ wbhae=(cem*sbaba(0,eemin,eemax,eel)
+ * -sbaba(1,eemin,eemax,eel)/ej)/(cem-1.d0)
+ endif
+
+ if(ej/cem.lt.eel.and.ej.gt.1.0001d0*eo)then
+ eemax=min(ej,eel)
+ eemin=max(ej/cem,eo)
+ wbhae=wbhae+(cem*sbaba(1,eemin,eemax,eel)/ej
+ * -sbaba(0,eemin,eemax,eel))/(cem-1.d0)
+ endif
+ wbhae=max(0d0,wbhae)
+ return
+ end
+
+c-----------------positron spectrum for bhabha-process-------------------------
+ double precision function wbhap(eel,ej,cem) !so200204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wbhap=0.d0
+ if(eel.lt.eo)return
+
+ if(ej.lt.eel-eo)then
+ eemax=eel-max(ej,eo)
+ eemin=max(eel-ej*cem,eo)
+ wbhap=((cem-eel/ej)*sbaba(0,eemin,eemax,eel)
+ * +sbaba(1,eemin,eemax,eel)/ej)/(cem-1.d0)
+ endif
+
+ if(ej.gt.1.0001d0*eo.and.eel-ej/cem.gt.eo)then
+ eemax=eel-max(ej/cem,eo)
+ eemin=max(eel-ej,eo)
+ wbhap=wbhap+((cem*eel/ej-1.d0)*sbaba(0,eemin,eemax,eel)
+ * -cem*sbaba(1,eemin,eemax,eel)/ej)/(cem-1.d0)
+ endif
+ wbhap=max(0d0,wbhap)
+ return
+ end
+
+c-----------------photon spectrum for annihilation-----------------------------
+ double precision function wanng(eel,ej,cem) !so200204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ wanng=0.d0
+ if(ej*cem.lt.1.0001d0*eel)then
+ egmax=ej*cem
+ egmin=max(ej,eo)
+ wanng=(cem*fann(0,egmin,egmax,eel)
+ * -fann(1,egmin,egmax,eel)/ej)/(cem-1.d0)
+ endif
+
+
+ if(ej.gt.1.0001d0*eo)then
+ egmax=ej
+ egmin=max(ej/cem,eo)
+ wanng=wanng+(cem*fann(1,egmin,egmax,eel)/ej
+ * -fann(0,egmin,egmax,eel))/(cem-1.d0)
+ endif
+
+ if(ej*cem.gt.1.0001d0*eel)then
+ egmax=eel+2.d0*amc2
+ egmin=max(ej,eel)
+ wanng=wanng+(cem*fann(1,egmin,egmax,eel)/ej
+ * -fann(0,egmin,egmax,eel))/(cem-1.d0)
+ if(eel.lt.1.01d0*eo)then
+ egmax=eel+2.d0*amc2
+ egmin=eel
+ wanng=wanng+cem*(fann(0,egmin,egmax,eel)
+ * -fann(1,egmin,egmax,eel)/ej)/(cem-1.d0)
+ endif
+ elseif(ej*cem**2.gt.1.0001d0*eel)then
+ egmax=eel+2.d0*amc2
+ egmin=max(ej*cem,eel)
+ wanng=wanng+(cem*fann(0,egmin,egmax,eel)
+ * -fann(1,egmin,egmax,eel)/ej)/(cem-1.d0)
+ endif
+ wanng=max(0d0,wanng)
+ return
+ end
+
+c------------------------------------------------------------------------------
+cionization losses below threshold (strictly speaking, valid only for electrons)
+ double precision function dedzEM(eel,hz,jep) !so230204
+c------------------------------------------------------------------------------
+c hz = Vertical height used in the Sternheimer correction
+c (when using egs4 dedx, be sure that egs tables are intitialized (IniEGS4))
+c better to use EGS4 ones because of the medium dependance (small)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common/cxstern/sterncor,istern !also in egs4 and conex.inc
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+
+
+ MEDIUM=1 !EGS4 info for sternheimer correction
+
+c bt2=1.0d0-(amc2/(amc2+eel))**2
+c if(jep.eq.-1)then
+c tmax=min(eo,eel/2.0d0)
+c drat=log(2.0d0*(eel-tmax)*tmax*(eel/amc2+2.0d0)/0.857d-7**2)
+c drc=-1.0d0-bt2+eel/(eel-tmax)+((tmax/amc2)**2/2.0d0
+c * +(1.0d0+2.0d0*eel/amc2)*log((eel-tmax)/eel))*(1.d0-bt2)
+c else
+c tmax=eo
+c drat=log(2.0d0*eel*tmax*(eel/amc2+2.0d0)/0.857d-7**2)
+c gp=eel/amc2+1.0d0
+c yp=1.0d0/(gp+1.0d0)
+c b1p=2.0d0-yp*yp
+c b2p=(1.0d0-2.0d0*yp)*(3.0d0+yp*yp)
+c b4p=(1.0d0-2.0d0*yp)**3
+c b3p=b4p+(1.0d0-2.0d0*yp)**2
+c drc=bt2*(-1.0d0+(b2p*tmax/eel/2.0d0-b1p)*tmax/eel
+c * +(tmax/eel)**3*(tmax/eel*b4p/4.0d0-b3p/3.0d0))
+c endif
+c
+c delden=0.0d0 !stern-heimer correction
+cc$$$ xede=log((eel/amc2)**2+2.0d0*eel/amc2)
+cc$$$ xed10=xede/(2.0d0*log(10.0d0))
+cc$$$ if(xed10.gt.1.742d0)then
+cc$$$ if(xed10.lt.4.0d0)then
+cc$$$ delden=xede-10.595d0+0.2466d0*(4.0d0-xed10)**2.879d0
+cc$$$ else
+cc$$$ delden=xede-10.595d0
+cc$$$ endif
+cc$$$ endif
+c
+cc ionization losses in exact sence
+c deion0=0.300465d0/2.0d0*amc2*(drat+drc-delden)/bt2
+
+C Energy loss from EGS4
+ EKE=eel*1000.d0 !egs4 in MeV
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=EKE1(MEDIUM)*ELKE+EKE0(MEDIUM)
+
+C ELECTRON
+ IF ((jep.LT.0)) THEN
+ dedx0=(EDEDX1(LELKE,MEDIUM)*ELKE+EDEDX0(LELKE,MEDIUM))*0.001d0
+C POSITRON
+ ELSE
+ dedx0=(PDEDX1(LELKE,MEDIUM)*ELKE+PDEDX0(LELKE,MEDIUM))*0.001d0
+ END IF
+c write(*,*)eel,deion0,dedx0,dedx0/deion0
+ deion0=dedx0
+
+C STERNHEIMER CORRECTION OF DENSITY DEPENDENT IONISATION ENERGY LOSS
+C DEDX. SATURATION VALUE OF DEDX AT HIGH ENERGIES IS PRESSURE DEPENDENT
+C AND SATURATES AT LOWER VALUES FOR HIGHER PRESSURE. THEREFORE THE
+C CROSS-SECTION FILE IS ESTABLISHED WITH GAS PRESSURE OF 1.E-6 ATM
+C (CORRESPONDING TO ABOUT 100 KM HIGHT IN ATMOSPHERE). THE CORRECTION
+C INTRODUCED GIVES VALUES ABOUT 3% TO HIGH IN TRANSITION REGION TO
+C SATURATION. THE PARAMETRISATION IS ONLY VALID FOR U.S. STANDARD ATMOS.
+C Formulas and parameters taken from Corsika 6.020 by Dieter Heck & Al
+C Correction by T. Pierog : Z(NP) (in cm) -> -hz (in m)
+ if(ISTERN.eq.1.and.eel+amc2.ge.3.D-3)then
+ deion=min(deion0,
+ * (86.65D0-STERNCOR+hz*8.D-4)/RLDU(MEDIUM)*1.d-3)
+ else
+C NO DENSITY DEPENDENT STERNHEIMER CORRECTION AT LOW ENERGIES
+ deion=deion0
+ endif
+
+ dedzEM=deion
+ return
+ end
+
+c-----------------------------------------------------pair production----------
+ double precision function spair(eg) !so271103
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common/cxgauss/xgauss7(7),wgauss7(7)
+
+ spair=0.0d0
+ if(eg.lt.2.d0*amc2)return
+
+ if(eg.gt..0021d0)then
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ eel=.5d0*(amc2+eg/2.d0)+xgauss7(i)*(m-1.5d0)*(amc2-eg/2.d0)
+ provi=f2(eel,eg)
+c eel=0.5d0*(2d0*amc2+eg)+xgauss7(i)*(m-1.5d0)*(2d0*amc2-eg)
+c provi=f2(eel+amc2,eg)
+ spair=spair+wgauss7(i)*provi
+ enddo
+ enddo
+ spair=spair*(eg/2.d0-amc2)
+c spair=spair*(eg-2.d0*amc2)*0.5d0
+ else
+ fac=.2d0 !correction factor
+ spair=fac*(eg-2.d0*amc2)
+ endif
+ spair=max(0d0,spair)
+ return
+ end
+
+c-----------------------------------e+- spectrum for pair production-----------
+ double precision function wpaire(eg,ej,cem) !so281103
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common /cxgauss/ xgauss7(7),wgauss7(7)
+
+ sx1=0.0d0
+ sx2=0.0d0
+ if(eg.lt.2.d0*amc2)goto 1
+
+ if(eg.gt..0021d0)then
+ if(ej.lt.eg-2.d0*amc2)then
+ eemax=min(ej*cem,eg-2.d0*amc2)
+ eemin=ej
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ ei=.5d0*(eemax+eemin)+xgauss7(i)*(m-1.5d0)*(eemax-eemin)
+ provi=f2(ei+amc2,eg)
+ sx1=sx1+wgauss7(i)*provi*(cem-ei/ej)
+ enddo
+ enddo
+ sx1=sx1*(eemax-eemin)/(cem-1.d0)/2.d0
+ endif
+ if(ej.gt.1.0001d0*eo.and.ej/cem.lt.eg-2.d0*amc2)then
+ eemax=min(ej,eg-2.d0*amc2)
+ eemin=ej/cem
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ ei=.5d0*(eemax+eemin)+xgauss7(i)*(m-1.5d0)*(eemax-eemin)
+ provi=f2(ei+amc2,eg)
+ sx2=sx2+wgauss7(i)*provi*(cem*ei/ej-1.d0)
+ enddo
+ enddo
+ sx2=sx2*(eemax-eemin)/(cem-1.d0)/2.d0
+ endif
+
+ else
+ fac=.2d0 !correction factor
+ if(ej.lt.eg-2.d0*amc2)then
+ eemax=min(ej*cem,eg-2.d0*amc2)
+ eemin=ej
+ sx1=(cem-.5d0*(eemax+eemin)/ej)*(eemax-eemin)/(cem-1.d0)*fac
+ endif
+ if(ej.gt.1.0001d0*eo.and.ej/cem.lt.eg-2.d0*amc2)then
+ eemax=min(ej,eg-2.d0*amc2)
+ eemin=ej/cem
+ sx2=(.5d0*cem*(eemax+eemin)/ej-1d0)*(eemax-eemin)/(cem-1.d0)*fac
+ endif
+ endif
+1 wpaire=sx1+sx2
+ wpaire=max(0d0,wpaire)
+ return
+ end
+
+c-----------------------------------------------------bremsstrahlung-----------
+ double precision function sbrem(eel) !so250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common/cxgauss/xgauss7(7),wgauss7(7)
+
+ eg1=max(.1d0,eo)
+ sx=0.0d0
+ if(eg1.lt..9999d0*eel)then
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ eg=eg1*(eel/eg1)**(.5d0+xgauss7(i)*(m-1.5d0))
+ provi=f4(eg,eel)
+ sx=sx+wgauss7(i)*provi*eg
+ enddo
+ enddo
+ sx=sx*dlog(eel/eg1)/2.d0
+ else
+ eg1=eel
+ endif
+
+ if(eg1.gt.1.0001d0*eo)then
+ sx1=0.0d0
+ do i=1,7 !gaussian integration for eg<eg1
+ do m=1,2
+ eg=eo*(eg1/eo)**(.5d0+xgauss7(i)*(m-1.5d0))
+ provi=f4(eg,eel)
+ sx1=sx1+wgauss7(i)*provi*eg
+ enddo
+ enddo
+ sx=sx+sx1*dlog(eg1/eo)/2.d0
+ endif
+ sbrem=max(0d0,sx)
+ return
+ end
+
+c-------------------------------------------bremsstrahlung from egs4-----------
+ double precision function fbrem(eel) !tp050304
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+
+ fbrem=0.d0
+ if(eel.lt.eo)return
+ IM=1
+ EKE=eel*1000.d0 !egs4 in MeV
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=int(EKE1(IM)*ELKE+EKE0(IM))
+
+C We use the Branching ratio of POSITRON because the one of ELECTRON
+C include delta process at low energy in EGS4
+ BR=PBR11(LELKE,IM)*ELKE+PBR10(LELKE,IM)
+ if(eel.le.AP(IM)*1d-3)then
+ fbrem=0.d0
+ else
+ sigtot=PSIG1(LELKE,IM)*ELKE+PSIG0(LELKE,IM)
+ fbrem=BR*sigtot
+ endif
+ fbrem=max(0d0,fbrem)
+
+ return
+ end
+
+c---------------------------------photon spectrum for bremsstrahlung-----------
+ double precision function wbremg(eel,ej,cem) !so250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common/cxgauss/xgauss7(7),wgauss7(7)
+
+ sx1=0.0d0
+ sx2=0.0d0
+ if(eel.lt.eo)goto 1
+
+ if(ej.lt..9999d0*eel.and.ej*cem.gt.eo)then !integration from ej/cem to ej if ej>Eo
+ egmax=min(eel,ej*cem)
+ egmin=max(ej,eo)
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ eg=egmin*(egmax/egmin)**(.5d0+xgauss7(i)*(m-1.5d0))
+ provi=f4(eg,eel)
+ sx1=sx1+wgauss7(i)*provi*eg*(cem-eg/ej)
+ enddo
+ enddo
+ sx1=sx1*dlog(egmax/egmin)/2.d0/(cem-1.d0)
+ endif
+
+ if(ej.gt.eo)then
+ egmax=ej
+ egmin=max(ej/cem,eo)
+ do i=1,7 !gaussian integration for eg>eg1
+ do m=1,2
+ eg=egmin*(egmax/egmin)**(.5d0+xgauss7(i)*(m-1.5d0))
+ provi=f4(eg,eel)
+ sx2=sx2+wgauss7(i)*provi*eg*(cem*eg/ej-1.d0)
+ enddo
+ enddo
+ sx2=sx2*dlog(egmax/egmin)/2.d0/(cem-1.d0)
+ endif
+1 wbremg=sx1+sx2
+ wbremg=max(0d0,wbremg)
+ return
+ end
+
+c---------------------------------electron spectrum for bremsstrahlung-----------
+ double precision function wbreme(eel,ej,cem) !so250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ common/cxgauss/xgauss7(7),wgauss7(7)
+
+ sx1=0.0d0
+ sx2=0.0d0
+ sx3=0.0d0
+ if(ej.gt.eo.and.eel-ej/cem.gt.eo)then
+ egmax=eel-max(eo,ej/cem)
+ egmin=max(eel-ej,eo)
+ do i=1,7 !integration from ej/cem to ej
+ do m=1,2
+ eg=egmin*(egmax/egmin)**(.5d0+xgauss7(i)*(m-1.5d0))
+ ei=eel-eg
+ provi=f4(eg,eel)
+ sx1=sx1+wgauss7(i)*provi*eg*(cem*ei/ej-1.d0)
+ enddo
+ enddo
+ sx1=sx1*dlog(egmax/egmin)/2.d0/(cem-1.d0)
+ endif
+
+ if(eel-ej.gt.eo)then !integration from ej to ej*cem
+ egmax=eel-ej
+ egmin=max(eel-ej*cem,eo)
+ do i=1,7
+ do m=1,2
+ eg=egmin*(egmax/egmin)**(.5d0+xgauss7(i)*(m-1.5d0))
+ ei=eel-eg
+ provi=f4(eg,eel)
+ sx2=sx2+wgauss7(i)*provi*eg*(cem-ei/ej)
+ enddo
+ enddo
+ sx2=sx2*dlog(egmax/egmin)/2.d0/(cem-1.d0)
+ endif
+
+ if(ej*cem*1.0001d0.gt.eel)then
+ do i=1,7 !integration for eg<eo
+ do m=1,2
+ eg=eo*(.5d0+xgauss7(i)*(m-1.5d0))
+ provi=f4(eg,eel)*eg
+ sx3=sx3+wgauss7(i)*provi
+ enddo
+ enddo
+ sx3=sx3*eo/2.d0*cem/(cem-1.d0)/eel
+ if(ej*1.001d0.gt.eel)sx3=-sx3
+ endif
+ wbreme=sx1+sx2+sx3
+ wbreme=max(0d0,wbreme)
+ return
+ end
+
+c-----------------------------subroutine differential--------------------------
+ subroutine homo(j,ce2,ce3,cg1,cg3,cp1,cp2,he1,he2,he3
+ *,hg1,hg2,hg3,hp1,hp2,hp3,w1,w2,w3) !so120204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ ce2=0.d0
+ ce3=0.d0
+ cg1=0.d0
+ cg3=0.d0
+ cp1=0.d0
+ cp2=0.d0
+ he1=0.d0
+ he2=0.d0
+ he3=0.d0
+ hg1=0.d0
+ hg2=0.d0
+ hg3=0.d0
+ hp1=0.d0
+ hp2=0.d0
+ hp3=0.d0
+ w1=0.d0
+ w2=0.d0
+ w3=0.d0
+
+ auu=suu(j,j)
+ auv=suv(j,j)
+ avu=svu(j,j)
+ avv=svv(j,j)
+ avw=svw(j,j)
+ aww=sww(j,j)
+ awu=swu(j,j)
+ awv=swv(j,j)
+
+ aaa=2.d0*aww-auu-avv
+ bbb=(auu-aww)*(avv-aww)-auv*avu-awv*avw
+ ccc=(auu-aww)*avw*awv-auv*avw*awu
+ ppp=dsqrt(aaa**2-bbb*3.d0)/3.d0
+ if(abs(ppp).lt.1.d-14)return
+ qqq=.5d0*(aaa*bbb/3.d0-aaa**3/13.5d0-ccc)/ppp**3
+ if(abs(qqq).le.1.d0)then
+ alf=acos(qqq)
+ elseif(abs(qqq)-1.d0.lt.1.d-10)then
+ alf=pi*0.5d0*(1.d0-qqq)
+ else
+ write(*,*)'qqq,ppp,aaa,bbb,ccc',qqq,ppp,aaa,bbb,ccc
+ alf=0.d0
+ stop
+ endif
+
+ w1=(auu+avv+aww)/3.d0-2.d0*ppp*cos((alf+pi)/3.d0)
+ w2=(auu+avv+aww)/3.d0+2.d0*ppp*cos(alf/3.d0)
+ w3=(auu+avv+aww)/3.d0-2.d0*ppp*cos((alf-pi)/3.d0)
+ if(abs(aww).gt.1.d-14.and.auu/aww.gt.1.d0)then
+ w4=w1
+ w1=w3
+ w3=w4
+ endif
+
+ if(abs((w1-aww)*(w1-avv)-avw*awv).le.1.d-14)then
+ cp1=0.d0
+ cg1=avu/(w1-avv)
+ else
+ cp1=(avu*awv+awu*(w1-avv))/((w1-aww)*(w1-avv)-avw*awv)
+ cg1=(avu+cp1*avw)/(w1-avv)
+ endif
+ ce2=0.d0
+ cp2=0.d0
+ if(abs(w2-auu).gt.1.d-14)ce2=auv/(w2-auu)
+ if(abs(w2-aww).gt.1.d-14)cp2=(awv+ce2*awu)/(w2-aww)
+ if(avu.eq.0.d0)then
+ ce3=0.d0
+ cg3=0.d0
+ elseif(auv.eq.0.d0)then
+ ce3=0.d0
+ cg3=0.d0
+ if(abs(w3-avv).gt.1.d-14)cg3=avw/(w3-avv)
+ else
+ ce3=avw*auv/((w3-auu)*(w3-avv)-avu*auv)
+ cg3=(avw+ce3*avu)/(w3-avv)
+ endif
+
+ he1=1.d0/(1.d0-cg1*ce2-(ce3-cg3*ce2)*(cp1-cp2*cg1)/(1.d0-cg3*cp2))
+ he2=he1*(cg3*(cp1-cp2*cg1)/(1.d0-cg3*cp2)-cg1)
+ he3=-he1*(cp1-cp2*cg1)/(1.d0-cg3*cp2)
+
+ hp1=-he1*(ce3-cg3*ce2)/(1.d0-cg3*cp2)
+ hp2=-(cg3+he2*(ce3-cg3*ce2))/(1.d0-cg3*cp2)
+ hp3=(1.d0-he3*(ce3-cg3*ce2))/(1.d0-cg3*cp2)
+
+ hg1=-he1*ce2-hp1*cp2
+ hg2=1.d0-he2*ce2-hp2*cp2
+ hg3=-he3*ce2-hp3*cp2
+
+
+ return
+ end
+
+c--------------------------------------delta-electron from electron--------------
+ double precision function smoel(idef,xe1,xe2,eel) !nk190204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ smoel=0.d0
+ if(eel.lt.2.d0*eo)return
+
+ d=0.075116d0
+ ge=eel/amc2+1.0d0
+ bet2=1.0d0-1.0d0/ge**2
+ c1=(1.0d0-1.0d0/ge)**2
+ c2=(2.0d0*ge-1.0d0)/ge**2
+ t1=xe1/eel
+ t2=xe2/eel
+ t3=1.0d0-t2
+ t4=1.0d0-t1
+
+ if(idef.eq.0)then
+ fm=(c1*(t2-t1)+(1.0d0/t1-1.0d0/t2)+(1.0d0/t3-1.0d0/t4)
+ * -c2*log((t2*t4)/(t1*t3)))*amc2/eel
+ else
+ fm=(c1/2.0d0*(t2-t1)*(t2+t1)+log(t2/t1)-(c2+1.0d0)*log(t4/t3)
+ * +(1.0d0/t3-1.0d0/t4))*amc2
+ endif
+ smoel=max(0.d0,fm*d/bet2)
+ return
+ end
+
+c-----------------------------delta-electron from electron of EGS--------------
+ double precision function fmoel(idef,xe1,xe2,eel) !tp 050304
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+
+ IM=1
+ fmoel=0.d0
+ if(eel.le.THMOLL(IM)*1.d-3)then !under this threshold, EGS4 cross section not defined
+ fmoel=smoel(idef,xe1,xe2,eel)
+ return
+ endif
+ EKE=eel*1000.d0 !egs4 in MeV
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=int(EKE1(IM)*ELKE+EKE0(IM))
+
+C Bremstrahlung Branching ratio
+ BR=EBR11(LELKE,IM)*ELKE+EBR10(LELKE,IM)
+ sigtot=ESIG1(LELKE,IM)*ELKE+ESIG0(LELKE,IM)
+ fmoel=max(0.d0,sigtot*(1.d0-br))
+ return
+ end
+
+c----------------------------------------delta-electron from positron----------
+ double precision function sbaba(idef,xe1,xe2,eel) !nk190204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ sbaba=0.d0
+ if(eel.lt.eo)return
+
+ d=0.150232d0
+ t1=xe1/eel
+ t2=xe2/eel
+ gp=eel/amc2+1.0d0
+ bet2=1.0d0-1.0d0/gp**2
+ yp=1.0d0/(gp+1.0d0)
+ b1p=2.0d0-yp*yp
+ b2p=(1.0d0-2.0d0*yp)*(3.0d0+yp*yp)
+ b4p=(1.0d0-2.0d0*yp)**3
+ b3p=b4p+(1.0d0-2.0d0*yp)**2
+ if(idef.eq.0)then
+ fb=((1.0d0/t1-1.0d0/t2)/bet2-b1p*log(t2/t1)+b2p*(t2-t1)+t2**2
+ * *(t2*b4p/3.0d0-b3p/2.0d0)-t1**2*(t1*b4p/3.0d0-b3p/2.0d0))/eel
+ else
+ fb=(1.0d0/bet2*log(t2/t1)+(b2p*(t2+t1)/2.0d0-b1p)*(t2-t1)
+ * +t2**3*(t2*b4p/4.0d0-b3p/3.0d0)-t1**3*(t1*b4p/4.0d0-b3p/3.0d0))
+ endif
+ sbaba=max(0.d0,fb*d*amc2)
+ return
+ end
+
+c----------------------------------------delta-electron from positron----------
+ double precision function fbaba(eel) !nk190204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+
+ fbaba=0.d0
+ if(eel.lt.Eo)return
+
+ IM=1
+ EKE=eel*1000.d0 !egs4 in MeV
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=int(EKE1(IM)*ELKE+EKE0(IM))
+
+C Bremsstrhalung Branching ratio
+ BR=PBR11(LELKE,IM)*ELKE+PBR10(LELKE,IM)
+ if(eel.le.AP(IM)*1d-3)BR=0.d0
+ sigtot=PSIG1(LELKE,IM)*ELKE+PSIG0(LELKE,IM)
+ fbaba=sigtot*(PBR21(LELKE,IM)*ELKE+PBR20(LELKE,IM)-BR)
+ fbaba=max(0d0,fbaba)
+ return
+ end
+
+c-----------------------------------------------annihilation-------------------
+ double precision function fann(idef,egini,egfin,ep) !nk190204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ fann=0.d0
+ d=0.075116d0
+ gfact=ep/amc2+1.0d0
+ gavail=gfact+1.0d0
+ ac2=gavail+2.d0*gfact/gavail
+ xmin=2.d0/(ac2+sqrt(ac2-2.0d0)*sqrt(ac2+2.0d0))
+ xmax=gavail-xmin
+ eg1nrm=max(egini/amc2,xmin)
+ eg2nrm=min(egfin/amc2,xmax)
+ if(eg1nrm.ge.eg2nrm)return
+
+ if(idef.eq.0)then
+ xaux1=-(eg2nrm-eg1nrm)+ac2*log(eg2nrm/eg1nrm)
+ if(xaux1.le.0.d0)
+ * xaux1=(eg2nrm-eg1nrm)*2.d0/gavail*(1.d0-1.d0/gavail)
+ xaux1=xaux1-(eg2nrm-eg1nrm)/eg1nrm/eg2nrm
+ xaux2=-(eg2nrm-eg1nrm)+ac2*log(min(gavail-eg1nrm,xmax)
+ * /max(gavail-eg2nrm,xmin))
+ if(xaux2.le.0.d0)
+ * xaux2=(eg2nrm-eg1nrm)*(2.d0/gavail*(1.d0-1.d0/gavail)
+ * +(eg2nrm+eg1nrm)/2.0d0/gavail*(1.d0+2.d0/gavail))
+ xaux2=xaux2-(eg2nrm-eg1nrm)/min(gavail-eg1nrm,xmax)
+ * /max(gavail-eg2nrm,xmin)
+ if(xaux1.lt.0.d0.or.xaux2.lt.0.d0)
+ * write(*,*)'idef',idef,xaux1,xaux2
+
+ else
+ xaux1=((eg2nrm-eg1nrm)*(ac2-(eg2nrm+eg1nrm)/2.0d0)
+ * -log(eg2nrm/eg1nrm))*amc2
+ if(xaux1.lt.0.d0)write(*,*)'idef-1',idef,xaux1
+ xaux2=-(eg2nrm-eg1nrm)*(ac2+(eg2nrm+eg1nrm)/2.0d0)
+ * +ac2*gavail*log(min(gavail-eg1nrm,xmax)/max(gavail-eg2nrm,xmin))
+ if(xaux2.le.0.d0)
+ * xaux2=(eg2nrm-eg1nrm)*(eg2nrm+eg1nrm)/gavail*(1.d0-1.d0/gavail)
+ xaux2=(xaux2+log(min(gavail-eg1nrm,xmax)/max(gavail-eg2nrm,xmin))
+ * -(eg2nrm-eg1nrm)/min(gavail-eg1nrm,xmax)/max(gavail-eg2nrm,xmin)
+ * *gavail)*amc2
+ if(xaux2.lt.-1.d-5)write(*,*)'idef-2',idef,xaux2
+ if(xaux2.lt.0.d0)xaux2=0.d0
+ endif
+ fann=(xaux1+xaux2)*d/(gfact-1.0d0)/(gfact+1.0d0)
+ fann=max(0d0,fann)
+ return
+ end
+
+c------------------------------- annihilation cross section from egs4----------
+ double precision function sheitl(eel) !tp170304
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+
+ sheitl=0.d0
+ if(eel.lt.Eo)return
+
+ IM=1
+ EKE=eel*1000.d0 !egs4 in MeV
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=int(EKE1(IM)*ELKE+EKE0(IM))
+
+C Bremsstrhalung +bhabha Branching ratio
+ BR=PBR21(LELKE,IM)*ELKE+PBR20(LELKE,IM)
+ sigtot=PSIG1(LELKE,IM)*ELKE+PSIG0(LELKE,IM)
+ sheitl=sigtot*(1.d0-BR)
+ sheitl=max(0d0,sheitl)
+ return
+ end
+
+c------------------------------------ pair cross section from egs4----------
+ double precision function sigpar(eg) !tp170304
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+
+ sigpar=0.d0
+ if(eg.lt.max(Eo,2.d0*amc2))return
+
+ IM=1
+ GE=eg*1000.d0 !egs4 in MeV
+ GLE=LOG(GE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LGLE=int(GE1(IM)*GLE+GE0(IM))
+
+ sigtot=(GMFP1(LGLE,IM)*GLE+GMFP0(LGLE,IM))
+ if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+C Pair Branching ratio
+ BR4=1.d0-(GBR41(LGLE,IM)*GLE+GBR40(LGLE,IM))
+ if(eg.le.2.d0*amc2)BR4=0.d0
+ sigpar=max(0d0,sigtot*br4)
+ return
+ end
+
+c------------------------------------ compton cross section from egs4----------
+ double precision function fcompt(eg) !tp170304
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+
+ fcompt=0.d0
+ if(eg.lt.Eo)return
+
+ IM=1
+ GE=eg*1000.d0 !egs4 in MeV
+ GLE=LOG(GE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LGLE=int(GE1(IM)*GLE+GE0(IM))
+
+ sigtot=(GMFP1(LGLE,IM)*GLE+GMFP0(LGLE,IM))
+ if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+C Pair Branching ratio
+ BR4=1.d0-(GBR41(LGLE,IM)*GLE+GBR40(LGLE,IM))
+ if(eg.le.2.d0*amc2)BR4=0.d0
+ br3=1.d0-(GBR31(LGLE,IM)*GLE+GBR30(LGLE,IM))
+ fcompt=max(0d0,sigtot*(br3-br4))
+ return
+ end
+
+c------------------------------------ muon pair cross section from egs4--------
+ double precision function sigmupar(eg) !tp061204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+
+ sigmupar=0.d0
+ if(eg.lt.max(Eo,rmmut2*1.d-3))return
+
+ IM=1
+ GE=eg*1000.d0 !egs4 in MeV
+ GLE=LOG(GE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LGLE=int(GE1(IM)*GLE+GE0(IM))
+
+ sigtot=(GMFP1(LGLE,IM)*GLE+GMFP0(LGLE,IM))
+ if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+C Muon Pair Branching ratio
+ BR1=GBR11(LGLE,IM)*GLE+GBR10(LGLE,IM)
+ if(GE.le.rmmut2)br1=0.d0
+ sigmupar=max(0d0,sigtot*br1)
+ return
+ end
+
+c---------------------------- photonuclear effect cross section from egs4------
+ double precision function sigphonu(eg) !tp061204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+
+ sigphonu=0.d0
+ if(eg.le.max(Eo,pithr*1.d-3))return
+
+ IM=1
+ GE=eg*1000.d0 !egs4 in MeV
+ GLE=LOG(GE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LGLE=int(GE1(IM)*GLE+GE0(IM))
+
+ sigtot=(GMFP1(LGLE,IM)*GLE+GMFP0(LGLE,IM))
+ if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+C Muon Pair Branching ratio
+ BR1=GBR11(LGLE,IM)*GLE+GBR10(LGLE,IM)
+ if(GE.le.rmmut2)br1=0.d0
+ BR2=GBR21(LGLE,IM)*GLE+GBR20(LGLE,IM)
+ if(GE.le.pithr)br2=0.d0
+ sigphonu=max(0d0,sigtot*(br2-br1))
+ return
+ end
+
+c---------------------------- photoelectric effect cross section from egs4------
+ double precision function sigphoel(eg) !tp171204
+c------------------------------------------------------------------------------
+c Photoelectric effect is not in CE, but take into account cross section for
+c gamma loss.
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+
+ sigphoel=0.d0
+ if(eg.le.Eo)return
+
+ IM=1
+ GE=eg*1000.d0 !egs4 in MeV
+ GLE=LOG(GE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LGLE=int(GE1(IM)*GLE+GE0(IM))
+
+ sigtot=(GMFP1(LGLE,IM)*GLE+GMFP0(LGLE,IM))
+ if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+C Muon Pair + photonuclear effect Branching ratio
+ BR2=GBR21(LGLE,IM)*GLE+GBR20(LGLE,IM)
+ if(GE.le.pithr)br2=0.d0
+C Pair + compton Branching ratio
+ br3=1.d0-(GBR31(LGLE,IM)*GLE+GBR30(LGLE,IM))
+
+ sigphoel=max(0.d0,sigtot*(1.d0-br2-br3))
+
+ return
+ end
+
+c$$$c----------------------------------------annihilation cross section------------
+c$$$ double precision function sheitl(eel) !nk190204
+c$$$c------------------------------------------------------------------------------
+c$$$ implicit double precision (a-h,o-z)
+c$$$ common /cxarea15/ amc2,eo,radle
+c$$$
+c$$$ gft1=eel/amc2+1.0d0
+c$$$ gft2=gft1**2-1.0d0
+c$$$ gft3=sqrt(gft1+1.0d0)*sqrt(gft1-1.0d0)
+c$$$ gaux=2.0d0/(gft1+1.0d0)
+c$$$ sheitl=0.075116d0*((gft1+3.0d0-gaux)*log(gft1+gft3)
+c$$$ *-gft3*(1+gaux))/gft2
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-----------------------------------------------------pair production----------
+c$$$ double precision function sigpar(eg) !nk250204
+c$$$c------------------------------------------------------------------------------
+c$$$ implicit double precision (a-h,o-z)
+c$$$ common /cxarea15/ amc2,eo,radle
+c$$$
+c$$$ sigpar=0.d0
+c$$$ if(eg.le.2.d0*amc2)return
+c$$$
+c$$$ emev=eg*1.0d3
+c$$$ if(emev.ge.50.0d0)then
+c$$$ ak=0.156d0+0.001d0*log(emev/50.0d0)/log(2.0d0)
+c$$$ ae1=0.47d0+0.0025d0*log(emev/50.0d0)/log(2.0d0)
+c$$$ if(emev.gt.125.0d0)then
+c$$$ ae2=1.32d0+0.0160d0*log(emev/125.0d0)/log(2.0d0)
+c$$$ else
+c$$$ ae2=1.32d0
+c$$$ endif
+c$$$ xs=ak*(emev**ae1-1.15d0)**ae2
+c$$$ xs=xs/(1.0d0+xs)*0.021133d0
+c$$$
+c$$$ else
+c$$$ ak=0.1425d0
+c$$$ ae1=0.47d0
+c$$$ ae2=1.32d0
+c$$$ if(emev.ge.30.0d0)then
+c$$$ xs=ak*(emev**ae1-1.15d0)**ae2
+c$$$ cs=0.021165d0-0.000092d0*((emev-30.0d0)/10.0d0)
+c$$$ * +0.000075d0*((emev-30.0d0)/10.0d0)*((emev-40.0d0)/10.0d0)
+c$$$ xs=xs/(1.0d0+xs)*cs
+c$$$ elseif(emev.ge.20.0d0)then
+c$$$ xs=ak*(emev**ae1-1.15d0)**ae2
+c$$$ xs=xs/(1.0d0+xs)*0.021165d0
+c$$$ elseif(emev.ge.10.0d0)then
+c$$$ xs=ak*(emev**ae1-1.15d0)**ae2
+c$$$ cs=0.021272d0-0.000008d0*((emev-10.0d0)/5.0d0)
+c$$$ * -0.000046d0*((emev-10.0d0)/5.0d0)*((emev-15.0d0)/5.0d0)
+c$$$ xs=xs/(1.0d0+xs)*cs
+c$$$ elseif(emev.ge.6.0d0)then
+c$$$ xs=ak*(emev**ae1-1.15d0)**ae2
+c$$$ cs=0.021105d0+0.000191d0*((emev-6.0d0)/2.0d0)
+c$$$ * -0.000108d0*((emev-6.0d0)/2.0d0)*((emev-8.0d0)/2.0d0)
+c$$$ xs=xs/(1.0d0+xs)*cs
+c$$$ elseif(emev.ge.1.5d0)then
+c$$$ xs=9.924d-5*((emev-1.022d0)/0.478d0)**2.864d0
+c$$$ * *(1.5d0/emev)**2.34625d0
+c$$$ elseif(emev.lt.1.5d0)then
+c$$$ xs=9.924d-5*((emev-1.022d0)/0.478d0)**0.90767d0
+c$$$ endif
+c$$$ endif
+c$$$ sigpar=xs
+c$$$ return
+c$$$ end
+c$$$
+c------------------------------------------------------------------------------
+ double precision function f2(e2,e1) !nk250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ e3 = e1-e2
+ f2 = 0.d0
+ if(e2.lt.amc2.or.e3.lt.amc2)return
+
+ coef = 1.4742d-3
+ dltb = .5d0*amc2*e1/e2/e3
+ if(e1.gt.5.d-2)then
+ fcoul = 3.3d-3
+ sp1 = fscrn1(dltb)-2.6321d0-4.d0*fcoul
+ sp2 = fscrn2(dltb)-2.6321d0-4.d0*fcoul
+ else
+ sp1 = fscrn1(dltb)-2.6321d0
+ sp2 = fscrn2(dltb)-2.6321d0
+ endif
+ f2 = coef/e1**3*((e2*e2+e3*e3)*sp1+.66667d0*e2*e3*sp2)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function fscrn1(dltb) !nk250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ dlt=140.86d0*dltb
+ if(dlt.le.1.d0)then
+ dlt2=dlt*dlt
+ fscrn1=20.867d0-3.242d0*dlt+.625d0*dlt2
+ else
+ fscrn1=21.12d0-4.184d0*log(dlt+.952d0)
+ endif
+ fscrn1=max(fscrn1,2.6453d0)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function fscrn2(dltb) !nk250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ dlt=140.86d0*dltb
+ if(dlt.le.1.d0)then
+ dlt2=dlt*dlt
+ fscrn2=20.029d0-1.93d0*dlt-.086d0*dlt2
+ else
+ fscrn2=21.12d0-4.184d0*log(dlt+.952d0)
+ endif
+ fscrn2=max(fscrn2,2.6453d0)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function f4(eg,eel) !nk250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /cxarea15/ amc2,eo,radle
+
+ e2=eg
+ e1=eel+amc2
+ e3=e1-e2
+ e31=e3/e1
+ coef=1.4742d-3
+ dltb=5.d-1*amc2*e2/e1/e3
+ if(e1.gt.5.d-2)then
+ fcoul=3.3d-3
+ sp1=fscrn1(dltb)-2.6321d0-4.d0*fcoul
+ sp2=fscrn2(dltb)-2.6321d0-4.d0*fcoul
+ else
+ sp1=fscrn1(dltb)-2.6321d0
+ sp2=fscrn2(dltb)-2.6321d0
+ endif
+ f4=coef/e2*((1.d0+e31*e31)*sp1-6.6667d-1*e31*sp2)*aprim(e1)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function aprim(e) !nk250204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ dimension aprimd(12),eprim(12)
+ data aprimd/1.32d0,1.26d0,1.18d0,1.13d0,1.09d0,1.07d0
+ *,1.05d0,1.04d0,1.03d0,1.02d0, 1.d0, 1.d0/
+ *,eprim/2.d-3,3.d-3,4.d-3, 5.d-3, 6.d-3, 7.d-3
+ *,8.d-3,9.d-3,1.d-2,1.1d-2,2.1d-2,3.1d-2/
+
+ if(e.ge.2.1d-2)then
+ aprim = 1.d0
+ elseif(e.lt.2.d-3)then
+ aprim = aprimd(1)
+ else
+ ie = 1
+ do while(eprim(ie).le.e)
+ ie = ie+1
+ enddo
+ f1 = aprimd(ie-1)
+ f2 = aprimd(ie)
+ f3 = aprimd(ie+1)
+ x1 = e-eprim(ie-1)
+ x2 = e-eprim(ie)
+ x3 = e-eprim(ie+1)
+ x12 = eprim(ie-1)-eprim(ie)
+ x13 = eprim(ie-1)-eprim(ie+1)
+ x23 = eprim(ie)-eprim(ie+1)
+ aprim = f1*x2*x3/x12/x13-f2*x1*x3/x12/x23+f3*x1*x2/x13/x23
+ endif
+ return
+ end
+
+c Hadronic cascade routines
+c (created by ???; updated by S. Ostapchenko and T. Pierog)
+c Last modifications 28.06.2017 correction for energy deposit by T.Pierog
+
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine d2hsource(nsi,j,px,py)
+c-----------------------------------------------------------------------
+c Copy current particle below cut off into source function for CE
+c nsi : 1 ... protons
+c 2 ... charged pions
+c 3 ... charged kaons
+c 4 ... neutral kaon Klong
+c 5 ... neutral kaon Kshort
+c 6 ... neutrons
+c 7 ... muons
+c 100 ... primary particle (proton or nucleus)
+c j : slant depth bin
+c px, py : transverse momentum in shower frame (only for 3D)
+c Authors S. Ostaptchenko and T. Pierog, last modifications 15.04.04
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ id=0
+ if(j.gt.maximz)return
+ epkin=dptl(4)-dptl(5) !kinetic energy
+
+ if(epkin.lt.0.d0)then
+ write(*,*) 'what append ???? in d2hsource',epkin,dptl(10)
+#ifdef __CXDEBUG__
+ write(*,*) 'what append ???? in d2hsource',epkin,dptl(10)
+#endif
+ return
+ endif
+
+ if(nsi.eq.100)then
+ id=abs(nint(dptl(10)))
+ wt=1.d0
+ if(id.ge.100.and.mod(id,100).eq.0)then !nuclei
+ ns=1
+ id=int(id/100)
+ wt=dble(id)
+ epkin=epkin/wt
+ id=id*10
+ elseif(id.eq.14)then !muon
+ ns=7
+ elseif(id.eq.1220)then !neutron
+ ns=6
+ elseif(id.eq.20)then !Ks or Kl
+ ns=4+nint(0.5d0*(1.d0+sign(1.d0,dptl(10))))
+ elseif(id.eq.130)then !charged K
+ ns=3
+ elseif(id.eq.130)then !charged Pi
+ ns=2
+ else !proton
+ ns=1
+ endif
+ nsi=ns
+ else
+ ns=abs(nsi)
+ nab=0
+ if(nsi.lt.0.and.(ns.eq.1.or.ns.eq.6))nab=1
+ wt=dptl(11)
+ endif
+ egycut=ehcut
+ if(ns.eq.7)egycut=emcut
+ egycut=min(egycut,eeha(iemax))
+
+c Each particle of energy Epkin is splitted between two e-bins with weights
+c appp1, appp2 ( appp1 + appp2 = 1, E_i * appp1 + E_(i+1) * appp2 = Epkin)
+ if(epkin.ge.eeha(iemax)*c2ha)then
+ i=iemax-1
+ appp2=epkin/egycut
+ appp1=0.d0
+ else
+ i=int(1.d0+log10(epkin/exmin)*decade)
+ appp1=(eeha(i+1)-epkin)/(eeha(i+1)-eeha(i))
+ appp2=1.d0-appp1
+ endif
+ if(i.eq.iemax.and.abs(appp2).lt.1.d-10)then
+ i=i-1
+ appp2=appp1
+ appp1=0.d0
+ elseif(i.ge.iemax)then
+ write(*,*)'source above limit',i,iemax,appp1,appp2,epkin,egycut
+ endif
+ if(appp1.lt.-1.d-10.or.appp2.lt.-1.d-10
+ *.or.appp1.gt.1.0000000001d0.or.appp2.gt.1.0000000001d0)then
+ write(*,*)'d2hsource appp',epkin,i,eeha(i),eeha(i+1),appp1,appp2
+ &,dptl(10),dptl(13)
+ appp1=max(0.d0,appp1)
+ appp2=max(0.d0,appp2)
+ endif
+
+
+c isoumax corresponds to maximal source particle energy
+c jsoumin corresponds to minimal source particle depth
+ isoumax=min(max(i+1,isoumax),iemax)
+ jsoumin=min(j,jsoumin)
+ hsource(ns,i,j) = hsource(ns,i,j) + wt*appp1
+ hsource(ns,i+1,j) = hsource(ns,i+1,j) + wt*appp2
+ if(lXfirst.and.nab.ne.0)antibars(j)=antibars(j)+wt !antiproton or antineutron
+#if __MC3D__ || __CXLATCE__
+ pt2=px**2+py**2
+ hpt2source(ns,i,j)=hpt2source(ns,i,j)+wt*appp1*pt2
+ hpt2source(ns,i+1,j)=hpt2source(ns,i+1,j)+wt*appp2*pt2
+#endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write (ifck,*)
+ * 'd2hsource: added particle :'
+ * ,i,appp1,i+1,appp2,wt,j,ns,nab,isoumax,jsoumin
+#if __MC3D__ || __CXLATCE__
+ * ,pt2
+#endif
+#ifndef __CXCORSIKA__
+ if(isx.ge.6)then
+#endif
+ id=nint(dptl(10))
+ ida=abs(id)
+ ebal=dptl(4)
+ if(lXfirst.and.ida.ge.1000)ebal=ebal-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice
+ etotsource=etotsource+ebal*dptl(11)
+#ifndef __CXCORSIKA__
+ endif
+#endif
+#endif
+
+ end
+
+
+c-------------------------------------------------------------------------
+ subroutine IniHadSource
+c-------------------------------------------------------------------------
+c initialization of hadronic source function
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+#ifdef __CXSUB__
+ do j=1,maximZ
+ antibars(j)=0.d0
+ do i=1,maximE
+#else
+ do j=1,mzHa
+ antibars(j)=0.d0
+ do i=iemin,iemax
+#endif
+ do k=1,8
+ hsource(k,i,j)=0.d0
+#if __MC3D__ || __CXLATCE__
+ hpt2source(k,i,j)=0.d0
+#endif
+ enddo
+ enddo
+ enddo
+ isoumax=0
+ jsoumin=mzHa
+
+
+ return
+ end
+
+#ifdef __MC3D__
+c-----------------------------------------------------------------------
+ subroutine HadronLowShower(kj,ki)
+c-----------------------------------------------------------------------
+c Sample current CE particles below low energy cut off into MC stack
+c and simulate low energy subshower (not to fill stack too much)
+c kj : first slant depth bin of CE
+c ki : slant depth bin
+c loop on np if k is large enough
+c np : 1 ... protons
+c 2 ... charged pions
+c 3 ... charged kaons
+c 4 ... neutral kaon Klong
+c 5 ... neutral kaon Kshort
+c 6 ... nothing (no pi0 subshower)
+c 7 ... neutrons
+c Author : T. Pierog, last modifications 29.01.10
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x(0:maximE),y(maximE),x1(maximE),y1(maximE)
+ & ,y2(maximE)
+ double precision Eout,Eini,Sum,Efin,dl,sintet,costet,am,P,h,dl0
+ double precision heightt,drangen,Xout,dlmu,rtr,depthmn!,Ediff
+ &,distance0,xNpart,yNtry,wmax,ebal,zz,xi,fmin,fminh,radtr
+ external heightt,drangen,distance0,distant,height,deptht,depth
+ integer np,Ibin,i,Itab,id,npmin,npmax,k,ki,kj,npo,imx
+ &,icut,nstck,npt,imn,istep,istp
+ double precision ep(3),rsin2th,s0xs,c0xs,s0s,c0s,phi,pt,dd,csp
+ &,sinphiP,cosphiP,sintheP,costheP,t0,x0,y0,h0,d0,dist,distant,da
+ &,sintet0,costet0,height,deptht,depth,snp,frac
+ integer j,l
+ logical go,cont,cut,cutsave
+#ifndef __CXCORSIKA__
+ double precision dptlsave(mxblk)
+ integer idum,isave
+#endif
+
+ npmin=1
+ if(ki.lt.0)then
+ npmax=9
+ k=-ki
+ else
+ k=ki
+ if(k.lt.mzmc.or.iehmc.le.iemin)npmin=9
+c if(k.lt.mzmc)npmin=19
+ npmax=9
+ if(iemmc.le.iemin)npmax=7
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)then
+ write(ifck,*) '--------------------------------------------'
+ if(ki.lt.0)write(ifck,*) 'Final sampling'
+ write(ifck,*) 'Sample depth k ',k,zha(k),' for ',npmin,npmax
+ endif
+#endif
+
+C fix common particle variables
+
+ if(ki.lt.0)then
+ zz=zha(k)
+ else
+#ifdef __CXCORSIKA__
+ zz=zha(k)-0.06d0*(1.d0+0.66d0*sinthet)*min(1d0,0.1d0*dzHa) !slant depth along shower axis
+#else
+ zz=zha(k)-0.0001d0*min(1d0,0.1d0*dzHa) !slant depth along shower axis
+#endif
+ endif
+ dl=distance0(zz)
+ if(dl.lt.distz(k))write(*,*)'Warning for dl in HadronLowShower'
+ & ,k,zz,dl,distz(k)
+ h=heightt(dl,radtr0)
+ dptl(1)=0d0
+ dptl(2)=0d0
+c x,y-coordinates with respect to the obs.
+ dl0=dl-sign(DistAlt,zsaxis)
+ dptl(6)=dl0*xsaxis !x-coordinate
+ dptl(7)=dl0*ysaxis !y-coordinate
+ dptl(8)=h !height, m
+c beta=sqrt((1.d0-pmass(7)/Eprima)*(1.d0+pmass(7)/Eprima))*cxlight
+ dptl(9)=-dl0 !time
+ if(i1DMC.le.1)then
+c angles for momentum
+ sintet=sign(min(1.d0,radtr0/(h+radearth)),dl0) !sin angle between impact parameter and starting point
+ costet=sign(dsqrt(1.d0-sintet*sintet),dl-1.d-10)
+c rotation angle for momentum after pt
+ ep(1)=0d0
+ ep(2)=sintet
+ ep(3)=costet
+ call cxdefrot(ep,s0xs,c0xs,s0s,c0s)
+ endif
+ if(ki.ge.mzHa)then
+ cut=.false.
+ dptl(12)=1000d0
+ if(iehmc.lt.iemax.and.iehmc.ne.0)then !sample above lowE with weight 1
+ istep=2
+ else
+ istep=1
+ endif
+ elseif(ki.lt.0)then
+ cut=.false.
+ dptl(12)=1000d0
+ istep=1
+ else
+ cut=ihthin.eq.1 !use variable weight and energy conservation only with thinning
+ dptl(12)=800d0 !generation
+ istep=1
+ endif
+ dptl(13)=zz !slant depth along shower axis
+ dptl(14)=0d0 !x-coordinate in shower frame
+ dptl(15)=0d0 !y-coordinate in shower frame
+ dptl(16)=dl !slant distance along shower axis
+
+ if(cut)then
+ fminh=0.4d1/(decade*log10(ehlow/enymin)) !at minimum, # particles = 0.5 * # bin per decade
+ else
+ fminh=1d10
+ endif
+ go=.false.
+ cutsave=cut
+
+ do np=npmin,npmax
+
+ if(np.eq.6.or.np.eq.8)goto 200
+
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*) 'Sample particle type ',np
+#endif
+ if(np.eq.9.and.iemmc.gt.iehmc.and.iehmc.ne.0.and.ki.gt.0)istep=2
+
+ fmin=fminh
+ imn=iemin
+ if(np.ne.1.and.np.ne.7)then
+ depthmn=depth(HGrd)-depth(h) !depth is vertical depth from top of atmo to h
+ if(depthmn.gt.zshlow)then !cut low energy if vertical depth larger than zshlow
+c considering energy loss as 1 MeV / g/cm2, we don't have to generate particles
+c with too low energy far from the ground
+ imn=max(imn,1+int(log10(depthmn*0.001*c2ha/exmin)*dnHa))
+ endif
+ endif
+ cut=cutsave
+
+ do istp=1,istep
+
+
+ if(istp.eq.2)then
+c last depth bin : sample all particles with weight 1 above elow(maxE is half a bin) with a maximum of 100000 particles
+ imn=imx+1
+ if(np.eq.9.and.k.lt.mzHa)then
+ imx=iemmc-1
+ else
+ imx=iemax
+ endif
+ fmin=min(fmin,1d-5)
+ cut=.false.
+ elseif(np.eq.9.and.iemmc.gt.iehmc.and.iehmc.ne.0.and.ki.gt.0)then
+ imx=iehmc-1
+ elseif(ki.gt.0)then
+c by definition (in bas), ehlow (emlow) are defined as the lower bin edge of iehmc (iemmc)
+ imx=iehmc-1
+ if(np.eq.9)imx=iemmc-1
+ else !last sample if only CE with 100000 part. per type to get energy distribution
+ imx=iemax
+ fmin=min(fmin,1d-5)
+ endif
+
+ if(imx.ge.iemax)imx=iemax
+
+ cont=.false.
+
+C fill array to be converted
+ Ibin=0
+ Sum=0d0
+ Eini=0d0
+ npo=np
+ npt=np
+ wmax=wshmax
+ if(np.eq.1)then
+ do i=imn,imx
+ if(.not.cont.and.rpHa(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=rpHa(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(np))
+ rpHa(i,1)=0d0
+ enddo
+ id=1120
+ elseif(np.eq.2)then
+ do i=imn,imx
+ if(.not.cont.and.ppHa(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=ppHa(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(np))
+ ppHa(i,1)=0d0
+ enddo
+ id=120
+ elseif(np.eq.3)then
+ do i=imn,imx
+ if(.not.cont.and.rkz(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=rkz(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(np))
+ rkz(i,1)=0d0
+ enddo
+ id=130
+ elseif(np.eq.4)then
+ do i=imn,imx
+ if(.not.cont.and.rkl(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=rkl(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(np))
+ rkl(i,1)=0d0
+ enddo
+ id=-20
+ elseif(np.eq.5)then
+ do i=imn,imx
+ if(.not.cont.and.rks(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=rks(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(4))
+ rks(i,1)=0d0
+ enddo
+ id=20
+ npo=4
+ elseif(np.eq.7)then
+ do i=imn,imx
+ if(.not.cont.and.rnHa(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=rnHa(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(6))
+ rnHa(i,1)=0d0
+ enddo
+ id=1220
+ npo=6
+ elseif(np.eq.9)then
+ wmax=wsmmax
+ if(cut)fmin=4.d0/(decade*log10(emlow/enymin)) !at minimum, 0.5 * # particles = # bin per decade
+ do i=imn,imx
+ if(.not.cont.and.Hamu(i,1).gt.0d0)cont=.true.
+ Ibin = Ibin+1
+ x(Ibin)=log10(eeha(i))
+ y(Ibin)=Hamu(i,1)
+ Sum=Sum+y(Ibin)
+ Eini=Eini+y(Ibin)*(eeha(i)+pmass(np))
+ Hamu(i,1)=0d0
+ enddo
+ dptl(12)=max(dptl(12),900d0) !generation > 500 to keep EM subshower in MC
+ id=14
+ npt=7
+ endif
+ if(.not.cont)goto 100 !array empty, nothing to sample
+c minimum and maximum bin are half size for sampling (like energy bin definition)
+c first bin is half
+ if(np.eq.1.or.np.eq.7)Sum=Sum-y(1)*0.5d0 !due to divergence at low E
+c Sum=Sum-y(1)*0.5d0 !due to divergence at low E
+c y(1)=y(1)*2d0 !half a bin
+c last bin is half only if maximum energy
+ if(imx.lt.iemax)then
+c Ibin = Ibin+1
+c x(Ibin)=log10(eeha(imx+1))
+c y(Ibin)=0d0
+c icut=1
+ icut=0
+ else
+c Sum=Sum-y(Ibin)*0.5d0 !for the integral
+ y(Ibin)=y(Ibin)*2.d0 !half a bin
+ icut=1 !cut to avoid Eout>eeha(imx)
+ endif
+ x(0)=x(1)-log10(Cha)
+
+c if(ki.gt.0)then
+ wmax=max(1.d0,min(wmax,Sum*fmin)) !at minimum, 10 particles per decade
+c wmax=0.1d0
+C convert histogram to function
+ call CXHI2FUN(x,y,Ibin,x1,y1,Itab)
+C prepare sampling
+ call CXSAMP1D(-1,x1,y1,y2,Itab,Xout)
+
+C fix the number of sampled particle according to the maximum weight
+
+ xNpart=Sum/wmax
+ yNtry=aint(xNpart)
+c fixed weight
+c if(drangen(xNpart).le.xNpart-yNtry)yNtry=yNtry+1d0
+c if(yNtry.lt.1d0)then
+c goto 100
+c else
+c go=.true.
+c endif
+
+c variable weight
+ if(drangen(xNpart).le.xNpart-yNtry)yNtry=yNtry+1d0
+ if(yNtry.lt.1d0)then
+ if(Sum.lt.1d0) goto 100
+ wmax=Sum
+ yNtry=1.d0
+ go=.true.
+ else
+ go=.true.
+ endif
+
+C fix common variables for this particle
+ dptl(11)=wmax !particle weight
+ am=pmass(npo)
+ dptl(5)=am
+
+C loop to sample particles
+ Efin=0d0
+ nstck=0
+ xi=1d0
+ do while (xi.le.yNtry)
+ xi=xi+1d0
+ nstck=nstck+1
+c limit maximum energy to remaining energy
+ call CXSAMP1D(icut,x1,y1,y2,Itab,Xout) !sampling using x1 and not x
+ Eout=10d0**Xout
+c if(Xout.ge.0.97d0)print *,Xout,Eout
+ if(npo.ne.4.and.drangen(Sum).gt.0.5d0)id=-id !randomize particle sign
+ dptl(10)=dble(id) !particle id
+ dptl(4)=Eout+am !kinetic energy
+ ebal=dptl(4)
+ if(abs(id).ge.1000)ebal=ebal-sign(am,dble(id)) !if anti-baryon, count mass twice
+c to conserve energy give to the last particle the remaining energy --> deform energy distribution too much in certain cases
+c Ediff=(Eini-Efin)/dptl(11)
+c if(Ediff-ebal.lt.0d0
+c & .or.abs(xi-yNtry-1d0).lt.1d-5)then
+c ebal=Ediff
+c if(abs(id).ge.1000)dptl(4)=ebal+sign(am,dble(id)) !if anti-baryon, count mass twice
+c Eout=dptl(4)-am
+c xi=yNtry+1d0
+c if(Eout.lt.enymin)goto 100
+c endif
+c end of enegry conservation part (can be commented off)
+ Efin=Efin+ebal*dptl(11)
+ P=sqrt((Eout+2d0*am)*Eout)
+ if(i1DMC.le.1)then
+ dptl(1)=0d0
+ dptl(2)=P*sintet ! local p_y
+ dptl(3)=P*costet ! local p_z
+c give pt to particles from the2ha
+ j=1+int(log10(Eout*c2ha/exmin)*dnHa)
+ if(the2ha(npt,j).gt.0d0.and.ki.gt.0)then
+ if(np.ne.9)then
+ frac=1.0d0
+ else !muons
+ frac=0.5d0
+ endif
+ pt=sqrt(rsin2th(the2ha(npt,j),the2ha(npt,j)**2,frac))*P
+ phi=2d0*pi*drangen(pt)
+ csp=cos(phi)
+ snp=sin(phi)
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*) 'Sample pt ',pt,P,csp,snp
+#endif
+ if(np.ne.9)then
+ ep(1)=pt*csp
+ ep(2)=pt*snp
+ ep(3)=sqrt(max(0d0,(P+pt)*(P-pt)))
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ else !(np.eq.9): for muons we can calculate offset from axis with pion decay time
+ 50 dlmu=-log(drangen(P))*dptl(4)/bdeca(2)
+ dd=(pt/P)*dlmu
+ da=sqrt((dlmu-dd)*(dlmu+dd))
+c distances has to be added for both downward and upward going showers
+c because the sign of the local projection and axis shower direction cancel each other
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*) 'Virtual pion path ',dlmu,dd,da
+ & ,dl,distz(kj),dl+da.le.distz(kj)
+#endif
+ if(dl+da.gt.distz(kj))goto 50 !don't start before the shower start
+ d0=dl0+da !starting point on shower axis
+ t0=-d0 !time at starting point of virtual pion
+ x0=d0*xsaxis !x-coordinate at starting point of virtual pion
+ y0=d0*ysaxis !y-coordinate at starting point of virtual pion
+ h0=heightt(dl+da,radtr0)
+ dptl(15)=dd*snp
+ dptl(14)=dd*csp
+ dptl(9)=t0+dlmu*dptl(4)/P !use muon beta as first approximation for pion (exact energy of pion not known)
+ rtr=dsqrt(x0*x0+y0*y0) !radial distance of starting point to obs point
+c cosine and sine of the angles between the obs frame and the particle frame
+ if(rtr.gt.1.d-20)then
+ sinphiP=y0/rtr
+ cosphiP=x0/rtr
+ sintheP=rtr/(h0+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ sintet0=sign(min(1.d0,radtr0/(h0+radearth)),d0) !sin angle between impact parameter and starting point
+ costet0=sign(dsqrt(1.d0-sintet0*sintet0),dl+da-1.d-10)
+
+c momentum along shower axis at starting point
+ dptl(1)=0d0
+ dptl(2)=P*sintet0 ! local p_y
+ dptl(3)=P*costet0 ! local p_z
+ do l=1,3
+ ep(l)=dptl(l)
+ enddo
+ call cxdefrot(ep,s0xs,c0xs,s0s,c0s)
+ ep(1)=pt*csp
+ ep(2)=pt*snp
+ ep(3)=sqrt(max(0d0,(P+pt)*(P-pt)))
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*) 'Virtual pion starting point '
+ & ,x0,y0,h0,t0,ep,sinphiP,cosphiP,sintheP,costheP
+#endif
+ radtr=(radearth+h0)
+ & *sqrt(max(0d0,(1d0-ep(3)/P)*(1d0+ep(3)/P))) !local impact radius
+ dist=sign(distant(h0,radtr),ep(3))
+ h=heightt(dist-dlmu,radtr)
+ if(h.le.hground)goto 50 !do not produce particles below ground
+
+ call ToObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in obs. frame at starting point
+
+c final position
+ dptl(6)=x0+dlmu*ep(1)/P
+ dptl(7)=y0+dlmu*ep(2)/P
+ dptl(8)=h
+ rtr=dsqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7)) !radial distance of final point to obs point
+c cosine and sine of the angles between the obs frame and the particle frame
+ if(rtr.gt.1.d-20)then
+ sinphiP=dptl(7)/rtr
+ cosphiP=dptl(6)/rtr
+ sintheP=rtr/(h+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !new direction of P in Particle frame
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*) 'Virtual pion final point ',
+ &dptl(6),dptl(7),dptl(8),dptl(9),ep,sinphiP,cosphiP,sintheP,costheP
+#endif
+ endif
+c final momentum
+ do l=1,3
+ dptl(l)=ep(l)
+ enddo
+ endif
+ else
+ dptl(3)=P
+ endif
+
+
+#ifdef __CXCORSIKA__
+ call d2cors(0)
+#else
+ call d2a
+c if number of particles too large in stack propagate particles
+ if(nstck.ge.mxstk)then
+c store dptl block as it is because HadronShower will change it
+ do isave=1,mxblk
+ dptlsave(isave)=dptl(isave)
+ enddo
+c Simulate subshowers
+ call HadronShower(0,idum)
+ nstck=0
+c restore dptl block to continue sampling
+ do isave=1,mxblk
+ dptl(isave)=dptlsave(isave)
+ enddo
+ endif
+#endif
+
+ enddo
+
+ 100 continue
+
+#ifdef __CXDEBUG__
+ etotsource=etotsource-Eini
+ if(isx.ge.4)then
+ if(Sum.le.0d0.or.yNtry.lt.1d0)then
+ write (ifck,*) 'Particle skipped: ',np,Sum,yNtry
+ else
+ write (ifck,*) 'Sample done with (ini->fin): '
+ * ,yNtry,Sum,' ->',wmax*yNtry,Eini,' ->',Efin,Efin/Eini
+ endif
+ endif
+ if(isx.ge.6)then
+ etotlost=etotlost+Eini-Efin
+ endif
+#endif
+
+
+ enddo !istep
+
+ 200 continue
+
+ enddo !np
+
+
+#ifndef __CXCORSIKA__
+C Simulate subshowers
+ if(go)call HadronShower(0,idum)
+#endif
+
+ end
+#endif
+
+
+#ifdef __CXSUB__
+
+c-------------------------------------------------------------------------
+ subroutine IniHadCasSub
+c-------------------------------------------------------------------------
+c initialization of hadronic cascade for maximum energy in subroutine use:
+c Reads tables for hadronic spectra
+c Reads tables for decay
+c Initialize cross section table rlamti=1/rlam
+c It has to be called after initializeMC2 because of cross sections
+c-------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexwei.h"
+ logical go
+
+ eemin=emin
+ egyhilo=EgyHiLoLim
+ dnHa=decade
+ c2ha=10.d0**(0.5d0/dnHa)
+
+
+#ifdef __CXCORSIKA__
+ if(eemin.lt.exmin.and.exmin.gt.2.d-3)write(*,*)
+#else
+ if(eemin.lt.exmin)write(*,*)
+#endif
+ &'Warning :Minimum energy for e/m below table limit for hadrons'
+ eemin=max(eemin,exmin)
+ Cha=c2ha*c2ha
+ iemin=max(1,1+int(log10(enymin*c2ha/exmin)*dnHa))
+ iehlim=1+int(log10(egyhilo*c2ha/exmin)*dnHa)
+ nminHa=1+int(log10(eemin*c2ha/exmin)*dnHa) !minimum energy bin for electromagnetic part
+ go=.false.
+
+
+c Fill in table with 0
+
+ do i2=1,mxn2
+ do i1=1,mxn1
+ do j=1,mxppj
+ do i=1,mxppj
+#if __MC3D__ || __CXLATCE__
+ pt2w(i,j,i1,i2)=0.d0
+#endif
+ wwHa(i,j,i1,i2)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+c ------------------------------------------------------------------
+
+c Muons and hadrons from gamma by muon pair production or photonuclear effect
+
+ if(ifdkg.gt.0)then
+ open(ifdkg,file=fndkg(1:nfndkg),status='old')
+ read(ifdkg,*) agpr,agne,agpi,agmu
+ close(ifdkg)
+ else
+ write(6,*)'Table dkg is not defined for hadron cascade !'
+ endif
+
+
+c ------------ Open Tables -----------------------------------------
+
+c low energy model oriented input
+
+ if(ilowegy.eq.1)then
+
+ iehlim1=iehlim-1
+
+ if(ifwle.gt.0)then
+ write(6,'(a,a)')'read LE model table from ',fnwle(1:nfnwle)
+ open(ifwle,file=fnwle(1:nfnwle),status='old')
+ read(ifwle,*) ppjver,exmin0,iemin0,iemax0,n1max0,n2max0,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (low) ***** '
+ iemin=max(iemin,iemin0) !set minimum to minimum in table
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (low) ***** '
+ if(n1maxi.gt.n1max0+2.or.n2maxi.gt.n2max0+1)
+ & stop'***** n1/n2 mismatch (low) ***** '
+ if(iehlim1.ge.iemin0.and.iehlim1.le.iemax0)then
+ read(ifwle,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin0,iemax0)
+ $ ,i2=1,n2max0)
+ $ ,i1=1,n1max0)
+ elseif(iehlim1.lt.iemin0)then
+ stop'***** iehlim too small *****'
+ elseif(iehlim1.gt.iemax0)then
+ stop'***** iehlim too big *****'
+ endif
+ close(ifwle)
+ go=.true.
+ else
+ write(6,*)'Table wle is not defined for hadron cascade !',ppjver
+ stop
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c low energy model oriented pt input
+ if(ifp2le.gt.0)then
+ write(6,'(a,a)')'read LE pt2 table from ',fnp2le(1:nfnp2le)
+ open(ifp2le,file=fnp2le(1:nfnp2le),status='old')
+ read(ifp2le,*) ppjver,exmin0,iemin0,iemax0,n1max0,n2max0,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (low p2) *****'
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (low p2) ***** '
+ if(n1maxi.gt.n1max0+2.or.n2maxi.gt.n2max0+1)
+ & stop'***** n1/n2 mismatch (low p2) ***** '
+ if(iemin0.gt.iemin)
+ & stop'***** iemin too small (low p2) ***** '
+ if(iehlim1.ge.iemin0.and.iehlim1.le.iemax0)then
+ read(ifp2le,*)
+ $ ((((p2j(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin0,iemax0)
+ $ ,i2=1,n2max0)
+ $ ,i1=1,n1max0)
+ elseif(iehlim1.lt.iemin0)then
+ stop'***** iehlimm too small (low p2) *****'
+ elseif(iehlim1.gt.iemax0)then
+ stop'***** iehlim too big (low p2) *****'
+ endif
+ close(ifp2le)
+ go=.true.
+ else
+ write(6,*)'Table p2le is not defined for hadron cascade !'
+ & ,ppjver
+ stop
+ endif
+#endif
+
+c Fill in low energy part of the table
+
+ eeha(1)=exmin
+ do i=2,iehlim1
+ eeha(i)=eeha(i-1)*Cha
+#if __MC3D__ || __CXLATCE__
+ do k=1,7
+ kp=k
+ if(k.eq.5)kp=4
+ if(k.eq.7)kp=9
+ p2ha(k,i)=eeha(i)*(eeha(i)+pmass(kp))
+ enddo
+ p2ha(8,i)=eeha(i)*eeha(i)
+#endif
+ end do
+
+c ------------------------------------------------------------------
+
+c Initialization of cross section table
+ write(6,'(a)')'cross section tables'
+
+ do i=iehlim1,iemin,-1
+ do k=1,n1maxi
+ m=k
+ if(k.ge.5)m=k-1
+ if(MCleModel.ne.8)then
+c fix the low energy cross section using parametrisation (problem with UrQMD)
+ rlamti(k,i)=1.d0/rlam(k,eeha(i),pmass(m))
+ else
+ rlamti(k,i)=1.d0/rlamold(k,eeha(i),0d0)
+ endif
+ enddo
+ enddo
+
+
+c ------------------------------------------------------------------
+
+c Initialization of weight table secondary particle spectra;
+c n1, n2 are equal to:
+c 1-proton; 2-charged pions; 3,4,5-kaons (charged, long, short); 6-pi0 ; 7-neutron
+c n1-primary, n2-secondary.
+c n2-secondary are equal to:
+c 8 - photon; 9 - muonm; 10 - muonp; 11 - electrons; 12 - positrons
+
+
+ do n1=1,n1maxi
+ n1p=n1
+ if(n1.eq.6)then
+ n1p=2
+ AUXIL = airava * pmass(7)
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iemin,iehlim1
+ ECMVM=SQRT( AUXIL*(AUXIL + 2.D0*eeha(k)) )
+ VMFRAC = .17560D0 * ECMVM**0.037303
+ & + .68008D0/(ECMVM**1.3021D0)
+ do i=mini,k
+ wwHa(k,i,n1,n2)=dble(ppj(i,k,n2p,n1p))*(1.d0-VMFRAC)
+ enddo
+ if(n2.eq.1)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpr(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.2)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpi(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.7)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agne(k,i)*VMFRAC
+ enddo
+ endif
+ enddo
+ enddo
+ else
+ if(n1.eq.5)n1p=4
+ if(n1.eq.7)n1p=5
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iemin,iehlim1
+ do i=mini,k
+ ecor=1.d0
+c below 1 GeV, problems with nucleon propagation : simply propagate without int.
+ if(n2.ne.1.and.n2.ne.7
+ & .and.k.le.ienmn)ecor=0d0 !min(1d0,eeha(i))
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=dble(p2j(i,k,n2p,n1p))
+#endif
+ wwHa(k,i,n1,n2)=dble(ppj(i,k,n2p,n1p))*rlamti(n1,k)*ecor
+ if(n2p.eq.4)wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)/2.d0
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+
+ endif
+
+#ifdef __MODEL__
+ imdmx=2
+ do imodel=1,imdmx
+
+ if(imodel.eq.1)then
+ fnwhe(nfnwhe-4:nfnwhe-2)='epo'
+#if __MC3D__ || __CXLATCE__
+ fnp2he(nfnp2he-4:nfnp2he-2)='epo'
+#endif
+ elseif(imodel.eq.2)then
+ fnwhe(nfnwhe-4:nfnwhe-2)='IIq'
+#if __MC3D__ || __CXLATCE__
+ fnp2he(nfnp2he-4:nfnp2he-2)='IIq'
+#endif
+ else
+ stop'wrong number of model in conex-had.F !'
+ endif
+#endif
+
+c high energy model oriented input
+ if(ifwhe.gt.0)then
+ write(6,'(a,a)')'read HE model table from ',fnwhe(1:nfnwhe)
+ open(ifwhe,file=fnwhe(1:nfnwhe),status='old')
+ read(ifwhe,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (high) ***** '
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (high) ***** '
+ if(go.and.(n1max.ne.n1max0.or.n2max.ne.n2max0))
+ & stop'***** nmax mismatch (high) ***** '
+ if(n1maxi.gt.n1max+2.or.n2maxi.gt.n2max+1)
+ & stop'***** n1/n2 mismatch (high) ***** '
+ if(.not.go)then
+ iemin=max(iemin,iemin1) !set minimum to minimum in table
+ iehlim=iemin !only HE model
+ endif
+ if((iemin1.gt.iemin.and..not.go).or.iehlim.lt.iemin1)
+ & stop'***** iemin too small (high) ***** '
+ iemax=iemax1 !set maximum to maximum in table
+ if(iehlim.lt.iemin1)stop'***** iehlim too small (high) ***** '
+ read(ifwhe,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifwhe)
+ else
+ write(6,*)'Table whe is not defined for hadron cascade !',ppjver
+ stop
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c high energy model oriented pt input
+ if(ifp2he.gt.0)then
+ write(6,'(a,a)')'read HE pt2 table from ',fnp2he(1:nfnp2he)
+ open(ifp2he,file=fnp2he(1:nfnp2he),status='old')
+ read(ifp2he,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (high pt2) *****'
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (high pt2) ***** '
+ if(go.and.(n1max.ne.n1max0.or.n2max.ne.n2max0))
+ & stop'***** nmax mismatch (high pt2) ***** '
+ if(n1maxi.gt.n1max+2.or.n2maxi.gt.n2max+1)
+ & stop'***** n1/n2 mismatch (high pt2) ***** '
+ if((iemin1.gt.iemin.and..not.go).or.iehlim.lt.iemin1)
+ & stop'***** iemin too small (high pt2) ***** '
+ if(iemax1.lt.iemax)stop'***** iemax too small (high pt2) ***'
+ if(iehlim.lt.iemin1)stop'*** iehlim too small (high pt2) *** '
+ read(ifp2he,*)
+ $ ((((p2j(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifp2he)
+ else
+ write(6,*)'Table p2he is not defined for hadron cascade !',ppjver
+ stop
+ endif
+#endif
+
+c Fill in high energy part of the table
+
+ nmaxHa=iemax
+ eeha(1)=exmin
+ do i=2,nmaxHa
+ eeha(i)=eeha(i-1)*Cha
+#if __MC3D__ || __CXLATCE__
+ do k=1,7
+ kp=k
+ if(k.eq.5)kp=4
+ if(k.eq.7)kp=9
+ p2ha(k,i)=eeha(i)*(eeha(i)+pmass(kp))
+ enddo
+ p2ha(8,i)=eeha(i)*eeha(i)
+#endif
+ end do
+
+c ------------------------------------------------------------------
+
+c Initialization of cross section table
+ write(6,'(a)')'cross section tables'
+
+ do i=iehlim,iemax
+ do k=1,n1maxi
+ m=k
+ if(k.ge.5)m=k-1
+ rlamti(k,i)=1.d0/rlam(k,eeha(i),pmass(m))
+ enddo
+ enddo
+
+
+
+c ------------------------------------------------------------------
+
+c Initialization of weight table secondary particle spectra;
+c n1, n2 are equal to:
+c 1-proton; 2-charged pions; 3,4,5-kaons (charged, long, short); 6-pi0 ; 7-neutron
+c n1-primary, n2-secondary.
+c n2-secondary are equal to:
+c 8 - photon; 9 - muonm; 10 - muonp; 11 - electrons; 12 - positrons
+
+
+ do n1=1,n1maxi
+ n1p=n1
+ if(n1.eq.6)then
+ n1p=2
+ AUXIL = airava * pmass(7)
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ ECMVM=SQRT( AUXIL*(AUXIL + 2.D0*eeha(k)) )
+ VMFRAC = .17560D0 * ECMVM**0.037303
+ & + .68008D0/(ECMVM**1.3021D0)
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)
+ & +dble(ppj(i,k,n2p,n1p))*(1.d0-VMFRAC)
+ enddo
+ if(n2.eq.1)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpr(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.2)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpi(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.7)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agne(k,i)*VMFRAC
+ enddo
+ endif
+ enddo
+ enddo
+ else
+ if(n1.eq.5)n1p=4
+ if(n1.eq.7)n1p=5
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ do i=mini,k
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=pt2w(k,i,n1,n2)+dble(p2j(i,k,n2p,n1p))
+#endif
+ wwhar=dble(ppj(i,k,n2p,n1p))*rlamti(n1,k)
+ if(n2p.eq.4)then
+c Kl interactions are Ks + Kl
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+wwHar/2.d0
+ else
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+wwHar
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+#ifdef __MODEL__
+ enddo
+
+
+c Normalize the table for the number of models
+
+ do n2=1,n2maxi
+ do n1=1,n1maxi
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ do i=mini,k
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=pt2w(k,i,n1,n2)/dble(imdmx)
+#endif
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)/dble(imdmx)
+ enddo
+ enddo
+ enddo
+ enddo
+
+#endif
+
+c high energy model oriented input completed
+
+
+c ------------------------------------------------------------------
+
+c Read the decay tables for kaons
+
+c Pions and pions 0 from charged Kaons
+
+ if(ifdkz.gt.0)then
+ open(ifdkz,file=fndkz(1:nfndkz),status='old')
+ read(ifdkz,*) akz,akz0
+ close(ifdkz)
+ else
+ write(6,*)'Table dkz is not defined for hadron cascade !'
+ endif
+
+c Pions and pions 0 from Kaon Long
+
+ if(ifdkl.gt.0)then
+ open(ifdkl,file=fndkl(1:nfndkl),status='old')
+ read(ifdkl,*) akl,akl0
+ close(ifdkl)
+ else
+ write(6,*)'Table dkl is not defined for hadron cascade !'
+ endif
+
+c Pions and pions 0 from Kaon short
+
+ if(ifdks.gt.0)then
+ open(ifdks,file=fndks(1:nfndks),status='old')
+ read(ifdks,*) aks,aks0
+ close(ifdks)
+ else
+ write(6,*)'Table dks is not defined for hadron cascade !'
+ endif
+
+c Muons from Charge Kaon, Kaon Long and Charged Pions
+
+ if(ifdkm.gt.0)then
+ open(ifdkm,file=fndkm(1:nfndkm),status='old')
+ read(ifdkm,*) akzm,aklm,apim
+ close(ifdkm)
+ else
+ write(6,*)'Table dkm is not defined for hadron cascade !'
+ endif
+
+
+c Electrons from Charge Kaon or Kaon Long and Gammas from Neutral Pions
+
+ if(ifdke.gt.0)then
+ open(ifdke,file=fndke(1:nfndke),status='old')
+ read(ifdke,*) akze,akle,ap0g,ap0e,amue
+ close(ifdke)
+ else
+ write(6,*)'Table dke is not defined for hadron cascade !'
+ endif
+
+c Neutrinos from Charge Kaon, Kaon Long and Charged Pions
+
+ if(ifdkn.gt.0)then
+ open(ifdkn,file=fndkn(1:nfndkn),status='old')
+ read(ifdkn,*) akzn,akln,apin,amun
+ close(ifdkn)
+ else
+ write(6,*)'Table dkn is not defined for hadron cascade !'
+ endif
+
+#if __MC3D__ || __CXLATCE__
+
+c decay pt input
+ if(ifp2d.gt.0)then
+ do i1=1,mxn1
+ do i2=1,mxn2
+ do j=1,mxppj
+ do i=1,mxppj
+ ppj(i,j,i2,i1)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+ write(6,'(a,a)')'read decay pt2 table from ',fnp2d(1:nfnp2d)
+ open(ifp2d,file=fnp2d(1:nfnp2d),status='old')
+ read(ifp2d,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (decay pt2) *****'
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (decay pt2) ***** '
+ if(iemin1.gt.iemin)
+ & stop'***** iemin too small (decay pt2) ***** '
+ if(iemax1.lt.iemax)stop'*** iemax too big (decay pt2) *** '
+c pt2 for primary 1: ch pions, 2: ch kaons, 3: kaonl, 4: kaons
+c and secondary 1: ch pions, 2: pion0, 3: gamma, 4: muon, 5: electron, 6:neutrino
+ read(ifp2d,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifp2d)
+ else
+ write(6,*)'Table p2d is not defined for hadron cascade !',ppjver
+ stop
+ endif
+c <pt2> for pions with energy i from kaons decay with energy k
+ do np=1,3
+ do k=iemin,iemax
+ do i=nminHa,k
+ pt2pi(np,k,i)=ppj(i,k,1,np+1)
+ enddo
+ enddo
+ enddo
+c <pt2> for muons with energy i from pions and kaons decay with energy k
+ do np=1,4
+ do k=iemin,iemax
+ do i=nminHa,k
+ if(np.eq.1)then
+ pt2mu(k,i,np)=ppj(i,k,7,2) !use pt of neutrino from K decay for pt of muon pair production (to have full range in energy) ????????????
+ else
+ pt2mu(k,i,np)=ppj(i,k,4,np-1)
+ endif
+ enddo
+ enddo
+ enddo
+#endif
+
+
+c pretabulation of particle of energy eeha(k) (k goes from iemin
+c (not less than 1GeV) to iemax)) decay spectra (akm,ake,api)
+c for particle n2 (mu, ele) of energy eeha(i) (i goes from 1
+c (not less than 1MeV) to iemax))
+c ( * B_dec / eetot of the parent )
+
+ do np=1,n2maxi
+ do i=nminHa,iemax
+ ndecmax(i,np)=iemin
+ enddo
+ enddo
+ do i=nminHa,iemax
+ do k=iemin,iemax
+ allldec(k,2)=bdeca(2)/(eeha(k)+pmass(2))
+ apin(k,i)=apin(k,i)*allldec(k,2)
+ enddo
+ do k=iemin,iemax
+ allldec(k,3)=bdeca(3)/(eeha(k)+pmass(3))
+ if(akze(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ akze(k,i)=akze(k,i)*allldec(k,3)
+ akzn(k,i)=akzn(k,i)*allldec(k,3)*10d0
+ enddo
+ do k=iemin,iemax
+ allldec(k,4)=bdeca(4)/(eeha(k)+pmass(4))
+ if(akle(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ akle(k,i)=akle(k,i)*allldec(k,4)
+ akln(k,i)=akln(k,i)*allldec(k,4)*2d0
+ enddo
+ do k=iemin,iemax
+ allldec(k,9)=bdeca(9)/(eeha(k)+pmass(9))
+ amun(k,i)=amun(k,i)*allldec(k,9)
+ if(amue(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ amue(k,i)=amue(k,i)*allldec(k,9)
+ enddo
+ enddo
+
+c pretabulation of particle ( of energy eeha(k) ) decay spectra (akz,akl,aks,akm,ake)
+c for particle n2 (pi+-, pi0) of energy eeha(i)
+c ( * B_dec / eetot of the parent )
+
+ do np=1,n1maxi
+ do k=iemin,iemax
+ ndecmin(k,np)=iemax
+ enddo
+ enddo
+ do i=iemin,iemax
+ do k=iemin,iemax
+ if(apim(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,2).eq.iemax)then
+ ndecmin(k,2)=i
+ endif
+ endif
+ wwdec(k,i,1)=ap0g(k,i) !use pi0->2gam to have gam->2mu spectra
+ wwdec(k,i,2)=apim(k,i)
+ apim(k,i)=apim(k,i)*allldec(k,2)
+ enddo
+ do k=iemin,iemax
+ wwdec(k,i,5)=apim(k,i)
+ enddo
+ do k=iemin,iemax
+
+ if(akz(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ akz(k,i)=akz(k,i)*allldec(k,3)
+
+ if(akz0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ akz0(k,i)=akz0(k,i)*allldec(k,3)
+
+ if(akzm(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,3).eq.iemax)then
+ ndecmin(k,3)=i
+ endif
+ endif
+ wwdec(k,i,3)=akzm(k,i)
+ akzm(k,i)=akzm(k,i)*allldec(k,3)
+ enddo
+ do k=iemin,iemax
+ wwdec(k,i,6)=akz(k,i)
+ wwdec(k,i,7)=akzm(k,i)
+ enddo
+
+ do k=iemin,iemax
+
+ if(akl(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ akl(k,i)=akl(k,i)*allldec(k,4)
+
+ if(akl0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ akl0(k,i)=akl0(k,i)*allldec(k,4)
+
+ if(aklm(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,4).eq.iemax)then
+ ndecmin(k,4)=i
+ endif
+ endif
+ wwdec(k,i,4)=aklm(k,i)
+ aklm(k,i)=aklm(k,i)*allldec(k,4)
+ enddo
+ do k=iemin,iemax
+ allldec(k,5)=bdeca(5)/(eeha(k)+pmass(4))
+
+ if(aks(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ aks(k,i)=aks(k,i)*allldec(k,5)
+
+ if(aks0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ aks0(k,i)=aks0(k,i)*allldec(k,5)
+ enddo
+ enddo
+
+
+c ------------------------------------------------------------------
+
+#ifdef __ANALYSIS__
+c Initialization of plotting array
+
+ do j=1,mzHa
+ do i=1,maxime
+ do k=1,7
+ hadspec(k,i,j)=0.d0
+#if __MC3D__ || __CXLATCE__
+ ptspec(1,j,i,k)=0.d0
+ ptspec(2,j,i,k)=0.d0
+#endif
+ enddo
+ enddo
+ enddo
+#endif
+
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine IniHadCas(id)
+c-------------------------------------------------------------------------
+c initialization of hadronic cascade :
+c Initialize
+c-------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+c Transfer information from conex-bas
+
+ call transf(id,zmin,zmax,eemin,ehmin,emax,e0,egyhilo
+ & ,ehMC,emMC,zMC)
+
+ iemin=max(1,1+int(log10(ehmin*c2ha/exmin)*dnHa))
+ iemax=1+int(log10(e0*c2ha/exmin)*dnHa)
+ if(e0.gt.1.000001d0*eeha(iemax))iemax=iemax+1 !to avoid problem with source
+
+ if(iemin.lt.nminHa)stop'Minimum energy too low for Hadronic CE!'
+ if(iemax.gt.nmaxHa)stop'Maximum energy too high for Hadronic CE!'
+ if(iemax.gt.maximEd)then
+ write(*,*)'Warning : decay and energy loss done for '
+ * ,maximEd,' bins !'
+ write(*,*)'You need ',iemax,' bins ...'
+ stop'Redo decay and eloss tables with proper Emax and decade'
+ endif
+ iehmc=max(0,1+int(log10(ehMC*c2ha/exmin)*dnHa))
+ iemmc=max(0,1+int(log10(emMC*c2ha/exmin)*dnHa))
+ ienmn=max(0,1+int(log10(1.d0*c2ha/exmin)*dnHa)) !no nucleon production from parent below this energy (pb in spectra of low energy models) : needed to match MC
+
+
+c ------------------------------------------------------------------
+
+ mzHa=min(maximZ,int((zmax-zmin)/dzHa)+1)
+c write(*,*)'Maximum Z in Hadronic CE',mzHa
+#ifndef __CXCORSIKA__
+ if(mzHa.eq.maximz)
+ & write(*,*)'Maximum depth reach : increase depth!'
+#endif
+ mzmc=min(maximZ,int((zMC-zmin)/dzHa)+2) !limit in depth to have low energy MC (+2 because zmc is defined just before the bin edge)
+ if(mzmc.eq.2)mzmc=0 !no limit
+
+ do j=1,mzHa !tp240205
+ distz(j)=distance0(zha(j)) !slant distance to obs level
+ !for slant depth zha(j) tp240205
+ hz=heightt(abs(distz(j)),radtr0) !so170903
+ rhoz(j)=rhoair(hz) !air density for slant depth zha(j)
+ if(distz(j).le.0.d0)then !check propagation on axis
+ z2=deptht(abs(distz(j)),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(distz(j),radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+
+c if precision problem appear, try dl=dz/rho
+ if(j.ne.1.and.abs(z2-zha(j)).gt.dzHa)then
+#ifdef __CXDEBUG__
+ write(*,*)'Initial Slant depth pb ',zha(j),z2-zha(j)
+ * ,radtr0,radearth,distz(j),hz
+#endif
+ dl=dzHa/rhoz(j-1)
+ distz(j)=distz(j-1)-dl
+ hz=heightt(abs(distz(j)),radtr0)
+ rhoz(j)=rhoair(hz)
+ if(distz(j).le.0.d0)then
+ z2=deptht(abs(distz(j)),radtr0)
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(distz(j),radtr0)
+ endif
+#ifdef __CXDEBUG__
+ if(abs(z2-zha(j)).gt.dzHa)
+ * write(*,*)'Slant depth pb ',zha(j),z2-zha(j)
+ * ,radtr0,radearth,distz(j),hz
+#endif
+ endif
+ if(j.ne.1)then
+ if(distz(j).ge.distz(j-1))then
+ write(*,*)'-----> big problem in hadronic CE depth !!!!!!!!!'
+ * ,j,zha(j),zha(j-1),distz(j),distz(j-1)
+ if(j.ge.2.and.distz(j-2).gt.distz(j))then
+ distz(j-1)=(distz(j-2)+distz(j))*0.5d0
+ else
+ dl=dzHa/rhoz(1)
+ distz(j-1)=distz(j)+dl
+ endif
+ hz=heightt(abs(distz(j-1)),radtr0)
+ rhoz(j-1)=rhoair(hz)
+ endif
+ endif
+ end do
+
+c Initialization of ionization loss table (set to 0 if not active)
+
+ if(ionloss.ne.0)then
+ rho=rhoair(HGrd)
+ do i=iemin,iemax
+ do np=1,3
+ dedxion(np,i)=dedxIonMC(np,eeha(i),rho)
+ enddo
+ enddo
+ do k=1,mzHa
+ rho=rhoz(k)
+ do i=iemin,iemax
+ dedxionmu(i,k)=dedxIonMC(4,eeha(i),rho)+dedxion(4,i)
+ enddo
+ enddo
+ else
+ do i=iemin,iemax
+ do np=1,3
+ dedxion(np,i)=0d0
+ enddo
+ enddo
+ do k=1,mzHa
+ rho=rhoz(k)
+ do i=iemin,iemax
+ dedxionmu(i,k)=dedxion(4,i)
+ enddo
+ enddo
+ endif
+
+
+
+ return
+ end
+
+#else
+
+c-------------------------------------------------------------------------
+ subroutine IniHadCas(id)
+c-------------------------------------------------------------------------
+c initialization of hadronic cascade :
+c Reads tables for hadronic spectra
+c Reads tables for decay
+c Initialize cross section table rlamti=1/rlam
+c It has to be called after initializeMC2 because of cross sections
+c-------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexwei.h"
+c dimension wwtr(maxime,maxime)
+ logical go
+
+c fraction to transfer from chrg pions to neutrons
+ trfr=0.1d0
+c Transfer information from conex-bas
+
+ call transf(id,zmin,zmax,eemin,ehmin,emax,e0,egyhilo
+ & ,ehMC,emMC,zMC)
+
+ if(eemin.lt.exmin)write(*,*)
+ &'Warning :Minimum energy for e/m below table limit for hadrons'
+ eemin=max(eemin,exmin)
+ Cha=c2ha*c2ha
+ iemin=max(1,1+int(log10(ehmin*c2ha/exmin)*dnHa))
+ iehlim=1+int(log10(egyhilo*c2ha/exmin)*dnHa)
+ nmaxHa=min(maximE,1+int(log10(emax*c2ha/exmin)*dnHa))
+ nminHa=1+int(log10(eemin*c2ha/exmin)*dnHa) !minimum energy bin for electromagnetic part
+ ienmn=max(0,1+int(log10(1.d0*c2ha/exmin)*dnHa)) !no nucleon production from parent below this energy (pb in spectra of low energy models) : needed to match MC
+ go=.false.
+
+ eeha(1)=exmin
+ do i=2,nmaxHa
+ eeha(i)=eeha(i-1)*Cha
+#if __MC3D__ || __CXLATCE__
+ do k=1,7
+ kp=k
+ if(k.eq.5)kp=4
+ if(k.eq.7)kp=9
+ p2ha(k,i)=eeha(i)*(eeha(i)+pmass(kp))
+ enddo
+ p2ha(8,i)=eeha(i)*eeha(i)
+#endif
+ enddo
+
+
+
+ iemax=1+int(log10(e0*c2ha/exmin)*dnHa)
+ if(e0.gt.1.000001d0*eeha(iemax))iemax=iemax+1 !to avoid problem with source
+
+ if(iemin.lt.nminHa)stop'Minimum energy too low for Hadronic CE!'
+ if(iemax.gt.nmaxHa)stop'Maximum energy too high for Hadronic CE!'
+ if(iemax.gt.maximEd)then
+ write(*,*)'Warning : decay and energy loss done for '
+ * ,maximEd,'bins !'
+ write(*,*)'You need ',iemax,' bins ...'
+ stop'Redo dekay and eloss tables with proper Emax and decade'
+ endif
+ iehmc=max(0,1+int(log10(ehMC*c2ha/exmin)*dnHa))
+ iemmc=max(0,1+int(log10(emMC*c2ha/exmin)*dnHa))
+ if(iehmc.gt.iemax)write(*,*)'No CE for hadrons ! '
+ * ,'Low threshold too high ...'
+ if(iemmc.gt.iemax)write(*,*)'No CE for muons ! '
+ * ,'Low threshold too high ...'
+
+
+ write(*,*)'Hadronic CE (nminHa,iemin,iehlim,iemax,iehmc,iemmc)'
+ & ,nminHa,iemin,iehlim,iemax,iehmc,iemmc
+
+c Fill in table with 0
+
+ do i2=1,mxn2
+ do i1=1,mxn1
+ do j=1,mxppj
+ do i=1,mxppj
+#if __MC3D__ || __CXLATCE__
+ pt2w(i,j,i1,i2)=0.d0
+#endif
+ wwHa(i,j,i1,i2)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(6,'(a)')'cross section tables'
+
+
+c ------------------------------------------------------------------
+
+c Initialization of cross section table
+
+ do i=iemax,iemin,-1
+ do k=1,n1maxi
+ m=k
+ if(k.ge.5)m=k-1
+ if(i.ge.iehlim.or.MCleModel.ne.8)then
+c fix the low energy cross section using parametrisation (problem with UrQMD)
+ rlamti(k,i)=1.d0/rlam(k,eeha(i),pmass(m))
+ else
+ rlamti(k,i)=1.d0/rlamold(k,eeha(i),0d0)
+ endif
+ enddo
+ enddo
+
+c ------------------------------------------------------------------
+
+c Muons and hadrons from gamma by muon pair production or photonuclear effect
+
+ if(mode.ge.7)then
+ if(ifdkg.gt.0)then
+ open(ifdkg,file=fndkg(1:nfndkg),status='old')
+ read(ifdkg,*) agpr,agne,agpi,agmu
+ close(ifdkg)
+ else
+ write(6,*)'Table dkg is not defined for hadron cascade !'
+ endif
+ endif
+
+
+c ------------ Open Tables -----------------------------------------
+
+c low energy model oriented input
+ iehlim1=iehlim-1
+
+ if(iemin.lt.iehlim.and.ilowegy.eq.1)then
+
+ if(ifwle.gt.0)then
+ write(6,'(a,a)')'read LE model table from ',fnwle(1:nfnwle)
+ open(ifwle,file=fnwle(1:nfnwle),status='old')
+ read(ifwle,*) ppjver,exmin0,iemin0,iemax0,n1max0,n2max0,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (low) ***** '
+ if(iemin0.gt.iemin)stop'***** iemin mismatch (low) ***** '
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (low) ***** '
+ if(n1maxi.gt.n1max0+2.or.n2maxi.gt.n2max0+1)
+ & stop'***** n1/n2 mismatch (low) ***** '
+ if(iehlim1.ge.iemin0.and.iehlim1.le.iemax0)then
+ read(ifwle,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin0,iemax0)
+ $ ,i2=1,n2max0)
+ $ ,i1=1,n1max0)
+ elseif(iehlim1.lt.iemin0)then
+ stop'***** iemin0 too big *****'
+ elseif(iehlim1.gt.iemax0)then
+ stop'***** iemax0 too small *****'
+ endif
+ close(ifwle)
+ go=.true.
+ else
+ write(6,*)'Table wle is not defined for hadron cascade !',ppjver
+ stop
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c high energy model oriented pt input
+ if(ifp2le.gt.0)then
+ write(6,'(a,a)')'read LE pt2 table from ',fnp2le(1:nfnp2le)
+ open(ifp2le,file=fnp2le(1:nfnp2le),status='old')
+ read(ifp2le,*) ppjver,exmin0,iemin0,iemax0,n1max0,n2max0,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (low p2) *****'
+ if(iemin0.gt.iemin)stop'***** iemin mismatch (low p2) ***** '
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (low p2) ***** '
+ if(n1maxi.gt.n1max0+2.or.n2maxi.gt.n2max0+1)
+ & stop'***** n1/n2 mismatch (low p2) ***** '
+ if(iehlim.ge.iemin0.and.iehlim.le.iemax0)then
+ read(ifp2le,*)
+ $ ((((p2j(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin0,iemax0)
+ $ ,i2=1,n2max0)
+ $ ,i1=1,n1max0)
+ elseif(iehlim.lt.iemin0)then
+ stop'***** iehlimm too small (low p2) *****'
+ elseif(iehlim.gt.iemax0)then
+ stop'***** iehlim too big (low p2) *****'
+ endif
+ close(ifp2le)
+ go=.true.
+ else
+ write(6,*)'Table p2le is not defined for hadron cascade !'
+ & ,ppjver
+ stop
+ endif
+#endif
+
+c Fill in low energy part of the table
+
+c ------------------------------------------------------------------
+
+c Initialization of weight table secondary particle spectra;
+c n1, n2 are equal to:
+c 1-proton; 2-charged pions; 3,4,5-kaons (charged, long, short); 6-pi0 ; 7-neutron
+c n1-primary, n2-secondary.
+c n2-secondary are equal to:
+c 8 - photon; 9 - muonm; 10 - muonp; 11 - electrons; 12 - positrons
+
+
+ do n1=1,n1maxi
+ n1p=n1
+ if(n1.eq.6.and.(mode.ge.7.or.mode.eq.-1))then
+ n1p=2
+ AUXIL = airava * pmass(7)
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iemin,iehlim1
+ ECMVM=SQRT( AUXIL*(AUXIL + 2.D0*eeha(k)) )
+ VMFRAC = .17560D0 * ECMVM**0.037303
+ & + .68008D0/(ECMVM**1.3021D0)
+ kmx=k
+ctp test using gamma->rho->pi+ + pi- instead of gamma->pi0
+c k2=max(iemin,1+int(log10(0.5d0*eeha(k)/exmin)*dnHa))
+c efrac=eeha(k)/eeha(k2)
+c kmx=k2
+ do i=mini,kmx
+ spectra=dble(ppj(i,k,n2p,n1p))
+c spectra=efrac*dble(ppj(i,k2,n2p,n1p))
+ wwHa(k,i,n1,n2)=spectra*(1.d0-VMFRAC)
+ enddo
+ if(n2.eq.1)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpr(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.2)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpi(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.7)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agne(k,i)*VMFRAC
+ enddo
+ endif
+ enddo
+ enddo
+ elseif(n1.ne.6)then
+ if(n1.eq.5)n1p=4
+ if(n1.eq.7)n1p=5
+ n2max=n1maxi
+ if(mode.ge.7.or.mode.eq.-1)n2max=n2maxi
+ do n2=1,n2max
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi.or.mode.eq.-1)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iemin,iehlim1
+ do i=mini,k
+ ecor=1.d0
+c below 1 GeV, problems with nucleon propagation : simply propagate without int.
+ if(n2.ne.1.and.n2.ne.7
+ & .and.k.le.ienmn)ecor=0d0!min(1d0,eeha(i))
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=dble(p2j(i,k,n2p,n1p))
+#endif
+ wwHar=dble(ppj(i,k,n2p,n1p))*ecor
+c transfer a fraction of charged pions into neutrons
+c if(n2.eq.2)then
+c wwtr(i,k)=trfr*wwhar
+c wwhar=wwhar-wwtr(i,k)
+c elseif(n2.eq.7)then
+c wwhar=wwhar+wwtr(i,k)
+c endif
+c end transfer
+ wwHa(k,i,n1,n2)=wwHar*rlamti(n1,k)
+ if(n2p.eq.4)wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)/2.d0 !Kl interactions are Ks + Kl
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif
+
+ if(.not.go)iehlim=iemin !only HE model
+
+#ifdef __MODEL__
+ imdmx=2
+ do imodel=1,imdmx
+
+
+ if(imodel.eq.1)then
+ fnwhe(nfnwhe-4:nfnwhe-2)='epo'
+#if __MC3D__ || __CXLATCE__
+ fnp2he(nfnp2he-4:nfnp2he-2)='epo'
+#endif
+ elseif(imodel.eq.2)then
+ fnwhe(nfnwhe-4:nfnwhe-2)='IIq'
+#if __MC3D__ || __CXLATCE__
+ fnp2he(nfnp2he-4:nfnp2he-2)='IIq'
+#endif
+ else
+ stop'wrong number of model in conex-had.F !'
+ endif
+#endif
+
+
+c high energy model oriented input
+ if(ifwhe.gt.0)then
+ write(6,'(a,a)')'read HE model table from ',fnwhe(1:nfnwhe)
+ open(ifwhe,file=fnwhe(1:nfnwhe),status='old')
+ read(ifwhe,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (high) ***** '
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (high) ***** '
+ if(go.and.(n1max.ne.n1max0.or.n2max.ne.n2max0))
+ & stop'***** nmax mismatch (high) ***** '
+ if(n1maxi.gt.n1max+2.or.n2maxi.gt.n2max+1)
+ & stop'***** n1/n2 mismatch (high) ***** '
+ if((iemin1.gt.iemin.and..not.go).or.iehlim.lt.iemin1)
+ & stop'***** iemin too big (high) ***** '
+ if(iemax1.lt.iemax)stop'***** iemax too small (high) ***** '
+ if(iehlim.lt.iemin1)stop'***** iehlim too small (high) ***** '
+ read(ifwhe,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifwhe)
+ else
+ write(6,*)'Table whe is not defined for hadron cascade !',ppjver
+ stop
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c high energy model oriented pt input
+ if(ifp2he.gt.0)then
+ write(6,'(a,a)')'read HE pt2 table from ',fnp2he(1:nfnp2he)
+ open(ifp2he,file=fnp2he(1:nfnp2he),status='old')
+ read(ifp2he,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (high pt2) *****'
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (high pt2) ***** '
+ if(go.and.(n1max.ne.n1max0.or.n2max.ne.n2max0))
+ & stop'***** nmax mismatch (high pt2) ***** '
+ if(n1maxi.gt.n1max+2.or.n2maxi.gt.n2max+1)
+ & stop'***** n1/n2 mismatch (high pt2) ***** '
+ if((iemin1.gt.iemin.and..not.go).or.iehlim.lt.iemin1)
+ & stop'***** iemin too small (high pt2) ***** '
+ if(iemax1.lt.iemax)stop'***** iemax too small (high pt2) *****'
+ if(iehlim.lt.iemin1)stop'*** iehlim too small (high pt2) *** '
+ read(ifp2he,*)
+ $ ((((p2j(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifp2he)
+ else
+ write(6,*)'Table p2he is not defined for hadron cascade !',ppjver
+ stop
+ endif
+#endif
+
+c Fill in high energy part of the table
+
+c ------------------------------------------------------------------
+
+c Initialization of weight table secondary particle spectra;
+c n1, n2 are equal to:
+c 1-proton; 2-charged pions; 3,4,5-kaons (charged, long, short); 6-pi0 ; 7-neutron
+c n1-primary, n2-secondary.
+c n2-secondary are equal to:
+c 8 - photon; 9 - muonm; 10 - muonp; 11 - electrons; 12 - positrons
+
+
+ do n1=1,n1maxi
+ n1p=n1
+ if(n1.eq.6.and.(mode.ge.7.or.mode.eq.-1))then
+ n1p=2
+ AUXIL = airava * pmass(7)
+ do n2=1,n2maxi
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ ECMVM=SQRT( AUXIL*(AUXIL + 2.D0*eeha(k)) )
+ VMFRAC = .17560D0 * ECMVM**0.037303
+ & + .68008D0/(ECMVM**1.3021D0)
+ kmx=k
+ctp test using gamma->rho->pi+ + pi- instead of gamma->pi0
+c k2=max(iehlim,1+int(log10(0.5d0*eeha(k)/exmin)*dnHa))
+c efrac=eeha(k)/eeha(k2)
+c kmx=k2
+ do i=mini,kmx
+ spectra=dble(ppj(i,k,n2p,n1p))
+c spectra=efrac*dble(ppj(i,k2,n2p,n1p))
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+spectra*(1.d0-VMFRAC)
+ enddo
+ if(n2.eq.1)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpr(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.2)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agpi(k,i)*VMFRAC
+ enddo
+ elseif(n2.eq.7)then
+ do i=mini,k
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+agne(k,i)*VMFRAC
+ enddo
+ endif
+ enddo
+ enddo
+ elseif(n1.ne.6)then
+ if(n1.eq.5)n1p=4
+ if(n1.eq.7)n1p=5
+ n2max=n1maxi
+ if(mode.ge.7.or.mode.eq.-1)n2max=n2maxi
+ do n2=1,n2max
+ n2p=n2
+ if(n2.ge.5)n2p=n2p-1
+ if(n2.gt.n1maxi.or.mode.eq.-1)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ do i=mini,k
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=pt2w(k,i,n1,n2)+dble(p2j(i,k,n2p,n1p))
+#endif
+ wwhar=dble(ppj(i,k,n2p,n1p))
+c transfer a fraction of charged pions into neutrons
+c if(n2.eq.2)then
+c wwtr(i,k)=trfr*wwhar
+c wwhar=wwhar-wwtr(i,k)
+c elseif(n2.eq.7)then
+c if(wwhar.gt.0d0)print *,k,i,wwtr(i,k)/wwhar
+c wwhar=wwhar+wwtr(i,k)
+c endif
+c end transfer
+ wwhar=wwhar*rlamti(n1,k)
+ if(n2p.eq.4)then
+c Kl interactions are Ks + Kl
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+wwHar/2.d0
+ else
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)+wwHar
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+#ifdef __MODEL__
+ enddo
+
+
+c ------------------------------------------------------------------
+
+
+c Normalize the table for the number of models
+
+ do n2=1,n2maxi
+ do n1=1,n1maxi
+ if(n2.gt.n1maxi)then
+ mini=nminHa
+ else
+ mini=iemin
+ endif
+ do k=iehlim,iemax
+ do i=mini,k
+#if __MC3D__ || __CXLATCE__
+ pt2w(k,i,n1,n2)=pt2w(k,i,n1,n2)/dble(imdmx)
+#endif
+ wwHa(k,i,n1,n2)=wwHa(k,i,n1,n2)/dble(imdmx)
+ enddo
+ enddo
+ enddo
+ enddo
+
+#endif
+
+c high energy model oriented input completed
+
+
+
+c ------------------------------------------------------------------
+
+c Read the decay tables for kaons
+
+c Pions and pions 0 from charged Kaons
+
+ if(ifdkz.gt.0)then
+ open(ifdkz,file=fndkz(1:nfndkz),status='old')
+ read(ifdkz,*) akz,akz0
+ close(ifdkz)
+ else
+ write(6,*)'Table dkz is not defined for hadron cascade !'
+ endif
+
+c Pions and pions 0 from Kaon Long
+
+ if(ifdkl.gt.0)then
+ open(ifdkl,file=fndkl(1:nfndkl),status='old')
+ read(ifdkl,*) akl,akl0
+ close(ifdkl)
+ else
+ write(6,*)'Table dkl is not defined for hadron cascade !'
+ endif
+
+c Pions and pions 0 from Kaon short
+
+ if(ifdks.gt.0)then
+ open(ifdks,file=fndks(1:nfndks),status='old')
+ read(ifdks,*) aks,aks0
+ close(ifdks)
+ else
+ write(6,*)'Table dks is not defined for hadron cascade !'
+ endif
+
+c Muons from Charge Kaon, Kaon Long and Charged Pions
+
+ if(ifdkm.gt.0)then
+ open(ifdkm,file=fndkm(1:nfndkm),status='old')
+ read(ifdkm,*) akzm,aklm,apim
+ close(ifdkm)
+ else
+ write(6,*)'Table dkm is not defined for hadron cascade !'
+ endif
+
+c Neutrinos from Charge Kaon, Kaon Long and Charged Pions
+
+ if(ifdkn.gt.0)then
+ open(ifdkn,file=fndkn(1:nfndkn),status='old')
+ read(ifdkn,*) akzn,akln,apin,amun
+ close(ifdkn)
+ else
+ write(6,*)'Table dkn is not defined for hadron cascade !'
+ endif
+
+c decay pt input
+ if(ifp2d.gt.0)then
+ do i1=1,mxn1
+ do i2=1,mxn2
+ do j=1,mxppj
+ do i=1,mxppj
+ ppj(i,j,i2,i1)=0.d0
+ enddo
+ enddo
+ enddo
+ enddo
+ write(6,'(a,a)')'read decay pt2 table from ',fnp2d(1:nfnp2d)
+ open(ifp2d,file=fnp2d(1:nfnp2d),status='old')
+ read(ifp2d,*) ppjver,exmin0,iemin1,iemax1,n1max,n2max,nde
+ if(nde.ne.nint(dnHa))stop'***** nde mismatch (decay pt2) *****'
+ if(abs(dble(exmin0)-exmin).gt.1.d-4)
+ & stop'***** exmin mismatch (decay pt2) ***** '
+ if(iemin1.gt.iemin)
+ & stop'***** iemin too small (decay pt2) ***** '
+ if(iemax1.lt.iemax)stop'*** iemax too big (decay pt2) *** '
+c pt2 for primary 1: ch pions, 2: ch kaons, 3: kaonl, 4: kaons
+c and secondary 1: ch pions, 2: pion0, 3: gamma, 4: muon, 5: electron, 6: positron, 7:neutrino
+ read(ifp2d,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=iemin1,iemax1)
+ $ ,i2=1,n2max)
+ $ ,i1=1,n1max)
+ close(ifp2d)
+ else
+ write(6,*)'Table p2d is not defined for hadron cascade !',ppjver
+ stop
+ endif
+#if __MC3D__ || __CXLATCE__
+c <pt2> for pions with energy i from kaons decay with energy k
+ do np=1,3
+ do k=iemin,iemax
+ do i=nminHa,k
+ pt2pi(np,k,i)=ppj(i,k,1,np+1)
+ enddo
+ enddo
+ enddo
+c <pt2> for muons with energy i from pions and kaons decay with energy k
+ do np=1,4
+ do k=iemin,iemax
+ do i=nminHa,k
+ if(np.eq.1)then
+ pt2mu(k,i,np)=ppj(i,k,7,2) !use pt of neutrino from K decay for pt of muon pair production (to have full range in energy) ????????????
+ else
+ pt2mu(k,i,np)=ppj(i,k,4,np-1)
+ endif
+ enddo
+ enddo
+ enddo
+#endif
+
+
+c pretabulation of particle ( of energy eeha(k) ) decay spectra (akz,akl,aks,akm,ake)
+c for particle n2 (pi+-, pi0) of energy eeha(i)
+c ( * B_dec / eetot of the parent )
+
+ do np=1,n1maxi
+ do k=iemin,iemax
+ ndecmin(k,np)=iemax
+ enddo
+ enddo
+ do np=1,n2maxi
+ do i=nminHa,iemax
+ ndecmax(i,np)=iemin
+ enddo
+ enddo
+ do i=iemin,iemax
+ do k=iemin,iemax
+ allldec(k,2)=bdeca(2)/(eeha(k)+pmass(2))
+ if(apim(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,2).eq.iemax)then
+ ndecmin(k,2)=i
+ endif
+ endif
+ wwdec(k,i,1)=ap0g(k,i) !use pi0->2gam to have gam->2mu spectra
+ wwdec(k,i,2)=apim(k,i)
+ apim(k,i)=apim(k,i)*allldec(k,2)
+ enddo
+ do k=iemin,iemax
+ wwdec(k,i,5)=apim(k,i)
+ enddo
+ do k=iemin,iemax
+ allldec(k,3)=bdeca(3)/(eeha(k)+pmass(3))
+
+ if(akz(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ akz(k,i)=akz(k,i)*allldec(k,3)
+
+ if(akz0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ akz0(k,i)=akz0(k,i)*allldec(k,3)
+
+ if(akzm(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,3).eq.iemax)then
+ ndecmin(k,3)=i
+ endif
+ endif
+ wwdec(k,i,3)=akzm(k,i)
+ akzm(k,i)=akzm(k,i)*allldec(k,3)
+ enddo
+ do k=iemin,iemax
+ wwdec(k,i,6)=akz(k,i)
+ wwdec(k,i,7)=akzm(k,i)
+ enddo
+ do k=iemin,iemax
+ allldec(k,4)=bdeca(4)/(eeha(k)+pmass(4))
+
+ if(akl(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ akl(k,i)=akl(k,i)*allldec(k,4)
+
+ if(akl0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ akl0(k,i)=akl0(k,i)*allldec(k,4)
+
+ if(aklm(k,i).gt.0d0)then
+ ndecmax(i,9)=max(ndecmax(i,9),k)
+ if(ndecmin(k,4).eq.iemax)then
+ ndecmin(k,4)=i
+ endif
+ endif
+ wwdec(k,i,4)=aklm(k,i)
+ aklm(k,i)=aklm(k,i)*allldec(k,4)
+ enddo
+ do k=iemin,iemax
+ allldec(k,5)=bdeca(5)/(eeha(k)+pmass(4))
+
+ if(aks(k,i).gt.0d0)ndecmax(i,2)=max(ndecmax(i,2),k)
+ aks(k,i)=aks(k,i)*allldec(k,5)
+
+ if(aks0(k,i).gt.0d0)ndecmax(i,6)=max(ndecmax(i,6),k)
+ aks0(k,i)=aks0(k,i)*allldec(k,5)
+ enddo
+ do k=iemin,iemax
+ allldec(k,9)=bdeca(9)/(eeha(k)+pmass(9))
+ enddo
+ enddo
+c Neutrino for Edepo
+ do i=nminHa,iemax
+ do k=iemin,iemax
+ apin(k,i)=apin(k,i)*allldec(k,2)
+ akzn(k,i)=akzn(k,i)*allldec(k,3)*10d0
+ akln(k,i)=akln(k,i)*allldec(k,4)*2d0
+ amun(k,i)=amun(k,i)*allldec(k,9)
+ enddo
+ enddo
+
+ if(mode.ge.7)then !Electromagnetic part !|----> hybrid mode
+
+c Electrons from Charge Kaon or Kaon Long and Gammas from Neutral Pions
+
+ if(ifdke.gt.0)then
+ open(ifdke,file=fndke(1:nfndke),status='old')
+ read(ifdke,*) akze,akle,ap0g,ap0e,amue
+ close(ifdke)
+ else
+ write(6,*)'Table dke is not defined for hadron cascade !'
+ endif
+
+
+c pretabulation of particle of energy eeha(k) (k goes from iemin
+c (not less than 1GeV) to iemax)) decay spectra (akm,ake,api)
+c for particle n2 (mu, ele) of energy eeha(i) (i goes from 1
+c (not less than 1MeV) to iemax))
+c ( * B_dec / eetot of the parent )
+
+ do i=nminHa,iemax
+ do k=iemin,iemax
+ akze(k,i)=akze(k,i)*allldec(k,3)
+ if(akze(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ enddo
+ do k=iemin,iemax
+ akle(k,i)=akle(k,i)*allldec(k,4)
+ if(akle(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ enddo
+ do k=iemin,iemax
+ if(amue(k,i).gt.0d0)then
+ ndecmax(i,11)=max(ndecmax(i,11),k)
+ ndecmax(i,12)=max(ndecmax(i,12),k)
+ endif
+ amue(k,i)=amue(k,i)*allldec(k,9)
+ enddo
+ enddo
+
+
+ endif !<----| hybrid mode
+
+
+c ------------------------------------------------------------------
+
+ mzHa=min(maximZ,int((zmax-zmin)/dzHa)+1)
+ write(*,*)'Maximum Z in Hadronic CE',mzHa,zmax
+ if(mzHa.eq.maximz)
+ & write(*,*)'Maximum depth reach : increase depth!'
+ zha(1)=zmin
+ do j=2,mzHa
+ zha(j)=zha(1)+dzHa*(j-1)
+ end do
+ mzmc=min(maximZ,int((zMC-zmin)/dzHa)+2) !limit in depth to have low energy MC (+2 because zmc is defined just before the bin edge)
+ if(mzmc.eq.2)mzmc=0 !no limit
+
+ do j=1,mzHa !so300603
+ distz(j)=distance0(zha(j)) !slant distance to obs level !tp240205 !for slant depth z(j)
+ hz=heightt(abs(distz(j)),radtr0) !so170903
+ rhoz(j)=rhoair(hz) !air density for slant depth z(j)
+ if(distz(j).le.0.d0)then !check propagation on axis
+ z2=deptht(abs(distz(j)),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(distz(j),radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+
+c if precision problem appear, try dl=dz/rho
+ if(j.ne.1.and.abs(z2-zha(j)).gt.dzHa)then
+#ifdef __CXDEBUG__
+ write(*,*)'Initial Slant depth pb ',zha(j),z2-zha(j)
+ * ,radtr0,radearth,distz(j),hz
+#endif
+ dl=dzHa/rhoz(j-1)
+ distz(j)=distz(j-1)-dl
+ hz=heightt(abs(distz(j)),radtr0)
+ rhoz(j)=rhoair(hz)
+ if(distz(j).le.0.d0)then
+ z2=deptht(abs(distz(j)),radtr0)
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(distz(j),radtr0)
+ endif
+#ifdef __CXDEBUG__
+ if(abs(z2-zha(j)).gt.dzHa)
+ * write(*,*)'Slant depth pb ',zha(j),z2-zha(j)
+ * ,radtr0,radearth,distz(j),hz
+#endif
+ endif
+ if(j.ne.1)then
+ if(distz(j).ge.distz(j-1))then
+ write(*,*)'-----> big problem in hadronic CE depth !!!!'
+ * ,j,zha(j),zha(j-1),distz(j),distz(j-1)
+ if(j.ge.2.and.distz(j-2).gt.distz(j))then
+ distz(j-1)=(distz(j-2)+distz(j))*0.5d0
+ else
+ dl=dzHa/rhoz(1)
+ distz(j-1)=distz(j)+dl
+ endif
+ hz=heightt(abs(distz(j-1)),radtr0)
+ rhoz(j-1)=rhoair(hz)
+ endif
+ endif
+ end do
+
+c Initialization of ionization loss table (set to 0 if not active)
+
+ if(ionloss.ne.0)then
+ if(id.eq.0)iemin=1
+ rho=rhoair(HGrd)
+ do i=iemin,iemax
+ do np=1,3
+ dedxion(np,i)=dedxIonMC(np,eeha(i),rho)
+ enddo
+ enddo
+ do k=1,mzHa
+ rho=rhoz(k)
+ do i=iemin,iemax
+ dedxionmu(i,k)=dedxIonMC(4,eeha(i),rho)+dedxion(4,i)
+ enddo
+ enddo
+ else
+ do i=iemin,iemax
+ do np=1,3
+ dedxion(np,i)=0d0
+ enddo
+ enddo
+ do k=1,mzHa
+ do i=iemin,iemax
+ dedxionmu(i,k)=dedxion(4,i)
+ enddo
+ enddo
+ endif
+
+c ------------------------------------------------------------------
+
+c Initialization of plotting array
+
+#ifdef __ANALYSIS__
+ do j=1,mzHa
+ do i=1,maxime
+ do k=1,7
+ hadspec(k,i,j)=0.d0
+#if __MC3D__ || __CXLATCE__
+ ptspec(1,k,i,j)=0.d0
+ ptspec(2,k,i,j)=0.d0
+#endif
+ enddo
+ enddo
+ enddo
+#endif
+
+
+c ------------------------------------------------------------------
+
+
+ return
+ end
+
+#endif
+c-------------------------------------------------------------------------
+ subroutine HadronCascade(id,n,nsho,iimode) !tp071204 so110903
+c-------------------------------------------------------------------------
+c cascade development simulation in atmosphere
+c secondary particle spectra are calculated according high and low energy model
+c gamma, electron, neutrino and muon numbers are computed.
+c id : initial particle id
+c n : shower number
+c nsho : number total of shower
+c iimode : run type : 0 if pure CE.
+c 1 in hybrid mode.
+c-------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ common /cxrinphotomuarea/Amdhti(maxime,maxime,2:3),dhtil(maxime)
+ *,rhhzm,gov2
+
+ logical go,gov2
+
+ parameter (mneloss=40,mxeloss=80)
+ dimension elossp(mneloss:mxeloss,0:4)
+
+ dimension enpart(2),rapHa(maxime,2),ranHa(maxime,2)
+#if __MC3D__ || __CXLATCE__
+ * ,pt2ha(7,maxime)
+c pt2ha is used as temporary storage for the weighted <pt2>
+c final <sin2(theta)(E)> is stored in the2ha
+#endif
+ save xxx1,xxx2,xpo
+
+c initialize array used for lost energy calculation
+
+ enpart(1)=0.d0
+ enpart(2)=0.d0
+
+c array to share energy loss defined below at least 1 GeV
+ if(eeha(mxeloss).lt.0.99d0)
+ & stop'max energy indice too low for elossp !'
+
+c initial condition setting
+c ipHa-index corresponding to primary (maximal source) energy
+c jpHa-first interaction point
+
+ if(iimode.eq.0)then !pure cascade equation
+ if(abs(id).gt.13)then !hadronic primary particle
+ jpHa=int(((dptl(13)-1d-9*dzHa)-zha(1))/dzHa)+1
+ ns=100
+ px0=0d0 !no pt for primary particle
+ py0=0d0
+ call d2hsource(ns,jpHa,px0,py0)
+ ipHa=isoumax
+ if(.not.lxfirst)then !first interaction
+ Xfirst=zha(jpHa)
+ lxfirst=.true.
+ XfirstIn=1.d0-wwHa(ipHa,ipHa,ns,ns)/rlamti(ns,ipHa)
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+ am=pmass(ns)
+ if(ns.eq.1.or.ns.eq.6)am=pmass(7)
+ enpart(2)=enpart(2)+am
+ else !e/m primary particle
+ call InitialParticleEphCas
+ ipHa=0 !we don't need the first iteration for hadrons
+ jpHa=mzHa
+ endif
+#ifndef __CXSUB__
+ if(mshow.eq.1)
+ * write(*,*)'CE (id,iE,jZ)',id,ipHa,jpHa
+#endif
+ else
+ ipHa=isoumax
+ jpHa=jsoumin
+#ifndef __CXSUB__
+ if(mshow.eq.1)
+ * write(*,*)'Start Hadronic CE (iE,jZ)',ipHa,jpHa
+#endif
+ endif
+
+ im=ipHa
+ if(mode.ge.7)then
+ imin=nminHa !calculate e/m contribution
+ if(zha(jpHa).gt.zzem(jminz0))then
+ jpHa=jminz0
+ im=0 !we don't need the first iteration for hadrons
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)'e/m CE first (jZ)',jpHa
+#endif
+ elseif(ipHa.eq.0)then
+ return
+ endif
+ call IniEMCE !initialize e/m CE
+ go=.true.
+ else
+ imin=iemin !only hadrons and muons
+ go=.false.
+ if(ipHa.eq.0)return
+ endif
+
+ if(jpHa.le.0.or.jpHa.ge.mzHa)return
+
+#ifdef __CXDEBUG__
+ if(isx.ge.1)write(ifck,*)'Start CE (id,iE,jZ,maxZ,lowZ)',id,ipHa
+ & ,jpHa,mzHa,lowZ
+#endif
+
+ do j=1,2
+ do i=iemin,iemax
+ rpHa(i,j)=0.d0
+ ppHa(i,j)=0.d0
+ pi0(i,j)=0.d0
+ rkz(i,j)=0.d0
+ rkl(i,j)=0.d0
+ rks(i,j)=0.d0
+ rnHa(i,j)=0.d0
+ hamu(i,j)=0.d0
+c number of baryon and antibaryon should only be used to count mass for
+c a given depth bin (summed over i). rapHa(i,j) or ranHa(i,j) for a given
+c i are meanless.
+ rapHa(i,j)=0.d0
+ ranHa(i,j)=0.d0
+ enddo
+ enddo
+#if __MC3D__ || __CXLATCE__
+ do i=iemin,iemax
+ do np=1,7
+ the2ha(np,i)=0d0
+ pt2ha(np,i)=0d0
+ enddo
+ enddo
+#endif
+
+ do i=iemin,im !source contribution at minimal depth
+ rpHa(i,1)=hsource(1,i,jpHa)
+ ppHa(i,1)=hsource(2,i,jpHa)
+ rkz(i,1)=hsource(3,i,jpHa)
+ rkl(i,1)=hsource(4,i,jpHa)
+ rks(i,1)=hsource(5,i,jpHa)
+ rnHa(i,1)=hsource(6,i,jpHa)
+ hamu(i,1)=hsource(7,i,jpHa)
+#if __MC3D__ || __CXLATCE__
+ do k=1,8
+ if(hsource(k,i,jpHa).gt.1d-20)the2ha(k,i)=
+ & min(1d0,hpt2source(k,i,jpHa)/hsource(k,i,jpHa)/p2ha(k,i))
+ enddo
+#endif
+c total energy for this depth given back to MC should not be counted as deposed
+ if(jpHa.le.mzmc.or.i.ge.iehmc)then
+ sum=rpHa(i,1)+ppHa(i,1)+rkz(i,1)+rkl(i,1)+rks(i,1)+rnHa(i,1)
+ sumas=ppHa(i,1)*pmass(2)+rkz(i,1)*pmass(3)
+ & +rkl(i,1)*pmass(4)+rks(i,1)*pmass(4)
+ & +rpHa(i,1)*(pmass(1)-pmass(7))+rnHa(i,1)*(pmass(6)-pmass(7))
+ else
+ sum=0d0
+ sumas=0d0
+ endif
+ if(i.ge.iemmc)then !muons
+ sum=sum+hamu(i,1)
+ sumas=sumas+hamu(i,1)*pmass(9)
+ endif
+ enpart(2)=enpart(2)+eeHa(i)*sum+sumas
+ enddo
+ enpart(2)=enpart(2)
+ & +2.d0*pmass(7)*antibars(jpHa) !antibaryon mass from source
+
+
+c output
+ j=1
+
+#ifdef __ANALYSIS__
+ccontributions to hadron spectra
+ j1=jpHa
+ do i=1,im-iemin+1
+ hadspec(1,i,j1)=hadspec(1,i,j1)+rnHa(i+iemin-1,j)
+ & +rpHa(i+iemin-1,j)
+ hadspec(2,i,j1)=hadspec(2,i,j1)+ppHa(i+iemin-1,j)
+ hadspec(3,i,j1)=hadspec(3,i,j1)+pi0(i+iemin-1,j)/dzHa
+ hadspec(4,i,j1)=hadspec(4,i,j1)+rkz(i+iemin-1,j)
+ hadspec(5,i,j1)=hadspec(5,i,j1)+rkl(i+iemin-1,j)
+ hadspec(6,i,j1)=hadspec(6,i,j1)+rks(i+iemin-1,j)
+ hadspec(7,i,j1)=hadspec(7,i,j1)+hamu(i+iemin-1,j)
+#if __MC3D__ || __CXLATCE__
+ do ip=1,7
+ k=ip
+ if(ip.eq.3)k=8
+ if(ip.gt.3)k=k-1
+ if(ip.eq.7)k=7
+ do m=1,2
+ ptspec(m,ip,i,j1)=ptspec(m,ip,i,j1)+the2ha(k,i+iemin-1)**m
+ enddo
+ enddo
+#endif
+ end do
+#endif
+
+c contributions to hadron profile for output
+ if(iwrt.ne.0.and.jpHa.ne.1)then
+ zj=dble(jpHa)
+ E=0.d0
+ wt=antibars(jpHa) !antiproton
+ call Profana(zj,zj,E,E,wt,-1170,0)
+ do i=iemin,im
+ E=eeha(i)
+ wt=rpHa(i,j) !protons
+ call Profana(zj,zj,E,E,wt,1120,0)
+ wt=rnHa(i,j) !neutrons
+ call Profana(zj,zj,E,E,wt,1220,0)
+ wt=ppHa(i,j) !charged pions
+ call Profana(zj,zj,E,E,wt,120,0)
+ wt=rkz(i,j) !chr kaons
+ call Profana(zj,zj,E,E,wt,130,0)
+ wt=rkl(i,j)+rks(i,j) !neut kaons
+ call Profana(zj,zj,E,E,wt,20,0)
+ wt=hamu(i,j) !muons
+ call Profana(zj,zj,E,E,wt,14,0)
+ end do
+ endif
+ xpo=0d0
+ xxx1=1d30
+ xxx2=1d30
+
+
+c Numerical cascade solution ###############################################
+
+ do k=jpHa+1,mzHa !depth loop
+
+
+ zk=dble(k)
+ j=2
+
+ do ii=mneloss,mxeloss !energy loss loop
+ elossp(ii,0)=0.d0 !Initialize energy loss
+ elossp(ii,1)=0.d0
+ elossp(ii,2)=0.d0
+ elossp(ii,3)=0.d0
+ elossp(ii,4)=0.d0
+ enddo
+
+ enpart(1)=enpart(2) !total energy of the previous depth
+ enpart(2)=0.d0
+ sumEloss=0.d0
+ sumnu=0.d0 !energy of neutrinos
+ sumpi0=0.d0 !energy of gamma
+
+ delLe=distz(k-1)-distz(k)
+ rhora=rhoz(k-1)/rhoz(k)
+ if(rhora.gt.1.d0)rhora=1.d0/rhora
+ z2mid=zha(k-1)+.5d0*dzHa !mid of the depth interval
+ distmid=distance0(z2mid) !slant distance for the depth z2
+ if(distmid.gt.distz(k-1).or.distmid.lt.distz(k))
+ * distmid=.5d0*(distz(k-1)+distz(k))
+
+
+ do i=im,imin,-1 !hadron energy loop
+
+ ei=eeha(i)
+#if __MC3D__ || __CXLATCE__
+ ei2=ei*ei
+#endif
+ sum=0d0
+ sumas=0d0
+ aBarProd=0d0
+
+
+ if(i.ge.iemin)then !------------------> Hadronic part
+
+ if(i.gt.1)then
+ delE=eeha(i)-eeha(i-1)
+ delast=1.d0
+ else
+ delE=1.d0-1.d0/Cha
+ delast=0.5d0 !for the first bin, only half size
+ endif
+
+ if(k.le.mzmc.or.i.ge.iehmc)then !self-propagation if CE only
+
+c center of mass energy for baryon pair number calculation
+ s = 2.D0*pmass(7)**2 + 2.D0*pmass(7)*eeha(i)
+c fit of pbar production in pp collision at s (from R. Engel (RE 07/01))
+ pbar_fit = -1.17920506d0+0.151187539d0*LOG(s)
+ & +1.07022762d0/SQRT(s)*LOG(s)
+ if(pbar_fit.lt.0.D0) pbar_fit = 0.D0
+c approximation for the number of baryon/antibaryon pair in h-air collision
+c (multiplicity at low pt scale like mass number A (and number of collision
+c is A too ...)
+ XSBARP = pbar_fit*airava
+
+
+ wl1=wwHa(i,i,1,1) !self-production probabilities*rlam (E_i -> E_i)
+ wl2=wwHa(i,i,2,2)
+ wl3=wwHa(i,i,3,3)
+ wl4=wwHa(i,i,4,4)
+ wl5=wwHa(i,i,5,5)
+ wl7=wwHa(i,i,7,7)
+
+ cos1i=1d0
+
+c All particles survival contribution
+
+c proton survival contribution (particle loss / gain due to interaction / energy loss,
+c corrected for the self-production probability)
+#if __MC3D__ || __CXLATCE__
+c the2ha=<sin2> but to take into account fluctuations we use <sin2>-0.5*<sin2>**2 for energy loss and selfcontribution
+ the2ha(1,i)=the2ha(1,i)*(1d0-0.5d0*the2ha(1,i))
+ if(i1DMC.ne.2)then
+ cos1i=1d0/sqrt(1d0-the2ha(1,i))
+ endif
+c no 3D correction for survival probability or decay because not necessary and
+c would imply complication in sumint and sumdec to consider the proper energy
+c dependent angle to sum the contributions. 3D correction only for energy loss.
+#endif
+ Psurv=exp(-dzHa*(rlamti(1,i)-wl1))
+ rpHa(i,j)=rpHa(i,j-1)*Psurv
+ rapHa(i,j)=rapHa(i,j-1)*Psurv
+
+ eloss=min(ei,dedxion(1,i)*dzHa*cos1i) !Ionization loss
+ sumEloss=SumEloss+eloss*0.5d0*(rpHa(i,j-1)+rpHa(i,j)) !for Edeposit
+c eloss = total energy loss in GeV
+c even in the first energy bin, not all energy is necessarily lost due to energy loss because of energy sharing in MC spectra (wwHa)
+ egain0=elossp(min(i,mxeloss),0)*delast
+ egain=elossp(min(i,mxeloss),1)*delast
+ if(eloss.lt.delE.and.i.gt.1)then
+c energy loss below current bin size (should always be the case for E>1GeV)
+ elsp=eloss/delE
+ elossp(min(i-1,mxeloss),0)=rapHa(i,j)*elsp !part for the (i-1) bin
+ elossp(min(i-1,mxeloss),1)=rpHa(i,j)*elsp !part for the (i-1) bin
+ eloss=1d0-elsp !remaining fraction
+ else
+ elsp=ei-eloss
+ if(elsp.ge.eeha(iemin))then
+c complete energy loss for current bin to be shared into 2 lower bins
+ ie=max(1,1+int(log10(elsp/exmin)*dnHa))
+ elsp=(eeha(ie+1)-elsp)/(eeha(ie+1)-eeha(ie))
+ ie1=min(mxeloss,ie+1)
+ ie=min(mxeloss,ie)
+ elossp(ie,0)=elossp(ie,0)+rapHa(i,j)*elsp
+ elossp(ie1,0)=elossp(ie1,0)+rapHa(i,j)*(1d0-elsp)
+ elossp(ie,1)=elossp(ie,1)+rpHa(i,j)*elsp
+ elossp(ie1,1)=elossp(ie1,1)+rpHa(i,j)*(1d0-elsp)
+c for current bin
+ eloss=0d0
+ else
+c all energy lost
+ eloss=0d0
+ endif
+ endif
+c non interacting part corrected by loss + energy lost of part from (i+1) bin
+ rpHa(i,j)=rpHa(i,j)*eloss+egain
+ rapHa(i,j)=rapHa(i,j)*eloss+egain0
+#if __MC3D__ || __CXLATCE__
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(1,i)=rpHa(i,j)*the2ha(1,i)*p2ha(1,i)
+#endif
+
+c number of antibaryons produced by p interactions
+ aBarProd=aBarProd+rpHa(i,j-1)*(1.d0-Psurv)*XSBARP
+
+
+c pion survival contribution (particle loss / gain due to interaction / decay
+c / energy loss,corrected for the self-production probability)
+#if __MC3D__ || __CXLATCE__
+c the2ha=<sin2> but to take into account fluctuations we use <sin2>-0.5*<sin2>**2 for energy loss and selfcontribution
+ the2ha(2,i)=the2ha(2,i)*(1d0-0.5d0*the2ha(2,i))
+ if(i1DMC.eq.2)then
+ cos1i=1d0/sqrt(1d0-the2ha(2,i))
+ endif
+#endif
+ Psurv=exp(-dzHa*(rlamti(2,i)-wl2))
+ ppHa(i,j)=ppHa(i,j-1)*Psurv*exp(-allldec(i,2)*delLe)
+
+ eloss=min(ei,dedxion(2,i)*dzHa*cos1i) !Ionization loss
+ sumEloss=SumEloss+eloss*0.5d0*(ppHa(i,j-1)+ppHa(i,j)) !for Edeposit
+c eloss = total energy loss in GeV
+c even in the first energy bin, not all energy is necessarily lost due to energy loss because of energy sharing in MC spectra (wwHa)
+ egain=elossp(min(i,mxeloss),2)*delast
+ if(eloss.lt.delE.and.i.gt.1)then
+c energy loss below current bin size (should always be the case for E>1GeV)
+ elsp=eloss/delE
+ elossp(min(i-1,mxeloss),2)=ppHa(i,j)*elsp !part for the (i-1) bin
+ eloss=1d0-elsp !remaining fraction
+ else
+ elsp=ei-eloss
+ if(elsp.ge.eeha(iemin))then
+c complete energy loss for current bin to be shared into 2 lower bins
+ ie=max(1,1+int(log10(elsp/exmin)*dnHa))
+ elsp=(eeha(ie+1)-elsp)/(eeha(ie+1)-eeha(ie))
+ ie1=min(mxeloss,ie+1)
+ ie=min(mxeloss,ie)
+ elossp(ie,2)=elossp(ie,2)+ppHa(i,j)*elsp
+ elossp(ie1,2)=elossp(ie1,2)+ppHa(i,j)*(1d0-elsp)
+c for current bin
+ eloss=0d0
+ else
+c all energy lost
+ eloss=0d0
+ endif
+ endif
+c non interacting part corrected by loss + energy lost of part from (i+1) bin
+ ppHa(i,j)=ppHa(i,j)*eloss+egain
+#if __MC3D__ || __CXLATCE__
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(2,i)=ppHa(i,j)*the2ha(2,i)*p2ha(2,i)
+#endif
+
+c number of antibaryons produced by pi interactions
+ aBarProd=aBarProd+ppHa(i,j-1)*(1.d0-Psurv)*XSBARP
+
+
+
+c charged kaon survival contribution (particle loss / gain due to interaction / decay
+c / energy loss,corrected for the self-production probability)
+#if __MC3D__ || __CXLATCE__
+c the2ha=<sin2> but to take into account fluctuations we use <sin2>-0.5*<sin2>**2 for energy loss and selfcontribution
+ the2ha(3,i)=the2ha(3,i)*(1d0-0.5d0*the2ha(3,i))
+ if(i1DMC.ne.2)then
+ cos1i=1d0/sqrt(1d0-the2ha(3,i))
+ endif
+#endif
+ rkz(i,j)=rkz(i,j-1)*exp(-dzHa*(rlamti(3,i)-wl3))
+ * *exp(-allldec(i,3)*delLe)
+
+ eloss=min(ei,dedxion(3,i)*dzHa*cos1i) !Ionization loss
+ sumEloss=SumEloss+eloss*0.5d0*(rkz(i,j)+rkz(i,j-1)) !for Edeposit
+c eloss = total energy loss in GeV
+c even in the first energy bin, not all energy is necessarily lost due to energy loss because of energy sharing in MC spectra (wwHa)
+ egain=elossp(min(i,mxeloss),3)*delast
+ if(eloss.lt.delE.and.i.gt.1)then
+c energy loss below current bin size (should always be the case for E>1GeV)
+ elsp=eloss/delE
+ elossp(min(i-1,mxeloss),3)=rkz(i,j)*elsp !part for the (i-1) bin
+ eloss=1d0-elsp !remaining fraction
+ else
+ elsp=ei-eloss
+ if(elsp.ge.eeha(iemin))then
+c complete energy loss for current bin to be shared into 2 lower bins
+ ie=max(1,1+int(log10(elsp/exmin)*dnHa))
+ elsp=(eeha(ie+1)-elsp)/(eeha(ie+1)-eeha(ie))
+ ie1=min(mxeloss,ie+1)
+ ie=min(mxeloss,ie)
+ elossp(ie,3)=elossp(ie,3)+rkz(i,j)*elsp
+ elossp(ie1,3)=elossp(ie1,3)+rkz(i,j)*(1d0-elsp)
+c for current bin
+ eloss=0d0
+ else
+c all energy lost
+ eloss=0d0
+ endif
+ endif
+c non interacting part corrected by loss + energy lost of part from (i+1) bin
+ rkz(i,j)=rkz(i,j)*eloss+egain
+#if __MC3D__ || __CXLATCE__
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(3,i)=rkz(i,j)*the2ha(3,i)*p2ha(3,i)
+#endif
+
+
+
+c kaon long survival contribution (particle loss / gain due to interaction / decay
+c ,corrected for the self-production probability)
+ rkl(i,j)=rkl(i,j-1)*exp(-dzHa*(rlamti(4,i)-wl4))
+ * *exp(-allldec(i,4)*delLe)
+#if __MC3D__ || __CXLATCE__
+ the2ha(4,i)=the2ha(4,i)*(1d0-0.5d0*the2ha(4,i))
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(4,i)=rkl(i,j)*the2ha(4,i)*p2ha(4,i)
+#endif
+
+
+
+c kaon short survival contribution (particle loss / gain due to interaction / decay
+c ,corrected for the self-production probability)
+ rks(i,j)=rks(i,j-1)*exp(-dzHa*(rlamti(5,i)-wl5))
+ * *exp(-allldec(i,5)*delLe)
+#if __MC3D__ || __CXLATCE__
+ the2ha(5,i)=the2ha(5,i)*(1d0-0.5d0*the2ha(5,i))
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(5,i)=rks(i,j)*the2ha(5,i)*p2ha(5,i)
+#endif
+
+c neutron survival contribution (particle loss due to interaction ,
+c corrected for the self-production probability)
+ Psurv=exp(-dzHa*(rlamti(7,i)-wl7))
+ rnHa(i,j)=rnHa(i,j-1)*Psurv
+ ranHa(i,j)=ranHa(i,j-1)*Psurv
+#if __MC3D__ || __CXLATCE__
+ the2ha(6,i)=the2ha(6,i)*(1d0-0.5d0*the2ha(6,i))
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(6,i)=rnHa(i,j)*the2ha(6,i)*p2ha(6,i)
+#endif
+
+c number of antibaryons produced by n interactions
+ aBarProd=aBarProd+rnHa(i,j-1)*(1.d0-Psurv)*XSBARP
+
+ elseif(i.eq.iehmc-1)then !give only energy loss from previous bin
+ rpHa(i,j)=elossp(min(i,mxeloss),1)*delast
+ rapHa(i,j)=elossp(min(i,mxeloss),0)*delast
+ ppHa(i,j)=elossp(min(i,mxeloss),2)*delast
+ rkz(i,j)=elossp(min(i,mxeloss),3)*delast
+ rkl(i,j)=0d0
+ rks(i,j)=0d0
+ rnHa(i,j)=0d0
+ ranHa(i,j)=0d0
+ aBarProd=0d0
+#if __MC3D__ || __CXLATCE__
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ the2ha(1,i)=the2ha(1,i)*(1d0-0.5d0*the2ha(1,i))
+ pt2ha(1,i)=rpHa(i,j)*the2ha(1,i)*p2ha(1,i)
+ the2ha(2,i)=the2ha(2,i)*(1d0-0.5d0*the2ha(2,i))
+ pt2ha(2,i)=ppHa(i,j)*the2ha(2,i)*p2ha(2,i)
+ the2ha(3,i)=the2ha(3,i)*(1d0-0.5d0*the2ha(3,i))
+ pt2ha(3,i)=rkz(i,j)*the2ha(3,i)*p2ha(3,i)
+ do np=1,7
+ pt2ha(np,i)=0d0
+ the2ha(np,i)=0d0
+ enddo
+#endif
+ else !if source for MC
+ rpHa(i,j)=0d0
+ rapHa(i,j)=0d0
+ ppHa(i,j)=0d0
+ rkz(i,j)=0d0
+ rkl(i,j)=0d0
+ rks(i,j)=0d0
+ rnHa(i,j)=0d0
+ ranHa(i,j)=0d0
+ aBarProd=0d0
+#if __MC3D__ || __CXLATCE__
+ do np=1,7
+ pt2ha(np,i)=0d0
+ the2ha(np,i)=0d0
+ enddo
+#endif
+ endif
+
+c ***** proton spectra at depth zha(k)
+
+ resp=0.d0
+ res2=0.d0
+ prd=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,1,res1,res2,prd,pt2pr) !production by parents of higher energies
+ resp=res1
+ hsource(1,i,k)=hsource(1,i,k)+res2 !contribution to the same energy bin
+ endif
+
+ rpHa(i,j)=rpHa(i,j)+resp
+ rapHa(i,j)=rapHa(i,j)+aBarProd*0.5d0
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20)then
+ pt2ha(1,i)=pt2ha(1,i)+resp*pt2pr/prd
+ endif
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ if(rpHa(i,j).gt.1.d-20)then
+ the2ha(1,i)=pt2ha(1,i)/rpHa(i,j)
+ else
+ the2ha(1,i)=0d0
+ endif
+#endif
+ sum=sum+rpHa(i,j)+res2
+ sumas=sumas+(rpHa(i,j)+res2)*(pmass(1)-pmass(7))
+ & +rapHa(i,j)*2.d0*pmass(7)
+
+
+
+c ******** neutron spectra at depth zha(k)
+
+ resn=0.d0
+ res2=0.d0
+ prd=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,7,res1,res2,prd,pt2pr) !production by parents of higher energies
+ resn=res1
+ hsource(6,i,k)=hsource(6,i,k)+res2 !contribution to the same energy bin
+ endif
+
+ rnHa(i,j)=rnHa(i,j)+resn
+ ranHa(i,j)=ranHa(i,j)+aBarProd*0.5d0
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20)then
+ pt2ha(6,i)=pt2ha(6,i)+resn*pt2pr/prd
+ endif
+ if(rnHa(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(6,i)=pt2ha(6,i)/rnHa(i,j)
+ else
+ the2ha(6,i)=0d0
+ endif
+#endif
+
+ sum=sum+rnHa(i,j)+res2
+ sumas=sumas+(rnHa(i,j)+res2)*(pmass(6)-pmass(7))
+ & +ranHa(i,j)*2.d0*pmass(7)
+
+
+c ************** charged kaon spectra at depth zha(k)
+
+ resk=0.d0
+ res2=0.d0
+ prd=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,3,res1,res2,prd,pt2pr) !production by parents of higher energies
+ resk=res1
+ hsource(3,i,k)=hsource(3,i,k)+res2 !contribution to the same energy bin
+ endif
+
+ rkz(i,j)=rkz(i,j)+resk
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20)then
+ pt2ha(3,i)=pt2ha(3,i)+resk*pt2pr/prd
+ endif
+ if(rkz(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(3,i)=pt2ha(3,i)/rkz(i,j)
+ else
+ the2ha(3,i)=0.d0
+ endif
+#endif
+
+ sum=sum+rkz(i,j)+res2
+ sumas=sumas+(rkz(i,j)+res2)*pmass(3)
+
+c ********************* neutral (l) kaon spectra at depth zha(k)
+
+ reskl=0.d0
+ res2=0.d0
+ prd=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,4,res1,res2,prd,pt2pr) !production by parents of higher energies
+ reskl=res1
+ hsource(4,i,k)=hsource(4,i,k)+res2 !contribution to the same energy bin
+ endif
+
+ rkl(i,j)=rkl(i,j)+reskl
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20)then
+ pt2ha(4,i)=pt2ha(4,i)+reskl*pt2pr/prd
+ endif
+ if(rkl(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(4,i)=pt2ha(4,i)/rkl(i,j)
+ else
+ the2ha(4,i)=0.d0
+ pt2ha(4,i)=0.d0
+ endif
+#endif
+
+ sum=sum+rkl(i,j)+res2
+ sumas=sumas+(rkl(i,j)+res2)*pmass(4)
+
+c **************************** neutral (s) kaon spectra at depth zha(k)
+
+ resks=0.d0
+ res2=0.d0
+ prd=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,5,res1,res2,prd,pt2pr) !production by parents of higher energies
+ resks=res1
+ hsource(5,i,k)=hsource(5,i,k)+res2 !contribution to the same energy bin
+ endif
+
+ rks(i,j)=rks(i,j)+resks
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20)then
+ pt2ha(5,i)=pt2ha(5,i)+resks*pt2pr/prd
+ endif
+ if(rks(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(5,i)=pt2ha(5,i)/rks(i,j)
+ else
+ the2ha(5,i)=0.d0
+ pt2ha(5,i)=0.d0
+ endif
+#endif
+
+ sum=sum+rks(i,j)+res2
+ sumas=sumas+(rks(i,j)+res2)*pmass(4)
+
+
+c ********************************* charged pion spectra at depth zha(k)
+c (done after kaons to benefit from theta calculation for pt of decay)
+
+
+ respp=0.d0
+ res2=0.d0
+ prd=0.d0
+ dec=0.d0
+ if(i.le.im)then
+ call sumint(im,i,j,k,2,res1,res2,prd,pt2pr) !production by parents of higher energies
+ respp=res1
+ hsource(2,i,k)=hsource(2,i,k)+res2 !contribution to the same energy bin
+
+ call sumdec(im,i,j,k,2,resn1,dec,pt2dc) !decays of kaons of higher energies
+ respp=respp+resn1
+ endif
+
+
+ ppHa(i,j)=ppHa(i,j)+respp
+
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1.d-20.and.dec.gt.1.d-20)then
+ pt2ha(2,i)=pt2ha(2,i)+res1*pt2pr/prd+resn1*pt2dc/dec
+ endif
+ if(ppHa(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(2,i)=pt2ha(2,i)/ppHa(i,j)
+ else
+ pt2ha(2,i)=0.d0
+ the2ha(2,i)=0.d0
+ endif
+#endif
+
+ sum=sum+ppHa(i,j)+res2
+ sumas=sumas+(ppHa(i,j)+res2)*pmass(2)
+
+
+c *************************************** muon spectra at depth zha(k)
+
+c if(k.le.mzmc.or.i.ge.iemmc)then !self-propagation if CE only
+ if(i.ge.iemmc)then !self-propagation if CE only
+
+c survival contribution (particle loss / gain due to interaction / decay)
+#if __MC3D__ || __CXLATCE__
+c the2ha=<sin2> but to take into account fluctuations we use <sin2>-0.5*<sin2>**2 for energy loss and selfcontribution
+ the2ha(7,i)=the2ha(7,i)*(1d0-0.5d0*the2ha(7,i))
+ if(i1DMC.ne.2)then
+ cos1i=1d0/sqrt(1d0-the2ha(7,i))
+ endif
+#endif
+ hamu(i,j)=hamu(i,j-1)*exp(-allldec(i,9)*delLe)
+
+ eloss=min(ei,dedxionmu(i,k)*dzHa*cos1i) !Ionization loss
+ sumEloss=SumEloss+eloss*0.5d0*(Hamu(i,j-1)+Hamu(i,j)) !for Edeposit
+c eloss = total energy loss in GeV
+c even in the first energy bin, not all energy is necessarily lost due to energy loss because of energy sharing in MC spectra (wwHa)
+ egain=elossp(min(i,mxeloss),4)*delast
+ if(eloss.lt.delE.and.i.gt.1)then
+c energy loss below current bin size (should always be the case for E>1GeV)
+ elsp=eloss/delE
+ elossp(min(i-1,mxeloss),4)=Hamu(i,j)*elsp !part for the (i-1) bin
+ eloss=1d0-elsp !remaining fraction
+ else
+ elsp=ei-eloss
+ if(elsp.ge.eeha(iemin))then
+c complete energy loss for current bin to be shared into 2 lower bins
+ ie=max(1,1+int(log10(elsp/exmin)*dnHa))
+ elsp=(eeha(ie+1)-elsp)/(eeha(ie+1)-eeha(ie))
+ ie1=min(mxeloss,ie+1)
+ ie=min(mxeloss,ie)
+ elossp(ie,4)=elossp(ie,4)+Hamu(i,j)*elsp
+ elossp(ie1,4)=elossp(ie1,4)+Hamu(i,j)*(1d0-elsp)
+c for current bin
+ eloss=0d0
+ else
+c all energy lost
+ eloss=0d0
+ endif
+ endif
+c non interacting part corrected by loss + energy lost of part from (i+1) bin
+ hamu(i,j)=hamu(i,j)*eloss+egain
+
+ elseif(i.eq.iemmc-1)then !give only energy loss from previous bin
+ hamu(i,j)=elossp(min(i,mxeloss),4)*delast
+ else !transfer to MC
+ hamu(i,j)=0d0
+ endif
+#if __MC3D__ || __CXLATCE__
+c pt2 of selfcontribution (the2ha is <sin2> here)
+ pt2ha(7,i)=hamu(i,j)*the2ha(7,i)*p2ha(7,i)
+#endif
+
+ if(i.le.im)then
+ if(MCmodel.eq.5)then
+ call sumint(im,i,j,k,9,res1,dum,prd1,pt2pr1) !muon- production by parents of higher energies
+ call sumint(im,i,j,k,10,res2,dum,prd2,pt2pr2) !muon+ production by parents of higher energies
+ hamu(i,j)=hamu(i,j)+res1+res2 !no prod from qgsjet, sibyll or gheisha and stat too low for nexus
+ else
+ res1=0d0
+ res2=0d0
+ prd1=0d0
+ prd2=0d0
+ endif
+ call sumdec(im,i,j,k,9,resn1,dec,pt2dc) !decays of K and pi of higher energies
+ hamu(i,j)=hamu(i,j)+resn1
+
+#if __MC3D__ || __CXLATCE__
+ if(dec.gt.1.d-20)then
+ pt2ha(7,i)=pt2ha(7,i)+resn1*pt2dc/dec
+ if(prd1.gt.0.d0)pt2ha(7,i)=pt2ha(7,i)+res1*pt2pr1/prd1
+ if(prd2.gt.0.d0)pt2ha(7,i)=pt2ha(7,i)+res2*pt2pr2/prd2
+ endif
+ if(hamu(i,j).gt.1.d-20)then
+c use the2ha temporary as <pt2> (with self-contribution) to be used for pt propagation
+ the2ha(7,i)=pt2ha(7,i)/hamu(i,j)
+ else
+ the2ha(7,i)=0d0
+ endif
+#endif
+ if(iwrt.ne.0)call Profana(zk,zk,ei,ei,resn1,14,-10)
+ endif
+ sum=sum+hamu(i,j)
+ sumas=sumas+hamu(i,j)*pmass(9)
+
+
+
+c ******************************************** neutral pion spectra at depth zha(k)
+
+ pi0(i,1)=0.d0
+ pi0(i,j)=0.d0
+ if(i.le.im)then
+ res1=0.d0
+ call sumdec(im,i,j,k,6,res1,dec,pt2dc) !decays of kaons of higher energies
+ pi0(i,1)=pi0(i,1)+res1
+ sumpi0=sumpi0+res1*ei !pi0 are lost
+ if(.not.go)then !count pi0 if no EM shower
+ call sumint(im,i,j,k,6,res1,dum,prd,pt2pr) !production by parents of higher energies
+ pi0(i,j)=pi0(i,1)+res1
+ gamHa(i)=pi0(i,j)
+ sumpi0=sumpi0+res1*ei !pi0 are lost (should be remove from Edepo but not from Ebalance)
+#if __MC3D__ || __CXLATCE__
+c no source for pi0 so calculate direclty the2ha
+ if(prd.gt.1.d-20)then
+ p2=ei*(ei+pmass(5))
+ the2ha(8,i)=min(1d0,pt2pr/prd/p2)
+ else
+ the2ha(8,i)=0.d0
+ endif
+#endif
+ else
+ pi0(i,j)=pi0(i,1)
+ endif
+ endif
+
+ endif !<--------------------------- end of Hadronic part
+
+c **************** neutrino production at depth zha(k) and energy eeha(i)
+
+ res1=0.d0
+ call rinwdec(13,im,i,j-1,k-1,0.d0,0.d0,res1,dec,pt2dc) !decays of K and pi and mu of higher energies into neutrinos
+ xnu=res1
+ sumnu=sumnu+xnu*ei !neutrinos are lost (should be remove from Edepo but not from Ebalance) but should be calculated down to imin
+
+ sumel=0.d0 !energy of electromagnetic part
+ sumasel=0.d0 !mass of electromagnetic part
+
+ if(go)then !---------------------------> e/m source part
+
+
+c ****** e+/e- production at depth zha(k) and energy eeha(i)
+
+ res1=0.d0
+ res2=0.d0
+c electron production by parents of higher energies
+ call rinweght(im,i,j-1,k-1,11,0.d0,0.d0,res1,dum,prde,pt2pre)
+c positron production by parents of higher energies
+ call rinweght(im,i,j-1,k-1,12,0.d0,0.d0,res2,dum,prdp,pt2prp)
+ elec=res1
+ posi=res2
+#if __MC3D__ || __CXLATCE__
+c difficult to tansfer hadronic pt to e/m shower because there is 2 components
+c in angular destribution (pure e/m + coming from hadrons) which cannot be
+c reproduce in a simplified approach. Better to use higher threshold in hybrid
+c mode to get the hadronic origin component of the e/m LDF correctly
+c if(prde.gt.1d-20)then
+c pt2pre=min(pt2pre/prde,ei2) !pt cannot exceed particle energy
+c else
+ pt2pre=0d0
+c endif
+c if(prdp.gt.1d-20)then
+c pt2prp=min(pt2prp/prdp,ei2) !pt cannot exceed particle energy
+c else
+ pt2prp=0d0
+c endif
+
+ call ConvHaEM3D(i,k,elec,pt2pre,-1)
+ call ConvHaEM3D(i,k,posi,pt2prp,1)
+#endif
+ res1=0.d0
+ call rinwdec(11,im,i,j-1,k-1,0.d0,0.d0,res1,dec,pt2dc) !decays of K and mu of higher energies
+ res1=res1*0.5d0
+ elec=elec+res1
+ posi=posi+res1
+#if __MC3D__ || __CXLATCE__
+c difficult to tansfer hadronic pt to e/m shower because there is 2 components
+c in angular destribution (pure e/m + coming from hadrons) which cannot be
+c reproduce in a simplified approach. Better to use higher threshold in hybrid
+c mode to get the hadronic origin component of the e/m LDF correctly
+c if(dec.gt.1d-20)then
+c pt2dc=min(pt2dc/dec,ei2) !pt cannot exceed particle energy
+c else
+ pt2dc=0d0
+c endif
+
+ call ConvHaEM3D(i,k,res1,pt2dc,-1)
+ call ConvHaEM3D(i,k,res1,pt2dc,1)
+#else
+ call ConvHaEM(i,k,elec,-1)
+ call ConvHaEM(i,k,posi,1)
+#endif
+
+ sumel=sumel+(elec+posi) !electrons are not lost if EM active
+ sumasel=sumasel+(elec+posi)*pmass(10)
+
+
+
+c **************** gamma production at depth zha(k) and energy eeha(i)
+
+ res1=0.d0
+c photon production by parents of higher energies
+ call rinweght(im,i,j-1,k-1,8,0.d0,0.d0,res1,dum,prd,pt2pr)
+ gam=res1
+#if __MC3D__ || __CXLATCE__
+c difficult to tansfer hadronic pt to e/m shower because there is 2 components
+c in angular destribution (pure e/m + coming from hadrons) which cannot be
+c reproduce in a simplified approach. Better to use higher threshold in hybrid
+c mode to get the hadronic origin component of the e/m LDF correctly
+c if(prd.gt.1d-20)then
+c pt2pr=min(pt2pr/prd,ei2) !pt cannot exceed particle energy
+c else
+ pt2pr=0d0
+c endif
+
+ call ConvHaEM3D(i,k,gam,pt2pr,0)
+#else
+ call ConvHaEM(i,k,gam,0)
+#endif
+ res1=0.d0
+c decays of pi0 of higher energies
+ call rinwdec(8,im,i,j-1,k-1,0.d0,0.d0,res1,dec,pt2dc)
+ call ConvHaEM(i,k,res1,0)
+ gam=gam+res1
+ gamHa(i)=gam !for plots
+ sumel=sumel+gam !photons are not lost if EM active
+
+ endif !<--------------------------- end of e/m part
+
+
+ enpart(2)=enpart(2)+eeHa(i)*(sum+sumel)+sumas+sumasel !total energy for this depth
+
+
+ enddo !end of the hadron energy loop
+
+ ebal=enpart(1)-enpart(2) !lost energy from k-1 to k
+ Emean=0.5d0*(enpart(1)+enpart(2))
+c if(ebal.lt.0.d0)write(*,*)'ha',k,zha(k),ebal,enpart(1),enpart(2) !there is still some ebal < 0 in hybrid mode with sibyll sometimes ... (tp 20.12.2004)
+
+ if(iwrt.ge.2)then
+ edepmn=sumEloss+sumpi0+sumnu
+ edep=max(0d0,ebal-edepmn)
+ fact=0.44d0
+ if(xpo.gt.0d0.or.(edep/edepmn.gt.xxx1.and.edep.gt.xxx2
+ . .and.edep.gt.fact*edepmn))then
+ xpo=1d0
+c edep=max(edep,sumEloss)
+ else
+ xxx1=edep/edepmn
+ xxx2=1d30
+ if(edep.gt.0d0)xxx2=edep
+ xpo=0d0
+ edep=min(xxx2,2d0*sumEloss,fact*edepmn)
+ endif
+c print*,k,xpo,edep,max(0d0,ebal-edepmn),ebal,edepmn
+c .,sumEloss,edep/edepmn!,sumpi0!,Emean
+ edep=0.75d0*edep !only a fraction of the energy of the particles below cut is deposited (0.75 is an approximation taking into account the fact that muons dominate)
+ edep=max(sumEloss,0d0)+edep !not all energy of lost particles goes into Edeposit
+c edep=0.d0
+ call Profana(zha(k)-0.1d0*dzHa,zha(mzHa)+0.1d0*dzHa
+ & ,ebal,edep,1.d0,999,-1)
+#ifdef __CXDEBUG__
+ etotsource=etotsource-ebal
+#endif
+ endif
+
+
+ if(go)then
+
+
+c initialization for eph2hsource
+ rhhzm=abs(dzha/delLE)
+ gov2=.false.
+c to avoid precision problem at high altitude, do more accurate calculation
+ if(abs(rhhzm/(rhoz(k-1)+rhoz(k))-0.5d0).gt.0.01)gov2=.true.
+
+ call SolveEMCE(k) !solve e/m CE
+
+ if(isoumax.gt.im)then !to avoid interferences with previous calculations
+ do i=im+1,isoumax
+ rpHa(i,2)=0.d0
+ ppHa(i,2)=0.d0
+ pi0(i,2)=0.d0
+ rkz(i,2)=0.d0
+ rkl(i,2)=0.d0
+ rks(i,2)=0.d0
+ rnHa(i,2)=0.d0
+ hamu(i,2)=0.d0
+ rapHa(i,2)=0.d0
+ ranHa(i,2)=0.d0
+ enddo
+ endif
+ im=isoumax
+ endif
+
+c recalculate energy of this depth including source functions
+ enpart(2)=0.d0
+ j=1
+ j1=k
+ sumab=0.d0
+ do i=iemin,im
+
+c add source contributions for depth zha(k) and energy eeHa(i)
+ rpHa(i,j)=rpHa(i,2)+hsource(1,i,k)
+ ppHa(i,j)=ppHa(i,2)+hsource(2,i,k)
+ rkz(i,j)=rkz(i,2)+hsource(3,i,k)
+ rkl(i,j)=rkl(i,2)+hsource(4,i,k)
+ rks(i,j)=rks(i,2)+hsource(5,i,k)
+ rnHa(i,j)=rnHa(i,2)+hsource(6,i,k)
+ hamu(i,j)=hamu(i,2)+hsource(7,i,k)
+ pi0(i,j)=0.d0
+ rapHa(i,j)=rapHa(i,2)
+ ranHa(i,j)=ranHa(i,2)
+#if __MC3D__ || __CXLATCE__
+c average value of pt2 with source to compute <sin2>
+ if(rpHa(i,1).gt.1d-20)the2ha(1,i)=
+ & min(1d0,(pt2ha(1,i)+hpt2source(1,i,k))/rpHa(i,1)/p2ha(1,i))
+ if(ppHa(i,1).gt.1d-20)the2ha(2,i)=
+ & min(1d0,(pt2ha(2,i)+hpt2source(2,i,k))/ppHa(i,1)/p2ha(2,i))
+ if(rkz(i,1).gt.1d-20)the2ha(3,i)=
+ & min(1d0,(pt2ha(3,i)+hpt2source(3,i,k))/rkz(i,1)/p2ha(3,i))
+ if(rkl(i,1).gt.1d-20)the2ha(4,i)=
+ & min(1d0,(pt2ha(4,i)+hpt2source(4,i,k))/rkl(i,1)/p2ha(4,i))
+ if(rks(i,1).gt.1d-20)the2ha(5,i)=
+ & min(1d0,(pt2ha(5,i)+hpt2source(5,i,k))/rks(i,1)/p2ha(5,i))
+ if(rnHa(i,1).gt.1d-20) the2ha(6,i)=
+ & min(1d0,(pt2ha(6,i)+hpt2source(6,i,k))/rnHa(i,1)/p2ha(6,i))
+ if(hamu(i,1).gt.1d-20)the2ha(7,i)=
+ & min(1d0,(pt2ha(7,i)+hpt2source(7,i,k))/hamu(i,1)/p2ha(7,i))
+#endif
+
+ enddo
+
+#ifdef __MC3D__
+c do MC simulations for low energy particles
+ if(max(iehmc,iemmc).gt.iemin)call HadronLowShower(jpHa,k)
+#endif
+
+
+ do i=iemin,im
+#ifdef __ANALYSIS__
+
+c contributions to hadron spectra
+ i1=i-iemin+1
+ hadspec(1,i1,j1)=hadspec(1,i1,j1)+rnHa(i,j)
+ & +rpHa(i,j)
+ hadspec(2,i1,j1)=hadspec(2,i1,j1)+ppHa(i,j)
+ hadspec(3,i1,j1)=hadspec(3,i1,j1)+gamHa(i)/dzHa
+ hadspec(4,i1,j1)=hadspec(4,i1,j1)+rkz(i,j)
+ hadspec(5,i1,j1)=hadspec(5,i1,j1)+rkl(i,j)
+ hadspec(6,i1,j1)=hadspec(6,i1,j1)+rks(i,j)
+ hadspec(7,i1,j1)=hadspec(7,i1,j1)+hamu(i,j)
+#if __MC3D__ || __CXLATCE__
+ do ip=1,7
+ kk=ip
+ if(ip.eq.3)kk=8
+ if(ip.gt.3)kk=kk-1
+ if(ip.eq.7)kk=7
+ do m=1,2
+ ptspec(m,ip,i1,j1)=ptspec(m,ip,i1,j1)+the2ha(kk,i)**m
+ enddo
+ enddo
+#endif
+#endif
+
+c total energy for this depth given back to MC should not be counted as deposed
+ sumab=sumab+rapHa(i,j)+ranHa(i,j)
+ sum=rpHa(i,j)+ppHa(i,j)+rkz(i,j)+rkl(i,j)+rks(i,j)+rnHa(i,j)
+ sumas=ppHa(i,j)*pmass(2)+rkz(i,j)*pmass(3)
+ & +rkl(i,j)*pmass(4)+rks(i,j)*pmass(4)
+ & +rpHa(i,j)*(pmass(1)-pmass(7))+rnHa(i,j)*(pmass(6)-pmass(7))
+ sum=sum+hamu(i,j)
+ sumas=sumas+hamu(i,j)*pmass(9)
+ enpart(2)=enpart(2)+eeHa(i)*sum+sumas
+
+ enddo
+ enpart(2)=enpart(2)
+ & +2.d0*pmass(7)*(antibars(k)+sumab) !antibaryon mass
+
+
+c output
+
+c contributions to hadron profile for output
+ if(iwrt.ne.0)then
+ E=0.d0
+ wt=antibars(k)+sumab !antibaryon
+ call Profana(zk,zk,E,E,wt,-1170,0)
+ do i=iemin,im
+ E=eeha(i)
+ wt=rpHa(i,j) !protons
+ call Profana(zk,zk,E,E,wt,1120,0)
+ wt=rnHa(i,j) !neutrons
+ call Profana(zk,zk,E,E,wt,1220,0)
+ wt=ppHa(i,j) !charged pions
+ call Profana(zk,zk,E,E,wt,120,0)
+ wt=rkz(i,j) !chr kaons
+ call Profana(zk,zk,E,E,wt,130,0)
+ wt=rkl(i,j)+rks(i,j) !neut kaons
+ call Profana(zk,zk,E,E,wt,20,0)
+ wt=hamu(i,j) !muons
+ call Profana(zk,zk,E,E,wt,14,0)
+ enddo
+ endif
+
+
+
+ enddo !end of the depth loop
+
+#ifdef __CXCORSIKA__
+c if particle still in CE stack (if no low Energy MC) save particles at ground
+c in CORSIKA stack
+ call HadronLowShower(jpHa,-mzHa)
+#else
+c if particle still in CE stack (and low Energy MC for hadrons or muons) save particles at ground
+#ifdef __MC3D__
+ if(max(iehmc,iemmc).gt.iemin)call HadronLowShower(jpHa,-mzHa)
+#endif
+#endif
+
+ if(nsho.ne.0.and.n.eq.nsho)then
+
+#ifdef __ANALYSIS__
+c normalization of hadron spectra
+ xnorm=1.d0/dble(nsho)
+
+ do k=1,mzHa
+ do i=1,maxime
+ do j=1,7
+ hadspec(j,i,k)=hadspec(j,i,k)*xnorm
+#if __MC3D__ || __CXLATCE__
+ ptspec(1,j,i,k)=ptspec(1,j,i,k)*xnorm
+ ptspec(2,j,i,k)=ptspec(2,j,i,k)*xnorm
+#endif
+ enddo
+ enddo
+ enddo
+#endif
+ endif
+
+ end
+
+
+c---------------------------------------------------------------------
+ subroutine sumint(im,i,j,jk,n2,rest,restp,prd,pt2pr) !so050207
+c---------------------------------------------------------------------
+c calculation of integral term contribution to spectra
+c of particles n2 produced by parents of higher energies
+c n2: 1 - proton; 2 - pi+-; 3 - K+-; 4 - K_l; 5 - K_s; 6 - pi0; 7 - neutron
+c 8 - photon; 9 - muonm; 10 - muonp; 11 - electrons; 12 - positrons
+c im - primary energy
+c i - current energy
+c j - current step
+c jk - current depth
+c---------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ if(n2.ne.6.and.n2.le.n1maxi)then !rrrl - inverse mean free pass corrected for self-prod.
+ wl=wwHa(i,i,n2,n2)
+ rrrl=rlamti(n2,i)-wl
+ np=n2
+ if(n2.eq.7)np=6
+ p2=p2ha(np,i)
+ else
+ rrrl=0.d0
+ if(n2.eq.6)then
+ p2=eeha(i)*(eeha(i)+pmass(5))
+ else
+ p2=p2ha(8,i)
+ endif
+ endif
+c alll - decay factor, alll=B_dec/etot, B_dec=m/c/tau0
+ if(n2.ne.1.and.n2.le.5)then
+ alll=allldec(i,n2) !tp260105
+ elseif(n2.eq.9.or.n2.eq.10)then
+ alll=allldec(i,9) !tp260105
+ p2=p2ha(7,i)
+ else
+ alll=0.d0 !so300603
+ endif
+
+c weighted integation
+ call rinweght(im,i,j-1,jk-1,n2,rrrl,alll,vint,vintp,prd,pt2pr)
+ pt2pr=min(pt2pr,prd*p2) !pt cannot exceed particle energy
+ rest=vint
+ restp=vintp
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine rinweght(im,i,j,jk,np,rrrl,alll,vintw,vintwp,prd,pt2pr)
+c---------------------------------------------------------------------
+c integration with weight function for secondary particle prod.
+c im - primary energy
+c i - current energy
+c j+1 - current step
+c jk+1 - current depth
+c arrt - pretabulated prod. spectra ( * inverse m.f.p. of the parent )
+c rrrl - inverse m.f.p. of the produced particle
+c alll - decay factor for the produced particle, alll=B_dec/eeha(i)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ logical src
+
+ src=.false.
+ v1=0.d0
+ v2=0.d0
+ v3=0.d0
+ pt2pr=0.d0 !so050207
+ prd=0.d0
+ v1p=0.d0
+ v3p=0.d0
+ vintw=0.d0
+ vintwp=0.d0
+c v1,v3 - contributions to particle spectra at depths zha(j), zha(j+1)
+c ( sum over parent type and energy ( eeha(k) ) ):
+c prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ if(np.eq.6.or.np.ge.8)then
+ imn=max(iemin,i)
+ elseif(i.ge.iemin)then !contribution to the current energy bin
+ src=.true.
+ imn=max(iemin,i+1)
+ k=i
+ if(np.ne.1)then !self contribution included in rrrl
+ ww1=wwHa(k,i,1,np)
+ v1p=v1p+ww1*rpHa(k,j)
+ v3p=v3p+ww1*rpHa(k,j+1)
+ endif
+ if(np.ne.2)then
+ ww2=wwHa(k,i,2,np)
+ v1p=v1p+ww2*ppHa(k,j)
+ v3p=v3p+ww2*ppHa(k,j+1)
+ endif
+ if(np.ne.3)then
+ ww3=wwHa(k,i,3,np)
+ v1p=v1p+ww3*rkz(k,j)
+ v3p=v3p+ww3*rkz(k,j+1)
+ endif
+ if(np.ne.4)then
+ ww4=wwHa(k,i,4,np)
+ v1p=v1p+ww4*rkl(k,j)
+ v3p=v3p+ww4*rkl(k,j+1)
+ endif
+ if(np.ne.5)then
+ ww5=wwHa(k,i,5,np)
+ v1p=v1p+ww5*rks(k,j)
+ v3p=v3p+ww5*rks(k,j+1)
+ endif
+ if(np.ne.7)then
+ ww7=wwHa(k,i,7,np)
+ v1p=v1p+ww7*rnHa(k,j)
+ v3p=v3p+ww7*rnHa(k,j+1)
+ endif
+ else
+ return
+ endif
+
+c if(im.lt.imn)return
+
+ do k=imn,im
+ ww1=wwHa(k,i,1,np)
+ ww2=wwHa(k,i,2,np)
+ ww3=wwHa(k,i,3,np)
+ ww4=wwHa(k,i,4,np)
+ ww5=wwHa(k,i,5,np)
+ ww7=wwHa(k,i,7,np)
+#if __MC3D__ || __CXLATCE__
+ nkp=np
+ if(np.gt.10)then
+ nkp=10
+ elseif(np.ge.9)then
+ nkp=9
+ elseif(np.eq.6.or.np.eq.8)then
+ nkp=5
+ elseif(np.eq.7)then
+ nkp=6
+ elseif(np.eq.5)then
+ nkp=4
+ endif
+ pt2pr=pt2pr
+ * +ww1*rpHa(k,j+1)*(pt2w(k,i,1,np)+fptadd(nkp,k,the2ha(1,k)))
+ * +ww2*ppHa(k,j+1)*(pt2w(k,i,2,np)+fptadd(nkp,k,the2ha(2,k)))
+ * +ww3*rkz(k,j+1)*(pt2w(k,i,3,np)+fptadd(nkp,k,the2ha(3,k)))
+ * +ww4*rkl(k,j+1)*(pt2w(k,i,4,np)+fptadd(nkp,k,the2ha(4,k)))
+ * +ww5*rks(k,j+1)*(pt2w(k,i,5,np)+fptadd(nkp,k,the2ha(5,k)))
+ * +ww7*rnHa(k,j+1)*(pt2w(k,i,7,np)+fptadd(nkp,k,the2ha(6,k)))
+#endif
+ v1=v1+ww1*rpHa(k,j)+ww2*ppHa(k,j)+ww3*rkz(k,j)+ww4*rkl(k,j)
+ * +ww5*rks(k,j)+ww7*rnHa(k,j)
+ v3=v3+ww1*rpHa(k,j+1)+ww2*ppHa(k,j+1)+ww3*rkz(k,j+1)
+ * +ww4*rkl(k,j+1)+ww5*rks(k,j+1)+ww7*rnHa(k,j+1)
+
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with decay contribution
+ prd=v3!*dzHa !so050207
+ pt2pr=pt2pr!*dzHa
+#endif
+
+ z1=zha(jk) !lower border of the depth bin
+ z3=zha(jk+1) !upper border of the depth bin
+
+ tttm=exp(-alll*delLe)
+ !prob. of no decay between z1, z3
+ if(tttm.gt..9d0*rhora)then
+c small decay prob. => linear integration over dzHa
+ z2=z2mid !mid of the depth interval
+ dist2=distmid
+ jlin=1
+ else
+c large decay prob. => integration over dl with the non-decay weight
+ dist2=distz(jk+1)-log(.5d0*(1.d0+tttm))/alll !half-decay distance
+ if(dist2.gt.distz(jk).or.dist2.lt.distz(jk+1))
+ * dist2=.5d0*(distz(jk)+distz(jk+1))
+ z2=deptht(dist2,radtr0) !so170903 !corresp. slant depth
+ if(dist2.le.0.d0)then
+ z2=deptht(abs(dist2),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(dist2,radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+ if(z2.lt.z1.or.z2.gt.z3)z2=z2mid
+ jlin=0
+ endif
+ de1=exp(-dzHa*rrrl) !prob. of no interaction for the produced
+ !particle between z1, z3
+ de2=exp(-(z3-z2)*rrrl) !prob. of no interaction for the produced
+ !particle between z2, z3
+
+c contribution to particle spectra at depth z2 (interpolation between z1 - z4)
+ www2=(z2-z1)/dzHa
+ www1=1.d0-www2
+ if(v1*v3.gt.0.d0)then
+ v2=v1**www1*v3**www2
+ v2p=v1p**www1*v3p**www2
+ else
+ v2=max(0.d0,v1*www1+v3*www2)
+ v2p=max(0.d0,v1p*www1+v3p*www2)
+ endif
+
+ v1=v1*de1 !correction for interaction loss
+ v2=v2*de2
+ if(jlin.eq.1)then
+ v1=v1*tttm !correction for decay loss
+ tttm2=exp(-alll*(dist2-distz(jk+1)))
+ v2=v2*tttm2
+ vintw=(v1+4.d0*v2+v3)/6.d0*dzHa !Simpson formula ( int(dzHa) )
+ if(src)then !put contribution from energy i into source function at jk+1
+ v1p=v1p*tttm*de1
+ v2p=v2p*tttm2*de2
+ vintwp=(v1p+4.d0*v2p+v3p)/6.d0*dzHa
+ endif
+#if __MC3D__ || __CXLATCE__
+ v2=v2*(z2-z1)*0.5d0 !half path
+#endif
+ else
+c integration with non-decay weight - Simpson formula
+c ( int(dx), x(l)=exp(-alll*(l1-l)), l - slant distance, l1 = l(z1) ):
+c int(dl)_l1^l3 x(l)*rho_air(l)*v(l) = int(dx)_tttm^1 rho_air(l)/alll*v(l);
+c rho_air(l)=dzHa(l)/dl, alll=B_dec/E, tttm=exp(-alll*(l1-l3))
+c v(l) - prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ v1=v1*rhoz(jk)
+ v3=v3*rhoz(jk+1)
+ hz=heightt(abs(dist2),radtr0)
+ rhhz=rhoair(hz)
+ v2=v2*rhhz
+ vintw=(v1+4.d0*v2+v3)/6.d0*(1.d0-tttm)/alll
+ if(src)then !put contribution from energy i into source function at jk+1
+ v1p=v1p*rhoz(jk)*de1
+ v3p=v3p*rhoz(jk+1)
+ v2p=v2p*rhhz*de2
+ vintwp=(v1p+4.d0*v2p+v3p)/6.d0*(1.d0-tttm)/alll
+ endif
+#if __MC3D__ || __CXLATCE__
+ v2=v2*0.5d0*(1.d0-sqrt(tttm))/alll !half path
+#endif
+ endif
+#if __MC3D__ || __CXLATCE__
+ if(i.lt.iehmc.and.jk.gt.mzmc)then
+c for correct integration below low energy MC threshold we need to know
+c the contribution of higher energy bin to subthreshold bins.
+ k=i
+ if(np.eq.1)then
+ rpHa(k,j)=rpHa(k,j)+v2
+ elseif(np.eq.2)then
+ ppHa(k,j)=ppHa(k,j)+v2
+ elseif(np.eq.3)then
+ rkz(k,j)=rkz(k,j)+v2
+ elseif(np.eq.4)then
+ rkl(k,j)=rkl(k,j)+v2
+ elseif(np.eq.5)then
+ rks(k,j)=rks(k,j)+v2
+ elseif(np.eq.7)then
+ rnHa(k,j)=rnHa(k,j)+v2
+ endif
+ endif
+#endif
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine sumdec(im,i,j,jk,n2,resd,dec,pt2dc)
+c---------------------------------------------------------------------
+c calculation of integral term contribution to spectra
+c of particles n2 produced by decays of parents of higher energies
+c n2: 2 - pi+-; 6 - pi0; 9/10 - muons; 11/12 - electrons
+c im - primary energy
+c i - current energy
+c j - current step
+c jk - current depth
+c---------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ if(n2.eq.2)then !rrrl - inverse mean free pass corrected for self-prod.
+ !alll - decay factor, alll=B_dec/etot, B_dec=m/c/tau0
+ wl=wwHa(i,i,n2,n2)
+ rrrl=rlamti(n2,i)-wl
+ alll=allldec(i,n2) !tp260105
+ p2=p2ha(2,i)
+ elseif(n2.eq.9.or.n2.eq.10)then !alll - decay factor, alll=B_dec/etot, B_dec=m/c/tau0
+ rrrl=0.d0
+ alll=allldec(i,9) !tp260105
+ p2=p2ha(7,i)
+ else
+ rrrl=0.d0
+ alll=0.d0
+ p2=p2ha(8,i)
+ endif
+
+ call rinwdec(n2,im,i,j-1,jk-1,rrrl,alll,vint,dec,pt2dc) !weighted integation
+ pt2dc=min(pt2dc,dec*p2) !pt cannot exceed particle energy
+ resd=vint
+
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine rinwdec(np,im,i,j,jk,rrrl,alll,vintdec,dec,pt2dc) !so110903
+c---------------------------------------------------------------------
+c integration with weight function for secondary particle prod. by decays
+c np - produced part
+c im - primary energy
+c i - current energy
+c j+1 - current step
+c jk+1 - current depth
+c rrrl - inverse m.f.p. of the produced particle
+c alll - decay factor for the produced particle, alll=B_dec/eeha(i)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+
+ v1=0.d0
+ v3=0.d0
+ pt2dc=0.d0 !so050207
+ dec=0.d0
+c v1,v3 - contributions to particle spectra at depths zha(jk), zha(jk+1)
+c ( sum over parent type and energy ( eeha(k) ) ):
+c decay spectra * B_dec / Etot ( arrt(k,n1) ) * parent spectra ( rkz,rkl,rks,pp,pi0 )
+ imn=iemin
+
+ if(np.eq.2)then !pion prod from kaons
+ kmax=min(im,ndecmax(i,np))
+ do k=max(imn,i),kmax
+ v1=v1+akz(k,i)*rkz(k,j)+akl(k,i)*rkl(k,j)+aks(k,i)*rks(k,j)
+ v3=v3+akz(k,i)*rkz(k,j+1)+akl(k,i)*rkl(k,j+1)
+ * +aks(k,i)*rks(k,j+1)
+#if __MC3D__ || __CXLATCE__
+c add pt of mother particles (approximate as pt of the same depth)
+ pt2dc=pt2dc+akz(k,i)*rkz(k,j+1)
+ * *(pt2pi(1,k,i)+fptadd(2,k,the2ha(3,k)))
+ * +akl(k,i)*rkl(k,j+1)*(pt2pi(2,k,i)+fptadd(2,k,the2ha(4,k)))
+ * +aks(k,i)*rks(k,j+1)*(pt2pi(3,k,i)+fptadd(2,k,the2ha(5,k)))
+#endif
+ enddo
+ elseif(np.eq.6)then !pion0 prod from kaons
+ kmax=min(im,ndecmax(i,np))
+ do k=max(imn,i),kmax
+ v1=v1+akz0(k,i)*rkz(k,j)+akl0(k,i)*rkl(k,j)+aks0(k,i)*rks(k,j)
+ v3=v3+akz0(k,i)*rkz(k,j+1)+akl0(k,i)*rkl(k,j+1)
+ * +aks0(k,i)*rks(k,j+1)
+ enddo
+ elseif(np.eq.8)then !gamma prod
+ kmax=min(im,ndecmax(i,np))
+ do k=max(imn,i),kmax
+c v1=v1+ap0g(k,i)*pi0(k,j)
+ v3=v3+ap0g(k,i)*pi0(k,j+1)
+ enddo
+ vintdec=v3 !instant decay : no integration
+ return
+ elseif(np.eq.9.or.np.eq.10)then !muon prod
+ kmax=min(im,ndecmax(i,np))
+ do k=max(imn,i),kmax
+ v1=v1+apim(k,i)*ppHa(k,j)+akzm(k,i)*rkz(k,j)
+ * +aklm(k,i)*rkl(k,j)
+ v3=v3+apim(k,i)*ppHa(k,j+1)+akzm(k,i)*rkz(k,j+1)
+ * +aklm(k,i)*rkl(k,j+1)
+#if __MC3D__ || __CXLATCE__
+c add pt of mother particles (approximate as pt of the same depth)
+ pt2dc=pt2dc
+ * +(pt2mu(k,i,2)+fptadd(9,k,the2ha(2,k)))*apim(k,i)*ppHa(k,j+1)
+ * +(pt2mu(k,i,3)+fptadd(9,k,the2ha(3,k)))*akzm(k,i)*rkz(k,j+1)
+ * +(pt2mu(k,i,4)+fptadd(9,k,the2ha(4,k)))*aklm(k,i)*rkl(k,j+1)
+#endif
+ enddo
+ elseif(np.eq.11.or.np.eq.12)then !electron prod
+ kmax=min(im,ndecmax(i,np))
+ do k=max(imn,i),kmax
+ v1=v1+akze(k,i)*rkz(k,j)+akle(k,i)*rkl(k,j)
+ & +amue(k,i)*HaMu(k,j)
+ v3=v3+akze(k,i)*rkz(k,j+1)+akle(k,i)*rkl(k,j+1)
+ & +amue(k,i)*HaMu(k,j+1)
+ enddo
+ elseif(np.eq.13)then !neutrino prod
+ do k=max(imn,i),im
+ v1=v1+apin(k,i)*ppHa(k,j)+akzn(k,i)*rkz(k,j)
+ * +akln(k,i)*rkl(k,j)+amun(k,i)*HaMu(k,j)
+ v3=v3+apin(k,i)*ppHa(k,j+1)+akzn(k,i)*rkz(k,j+1)
+ * +akln(k,i)*rkl(k,j+1)+amun(k,i)*HaMu(k,j+1)
+ enddo
+ endif
+
+ v1=max(v1,0.d0)
+ v3=max(v3,0.d0)
+
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with int. contribution
+ dec=v3!*dzHa/rhoz(jk)
+ pt2dc=pt2dc!*dzHa/rhoz(jk)
+#endif
+
+ z1=zha(jk) !lower border of the depth bin
+ z3=z1+dzHa !upper border of the depth bin
+
+ tttm=exp(-alll*delLe) !prob. of no decay for the
+ !produced particle between z1, z3
+ if(tttm.gt..9d0)then
+c small decay prob. => linear integration over dl (slant distance)
+ dist2=.5d0*(distz(jk)+distz(jk+1)) !mid of the distance interval
+ else
+c large decay prob. => integration over dl with the non-decay weight
+ dist2=distz(jk+1)-log(.5d0*(1.d0+tttm))/alll !half-decay distance
+ if(dist2.gt.distz(jk).or.dist2.lt.distz(jk+1))
+ * dist2=.5d0*(distz(jk)+distz(jk+1))
+ endif
+ if(dist2.le.0.d0)then
+ z2=deptht(abs(dist2),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(dist2,radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+ if(z2.lt.z1.or.z2.gt.z3)z2=z2mid
+
+ de1=exp(-dzHa*rrrl) !prob. of no interaction for the produced
+ !particle between z1, z3
+ de2=exp(-(z3-z2)*rrrl) !prob. of no interaction for the produced
+ !particle between z2, z3
+c contribution to particle spectra at depth z2 (interpolation between z1 - z4)
+ www2=(z2-z1)/dzHa
+ www1=1.d0-www2
+ if(v1*v3.gt.0.d0)then
+ v2=v1**www1*v3**www2
+ else
+ v2=max(0.d0,v1*www1+v3*www2)
+ endif
+
+ v1=v1*de1 !correction for interaction loss
+ v2=v2*de2
+ if(tttm.gt..9d0)then
+c linear integration over distance - Simpson formula:
+c int(dl)_l1^l3 x(l) * v(l)
+c ( x(l)=exp(-alll*(l1-l)), l - slant depth, l1 = l(z1), alll=B_dec/E,
+c v(l) = decay spectra * B_dec / eeha(k) * parent spectra )
+ vintdec=(v1*tttm+4.d0*v2*dsqrt(tttm)+v3)/6.d0*delLe
+#if __MC3D__ || __CXLATCE__
+ v2=v2*0.25d0*delLe !half path
+#endif
+ else
+c integration with non-decay weight - Simpson formula:
+c int(dl)_l1^l3 x(l) * v(l) = int(dx)_tttm^1 v(l) / alll;
+c tttm=exp(-alll*(l3-l1)) )
+ vintdec=(v1+4.d0*v2+v3)/6.d0*(1.d0-tttm)/alll
+#if __MC3D__ || __CXLATCE__
+ v2=v2*0.5d0*(1.d0-sqrt(tttm))/alll !half path
+#endif
+ endif
+
+ if(np.eq.11.or.np.eq.12)then !electron prod from piO
+ do k=max(iemin,i),im
+ vintdec=vintdec+ap0e(k,i)*pi0(k,j+1)
+ enddo
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with decay contribution
+ if(np.eq.2.and.i.lt.iehmc.and.jk.gt.mzmc)then
+c for correct integration below low energy MC threshold we need to know
+c the contribution of higher energy bin to subthreshold bins.
+ k=i
+ ppHa(k,j)=ppHa(k,j)+v2
+ endif
+ if((np.eq.9.or.np.eq.10).and.i.lt.iemmc)then
+c for correct integration below low energy MC threshold we need to know
+c the contribution of higher energy bin to subthreshold bins.
+ k=i
+ HaMu(k,j)=HaMu(k,j)+v2
+ endif
+#endif
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine eph2hsource(iim,ii,k,n2,Eused) !tp240105
+c---------------------------------------------------------------------
+c calculation of integral term contribution to spectra
+c of particles n2 produced by photonuclear effect of gamma of higher
+c energies
+c n2: 1 - proton; 2 - pi+-; 3 - K+-; 4 - K_l; 5 - K_s; 7 - neutron
+c 8 - gamma; 9 - muons
+c im - primary energy
+c i - current energy
+c j - current step
+c k - current depth
+c Eused - energy sent to had CE
+c---------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ Eused=0.d0
+ if(n2.eq.6)return
+ i=ii-minEhad
+ if(i.lt.iemin)return
+ im=iim-minEhad
+ isoumax=max(i,isoumax)
+ jsoumin=min(k,jsoumin)
+ if(n2.le.n1maxi)then !rrrl - inverse mean free pass corrected for self-prod.
+ wl=wwHa(i,i,n2,n2)
+ rrrl=rlamti(n2,i)-wl
+ else
+ rrrl=0.d0
+ endif
+c alll - decay factor, alll=B_dec/etot, B_dec=m/c/tau0
+ if(n2.ne.1.and.n2.le.5)then
+ nsi=n2
+ m2=n2
+ if(n2.ge.5)m2=n2-1
+ ams=pmass(m2)
+ alll=allldec(i,n2) !tp260105
+ call rinphoto(im,i,k-1,n2,rrrl,alll,vint1,prd,pt2pr) !weighted integation
+ vint2=0.d0
+ dec=0d0
+ pt2dc=0d0
+c if(n2.eq.2)then
+c call rinphotodec(im,i,k-1,3,alll,vint2,dec,pt2dc) !semi-analytical integation from intermediate decay of kaon into pions
+c pt2pr=pt2pr+pt2dc
+c prd=prd+dec
+c endif
+ vint=vint1+vint2
+ elseif(n2.eq.9.or.n2.eq.10)then
+ nsi=7
+ ams=pmass(9)
+ alll=allldec(i,9) !tp260105
+ pt2dc1=0d0
+ dec1=0d0
+ call rinmu(im,i,k-1,rrrl,alll,vint1,dec1,pt2dc1) !weighted integration
+ vint2=0.d0
+ dec2=0d0
+ pt2dc2=0d0
+c if(MCModel.eq.1.and.i.ge.iehlim)
+c & call rinphoto(im,i,k-1,n2,rrrl,alll,vint2,dec2,pt2dc2) !weighted integation direct production
+ vint3=0.d0
+ dec3=0d0
+ pt2dc3=0d0
+ call rinphotodec(im,i,k-1,2,alll,vint3,dec3,pt2dc3) !semi-analytical integation from intermediate decay of pions into muons
+ vint4=0.d0
+ pt2dc4=0d0
+ dec4=0d0
+c call rinphotodec(im,i,k-1,4,alll,vint4,dec4,pt2dc4) !semi-analytical integation from intermediate decay of kaons into muons
+ vint=vint1+vint2+vint3+vint4
+#if __MC3D__ || __CXLATCE__
+ prd=dec1+dec2+dec3+dec4
+ pt2pr=(pt2dc1+pt2dc2+pt2dc3+pt2dc4)
+#endif
+ zk=dble(k)
+ ei=eeha(i)
+ if(iwrt.ne.0)call Profana(zk,zk,ei,ei,vint,14,-10)
+ else
+ nsi=n2
+ ams=0.d0
+ if(nsi.eq.1)then
+ ams=pmass(1)-pmass(7)
+ elseif(nsi.eq.7)then
+ nsi=6
+ ams=pmass(6)-pmass(7)
+ endif
+ alll=0.d0
+ call rinphoto(im,i,k-1,n2,rrrl,alll,vint,prd,pt2pr) !weighted integation
+ endif
+
+ Eused=vint*(eeha(i)+ams)
+ if(n2.eq.8)then !give back photon to e/m CE
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.0d0)then
+ pt2pr=min(pt2pr/prd,eeHa(i)**2) !pt cannot exceed particle energy
+ else
+ pt2pr=0d0
+ endif
+
+ call ConvHaEM3D(i,k,vint,pt2pr,2)
+#else
+ call ConvHaEM(i,k,vint,2)
+#endif
+ else
+ hsource(nsi,i,k)=hsource(nsi,i,k)+vint
+#if __MC3D__ || __CXLATCE__
+ if(prd.gt.1d-20)
+ &hpt2source(nsi,i,k)=hpt2source(nsi,i,k)
+ & +hsource(nsi,i,k)*min(1d0,pt2pr/prd/eeha(i)**2)
+#endif
+ endif
+
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine rinphoto(im,i,j,np,rrrl,alll,vintw,prd,pt2pr)
+c---------------------------------------------------------------------
+c integration with weight function for secondary particle prod.
+c im - primary energy
+c i - current energy
+c j+1 - current depth
+c rrrl - inverse m.f.p. of the produced particle
+c alll - decay factor for the produced particle, alll=B_dec/eeha(i)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ v1=0.d0
+ v3=0.d0
+ vintw=0.d0
+ prd=0d0
+ pt2pr=0.d0
+c v1,v3 - contributions to particle spectra at depths zha(j), zha(j+1)
+c ( sum over parent type and energy ( eeha(k) ) ):
+c prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ imn=max(iemin,i)
+
+ do k=im,imn,-1
+ kk=k+minEhad
+ ww=wwHa(k,i,6,np)*svh(kk)
+ v1=v1+ww*ag(kk,j)
+ v3=v3+ww*ag(kk,j+1)
+#if __MC3D__ || __CXLATCE__
+ fsinth2=sin2theta(kk,2)
+ pt2g=eeha(k)**2*fsinth2
+ pt2pr=pt2pr+ww*ag(kk,j)*(pt2w(k,i,6,np)+fptadd(5,i,pt2g))
+#endif
+ enddo
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with int. contribution
+ prd=v3!*dzHa
+ pt2pr=pt2pr!*dzHa
+#endif
+
+ z1=zha(j) !lower border of the depth bin
+ z3=zha(j+1) !upper border of the depth bin
+
+ tttm=exp(-alll*delLe)
+ !prob. of no decay between z1, z3
+ if(tttm.gt..9d0*rhora)then
+c small decay prob. => linear integration over dzHa
+ z2=z2mid !mid of the depth interval
+ dist2=distmid
+ jlin=1
+ else
+c large decay prob. => integration over dl with the non-decay weight
+ dist2=distz(j+1)-log(.5d0*(1.d0+tttm))/alll !half-decay distance
+ if(dist2.gt.distz(j).or.dist2.lt.distz(j+1))
+ * dist2=.5d0*(distz(j)+distz(j+1))
+ if(dist2.le.0.d0)then
+ z2=deptht(abs(dist2),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(dist2,radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+ if(z2.lt.z1.or.z2.gt.z3)z2=z2mid
+ jlin=0
+ endif
+ de1=exp(-dzHa*rrrl) !prob. of no interaction for the produced
+ !particle between z1, z3
+ de2=exp(-(z3-z2)*rrrl) !prob. of no interaction for the produced
+ !particle between z2, z3
+
+c contribution to particle spectra at depth z2 (interpolation between z1 - z4)
+ www2=(z2-z1)/dzHa
+ www1=1.d0-www2
+ if(v1*v3.gt.0.d0)then
+ v2=v1**www1*v3**www2
+ else
+ v2=max(0.d0,v1*www1+v3*www2)
+ endif
+
+ v1=v1*de1 !correction for interaction loss
+ v2=v2*de2
+ if(jlin.eq.1)then
+ v1=v1*tttm !correction for decay loss
+ v2=v2*exp(-alll*(dist2-distz(j+1)))
+ vintw=(v1+4.d0*v2+v3)/6.d0*dzHa !Simpson formula ( int(dzHa) )
+ else
+c integration with non-decay weight - Simpson formula
+c ( int(dx), x(l)=exp(-alll*(l1-l)), l - slant distance, l1 = l(z1) ):
+c int(dl)_l1^l3 x(l)*rho_air(l)*v(l) = int(dx)_tttm^1 rho_air(l)/alll*v(l);
+c rho_air(l)=dzHa(l)/dl, alll=B_dec/E, tttm=exp(-alll*(l1-l3))
+c v(l) - prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ v1=v1*rhoz(j)
+ v3=v3*rhoz(j+1)
+ hz=heightt(abs(dist2),radtr0)
+ rhhz=rhoair(hz)
+ v2=v2*rhhz
+ vintw=(v1+4.d0*v2+v3)/6.d0*(1.d0-tttm)/alll
+ endif
+ return
+ end
+
+c---------------------------------------------------------------------
+ subroutine rinmu(im,i,j,rrrl,alll,vintw,prd,pt2pr)
+c---------------------------------------------------------------------
+c integration with weight function for secondary particle prod.
+c im - primary energy
+c i - current energy
+c j+1 - current depth
+c rrrl - inverse m.f.p. of the produced particle
+c alll - decay factor for the produced particle, alll=B_dec/eeha(i)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ v1=0.d0
+ v3=0.d0
+ vintw=0.d0
+ prd=0d0
+ pt2pr=0d0
+c v1,v3 - contributions to particle spectra at depths zha(j), zha(j+1)
+c ( sum over parent type and energy ( eeha(k) ) ):
+c prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ imn=max(iemin,i)
+
+
+ do k=im,imn,-1
+ kk=k+minEhad
+ ww=agmu(k,i)*svm(kk)
+ v1=v1+ww*ag(kk,j)
+ v3=v3+ww*ag(kk,j+1)
+#if __MC3D__ || __CXLATCE__
+ fsinth2=sin2theta(kk,2)
+ pt2g=eeha(k)**2*fsinth2
+ pt2pr=pt2pr+(pt2mu(k,i,1)+fptadd(9,i,pt2g))*ww*ag(kk,j)
+#endif
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with decay contribution
+ prd=v3!*dzHa
+ pt2pr=pt2pr!*dzHa
+#endif
+
+ z1=zha(j) !lower border of the depth bin
+ z3=zha(j+1) !upper border of the depth bin
+
+ tttm=exp(-alll*delLe)
+ !prob. of no decay between z1, z3
+ if(tttm.gt..9d0*rhora)then
+c small decay prob. => linear integration over dzHa
+ z2=z2mid
+ dist2=distmid
+ jlin=1
+ else
+c large decay prob. => integration over dl with the non-decay weight
+ dist2=distz(j+1)-log(.5d0*(1.d0+tttm))/alll !half-decay distance
+ if(dist2.gt.distz(j).or.dist2.lt.distz(j+1))
+ * dist2=.5d0*(distz(j)+distz(j+1))
+ if(dist2.le.0.d0)then
+ z2=deptht(abs(dist2),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(dist2,radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+ if(z2.lt.z1.or.z2.gt.z3)z2=z2mid
+ jlin=0
+ endif
+ de1=exp(-dzHa*rrrl) !prob. of no interaction for the produced
+ !particle between z1, z3
+ de2=exp(-(z3-z2)*rrrl) !prob. of no interaction for the produced
+ !particle between z2, z3
+
+c contribution to particle spectra at depth z2 (interpolation between z1 - z4)
+ www2=(z2-z1)/dzHa
+ www1=1.d0-www2
+ if(v1*v3.gt.0.d0)then
+ v2=v1**www1*v3**www2
+ else
+ v2=max(0.d0,v1*www1+v3*www2)
+ endif
+
+ v1=v1*de1 !correction for interaction loss
+ v2=v2*de2
+ if(jlin.eq.1)then
+ v1=v1*tttm !correction for decay loss
+ v2=v2*exp(-alll*(dist2-distz(j+1)))
+ vintw=(v1+4.d0*v2+v3)/6.d0*dzHa !Simpson formula ( int(dzHa) )
+ else
+c integration with non-decay weight - Simpson formula
+c ( int(dx), x(l)=exp(-alll*(l1-l)), l - slant distance, l1 = l(z1) ):
+c int(dl)_l1^l3 x(l)*rho_air(l)*v(l) = int(dx)_tttm^1 rho_air(l)/alll*v(l);
+c rho_air(l)=dzHa(l)/dl, alll=B_dec/E, tttm=exp(-alll*(l1-l3))
+c v(l) - prod. spectra / m.f.p. ( arrt(k,n1) ) * parent spectra ( rn, pp, ... )
+ v1=v1*rhoz(j)
+ v3=v3*rhoz(j+1)
+ hz=heightt(abs(dist2),radtr0)
+ rhhz=rhoair(hz)
+ v2=v2*rhhz
+ vintw=(v1+4.d0*v2+v3)/6.d0*(1.d0-tttm)/alll
+ endif
+ return
+ end
+
+
+c---------------------------------------------------------------------
+ subroutine rinphotodec(im,i,jk,npi,alll,vintdec,dec,pt2dc)
+c---------------------------------------------------------------------
+c semi-analytical integration with constant air density for a given depth
+c for muon and pion prod. from pion and kaon decay from photonuclear effect
+c integration with weight function for secondary particle prod. by decays
+c im - primary energy
+c i - current energy
+c jk+1 - current depth
+c npi - intermediate decaying particle (3 and 4 are charged kaons)
+c (3 if secondary is pion, 4 if secondary is muon)
+c alll - decay factor for the produced particle, alll=B_dec/eeha(i)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ logical gov2
+ common /cxrinphotomuarea/Amdhti(maxime,maxime,2:3),dhtil(maxime)
+ *,rhhzm,gov2
+
+ v1=0.d0
+ v2=0.d0
+ v3=0.d0
+ vintdec=0.d0
+ dec=0.d0
+ pt2dc=0d0
+ ii=i+minEhad
+ imn=max(iemin,i)
+ np=npi
+ if(npi.eq.4)np=3
+
+c initialize and precalculate terms of equations
+
+ tttm=exp(-alll*delLe) !prob. of no decay for the
+ !produced particle between z1, z3
+ ratioag=0.d0
+ if(ag(ii,jk+1).gt.0.d0)then
+ ratioag=ag(ii,jk)/ag(ii,jk+1)
+ if(ratioag.le.0.d0)then
+ ratioag=-1.d30
+ else
+ ratioag=log(ratioag)
+ endif
+ endif
+
+ dhtil(i)=ratioag/delLe
+ do j=imn,im
+ Amdhti(j,i,np)=allldec(i,npi)-dhtil(j)
+ if(Amdhti(j,i,np).lt.1.d20)then
+ Amdhti(j,i,np)=(1.d0-exp(-Amdhti(j,i,np)*delLe))/Amdhti(j,i,np)
+ else
+ Amdhti(j,i,np)=0.d0
+ endif
+ enddo
+
+c v3 - contributions to particle spectra at depths zha(jk+1)
+
+ if(npi.eq.3)then
+ kmax=min(im,ndecmax(i,2))
+ else
+ kmax=min(im,ndecmax(i,9))
+ endif
+ do k=imn,kmax !sum over intermediate pion energy for z3
+ vint=0.d0
+ do j=k,im !sum over gamma energy
+ jj=j+minEhad
+ tt1=ag(jj,jk+1)*Amdhti(j,k,np)
+ vint=vint+wwha(j,k,6,np)*svh(jj)*tt1
+ enddo
+ v3=v3+vint*wwdec(k,i,npi+3)
+#if __MC3D__ || __CXLATCE__
+ if(npi.eq.2)then
+ pt2dc=pt2dc+wwdec(k,i,npi+3)*vint*pt2mu(k,i,3)
+ elseif(npi.eq.4)then
+ pt2dc=pt2dc+wwdec(k,i,npi+3)*vint*pt2mu(k,i,3)
+ elseif(npi.eq.3)then
+ pt2dc=pt2dc+wwdec(k,i,npi+3)*vint*pt2pi(1,k,i)
+ endif
+#endif
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+c simplified integration needed for relative weight with int. contribution
+ dec=v3!*dzHa/rhoz(jk+1)
+ pt2dc=pt2dc!*dzHa/rhoz(jk+1)
+#endif
+
+ v3=max(v3*rhhzm,0.d0)
+
+
+
+ z1=zha(jk) !lower border of the depth bin
+ z3=zha(jk+1) !upper border of the depth bin
+
+ if(tttm.gt..9d0)then
+c small decay prob. => linear integration over dl (slant distance)
+ dist2=.5d0*(distz(jk)+distz(jk+1)) !mid of the distance interval
+ else
+c large decay prob. => integration over dl with the non-decay weight
+ dist2=distz(jk+1)-log(.5d0*(1.d0+tttm))/alll !half-decay distance
+ if(dist2.gt.distz(jk).or.dist2.lt.distz(jk+1))
+ * dist2=.5d0*(distz(jk)+distz(jk+1))
+ endif
+
+
+
+c v2 - contributions to particle spectra at depths z2
+
+ if(gov2)then
+ del2=distz(jk)-dist2
+ do k=imn,kmax !sum over intermediate pion energy for z2
+ vint=0.d0
+ do j=k,im !sum over gamma energy
+ jj=j+minEhad
+ Amdhti2=allldec(k,np)-dhtil(j)
+ if(Amdhti2.lt.1.d20)then
+ tt1=ag(jj,jk+1)/Amdhti2*(1.d0-exp(-Amdhti2*del2))
+ vint=vint+wwha(j,k,6,np)*svh(jj)*tt1
+ endif
+ enddo
+ v2=v2+vint*wwdec(k,i,npi+3)
+ enddo
+ v2=max(v2*rhhzm,0.d0)
+ else
+ if(dist2.le.0.d0)then
+ z2=deptht(abs(dist2),radtr0) !new slant depth along shower axis, g/cm^2
+ z2=dphmaxi0-z2
+ else
+ z2=deptht(dist2,radtr0) !new slant depth along shower axis, g/cm^2
+ endif
+ if(z2.lt.z1.or.z2.gt.z3)z2=z2mid
+ www2=(z2-z1)/dzHa
+ v2=max(0.d0,v3*www2)
+ endif
+
+ if(tttm.gt..9d0)then
+c linear integration over distance - Simpson formula:
+c int(dl)_l1^l3 x(l) * v(l)
+c ( x(l)=exp(-alll*(l1-l)), l - slant depth, l1 = l(z1), alll=B_dec/E,
+c v(l) = decay spectra * B_dec / eeha(k) * parent spectra )
+ vintdec=(v1*tttm+4.d0*v2*dsqrt(tttm)+v3)/6.d0*delLe
+ else
+c integration with non-decay weight - Simpson formula:
+c int(dl)_l1^l3 x(l) * v(l) = int(dx)_tttm^1 v(l) / alll;
+c tttm=exp(-alll*(l3-l1)) )
+ vintdec=(v1+4.d0*v2+v3)/6.d0*(1.d0-tttm)/alll
+ endif
+
+
+ return
+ end
+
+c---------------------------------------------------------------------
+ double precision function rlamold(k,e,w)
+c---------------------------------------------------------------------
+c inelastic interaction path
+ implicit double precision (a-h,o-z)
+ dimension alfa(5),rl(5)
+ parameter(e0=3.d2)
+ data alfa/0.06,0.06,0.06,.06,.06/
+ data rl/87.,120.,133.,133.,133./
+ if(k.le.5)then
+ np=k
+ elseif(k.eq.7)then
+ np=1
+ else
+ np=2
+ endif
+ if(e.lt.300.d0) then
+ rlamold=rl(np)
+ else
+ rlamold=rl(np)/(1.d0+alfa(np)*dlog(e/e0))
+ end if
+ rlamold=rlamold/(1.d0-w)
+ return
+ end
+c Electro-magnetic cascade routines with lateral distributions
+c (created by V. Chernatkin, partly based on the original work
+c by N. Kalmykov and S. Ostapchenko, updated by T. Pierog)
+c Last modifications 28.06.2017 correction for energy deposit by T.Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+#if __MC3D__ || __CXLATCE__
+
+c-------------------------------------------------------------------------
+ subroutine ConvPartLept3d(alpha,beta,x,y,Eparti,Zpart
+ * ,Wpart,idi) !vc061005
+c-------------------------------------------------------------------------
+c ConvPartLept - form initial conditions for e/m cascade
+c called by AUSGAB (in egs4_conex)
+c Epart -lepton kinetic energy,
+c Zpart -lepton depth,
+c Wpart -lepton weight,
+c idi -lepton id ( 0 - gamma, -1 - e-, +1 - e+ )
+c And 3D info for moment calculation
+c alpha - sin(theta)cos(phi)
+c beta - sin(theta)sin(phi)
+c x - x distance to shower axis
+c y - y distance to shower axis
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+#include "conex.h"
+ logical go
+
+ go=.false.
+ Epart=Eparti
+
+c Each particle of energy Epart is splitted between two e-bins with weights
+c appp1, appp2 ( appp1 + appp2 = 1, E_i * appp1 + E_(i+1) * appp2 = Epart)
+ if(Epart.gt.Eo.and.Zpart.lt.ZZEM(maxZ))then
+ i=min(int(1.d0+log10(Epart/Eo)*emdecade),maxE-1)
+ appp1=(eeEM(i+1)-Epart)/(eeEM(i+1)-eeEM(i))
+ appp2=1.d0-appp1
+ if(appp1.lt.-1.d-10.or.appp2.lt.-1.d-10
+ * .or.appp1.gt.1.000000001d0.or.appp2.gt.1.000000001d0)then
+ write(*,*)'appp-lept',i,eeEM(i),epart,eeEM(i+1),appp1,appp2
+ * ,zpart,idi
+ appp1=max(0.d0,appp1)
+ appp2=max(0.d0,appp2)
+ endif
+
+ imaxE0=max(imaxE0,i+1)
+
+ if(Zpart.le.ZZo)then
+ j=1
+ else
+ j=int((Zpart-ZZo)/dZZ)+2 !correspond to the next bin (tp171203)
+ if(j.gt.maxZ)return
+ endif
+
+ jminZ0=min(jminZ0,j)
+
+ if(idi.eq.0)then !gammas
+ id=2
+ SFG(i,j)=SFG(i,j) + Wpart*appp1
+ SFG(i+1,j)=SFG(i+1,j) + Wpart*appp2
+ elseif(idi.eq.-1)then !e-
+ id=1
+ SFE(i,j)=SFE(i,j) + Wpart*appp1
+ SFE(i+1,j)=SFE(i+1,j) + Wpart*appp2
+ elseif(idi.eq.1)then !e+
+ id=3
+ SFP(i,j)=SFP(i,j) + Wpart*appp1
+ SFP(i+1,j)=SFP(i+1,j) + Wpart*appp2
+ else
+ go=.true.
+ endif
+
+ if(.not.go)then
+
+c il faut definir source3d() ca pour toutes les profondeurs dans conex.incep
+c et(!) de passer le numero de la profondeur (j ici) comme argument a SDEstep()
+c pour le substituer dans source3d()
+
+c alpha et beta ont le meme sens que dans cascade, alors
+c \alpha = \sin\theta \cos\phi, \beta=\sin\theta \sin\phi
+
+ do ialpha=1,n4mreal
+ source3d(ialpha,i,j,id)=source3d(ialpha,i,j,id)
+ & +appp1*Wpart*x**i4A(ialpha,3)*y**i4A(ialpha,4)
+ & *alpha**i4A(ialpha,1)*beta**i4A(ialpha,2)
+ source3d(ialpha,i+1,j,id)=source3d(ialpha,i+1,j,id)
+ & +appp2*Wpart*x**i4A(ialpha,3)*y**i4A(ialpha,4)
+ & *alpha**i4A(ialpha,1)*beta**i4A(ialpha,2)
+ enddo
+ endif
+
+
+ elseif(Eo.gt.emin.and.Zpart.lt.ZZEM(maxZ))then
+ go=.true.
+ else
+ print *,'ConvPartLept3d ?????',Eparti,Zpart,Wpart,idi
+ endif
+ if(go.and.iwrt.ge.2)then
+ if(id.eq.1)Epart=Epart+2.d0*amc2 !to count properly the rest mass of e-
+ Ebal=Epart
+ imode=1
+ call Profana(Zpart-0.1d0*dzHa,zshmax,Ebal,Epart
+ & ,Wpart,999,imode) !count it for energy depo
+ etotsource=etotsource-ebal*Wpart
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)
+ * write (ifck,'(a,5(i6),2e13.4)') 'ConvPartLept3: added particle :'
+ * ,i,j,id,imaxE0,jminZ0,eeem(i),eeem(imaxE0)
+#endif
+
+ return
+ end
+
+c-------------------------------------------------------------------------
+ subroutine ConvHaEM3D(ih,j,Wpart,pt2,idi) !tp140205
+c-------------------------------------------------------------------------
+c ConvHaEM - form initial conditions for e/m cascade from hadronic cascade
+c called by HadronCascade (in conex-had)
+c ih -hadronic kinetic energy bin,
+c j -lepton depth bin,
+c Wpart -lepton weight,
+c idi -lepton id ( 0 - gamma, -1 - e-, +1 - e+ )
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+#include "conex.h"
+
+ i=ih+minEHad
+
+
+ imaxE0=max(imaxE0,i)
+ jminZ0=min(jminZ0,j)
+
+ if(idi.eq.0)then !gammas
+ id=2
+ SFG(i,j)=SFG(i,j) + wsf2noint(1,i)*Wpart
+ SF2HAD(1,i)=SF2HAD(1,i) + (1.d0-wsf2noint(1,i))*Wpart
+ elseif(idi.eq.-1)then !e-
+ id=1
+ SFE(i,j)=SFE(i,j) + wsf2noint(2,i)*Wpart
+ SF2HAD(2,i)=SF2HAD(2,i) + (1.d0-wsf2noint(2,i))*Wpart
+ elseif(idi.eq.1)then !e+
+ id=3
+ SFP(i,j)=SFP(i,j) + wsf2noint(3,i)*Wpart
+ SF2HAD(3,i)=SF2HAD(3,i) + (1.d0-wsf2noint(3,i))*Wpart
+ elseif(idi.eq.2)then !gammas from photonuclear effect
+ SFG(i,j)=SFG(i,j) + Wpart
+ id=2
+ else
+ return
+ endif
+
+c 3D source
+
+ do ialpha=1,n4mreal
+ if(i4A(ialpha,3).eq.0.and.i4A(ialpha,4).eq.0)then
+c integral of phi from 0 to 2pi of alpha=sin(theta)*cos(phi)
+c and beta=sint(theta)*sin(phi) for different moments with sin(theta)=pt/P
+ if(i4A(ialpha,1).ne.0.and.i4A(ialpha,2).ne.0)then
+ stop'integral of alpha and beta not defined !'
+ else
+ m=(i4A(ialpha,1)+i4A(ialpha,2))/2
+
+c No integration needed for the source (just as for MC)
+
+ if(pt2.gt.0d0.and.m.ne.0)then
+c phiint=(\int_0^2pi dphi cos(phi)^m1 sin(phi)^m2)/2pi
+ if(m.eq.1)then
+ phiint=0.5
+ elseif(m.eq.2)then
+ phiint=0.375d0
+ elseif(m.eq.3)then
+ phiint=0.3125
+ elseif(m.eq.4)then
+ phiint=35d0/128d0
+ elseif(m.eq.5)then
+ phiint=63d0/256d0
+ else
+ stop'integral of phi not defined above i4a>11'
+ endif
+
+c sin(theta)~pt/E
+ source3d(ialpha,i,j,id)=source3d(ialpha,i,j,id)
+c & +Wpart*(pt2/eeem(i)**2)**m
+ & +Wpart*phiint*(pt2/eeem(i)**2)**m
+ endif
+
+ endif
+ endif
+ enddo
+
+ return
+ end
+
+
+c-----------------------------------------------------------------------!vc1765
+c Solve Diff. Equation step precision control
+c-----------------------------------------------------------------------!vc1765
+ subroutine SDEstepp(zai,dze,iqueue)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ integer iqueue(0:n4m)
+
+ prec=1d-2 !precision
+ niter=1
+ if(abs(dze-dZZ).lt.1.d-10)niter=0
+ test0=1.d30
+ test1=1.d30
+ za=max(1d-10,zai) !to avoid precision problem with z=0
+
+c when trying a new step the start point is stored in (,,3,)
+c (,,0,), (,,1,), (,,2,) are used for z0, z0+dz/2, z0+dz in SDEstep
+
+ mtest=maxe
+ do j=mine, maxe
+ do ialpha=0, n4mreal-1
+ AF4m(ialpha,j,0,1)=AF4m(ialpha,j,3,1)
+ AF4m(ialpha,j,0,2)=AF4m(ialpha,j,3,2)
+ AF4m(ialpha,j,0,3)=AF4m(ialpha,j,3,3)
+ enddo
+ if(lcorrp)then
+ verif=AF4m(0,j,0,1)+AF4m(0,j,0,2)+AF4m(0,j,0,3)
+ if(verif.gt.0.d0)mtest=j-1
+ endif
+ enddo !ialpha
+ mtest=min(mine+int(emdecade),max(mine,mtest))
+
+
+ call SDEstep(za,dze,iqueue) !step with dz
+
+ if(.not.lcorrp)goto 123 !no precision control for large slant depth
+
+ v1=AF4m(1,mtest,2,1)+AF4m(1,mtest,2,2)+AF4m(1,mtest,2,3) !this value is used to evaluate precision
+ & +AF4m(0,mtest,2,1)+AF4m(0,mtest,2,2)+AF4m(0,mtest,2,3)
+
+
+ do !cutting step in two (if needed for precision asked)
+ niter=niter+1
+ call SDEstep(za,dze*.5d0,iqueue) !1 step with dz/2
+
+ v21=AF4m(1,mtest,2,1)+AF4m(1,mtest,2,2)+AF4m(1,mtest,2,3) !this value is used to evaluate precision
+ & +AF4m(0,mtest,2,1)+AF4m(0,mtest,2,2)+AF4m(0,mtest,2,3)
+
+ do j=mine, maxe
+ do ialpha=0, n4mreal-1
+ AF4m(ialpha,j,0,1)=AF4m(ialpha,j,2,1)
+ AF4m(ialpha,j,0,2)=AF4m(ialpha,j,2,2)
+ AF4m(ialpha,j,0,3)=AF4m(ialpha,j,2,3)
+ enddo
+ enddo !ialpha
+
+ call SDEstep(za+dze*.5d0,dze*.5d0,iqueue) !+1 step with dz/2
+
+ v2=AF4m(1,mtest,2,1)+AF4m(1,mtest,2,2)+AF4m(1,mtest,2,3) !this value is used to evaluate precision
+ & +AF4m(0,mtest,2,1)+AF4m(0,mtest,2,2)+AF4m(0,mtest,2,3)
+
+
+ test=abs(v2-v1)/(v2+v1)
+ if (test.gt.prec.and.test.le.test1.and.dze.gt.0.1d0) then !evaluating precision
+#ifdef __CXDEBUG__
+ if(isx.ge.1)write(*,*) za, ' iteration dze=', dze, test
+ & , v1,v21,v2 !this means the step was too big. we cut it
+#endif
+ test1=max(test,test0)
+ test0=test
+ dze=dze*.5d0
+ v1=v21 !take previous small step as new big
+ do j=mine, maxe
+ do ialpha=0, n4mreal-1 !return to start position
+ AF4m(ialpha,j,0,1)=AF4m(ialpha,j,3,1)
+ AF4m(ialpha,j,0,2)=AF4m(ialpha,j,3,2)
+ AF4m(ialpha,j,0,3)=AF4m(ialpha,j,3,3)
+ enddo
+ enddo !ialpha
+ else
+ goto 123
+ endif
+ enddo
+
+ 123 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.1.and.test.gt.prec)write(*,*)'Precision not reached !'
+ & ,test,test1,test0
+#endif
+ if(niter.eq.1)lcorrp=.false.
+
+ end
+
+
+c one step of integration with given dF
+c------------------------------------------------------------------------------
+ subroutine SDEstep(ze,dze,iqueue) !vc2335
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+#include "conex.h"
+ integer iqueue(0:n4mreal)
+ dimension ff(3,3),feg1(3),feg2(3),feg3(3), rhoa(3)
+ dimension DAF(0:n4mreal,maximume,0:2,3)
+c common/cxcurdepth/kcdep
+
+
+ x1=distance0(ze)
+ x2=distance0(ze+dze*.5d0)
+ x3=distance0(ze+dze)
+
+ h1=heightt(x1,radtr0)
+ h2=heightt(x2,radtr0)
+ h3=heightt(x3,radtr0)
+
+ rhoa(1)=rhoair(h1) !values of rho for z0, z0+dz/2, z0+dz
+ rhoa(2)=rhoair(h2)
+ rhoa(3)=rhoair(h3)
+
+
+ do ia=4,1,-1 !layer number
+ if (h2.gt.eatm(ia)) goto 8
+ enddo
+ 8 continue
+ sinav=radtr0/sqrt(x2**2+radtr0**2) !angle with vertical
+ Drho=sinav/catm(ia)
+c print *, 'Drho', Drho
+
+
+ do ialpha=0, n4mreal-1 !return to start position
+ do j=mine, maxe
+ do ip=1,3
+ DAF(ialpha,j,0,ip)=0.d0 !delta F=0
+ DAF(ialpha,j,1,ip)=0.d0 !delta F=0
+ DAF(ialpha,j,2,ip)=0.d0
+ AF4m(ialpha,j,1,ip)=0.d0
+ AF4m(ialpha,j,2,ip)=0.d0
+ enddo !ip
+ enddo !j
+ enddo !ialpha
+
+ do jalpha=0, n4mreal-1 !this runs the equations
+ ialpha=iqueue(jalpha) !queue() gives the order of solving
+
+ m1=i4A(ialpha,1)
+ m2=i4A(ialpha,2)
+ m3=i4A(ialpha,3)
+ m4=i4A(ialpha,4)
+
+ m=(m1+m2+m3+m4)/2
+ if (m1+m2+m3+m4.eq.2*m) then
+ if ((m2.ne.0).or.(m4.ne.0)) then
+ iialpha=ifindindexs(m2,m1,m4+2,m3)
+c if (iialpha.ne.n4m) print *, ' symm: ',iialpha, ' for ', ialpha
+ else
+ iialpha=n4m
+ endif
+ if (iialpha.ne.n4m) then
+ do j=maxe, mine,-1
+ do ip=1,3 !delta F
+ DAF(ialpha,j,0,ip)=Drho**2*AF4m(iialpha,j,0,ip)/2.d0
+ DAF(ialpha,j,1,ip)=Drho**2*AF4m(iialpha,j,1,ip)/2.d0
+ DAF(ialpha,j,2,ip)=Drho**2*AF4m(iialpha,j,2,ip)/2.d0
+ enddo
+ enddo
+ endif
+ else
+ if ((m2.ne.0).or.(m4.ne.0)) then
+ iialpha=ifindindexs(m2,m1,m4+1,m3)
+c if (iialpha.ne.n4m) print *, 'asymm: ', iialpha, ' for ', ialpha
+ else
+ iialpha=n4m
+ endif
+ if (iialpha.ne.n4m) then
+ do j=maxe, mine,-1
+ do ip=1,3 !delta F
+ DAF(ialpha,j,0,ip)=Drho*AF4m(iialpha,j,0,ip)
+ DAF(ialpha,j,1,ip)=Drho*AF4m(iialpha,j,1,ip)
+ DAF(ialpha,j,2,ip)=Drho*AF4m(iialpha,j,2,ip)
+ enddo
+ enddo
+ endif
+ endif
+
+ do j=maxe, mine,-1
+
+ call homoef(j,ce2,ce3,cg1,cg3,cp1,cp2,he1,he2,he3 !ce2... is the inverse matrix of he1...
+ * ,hg1,hg2,hg3,hp1,hp2,hp3,w1,w2,w3)
+
+ do i=1,3
+ ff(i,1)=0.d0
+ ff(i,2)=0.d0
+ ff(i,3)=0.d0
+ enddo
+
+c I changed the notations to save place. now in AF4m(1,2,3,4)
+c 1 is equation number
+c 2 is the energie
+c 3 is depth 0=z0, 1=z0+dz/2, 2=z0+dz
+c 4 is sort of particle 1=electrons, 2=photons, 3=positrons
+
+ do i=j+1, maxe !this accounts for L[F]
+ do kk=1,3
+ do ipt1=1,3
+ do ipt2=1,3
+c ff(kk,ipt1)=ff(kk,ipt1)+AF4m(ialpha,i,kk-1,ipt2)
+ ff(kk,ipt1)=ff(kk,ipt1)+(AF4m(ialpha,i,kk-1,ipt2)
+ & +DAF(ialpha,i,kk-1,ipt2))
+ & *sef(ipt2,ipt1,i,j)
+ enddo !ipt1
+ enddo !ipt2
+ enddo !kk
+ enddo !i
+
+ do jjj=1, ISIr(ialpha,0,1) !this is the source due to Coulomb scattering
+ jj=ISIr(ialpha,jjj,3)
+ ic=ISIr(ialpha,jjj,1)
+ jc=ISIr(ialpha,jjj,2)
+ ccc=0d0
+ if(imscat.eq.1)ccc=cccoef(ic,jc,j) !coulomb term
+ ccce=0d0
+ cccg=0d0
+ cccp=0d0
+ if(i1DEM.eq.0)then !pt term (effective)
+ ccce=cccoefpt(ic,jc,j,1)
+ cccg=cccoefpt(ic,jc,j,2)
+ cccp=cccoefpt(ic,jc,j,3)
+ endif
+
+ do kk=1,3
+ ccc1=ccc+ccce
+ ff(kk,1)=ff(kk,1)+ASCr(ialpha,jjj)*ccc1*(AF4m(jj,j,kk-1,1)
+ & +DAF(ialpha,j,kk-1,1))
+ ccc2=cccg
+ ff(kk,2)=ff(kk,2)+ASCr(ialpha,jjj)*ccc2*(AF4m(jj,j,kk-1,2)
+ & +DAF(ialpha,j,kk-1,2))
+ ccc3=ccc+cccp
+ ff(kk,3)=ff(kk,3)+ASCr(ialpha,jjj)*ccc3*(AF4m(jj,j,kk-1,3)
+ & +DAF(ialpha,j,kk-1,3))
+ enddo !kk
+ enddo
+
+ do jjj=1, ISI(ialpha,0) !this is the spatial part of the source. that's why /rhoa()
+ jj=ISI(ialpha,jjj)
+ do kk=1,3
+ ff(kk,1)=ff(kk,1)+ASC(ialpha,jjj)*AF4m(jj,j,kk-1,1)/rhoa(kk)
+ ff(kk,2)=ff(kk,2)+ASC(ialpha,jjj)*AF4m(jj,j,kk-1,2)/rhoa(kk)
+ ff(kk,3)=ff(kk,3)+ASC(ialpha,jjj)*AF4m(jj,j,kk-1,3)/rhoa(kk)
+ enddo !kk
+ enddo
+
+c add 3dsource
+c do kk=1,3
+c ff(kk,1)=ff(kk,1)+source3d(ialpha,j,kcdep,1)
+c ff(kk,2)=ff(kk,2)+source3d(ialpha,j,kcdep,2)
+c ff(kk,3)=ff(kk,3)+source3d(ialpha,j,kcdep,3)
+c enddo !kk
+
+c Note: if you add some other source, make it here the same manner as I did
+c (not just by adding it after). Here it will be integrated correctly with blow32()
+
+ do i=1,3
+ feg1(i)=(ff(i,1)+cg1*ff(i,2)+cp1*ff(i,3))
+ feg2(i)=(ce2*ff(i,1)+ff(i,2)+cp2*ff(i,3))
+ feg3(i)=(ce3*ff(i,1)+cg3*ff(i,2)+ff(i,3))
+ enddo
+
+ ffeg1=(AF4m(ialpha,j,0,1)+cg1*AF4m(ialpha,j,0,2)
+ * +cp1*AF4m(ialpha,j,0,3))*exp(w1*dze)
+ * +blow32(feg1,w1,dze,1)
+ ffeg2=(ce2*AF4m(ialpha,j,0,1)+AF4m(ialpha,j,0,2)
+ * +cp2*AF4m(ialpha,j,0,3))*exp(w2*dze)
+ * +blow32(feg2,w2,dze,1)
+ ffeg3=(ce3*AF4m(ialpha,j,0,1)+cg3*AF4m(ialpha,j,0,2)
+ * +AF4m(ialpha,j,0,3))*exp(w3*dze)
+ * +blow32(feg3,w3,dze,1)
+
+c here F(z0+dz)
+
+ AF4m(ialpha,j,2,1)=
+ & he1*ffeg1+he2*ffeg2+he3*ffeg3
+ AF4m(ialpha,j,2,2)=
+ & hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ AF4m(ialpha,j,2,3)=
+ & hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ ffeg1=(AF4m(ialpha,j,0,1)+cg1*AF4m(ialpha,j,0,2)
+ * +cp1*AF4m(ialpha,j,0,3))*exp(w1*dze*0.5d0)
+ * +blow32(feg1,w1,dze,0)
+ ffeg2=(ce2*AF4m(ialpha,j,0,1)+AF4m(ialpha,j,0,2)
+ * +cp2*AF4m(ialpha,j,0,3))*exp(w2*dze*0.5d0)
+ * +blow32(feg2,w2,dze,0)
+ ffeg3=(ce3*AF4m(ialpha,j,0,1)+cg3*AF4m(ialpha,j,0,2)
+ * +AF4m(ialpha,j,0,3))*exp(w3*dze*0.5d0)
+ * +blow32(feg3,w3,dze,0)
+
+c here F(z0+dz/2)
+
+ AF4m(ialpha,j,1,1)=
+ & he1*ffeg1+he2*ffeg2+he3*ffeg3
+ AF4m(ialpha,j,1,2)=
+ & hg1*ffeg1+hg2*ffeg2+hg3*ffeg3
+ AF4m(ialpha,j,1,3)=
+ & hp1*ffeg1+hp2*ffeg2+hp3*ffeg3
+
+ enddo ! cycle over j is completed
+ enddo !ialpha
+
+ end
+
+
+c-------------------subroutine integral over a source function-----------------
+ double precision function blow32(aeg,w,adelt,intp) !+vc1765
+c I replace 3 point interploation by 2 point in case it gives negative
+c integral for all-positive function. it's not really nessesary.
+c I did it for non-symmetric case where it's crutial
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ integer intp
+ dimension aeg(3)
+
+
+ if(abs(w).gt.1.d-20)then
+ if(intp.eq.1)then
+ xau=adelt*w
+ yau=(exp(xau)-1.d0)/xau
+ func0=yau*adelt
+ func1=2.d0*(yau-1.d0)/w
+ func2=(4.d0*(yau-1.d0)/xau-yau-1.d0)/w
+ else
+ xau=adelt*w/2.d0
+ yau=(exp(xau)-1.d0)/xau
+ func0=yau*adelt/2.d0
+ func1=(yau-1.d0)/w
+ func2=((yau-1.d0)/xau-yau/2.d0)/w
+ endif
+ else
+ if(intp.eq.1)then
+ func0=adelt
+ func1=adelt
+ func2=adelt/6.d0
+ else
+ func0=adelt/2.d0
+ func1=adelt/4.d0
+ func2=-adelt/24.d0
+ endif
+ endif
+ s=aeg(1)*func0+(aeg(2)-aeg(1))*func1
+ * +(aeg(3)+aeg(1)-2.d0*aeg(2))*func2
+
+ if ((aeg(1).ge.0.d0.and.aeg(2).ge.0.d0 !this is, actually, my contribution to blow32()
+ & .and.aeg(3).ge.0.d0).and.s.lt.0.d0) then
+ f1=aeg(1)
+ f2=aeg(2)
+ f3=aeg(3)
+ dx=adelt
+
+ if(intp.eq.0)then
+ if(abs(w).gt.1.d-20)then
+ s=(exp(w*dx/2.d0)*(2.d0*f2 + f1*(-2.d0 + dx*w))
+ & + (2.d0*f1 - f2*(2.d0 + dx*w)))/(dx*w**2)
+ else
+ s=dx*(f1 + f2)*0.25d0
+ endif
+ else
+ if(abs(w).gt.1.d-20)then
+ s=(exp(w*dx/2.d0)*(2.d0*f2 + f1*(-2.d0 + dx*w))
+ & + (2.d0*f1 - f2*(2.d0 + dx*w)))/(dx*w**2)+
+ & (exp(w*dx/2.d0)*(2.d0*f3 + f2*(-2.d0 + dx*w))
+ & + (2.d0*f2 - f3*(2.d0 + dx*w)))/(dx*w**2)
+ else
+ s=dx*(f1+f2*2+f3)*0.25d0
+ endif
+ endif
+ endif
+
+ blow32=s
+ return
+ end
+
+
+
+
+c the only thing I changed here is the notation for sef
+c otherwise it's not mine
+c-----------------------------subroutine differential--------------------------
+ subroutine homoef(j,ce2,ce3,cg1,cg3,cp1,cp2,he1,he2,he3
+ * ,hg1,hg2,hg3,hp1,hp2,hp3,w1,w2,w3) !so120204
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ ce2=0.d0
+ ce3=0.d0
+ cg1=0.d0
+ cg3=0.d0
+ cp1=0.d0
+ cp2=0.d0
+ he1=0.d0
+ he2=0.d0
+ he3=0.d0
+ hg1=0.d0
+ hg2=0.d0
+ hg3=0.d0
+ hp1=0.d0
+ hp2=0.d0
+ hp3=0.d0
+ w1=0.d0
+ w2=0.d0
+ w3=0.d0
+
+ auu=sef(1,1,j,j)
+ auv=sef(1,2,j,j)
+ avu=sef(2,1,j,j)
+ avv=sef(2,2,j,j)
+ avw=sef(2,3,j,j)
+ aww=sef(3,3,j,j)
+ awu=sef(3,1,j,j)
+ awv=sef(3,2,j,j)
+
+ aaa=2.d0*aww-auu-avv
+ bbb=(auu-aww)*(avv-aww)-auv*avu-awv*avw
+ ccc=(auu-aww)*avw*awv-auv*avw*awu
+ ppp=dsqrt(aaa**2-bbb*3.d0)/3.d0
+ if(abs(ppp).lt.1.d-14)return
+ qqq=.5d0*(aaa*bbb/3.d0-aaa**3/13.5d0-ccc)/ppp**3
+ if(abs(qqq).le.1.d0)then
+ alf=acos(qqq)
+ elseif(abs(qqq)-1.d0.lt.1.d-5)then
+ alf=pi*0.5d0*(1.d0-qqq)
+ else
+ write(*,*)'qqq,ppp,aaa,bbb,ccc',qqq,ppp,aaa,bbb,ccc
+ alf=0.d0
+ stop
+ endif
+
+ w1=(auu+avv+aww)/3.d0-2.d0*ppp*cos((alf+pi)/3.d0)
+ w2=(auu+avv+aww)/3.d0+2.d0*ppp*cos(alf/3.d0)
+ w3=(auu+avv+aww)/3.d0-2.d0*ppp*cos((alf-pi)/3.d0)
+ if(abs(aww).gt.1.d-14.and.auu/aww.gt.1.d0)then
+ w4=w1
+ w1=w3
+ w3=w4
+ endif
+
+ if(abs((w1-aww)*(w1-avv)-avw*awv).le.1.d-14)then
+ cp1=0.d0
+ cg1=avu/(w1-avv)
+ else
+ cp1=(avu*awv+awu*(w1-avv))/((w1-aww)*(w1-avv)-avw*awv)
+ cg1=(avu+cp1*avw)/(w1-avv)
+ endif
+ ce2=0.d0
+ cp2=0.d0
+ if(abs(w2-auu).gt.1.d-14)ce2=auv/(w2-auu)
+ if(abs(w2-aww).gt.1.d-14)cp2=(awv+ce2*awu)/(w2-aww)
+ if(avu.eq.0.d0)then
+ ce3=0.d0
+ cg3=0.d0
+ elseif(auv.eq.0.d0)then
+ ce3=0.d0
+ cg3=0.d0
+ if(abs(w3-avv).gt.1.d-14)cg3=avw/(w3-avv)
+ else
+ ce3=avw*auv/((w3-auu)*(w3-avv)-avu*auv)
+ cg3=(avw+ce3*avu)/(w3-avv)
+ endif
+
+ he1=1.d0/(1.d0-cg1*ce2-(ce3-cg3*ce2)*(cp1-cp2*cg1)/(1.d0-cg3*cp2))
+ he2=he1*(cg3*(cp1-cp2*cg1)/(1.d0-cg3*cp2)-cg1)
+ he3=-he1*(cp1-cp2*cg1)/(1.d0-cg3*cp2)
+
+ hp1=-he1*(ce3-cg3*ce2)/(1.d0-cg3*cp2)
+ hp2=-(cg3+he2*(ce3-cg3*ce2))/(1.d0-cg3*cp2)
+ hp3=(1.d0-he3*(ce3-cg3*ce2))/(1.d0-cg3*cp2)
+
+ hg1=-he1*ce2-hp1*cp2
+ hg2=1.d0-he2*ce2-hp2*cp2
+ hg3=-he3*ce2-hp3*cp2
+
+ return
+ end
+
+#ifndef __CXSUB__
+
+c------------------------------------------------------------------------------
+c this is the subroutine to call from conex-eph.F
+c------------------------------------------------------------------------------
+ subroutine SolveDiffEqs !vc1854
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension enpart(2)
+ common/cxcequeue/iqueue(0:n4m)
+ integer iqueue
+c common/cxcurdepth/kcdep
+
+c initialize array used for lost energy calculation
+ enpart(1)=0.d0
+ enpart(2)=0.d0
+
+c----------------set initial energy distribution to be uniform-----------------
+
+ lcorrp=.true.
+
+ do j=1, maximumE !remove path correction
+ dethe(j)=1.d0
+ dethp(j)=1.d0
+ dethg(j)=1.d0
+ enddo
+
+c here initial source. it may be 2D (not only M0!=0)
+ do ialpha=0, n4mreal
+ do j=mine, maxe
+ do i=0, 3
+ AF4m(ialpha,j,i,1)=0.d0
+ AF4m(ialpha,j,i,2)=0.d0
+ AF4m(ialpha,j,i,3)=0.d0
+ enddo
+ enddo
+ enddo !ialpha
+
+ do k=1, maxz
+ do j=mine, maxe
+ ae(j,k)=0.0d0
+ ag(j,k)=0.0d0
+ ap(j,k)=0.0d0
+ enddo
+ enddo
+
+c calculation on a limited range (given by the source)
+
+ ismaxe=maxe
+ minz=jminz0
+ maxe=imaxe0
+ maxzz=maximumZ*100
+
+ do j=mine, maxe !one-dimensional initial source
+ AF4m(0,j,0,1)=sfe(j,minz)
+ AF4m(0,j,0,2)=sfg(j,minz)
+ AF4m(0,j,0,3)=sfp(j,minz)
+ do ialpha=1, n4mreal
+ AF4m(ialpha,j,0,1)=source3d(ialpha,j,minz,1)
+ AF4m(ialpha,j,0,2)=source3d(ialpha,j,minz,2)
+ AF4m(ialpha,j,0,3)=source3d(ialpha,j,minz,3)
+ enddo !ialpha
+ ae(j,minz)=sfe(j,minz)
+ ag(j,minz)=sfg(j,minz)
+ ap(j,minz)=sfp(j,minz)
+ enpart(2)=enpart(2)+eeem(j)*(ae(j,minz)+ag(j,minz)+ap(j,minz))
+c count mass in energy balance only if not primary particle
+ if(lxfirst)enpart(2)=enpart(2)+amc2*(ae(j,minz)+ap(j,minz))
+ enddo
+
+ if(.not.lxfirst)then !first interaction
+ Xfirst=zzem(minz)
+ lxfirst=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+
+ if(minz+1.gt.maxz)goto 999
+
+
+
+ do ialpha=0, n4mreal
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,0,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,0,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,0,3)
+ enddo
+ enddo !ialpha
+
+
+ za=zzem(minz) !initial z
+ dze=dzz !initial dz
+ dzo=0.d0
+ kk=1
+ mmm=1
+
+ write(*,*) 'k loop'
+ do k=1, maxzz !z
+
+!update cross sections
+ do j=mine,maxe
+ dethe(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,1)))
+ dethg(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,2)))
+ dethp(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,3)))
+ do i=mine,j
+ sef(2,2,j,i)=wgg(j,i)*dethg(j)
+ sef(1,2,j,i)=weg(j,i)*dethe(j)
+ sef(2,1,j,i)=wge(j,i)*dethg(j)
+
+ sef(2,3,j,i)=wgp(j,i)*dethg(j)
+ sef(3,1,j,i)=wpe(j,i)*dethp(j)
+ sef(3,2,j,i)=wpg(j,i)*dethp(j)
+
+ sef(1,3,j,i)=0.d0
+
+ sef(1,1,j,i)=wee(j,i)*dethe(j)
+ sef(3,3,j,i)=wpp(j,i)*dethp(j)
+ enddo
+ enddo
+
+ if(ionloss.ne.0)then
+ dist=distance0(za) !slant distance to obs level
+ hz=heightt(dist,radtr0)
+ do j=mine,maxe !so081203
+ eej=eeem(j)
+ delE=eej*(1.d0-1.d0/cem)
+ betheb(1,j)=dedzEM(eej,hz,-1)*dethe(j)
+ dltl=betheb(1,j)/delE
+ betheb(2,j)=dedzEM(eej,hz,1)*dethp(j)
+ dltpl=betheb(2,j)/delE
+ sef(1,1,j,j)=sef(1,1,j,j)-dltl !account for de/dz
+ sef(3,3,j,j)=sef(3,3,j,j)-dltpl !account for de/dz
+ if(j.gt.mine)then
+ sef(1,1,j,j-1)=sef(1,1,j,j-1)+dltl
+ sef(3,3,j,j-1)=sef(3,3,j,j-1)+dltpl
+ endif
+ betheb(1,j)=betheb(1,j)*dzz !for edep
+ betheb(2,j)=betheb(2,j)*dzz !for edep
+ enddo
+ endif
+
+ if (dzo.ne.0.d0) then !this is to fall on measuring depthes exactly
+ dze=dzo
+ endif
+ dzo=0.d0
+ iiz=int((za-zzo+1d-6*dzz)/dzz)+1
+ kk=int((za+dze-zzo+1d-6*dzz)/dzz)+1
+c kcdep=max(minz,kk-1)
+ if (iiz.ne.kk) then
+ zi=(kk-1)*dzz+zzo
+ dzo=dze
+ dze=zi-za
+ endif
+
+ call SDEstepp(za,dze,iqueue)
+
+
+ ialpha=0
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)
+ enddo
+ do ialpha=1, n4mreal
+ m1=i4A(ialpha,1)
+ m2=i4A(ialpha,2)
+ m3=i4A(ialpha,3)
+ m4=i4A(ialpha,4)
+ m=(m1+m2+m3+m4)/2
+ if(m3+m4.ne.0)then !if moments related to distance
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)/dethe(j)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)/dethg(j)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)/dethp(j)
+ enddo
+ else !only angles
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)
+ enddo
+ endif
+ enddo !ialpha
+
+
+
+ za=za+dze
+ dze=dze*1.5d0
+
+c if (dzo.eq.0.d0) then !indication
+c print *, 'za,dze=', za-zzo, dze, AF4m(0,mine,2,1),
+c & AF4m(0,mine,2,2), AF4m(0,mine,2,3), eeem(maxe)
+c else
+c print *, '[za],dze=', za-zzo, dze, AF4m(0,mine,2,1),
+c & AF4m(0,mine,2,2), AF4m(0,mine,2,3), eeem(maxe)
+c endif
+
+ if(abs(za-zzem(kk)).lt.1.d-5)then
+ write(*,*) 'registered z=', za,kk ,' rho=', rhoair(hz)
+
+ enpart(1)=enpart(2) !total energy for the previous depth
+ enpart(2)=0.d0
+ sumEloss=0d0
+ do j=minE,maxE
+ AE(j,kk)=AF4m(0,j,3,1)
+ AG(j,kk)=AF4m(0,j,3,2)
+ AP(j,kk)=AF4m(0,j,3,3)
+ sumEloss=sumEloss+ae(j,kk)*betheb(1,j)+ap(j,kk)*betheb(2,j)
+ enpart(2)=enpart(2)+eeEM(j)*(AE(j,kk)+AG(j,kk)+AP(j,kk))
+ & +amc2*2.d0*AP(j,kk) !total energy for this depth
+ if(mmm.le.3.and.kk.eq.kfirst+(mmm-1)*modk)then
+#ifdef __ANALYSIS__
+ if(nshower.eq.1)call printcostm(j,mmm,1)
+#endif
+ if(j.eq.maxe)mmm=mmm+1
+ endif
+ enddo !j
+ ebal=enpart(1)-enpart(2) !lost energy from kk-1 to kk
+ if(iwrt.ge.2)then
+ edep=max(0d0,ebal-sumEloss)
+ Emean=0.5d0*(enpart(1)+enpart(2))
+ if(Emean.gt.0d0.and.edep.gt.0d0)then
+ xxx=(sumEloss/Emean/2.d-2)**0.5
+c xxx=(ebal/Emean)**0.3*sumEloss/edep
+ if(xxx.lt.1.d0)then
+ edep=edep*xxx
+ endif
+ else
+ edep=0d0
+ endif
+ edep=max(0d0,sumEloss)+edep
+
+ call Profana(ZZEM(kk)-0.1d0*dzHa,ZZEM(maxZ)+0.1d0*dzHa
+ & ,ebal,edep,1.d0,999,-1)
+ endif
+ etotsource=etotsource-ebal
+
+cc part of the source outside the loop
+ enpart(2)=0.d0
+
+ do j=mine,maxe !adding source contributions for depth zzem(k)
+c count electron mass from source and twice positron mass for shower
+ if(kk.lt.lowZ.or.j.ge.lowE)then
+ enpart(2)=enpart(2)+amc2*(sfe(j,kk)+sfp(j,kk)+2.d0*ap(j,kk))
+ endif
+ AF4m(0,j,3,1)=AF4m(0,j,3,1)+sfe(j,kk)
+ AF4m(0,j,3,2)=AF4m(0,j,3,2)+sfg(j,kk)
+ AF4m(0,j,3,3)=AF4m(0,j,3,3)+sfp(j,kk)
+ do ialpha=1, n4mreal !3D source
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,3,1)
+ & +source3d(ialpha,j,kk,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,3,2)
+ & +source3d(ialpha,j,kk,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,3,3)
+ & +source3d(ialpha,j,kk,3)
+ enddo !ialpha
+ AE(j,kk)=AF4m(0,j,3,1)
+ AG(j,kk)=AF4m(0,j,3,2)
+ AP(j,kk)=AF4m(0,j,3,3)
+ AAEm(0,j,kk)=AF4m(0,j,3,1)
+ AAGm(0,j,kk)=AF4m(0,j,3,2)
+ AAPm(0,j,kk)=AF4m(0,j,3,3)
+#ifdef __CXLATCE__
+ do m=1,maxoep
+ AAEm(m,j,kk)=AF4m(m,j,3,1)/fkcoef(m)
+ AAGm(m,j,kk)=AF4m(m,j,3,2)/fkcoef(m)
+ AAPm(m,j,kk)=AF4m(m,j,3,3)/fkcoef(m)
+ enddo
+#endif
+ do m=maxoep+1,maximom
+ mm=m-maxoep
+ jj=ifindindexs(2*mm,0,0,0) !cherche le numero du moment 2m000
+ AAEm(m,j,kk)=AF4m(jj,j,3,1)/fkcoef(mm)
+ AAGm(m,j,kk)=AF4m(jj,j,3,2)/fkcoef(mm)
+ AAPm(m,j,kk)=AF4m(jj,j,3,3)/fkcoef(mm)
+ enddo
+ if(kk.lt.lowZ.or.j.ge.lowE)then
+ enpart(2)=enpart(2)+eeem(j)*(ae(j,kk)+ag(j,kk)+ap(j,kk))
+ endif
+ enddo
+
+c do MC simulations for low energy particles
+ if(lowE.gt.minE)call ElectronPhotonLowShower(kk)
+
+ if (kk.eq.maxz) goto 999 !all depthes done
+
+ endif
+ enddo !cycle over k is completed
+
+ write(*,*)'Warning, maxZ not reached : too much intermediate step'
+ & ,' : k=',k,' Z=',zzem(kk)
+ 999 maxe=ismaxe
+#ifdef __ANALYSIS__
+ if(nshower.eq.1)call printcostm(0,0,2)
+#ifdef __CXLATCE__
+ if (iLatCE.eq.1.and.(imscat.ne.0.or.i1DEM.ne.1)) then
+ call Transverses
+ endif
+#endif
+#endif
+ end
+#endif
+
+c------------------------------------------------------------------------------
+ subroutine InitialQueue !tp240805
+c------------------------------------------------------------------------------
+c Initialization before Solving the differential equation
+c------------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ common/cxcequeue/iqueue(0:n4m)
+ integer iqueue
+
+c Full range initialization
+#ifdef __ANALYSIS__
+ if(nshower.eq.1)call printcostm(0,0,0)
+#endif
+
+ do i=0,n4m
+ do j=1,5
+ i4A(i,j)=0
+ enddo
+ enddo
+
+
+#ifdef __CXLATCE__
+ do i=0, maxoep*2,2 !here moments M_{00i0}: M_{0000},M_{0020},M_{0040}
+ jdum=ifindindexs(0,0,i,0)
+#else
+ do i=0,maximom*2,2 !here moments M_{i000}: M_{0000},M_{2000},M_{4000}
+ jdum=ifindindexs(i,0,0,0)
+#endif
+ enddo
+ call composesource() !adds missing equations
+
+ call formqueue(iqueue) !generate the order of solving
+ end
+
+c------------------------------------------------------------------------------
+ subroutine IniEMCEs !tp230805
+c------------------------------------------------------------------------------
+c Initialization before Solving the differential equation
+c------------------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ lcorrp=.true.
+
+c here initial source. it may be 2D (not only M0!=0)
+ do ialpha=0, n4mreal
+ do j=1, maximumE
+ do i=0, 3
+ AF4m(ialpha,j,i,1)=0.d0
+ AF4m(ialpha,j,i,2)=0.d0
+ AF4m(ialpha,j,i,3)=0.d0
+ enddo
+ enddo
+ enddo !ialpha
+
+
+ return
+
+ end
+
+c------------------------------------------------------------------------------
+c this is the subroutine to call from conex-eph.F
+c------------------------------------------------------------------------------
+ subroutine SolveEMCEs(kk) !tp22805 from vc
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ common/cxcequeue/iqueue(0:n4m)
+ integer iqueue
+ logical goCE
+ common/cxembaltmp/enpartem(2),goCE
+c common/cxcurdepth/kcdep
+
+
+c calculation on a limited range (given by the source)
+
+ imaxe=imaxe0
+ maxzz=100
+
+ if(goCE)then
+ if(kk.eq.jminz0)then
+ goCE=.false.
+ elseif(kk-1.eq.jminz0)then
+ goCE=.false.
+ minz=jminz0
+ enpartem(2)=0.d0
+ do j=mine, imaxe
+ AF4m(0,j,0,1)=sfe(j,minz)
+ AF4m(0,j,0,2)=sfg(j,minz)
+ AF4m(0,j,0,3)=sfp(j,minz)
+ do ialpha=1, n4mreal
+ AF4m(ialpha,j,0,1)=source3d(ialpha,j,minz,1)
+ AF4m(ialpha,j,0,2)=source3d(ialpha,j,minz,2)
+ AF4m(ialpha,j,0,3)=source3d(ialpha,j,minz,3)
+ enddo !ialpha
+ ae(j,minz)=sfe(j,minz)
+ ag(j,minz)=sfg(j,minz)
+ ap(j,minz)=sfp(j,minz)
+ if(minz.lt.lowZ.or.j.ge.lowE)then
+ enpartem(2)=enpartem(2)+eeem(j)*(ae(j,minz)+ag(j,minz)
+ & +ap(j,minz))
+ endif
+c count mass in energy balance only if not primary particle
+ if(lxfirst)enpartem(2)=enpartem(2)+amc2*(ae(j,minz)+ap(j,minz))
+ enddo
+ if(.not.lxfirst)then !first interaction
+ Xfirst=zzem(minz)
+ lxfirst=.true.
+#ifdef __CXCORSIKA__
+ CALL CONEXPRM(Xfirst)
+#endif
+ endif
+ do j=mine, maxe
+ do ialpha=0, n4mreal
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,0,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,0,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,0,3)
+ enddo !ialpha
+ enddo
+ endif
+ endif
+
+ if(kk.gt.maxz)return
+c kcdep=jminz0
+c if(kk.gt.jminz0)kcdep=kk-1
+
+ enpartem(1)=enpartem(2) !total energy for the previous depth
+ enpartem(2)=0.d0
+
+ emsf2had=0.d0
+ do j=mine,imaxe
+
+c add half of the source from Had CE
+ emsf2had=emsf2had+eeem(j)*(sf2had(1,j)+sf2had(2,j)+sf2had(3,j))
+ & +amc2*(sf2had(2,j)+sf2had(3,j)) !count electron mass from source
+ AF4M(0,j,3,2)=AF4M(0,j,3,2)+sf2had(1,j) !gamma
+ AF4M(0,j,3,1)=AF4M(0,j,3,1)+sf2had(2,j) !electron
+ AF4M(0,j,3,3)=AF4M(0,j,3,3)+sf2had(3,j) !positron
+ enddo
+ enpartem(1)=enpartem(1)+emsf2had
+
+ za=zzem(kk-1) !initial z
+ dze=dzz !initial dz
+ dzo=0.d0
+ mmm=max(0,kk-kfirst)/modk+1
+ do k=1, maxzz !z
+
+!update cross sections
+ do j=mine,maxe
+ dethe(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,1)))
+ dethg(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,2)))
+ dethp(j)=1.d0/sqrt(max(1d-4,1d0-sin2theta(j,3)))
+ svh(j)=wgh(j)*dethg(j)
+ svm(j)=wgm(j)*dethg(j)
+ do i=mine,j
+ sef(2,2,j,i)=wgg(j,i)*dethg(j)
+ sef(1,2,j,i)=weg(j,i)*dethe(j)
+ sef(2,1,j,i)=wge(j,i)*dethg(j)
+
+ sef(2,3,j,i)=wgp(j,i)*dethg(j)
+ sef(3,1,j,i)=wpe(j,i)*dethp(j)
+ sef(3,2,j,i)=wpg(j,i)*dethp(j)
+
+ sef(1,3,j,i)=0.d0
+
+ sef(1,1,j,i)=wee(j,i)*dethe(j)
+ sef(3,3,j,i)=wpp(j,i)*dethp(j)
+ enddo
+ wsf2noint(1,j)=exp(sef(2,2,j,j)*2.d0*dZZ) !probability to go through 2 bins wihtout interacting
+ wsf2noint(2,j)=exp(sef(1,1,j,j)*2.d0*dZZ)
+ wsf2noint(3,j)=exp(sef(3,3,j,j)*2.d0*dZZ)
+ enddo
+
+ if(ionloss.ne.0)then
+ dist=distance0(za) !slant distance to obs level
+ hz=heightt(dist,radtr0)
+ do j=mine,maxe !so081203
+ eej=eeem(j)
+ delE=eej*(1.d0-1.d0/cem)
+ betheb(1,j)=dedzEM(eej,hz,-1)*dethe(j)
+ dltl=betheb(1,j)/delE
+ betheb(2,j)=dedzEM(eej,hz,1)*dethp(j)
+ dltpl=betheb(2,j)/delE
+ sef(1,1,j,j)=sef(1,1,j,j)-dltl !account for de/dz
+ sef(3,3,j,j)=sef(3,3,j,j)-dltpl !account for de/dz
+ if(j.gt.mine)then
+ sef(1,1,j,j-1)=sef(1,1,j,j-1)+dltl
+ sef(3,3,j,j-1)=sef(3,3,j,j-1)+dltpl
+ endif
+ betheb(1,j)=betheb(1,j)*dzz !for edep
+ betheb(2,j)=betheb(2,j)*dzz !for edep
+ enddo
+ endif
+
+ if (dzo.ne.0.d0) then !this is to fall on measuring depthes exactly
+ dze=dzo
+ endif
+ dzo=0.d0
+ iiz=int((za-zzo+1d-6*dzz)/dzz)+1
+ kk=int((za+dze-zzo+1d-6*dzz)/dzz)+1
+ if (iiz.ne.kk) then
+ zi=(kk-1)*dzz+zzo
+ dzo=dze
+ dze=zi-za
+ endif
+
+ call SDEstepp(za,dze,iqueue)
+
+
+ ialpha=0
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)
+ enddo
+ do ialpha=1, n4mreal
+ m1=i4A(ialpha,1)
+ m2=i4A(ialpha,2)
+ m3=i4A(ialpha,3)
+ m4=i4A(ialpha,4)
+ m=(m1+m2+m3+m4)/2
+ if(m3+m4.ne.0)then !if moments related to distance
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)/dethe(j)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)/dethg(j)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)/dethp(j)
+ enddo
+ else !only angles
+ do j=mine, maxe
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,2,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,2,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,2,3)
+ enddo
+ endif
+ enddo !ialpha
+
+
+
+ za=za+dze
+ dze=dze*1.5d0
+
+c if (dzo.eq.0.d0) then !indication
+c print *, 'za,dze=', za-zzo, dze, AF4m(0,mine,2,1),
+c & AF4m(0,mine,2,2), AF4m(0,mine,2,3), eeem(maxe)
+c else
+c print *, '[za],dze=', za-zzo, dze, AF4m(0,mine,2,1),
+c & AF4m(0,mine,2,2), AF4m(0,mine,2,3), eeem(maxe)
+c endif
+
+ if(abs(za-zzem(kk)).lt.1.d-5)then
+#ifdef __CXCORSIKA__
+ if(isx.ge.2)then
+#endif
+ write(*,*) 'registered z=', za ,' rho=', rhoair(hz)
+#ifdef __CXCORSIKA__
+ endif
+#endif
+ sumEloss=0d0
+ do j=maxE,minE,-1
+ AE(j,kk)=AF4m(0,j,3,1)
+ AG(j,kk)=AF4m(0,j,3,2)
+ AP(j,kk)=AF4m(0,j,3,3)
+ sumEloss=sumEloss+ae(j,kk)*betheb(1,j)+ap(j,kk)*betheb(2,j)
+ shad=0.d0 !send photonuclear and muon pair gammas in had CE
+ wt=0.d0
+ do np=1,9
+ call eph2hsource(maxe,j,kk,np,wt)
+ shad=shad+wt !count energy converted into hadron
+ enddo
+
+c total energy for this depth
+ enpartem(2)=enpartem(2)+eeEM(j)*(AE(j,kk)+AG(j,kk)+AP(j,kk))
+ & +amc2*2.d0*AP(j,kk)+shad !total energy for this depth
+
+ if(mmm.le.3.and.kk.eq.kfirst+(mmm-1)*modk)then
+#ifdef __ANALYSIS__
+ if(nshower.eq.1)call printcostm(j,mmm,1)
+#endif
+ if(j.eq.mine)mmm=mmm+1
+ endif
+ enddo !j
+ ebal=enpartem(1)-enpartem(2) !lost energy from k-1 to k
+ if(iwrt.ge.2)then
+ edep=max(0d0,ebal-sumEloss)
+ Emean=0.5d0*(enpartem(1)+enpartem(2))
+ if(Emean.gt.0d0.and.edep.gt.0d0)then
+ xxx=(sumEloss/Emean/2.d-2)**0.5
+c xxx=(ebal/Emean)**0.3*sumEloss/edep
+ if(xxx.lt.1.d0)then
+ edep=edep*xxx
+ endif
+ else
+ edep=0d0
+ endif
+ edep=max(sumEloss,0d0)+edep
+ call Profana(ZZEM(kk)-0.1d0*dzHa,ZZEM(maxZ)+0.1d0*dzHa,ebal,edep
+ & ,1.d0,999,-1)
+ endif
+ etotsource=etotsource-ebal
+
+cc part of the source outside the loop
+ enpartem(2)=0.d0
+
+ do j=mine,maxe !adding source contributions for depth zzem(k)
+ if(kk.lt.lowZ.or.j.ge.lowE)then
+ enpartem(2)=enpartem(2)
+ & +amc2*(sfe(j,kk)+sfp(j,kk)+2.d0*ap(j,kk)) !count electron mass from source and twice positron mass for shower
+ endif
+ AF4m(0,j,3,1)=AF4m(0,j,3,1)+sfe(j,kk)
+ AF4m(0,j,3,2)=AF4m(0,j,3,2)+sfg(j,kk)
+ AF4m(0,j,3,3)=AF4m(0,j,3,3)+sfp(j,kk)
+ do ialpha=1, n4mreal !3D source
+ AF4m(ialpha,j,3,1)=AF4m(ialpha,j,3,1)
+ & +source3d(ialpha,j,kk,1)
+ AF4m(ialpha,j,3,2)=AF4m(ialpha,j,3,2)
+ & +source3d(ialpha,j,kk,2)
+ AF4m(ialpha,j,3,3)=AF4m(ialpha,j,3,3)
+ & +source3d(ialpha,j,kk,3)
+ enddo !ialpha
+ AE(j,kk)=AF4m(0,j,3,1)
+ AG(j,kk)=AF4m(0,j,3,2)
+ AP(j,kk)=AF4m(0,j,3,3)
+ AAEm(0,j,kk)=AF4m(0,j,3,1)
+ AAGm(0,j,kk)=AF4m(0,j,3,2)
+ AAPm(0,j,kk)=AF4m(0,j,3,3)
+#ifdef __CXLATCE__
+c /fkoef(m) makes them to be radial moments
+ do m=1,maxoep
+ AAEm(m,j,kk)=AF4m(m,j,3,1)/fkcoef(m)
+ AAGm(m,j,kk)=AF4m(m,j,3,2)/fkcoef(m)
+ AAPm(m,j,kk)=AF4m(m,j,3,3)/fkcoef(m)
+ enddo
+#endif
+ do m=maxoep+1,maximom
+ mm=m-maxoep
+ jj=ifindindexs(2*mm,0,0,0) !cherche le numero du moment 2m000
+ AAEm(m,j,kk)=AF4m(jj,j,3,1)/fkcoef(mm)
+ AAGm(m,j,kk)=AF4m(jj,j,3,2)/fkcoef(mm)
+ AAPm(m,j,kk)=AF4m(jj,j,3,3)/fkcoef(mm)
+ enddo
+ if(kk.lt.lowZ.or.j.ge.lowE)then
+ enpartem(2)=enpartem(2)+eeem(j)*(ae(j,kk)+ag(j,kk)+ap(j,kk))
+ endif
+ do np=1,3
+ SF2HAD(np,j)=0.0D0
+ enddo
+ enddo
+
+c do MC simulations for low energy particles
+ if(lowE.gt.minE)call ElectronPhotonLowShower(kk)
+
+ goto 999 !all depthes done
+
+ endif
+ enddo !cycle over k is completed
+
+ write(*,*)'Warning, Z not reached : too much intermediate step'
+ & ,' : k=',k,' Z=',zzem(kk)
+ 999 continue
+
+ end
+
+c-----------------------------------------------------------------------
+c this coeficient is due to \int d\phi F(r,\phi) \cos^{2m}\phi /(2\pi)
+c-----------------------------------------------------------------------
+ double precision function fkcoef(m) !vc1854
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ s1=1.d0
+ s2=1.d0
+ do i=2*m,2,-2
+ s1=s1*i
+ s2=s2*(i-1)
+ enddo
+
+ fkcoef=s2/s1
+
+ end
+
+
+c-----------------------------------------------------------------------
+c Coulomb moments coefficient C_{ij}(E)
+c-----------------------------------------------------------------------
+ double precision function cccoef(iic, jjc, j) !vc1854
+c-----------------------------------------------------------------------
+c coefficient for moments
+c j - energy
+c i - number of coeficient 10=1, 11=2, 20=3
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ if (jjc.gt.iic) then
+ ic=jjc
+ jc=iic
+ else
+ ic=iic
+ jc=jjc
+ endif
+
+
+ fmc2=amc2
+ fNa=avog*1.d+27
+ fZ=airavz
+ fA=airava
+ fre=2.81794d-13
+ falpha=1.d0/fialpha
+
+
+ pci=(eeem(j)+fmc2)/(eeem(j)+2.d0*fmc2) !1/beta/p/c
+ & *sqrt((1+fmc2/eeem(j))*(1-fmc2/eeem(j))) !*beta
+ theta0=falpha*fZ**0.333333333d0*fmc2/eeem(j)*pci
+ thetamax=min(theta0*183d0**2/fZ**0.666666666d0,1.d0)
+ xmax=(thetamax/theta0)**2
+
+ c=2.d0*pi
+ do i=jc,1,-1
+ c=c*(2.d0*i-1)/(2.d0*i+2.d0*ic)
+ enddo
+ do i=ic,1,-1
+ c=c*(2.d0*i-1)/(2.d0*i)
+ enddo
+ fJ=c
+
+ fi0 = xmax/(1.d0+xmax)
+ fi1 = (-xmax + (1.d0 + xmax)*Log(1.d0+xmax))/(1.d0 + xmax)
+ if (ic+jc.ge.2) then
+ do i=2,ic+jc
+ fi2 = xmax**(i-1)/(i-1) - 2.d0*fi1 - fi0
+ fi0=fi1
+ fi1=fi2
+ enddo
+ endif
+ fI = fi1*0.5d0
+
+c fi0=dble(ic+jc)*(-1.d0)**(ic+jc-1)*log(1.d0+xmax)
+c fi1=(-1.d0)**(ic+jc+1)*xmax/(1.d0+xmax)
+c fi2=0.d0
+c do k=2,ic+jc
+c fi2=fi2+factorial(ic+jc)/factorial(k)/factorial(ic+jc-k)
+c & *(-1.d0)**(ic+jc-k)/dble(k-1)*((1.d0+xmax)**(k-1)-1.d0)
+c enddo
+c fI=0.5d0*(fi0+fi1+fi2)
+
+
+ U=(fmc2/eeem(j)*pci)**2 * 4.d0*fNa*fZ*(fZ+1)/fA*fre**2
+ cc=fJ*fI*U*theta0**(2*ic+2*jc-2)/factorial(2*ic)
+ & /factorial(2*jc)
+
+ cccoef = cc
+ if(ic.eq.jc)cccoef=cccoef*0.5d0
+
+ end
+
+
+c-----------------------------------------------------------------------
+c Coulomb moments coefficient C_{ij}(E)
+c-----------------------------------------------------------------------
+ double precision function cccoefpt(iic, jjc, j,ip) !tp050805
+c-----------------------------------------------------------------------
+c coefficient for moments for inelastic process
+c effective cross section based on coulomb cross section
+c j - energy
+c i - number of coeficient 10=1, 11=2, 20=3
+c ip - particle type (1=e, 2=gam)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ cccoefpt=0.d0
+ if (jjc.gt.iic) then
+ ic=jjc
+ jc=iic
+ else
+ ic=iic
+ jc=jjc
+ endif
+
+ fmc2=amc2
+
+ U=0.d0
+ theta0=1.d-6/eeem(j)
+ if(ip.eq.1)then
+ pci=(eeem(j)+fmc2)/(eeem(j)+2.d0*fmc2) !1/beta/p/c
+ & *sqrt((1+fmc2/eeem(j))*(1-fmc2/eeem(j))) !*beta
+ U=(8.d1*fmc2/eeem(j)*pci)**2
+ elseif(ip.eq.2)then
+ U=(5.d-3/eeem(j))**2
+ elseif(ip.eq.3)then
+ pci=(eeem(j)+fmc2)/(eeem(j)+2.d0*fmc2) !1/beta/p/c
+ & *sqrt((1+fmc2/eeem(j))*(1-fmc2/eeem(j))) !*beta
+ U=(3.d1*fmc2/eeem(j)*pci)**2
+ endif
+ thetamax=min(0.2d0*theta0,1.d0)
+
+
+ xmax=(thetamax/theta0)**2
+
+ c=2.d0*pi
+ do i=jc,1,-1
+ c=c*(2.d0*i-1)/(2.d0*i+2.d0*ic)
+ enddo
+ do i=ic,1,-1
+ c=c*(2.d0*i-1)/(2.d0*i)
+ enddo
+ fJ=c
+
+ fi0 = xmax/(1.d0+xmax)
+ fi1 = (-xmax + (1.d0 + xmax)*Log(1.d0+xmax))/(1.d0 + xmax)
+ if (ic+jc.ge.2) then
+ do i=2,ic+jc
+ fi2 = xmax**(i-1)/(i-1) - 2.d0*fi1 - fi0
+ fi0=fi1
+ fi1=fi2
+ enddo
+ endif
+ fI = fi1*0.5d0
+
+ cc=fJ*fI*U*theta0**dble(2*ic+2*jc-1.9)/factorial(2*ic)
+ & /factorial(2*jc)
+
+ cccoefpt = cc
+ if(ic.eq.jc)cccoefpt=cccoefpt*0.5d0
+
+
+ end
+
+
+
+
+
+c-----------------------------------------------------------------------
+ subroutine composesource()
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ do ialpha=0,n4m
+ do jalpha=0,lleng
+ ASC(ialpha,jalpha)=0.d0 !coefficients spatial for source terms
+ ISI(ialpha,jalpha)=0 !list of spatial source terms
+ ASCr(ialpha,jalpha)=0.d0 !coefficients Coulomb for source terms
+ ISIr(ialpha,jalpha,1)=0 !ic for C_{ic,jc}
+ ISIr(ialpha,jalpha,2)=0 !jc for C_{ic,jc}
+ ISIr(ialpha,jalpha,3)=0 !Coulomb source moment numbers
+ enddo
+ enddo
+
+c compose sources and add all needed equations
+ ialpha=1
+ do while (i4A(ialpha, 5).eq.1)
+ m1=i4A(ialpha,1)
+ m2=i4A(ialpha,2)
+ m3=i4A(ialpha,3)
+ m4=i4A(ialpha,4)
+ m=(m1+m2+m3+m4)/2
+
+ jj1=ifindindexs(m1+1,m2+0,m3-1,m4+0) !adds to the equations list
+ jj2=ifindindexs(m1+0,m2+1,m3+0,m4-1)
+ if (jj1.ne.n4m) then
+ ISI(ialpha,0)=ISI(ialpha,0)+1 !adds to the source list
+ jjj=ISI(ialpha,0)
+ ASC(ialpha,jjj)=m3 !spatial alpha*x-source
+ ISI(ialpha,jjj)=jj1 !source moment number
+ endif
+ if (jj2.ne.n4m) then
+ ISI(ialpha,0)=ISI(ialpha,0)+1
+ jjj=ISI(ialpha,0)
+ ASC(ialpha,jjj)=m4 !spatial beta*y-source
+ ISI(ialpha,jjj)=jj2
+ endif
+c here begins Coulomb source
+ do ic=0, m
+ if (ic.eq.0) then !to begin from C_{10}
+ jc0=1
+ else
+ jc0=0
+ endif
+ do jc=jc0, m-ic
+c if don't need \cos^{2i}\theta just replace ic,nc->0 here (cos^(2i) have not been implemented) -> should not be changed
+ do nc=0,0 !ic
+ do kc=0,0 !nc
+ mm1=m1+2*kc-2*ic
+ mm2=m2+2*(nc-kc)-2*jc
+ mm3=m3
+ mm4=m4
+ jj=ifindindexs(mm1+0,mm2+0,mm3+0,mm4+0) !add to equations list
+ if (jj.ne.n4m) then
+c s=cf(mm1,mm2,mm3,mm4,ic,jc,nc,kc)
+ s=cf(mm1,mm2,ic,jc,nc,kc)
+ ISIr(ialpha,0,1)=ISIr(ialpha,0,1)+1 !coulomb source number
+ jjj=ISIr(ialpha,0,1)
+ ASCr(ialpha,jjj)=s
+ ISIr(ialpha,jjj,1)=ic
+ ISIr(ialpha,jjj,2)=jc
+ ISIr(ialpha,jjj,3)=jj
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ ialpha=ialpha+1
+ if(ialpha.gt.n4m)stop'ialpha too large, increase n4m'
+ enddo
+ n4mreal=ialpha !here the real number of equations is deterimned
+ if (imscat.eq.0.and.i1DEM.eq.1)n4mreal=1
+
+ end
+
+c----------------------------------------------------
+c generates the order of solving to have all
+c the sources of each equation calculated before
+c solving the equation
+c----------------------------------------------------
+ subroutine formqueue(iqueue2) !vc??4
+c----------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ integer iqueue(0:n4m), iqueue2(0:n4m)
+
+#ifdef __CXCORSIKA__
+ if(isx.ge.2)then
+#endif
+ write(*,*) 'forming queue'
+#ifdef __CXCORSIKA__
+ endif
+#endif
+ do ialpha=0,n4m
+ iqueue(ialpha)=ialpha
+ enddo
+ ialpha=0
+ do
+ ialpha=ialpha+1
+ if (ialpha.ge.n4m) goto 102
+ 101 continue
+ do i=1,ISIr(ialpha,0,1)
+ is=ISIr(ialpha,i,3)
+ if (iqueue(is).gt.iqueue(ialpha)) then
+ iq=iqueue(ialpha)
+ iqueue(ialpha)=iqueue(is)
+ iqueue(is)=iq
+ ialpha=0
+ goto 101
+ endif
+ enddo
+ do i=1,ISI(ialpha,0)
+ is=ISI(ialpha,i)
+ if (iqueue(is).gt.iqueue(ialpha)) then
+ iq=iqueue(ialpha)
+ iqueue(ialpha)=iqueue(is)
+ iqueue(is)=iq
+ ialpha=0
+ goto 101
+ endif
+ enddo
+ enddo
+ 102 continue
+ do ialpha=0,n4m-1
+ iqueue2(iqueue(ialpha))=ialpha
+ enddo
+#ifdef __CXDEBUG__
+#ifdef __CXCORSIKA__
+ if(isx.ge.2)then
+#endif
+ do jalpha=0,n4mreal
+ ialpha=iqueue2(jalpha)
+ write(*,*) ialpha,' i4a=', (i4a(ialpha,i),i=1,4),': ',
+ & ("(",ISIr(ialpha,i,3),ASCr(ialpha,i),")",i=1,ISIr(ialpha,0,1)),
+ & ("(",ISI(ialpha,i),ASC(ialpha,i),")",i=1,ISI(ialpha,0))
+ enddo
+#ifdef __CXCORSIKA__
+ endif
+#endif
+#endif
+ do ialpha=0,n4m-1
+ do i=1,ISIr(iqueue2(ialpha),0,1)
+ is=ISIr(iqueue2(ialpha),i,3)
+ s=0
+ do jalpha=ialpha, 0, -1
+ if (is.eq.iqueue2(jalpha)) s=1
+ enddo
+ if (s.eq.0)write(*,*) is, ' queue error!'
+ enddo
+ do i=1,ISI(iqueue2(ialpha),0)
+ is=ISI(iqueue2(ialpha),i)
+ s=0
+ do jalpha=ialpha, 0, -1
+ if (is.eq.iqueue2(jalpha)) s=1
+ enddo
+ if (s.eq.0)write(*,*) is,' queue error!'
+ enddo
+ enddo
+
+
+ end
+
+c--------------------------------------------------------------
+c coefficient in Coulomb expansion
+c--------------------------------------------------------------
+ double precision function cf(m1,m2,ic,jc,nc,kc)
+c double precision function cf(m1,m2,m3,m4,ic,jc,nc,kc)
+c--------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ i=nc/2
+ if (nc.ne.2*i) then
+ isig=-1
+ else
+ isig=1
+ endif
+
+ s=1.d0
+ s=s*bico(ic,nc)*bico(nc,kc)*isig
+ s=s*factorial(m1+2*ic)*factorial(m2+2*jc)
+ s=s/(factorial(m1)*factorial(m2))
+ cf = s
+
+ end
+
+c-----------------------------------------------------index for source---------
+ integer function ifindindexs(mm1,mm2,mm3,mm4) !vc??4
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ m1=mm1
+ m2=mm2
+ m3=mm3
+ m4=mm4
+c if ((m1.lt.m2).or.((m1.eq.m2).and.(m3.lt.m4))) then
+c m=m1
+c m1=m2
+c m2=m
+c m=m3
+c m3=m4
+c m4=m
+c endif
+ if ((m1.lt.0).or.(m2.lt.0).or.(m3.lt.0).or.(m4.lt.0)) then
+ ifindindexs = n4m
+ return
+ endif
+ do iitmp=0, n4m-1
+ if ((i4A(iitmp, 1).eq.m1).and.(i4A(iitmp, 2).eq.m2)
+ & .and.(i4A(iitmp, 3).eq.m3).and.(i4A(iitmp, 4).eq.m4)
+ & .and.(i4A(iitmp, 5).eq.1)) goto 10
+ if (i4A(iitmp, 5).ne.1) then
+ i4A(iitmp, 1) = m1
+ i4A(iitmp, 2) = m2
+ i4A(iitmp, 3) = m3
+ i4A(iitmp, 4) = m4
+ i4A(iitmp, 5) = 1 !occupied
+ goto 10
+ endif
+ enddo
+ stop 'error. you should enlarge i4A in SolveMomentEquations!'
+ 10 ifindindexs = iitmp
+ end
+
+
+
+
+#ifdef __CXLATCE__
+#ifdef __ANALYSIS__
+c----------------------------------------------------
+c generates lateral distribution function parameters
+c from the moments already calculatd
+c----------------------------------------------------
+ subroutine Transverses
+c----------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+
+ dimension amps4(4,maximume,maximumz,3),emoms(0:maxoep+1),alpo(3)
+ data alpo /-0.5d0,-2.d0,-2.d0/
+
+ maxpow=min(maxoep,6)
+
+ maxpow=2 !maximal order used for reconstruction maxpow<=maxoep
+ methode=2 !method (c,b,gamma) is strongly recommended
+
+ alphao=-1.d0 !0.3d0 !????????? !alpha is responsible for near-zero beahvior and not important typically
+ minee=mine !minimal energy (I did this not to see small energies)
+
+ write(*,*) 'Transverses'
+
+ do ip=1,3
+ alphao=alpo(ip)
+ do k=1,3
+ kk=kfirst+(k-1)*modk
+ do j=minee, maxe
+ if (ip.eq.1) then !transfering the moments
+ do jalpha=0,maxoep
+ emoms(jalpha)=abs(AAGm(jalpha,j,kk))
+ enddo
+ elseif (ip.eq.2) then
+ do jalpha=0,maxoep
+ emoms(jalpha)=abs(AAEm(jalpha,j,kk))
+ enddo
+ elseif (ip.eq.3) then
+ do jalpha=0,maxoep
+ emoms(jalpha)=abs(AAPm(jalpha,j,kk))
+ enddo
+ endif
+
+ amps4(4,j,k,ip)=0.d0
+ if (emoms(maxpow)*emoms(maxpow-1).ne.0.d0) then
+
+ if (methode.eq.0) then !3 parametres b,c et alpha (calcul dans mon cahier)
+ fd=emoms(maxpow-2)*emoms(maxpow)-emoms(maxpow-1)**2
+
+ amps4(2,j,k,ip)=(emoms(maxpow-2)*emoms(maxpow)*(1+i)
+ & -emoms(maxpow-1)**2*(3+i))/fd
+ amps4(3,j,k,ip)=log(emoms(maxpow-2))
+ & +log(emoms(maxpow-1))-log(fd)
+ amps4(4,j,k,ip)=2.d0
+ fnu=((maxpow-2)*2.d0-amps4(2,j,k,ip)+1.d0)
+ & /amps4(4,j,k,ip)
+ write(*,*) 'fnu=',fnu, amps4(2,j,k,ip)
+ amps4(1,j,k,ip)=log(emoms(maxpow-2))+fnu*amps4(3,j,k,ip)
+ & -gammlncx(fnu)
+
+ write(*,*) 'pars', (amps4(i,j,k,ip), i=1,4)
+
+ if ((ip.eq.2).and.(k.eq.2).and.(j.eq.61)) then
+ write(*,*) j, ' fd', fd, emoms(0),emoms(1),emoms(2)
+ do ialpha=0,2
+ fnu=(ialpha*2-amps4(2,j,k,ip)+1.d0)/amps4(4,j,k,ip)
+ write(*,*) ialpha , j,k,ip,' emoms', emoms(maxpow-2),
+ & exp(amps4(1,j,k,ip)-amps4(3,j,k,ip)*fnu+gammlncx(fnu))
+ enddo
+ endif
+ elseif (methode.eq.1) then !2 parametres b et c
+ fnu=(maxpow*2.d0-alphao-1.d0)*0.5d0
+
+ amps4(2,j,k,ip)=alphao
+ amps4(3,j,k,ip)=log(fnu*emoms(maxpow-1)/emoms(maxpow))
+ amps4(4,j,k,ip)=2.d0
+ amps4(1,j,k,ip)=log(emoms(maxpow-1))
+ & +fnu*amps4(3,j,k,ip)-gammlncx(fnu)
+
+ if ((ip.eq.2).and.(k.eq.2).and.(j.eq.61)) then
+ do ialpha=0,2
+ fnu=(ialpha*2-amps4(2,j,k,ip)+1.d0)
+ & /amps4(4,j,k,ip)
+ write(*,*) ialpha , j,k,ip,' emoms', emoms(maxpow-2)
+ & ,exp(amps4(1,j,k,ip)-amps4(3,j,k,ip)*fnu+gammlncx(fnu))
+ enddo
+ endif
+ elseif (methode.eq.2) then !3-parametres
+ call assyp(maxpow,emoms,Co,alphao,Bo,gammao)
+ if(gammao.gt.0.d0)then
+ amps4(1,j,k,ip)=Co
+ amps4(2,j,k,ip)=alphao
+ amps4(3,j,k,ip)=Bo
+ amps4(4,j,k,ip)=gammao
+ else
+ write(*,*)'No LDF par. for this energy and particle :'
+ & ,ip,eeem(j),k
+ endif
+ else
+ stop'Problem in LDF methode'
+ endif !methode
+
+ endif !if moments are not 0
+
+ enddo
+ enddo
+ enddo !ip
+
+
+c write LDF in plotting array
+
+ do ir=1,numir
+ rr= ramin*(ramax/ramin)**((dble(ir)-0.5d0)/dble(numir))
+ ra= (ramin*(ramax/ramin)**((dble(ir)-1.d0)/dble(numir)))**2.d0
+ rb= (ramin*(ramax/ramin)**((dble(ir)-0.d0)/dble(numir)))**2.d0
+ d=(rb-ra)*pi
+ do m=1,3
+ do ip=1,3
+ xldf=flatef(rr,m,ip,amps4)
+ if(xldf.gt.1.d-15)yieldrt1(ip,m,ir)=yieldrt1(ip,m,ir)+xldf*d
+ enddo
+ enddo
+ enddo
+
+
+
+
+ end
+
+c----------------------------------------------------
+c reconstructed lateral distribution
+c----------------------------------------------------
+ double precision function flf(x,k,j,ip,aps4)
+c----------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension aps4(4,maximume,maximumz,3)
+ flf=aps4(4,j,k,ip)*x**(-aps4(2,j,k,ip))
+ & *exp(-exp(aps4(3,j,k,ip))*
+ & x**aps4(4,j,k,ip)+aps4(1,j,k,ip))
+ & /(x*2.d0*pi)
+ end
+
+c----------------------------------------------------
+c integrate lateral distribution function by energy
+c----------------------------------------------------
+ double precision function flatef(x,k,ip,aps4)
+c----------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conexep.h"
+ dimension aps4(4,maximume,maximumz,3)
+ s=0.d0
+ do j=mine,maxe !integrate by energy
+c if (eeem(j).gt.1.)
+c & s = s + flf(x,k,j,ip,aps4) !logarithmic integral
+ s = s + flf(x,k,j,ip,aps4) !logarithmic integral
+c s = s + (eeem(j)-eeem(j-1))* !normal integral
+c & (flf(x,k,j,ip)+flf(x,k,j-1,ip))*.5d0
+ enddo
+ flatef=s!+1d-20!/(eeem(maxee-1)-eeem(minee))+1e-10 !logarithmic integral
+c flatef=s/(eeem(maxee-1)-eeem(minee))+1e-10 !normal integral
+ end
+
+c----------------------------------------------------
+c assymtotic params calc (c,b,gamma)
+c syst5.nb -> for expressions
+c 08cf.f -> for the code
+c----------------------------------------------------
+ subroutine assyp(mpw,emoms,lCo,alphao,lBo,gammao) !vc020604
+c----------------------------------------------------
+ integer maxpow, e, l,ll, mpw
+ double precision emoms(0:mpw), moms(0:2*mpw)
+ double precision alphao, gammao, lCo, lBo
+ double precision alpha, gamma, gammab, lC, lB
+ double precision gamma0, x, zt
+ double precision gammlncx, nu, dev
+ double precision log0, log2, log4
+
+ lCo = 0.d0
+ lBo = 0.d0
+ gammao = -1.d0
+
+ alpha = alphao-1.d0
+ maxpow=2*mpw !because 0 2 4... and not 0 1 2...
+
+ gammab=1.d0/(log(emoms(mpw)*emoms(mpw-2))-
+ & 2.d0*log(emoms(mpw-1)))
+ if(gammab.le.0.d0)return
+ gamma=gammab
+
+ do e=0, 30 !iterations for gamma
+ gamma0 = gamma
+ do l=0,maxpow,2
+ nu = (dble(l)-alpha)/gamma
+ ll=l/2
+ moms(l) = log(emoms(ll))
+ & -(gammlncx(nu)-(nu-.5d0)*log(nu)+nu)
+ enddo
+ log0 = log(- alpha + maxpow)
+ log2 = log(-2d0 - alpha + maxpow)
+ log4 = log(-4d0 - alpha + maxpow)
+ gamma = (2d0*(4d0*(log2 - log4) -
+ - (log0 - 2d0*log2 + log4)*(alpha - maxpow)))/
+ - (log0 - 2d0*log2 + log4 + 2d0*moms(-4 + maxpow) -
+ - 4d0*moms(-2 + maxpow) + 2d0*moms(maxpow))
+ if (gamma.lt.0.d0) then
+ write(*,*) 'gamma not converged!', gamma, gammab
+ return
+ endif
+ enddo
+
+ dev = ((gamma0-gamma)/(gamma0+gamma))**2
+ if (sqrt(dev).gt.1e-10)
+ & write(*,*)'precision ',sqrt(dev),' only in assyp for ', gamma
+
+ x=(-(log0*log2) + 2d0*log0*log4 - log2*log4 +
+ - (2d0*log2 - (log0 - log2)*(alpha - maxpow))*
+ - moms(-4 + maxpow) +
+ - (-4d0*log4 + (log0 - log4)*(alpha - maxpow))*
+ - moms(-2 + maxpow) +
+ - (log4*(4d0 + alpha - maxpow) +
+ - log2*(-2d0 - alpha + maxpow))*moms(maxpow))/
+ - (log0 - 2d0*log2 + log4 + 2d0*moms(-4 + maxpow) -
+ - 4d0*moms(-2 + maxpow) + 2d0*moms(maxpow))
+
+ zt=(log0*(-2d0*log4*(2d0 + alpha - maxpow) +
+ - log2*(4d0 + alpha - maxpow)) +
+ - log2*log4*(alpha - maxpow) +
+ - (log0 - log2)*(alpha - maxpow)*
+ - (2d0 + alpha - maxpow)*moms(-4 + maxpow) +
+ - (4d0 + alpha - maxpow)*
+ - (-((log0 - log4)*(alpha - maxpow)*
+ - moms(-2 + maxpow)) +
+ - (log2 - log4)*(2d0 + alpha - maxpow)*
+ - moms(maxpow)))/
+ - (log0 - 2d0*log2 + log4 + 2d0*moms(-4 + maxpow) -
+ - 4d0*moms(-2 + maxpow) + 2d0*moms(maxpow))
+
+ lB = x-1.d0-log(gamma)
+ lC = zt/gamma-.5d0*log(gamma)
+
+ lCo = lC
+ lBo = lB
+ gammao = gamma
+
+ end
+
+c------------------------------------------------------------------------------
+c output of lateral ditributions
+c------------------------------------------------------------------------------
+ subroutine printlaterals(ch, ndep) !vc??4
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ character*4 ch(ndep)
+
+ write(ifho,'(a)')'!--------------spectrr----------------------'
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name sprlt'
+ write(ifho,'(a)') 'htyp poc'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',ramin,ramax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis distance (m)"'
+ do jj=1,ndep
+ write(ifho,'(a,i2,a)')'++ txt "yaxis phot (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a,i2,a)')'++ txt "yaxis elec (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a,i2,a)')'++ txt "yaxis posi (z='//ch(jj)//')"'
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-ndep*6
+
+c fm=0.d0
+
+c print *, 'numir=',numir
+ anorm=dble(max(1,nshower))
+ do ir=1,numir
+ rr= ramin*(ramax/ramin)**((dble(ir)-0.5d0)/dble(numir))
+ ra= (ramin*(ramax/ramin)**((dble(ir)-1.d0)/dble(numir)))**2.d0
+ rb= (ramin*(ramax/ramin)**((dble(ir)-0.d0)/dble(numir)))**2.d0
+ d=(rb-ra)*pi
+
+ write(ifho,'(200e11.3)')rr
+ & ,((abs(yieldrt(ip,m,ir))/d
+ & ,sqrt(max(0.d0,yieldrt2(ip,m,ir)-yieldrt(ip,m,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d,m=1,ndep),ip=1,3)
+ enddo
+
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,ndep*3-1
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot sprlt+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot sprlt+',ip
+ enddo
+ ip=ndep*3
+ if(ip.le.9)write(ifho,'(a,i1)') ' plot sprlt+',ip
+ if(ip.gt.9)write(ifho,'(a,i2)') ' plot sprlt+',ip
+
+
+
+ end
+
+#endif
+#endif
+
+
+#ifdef __ANALYSIS__
+c------------------------------------------------------------------------------
+ subroutine printcostm(j,k,ityp)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ parameter(ndep=3)
+ integer l(ndep)
+ character*4 ch(ndep)
+ dimension costm(2,ndep,3,maximumE)
+ save costm
+
+ if(ityp.eq.0)then !initialization
+
+ do ie=mine,maxe
+ do ip=1,3
+ do iz=1,ndep
+ costm(1,iz,ip,ie)=0.d0
+ costm(2,iz,ip,ie)=0.d0
+ enddo
+ enddo
+ enddo
+
+ elseif(ityp.eq.1)then !fill array
+
+ costm(1,k,1,j)=sqrt(max(1d-4,1d0-sin2theta(j,2))) !gamma
+ costm(2,k,1,j)=sin2theta(j,2) !gamma
+ costm(1,k,2,j)=sqrt(max(1d-4,1d0-sin2theta(j,1))) !electron
+ costm(2,k,2,j)=sin2theta(j,1) !electron
+ costm(1,k,3,j)=sqrt(max(1d-4,1d0-sin2theta(j,3))) !positron
+ costm(2,k,3,j)=sin2theta(j,3) !positron
+
+ elseif(ityp.eq.2)then !write histo
+
+ do m=1,ndep
+ l(m)=min(maximumZ,kfirst+(m-1)*modk)
+ write(ch(m),'(i4)')nint(zzEM(l(m)))
+ enddo
+
+ write(ifho,'(a)')'!-------------- costmCE-------------------'
+ write(ifho,'(a)') 'zone 3 3 1 openhisto name costmce'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)') 'xrange ',eeEM(minE),eeEM(maxE)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)"'
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q]) [g] (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q]) e^-! (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q]) e^+! (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis sin^2!([q]) [g] (z='
+ * //ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis sin^2!([q]) e^-! (z='
+ * //ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis sin^2!([q]) e^+! (z='
+ * //ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q])?eff! [g] (z='
+ & //ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q])?eff! e^-! (z='
+ & //ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis 1-cos([q])?eff! e^+! (z='
+ & //ch(jj)//')"'
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-9*ndep
+
+ etheef=.00095d0
+ ethgef=.00055d0
+
+ do i=minE,maxE
+ write(ifho,'(2000e16.6)')eeEM(i)
+ & ,(((1.d0-costm(1,m,ip,i)),m=1,ndep),ip=1,3)
+ & ,((costm(2,m,ip,i),m=1,ndep),ip=1,3)
+ & ,((1d0-cos(pi/2.d0*sqrt(1.d0-exp(-(ethgef/eeEM(i))**2)))
+ & /(1.d0+zzEM(l(m))*4.d-5)),m=1,ndep)
+ & ,((1d0-cos(pi/2.d0*sqrt(1.d0-exp(-etheef/eeEM(i))))
+ & /(1.d0-zzEM(l(m))*1.d-5)),m=1,ndep)
+ & ,((1d0-cos(pi/2.d0*sqrt(1.d0-exp(-etheef/eeEM(i))))
+ & /(1.d0-zzEM(l(m))*1.d-5)),m=1,ndep)
+ end do
+
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,9*ndep
+ if(ip.le.9)then
+ write(ifho,'(a,i1,$)') ' plot costmce+',ip
+ elseif(ip.le.99) then
+ write(ifho,'(a,i2,$)') ' plot costmce+',ip
+ elseif(ip.le.999)then
+ write(ifho,'(a,i3,$)') ' plot costmce+',ip
+ endif
+ enddo
+ endif
+
+ end
+#endif
+
+
+c----------------------------------------------------
+ double precision function bico(n,k)
+c----------------------------------------------------
+ integer k,n
+ double precision gammlncx, s, a
+
+ s = n
+ a = k
+
+ bico=nint(exp(gammlncx(s+1)-
+ & gammlncx(a+1)-gammlncx(s-a+1)))
+
+ end
+
+c------------------------------------------------------------------------
+ double precision function factorial(i)
+c------------------------------------------------------------------------
+
+ integer i, k
+ double precision s
+
+
+ if (i.EQ.0) then
+ s = 1.d0
+ else
+ s = 1.d0
+
+ do k=1, i
+ s=s*k
+ enddo
+
+ endif
+
+ factorial = s
+
+ end
+
+c------------------------------------------------------------------------
+ double precision function sin2theta(j,ip)
+c------------------------------------------------------------------------
+c calcule cos theta pour l'energie j,
+c type des particules ip(=1e-,2gamma,3e+)
+c based on F_2000=int(alpha*F(theta))
+c =int(sin(theta)*cos(phi)*F(theta))
+c =int(cos(phi))*int(sin(theta)*F(theta))
+c =2*pi*fkcoef(0)*int(sin(theta)*F(theta))
+c F_2000/F_0000=2*pi*fkcoef(0)*int(sin(theta)*F(theta))/(2*pi)*int(F(theta))
+c =fkcoef(0)*<sin(theta)>
+c------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ dimension smax(3),ff(3)
+ data smax /0.99d0,0.99d0,0.99d0/
+ data ff /0.7d0,0.7d0,0.7d0/ !parameter to fix exactly M0(CE)=M0(MC)
+
+ sin2theta=0.d0
+ jj1=ifindindexs(0,0,0,0) !cherche le numero du moment 0000
+ s00=AF4m(jj1,j,3,ip) !1/fkcoef(0)=1 !int_phi = 2*pi*fkcoef(m) (2pi cancel out with higher moment)
+ if (s00.le.0.d0)return
+
+ jj2=ifindindexs(2,0,0,0)
+ s=ff(ip)*AF4m(jj2,j,3,ip)/s00*2d0 !2=1/fkcoef(1)
+ if(s.le.0.d0)return
+
+ sin2theta=min(smax(ip),s)
+
+ end
+
+
+
+cc------------------------------------------------------------------------
+c FUNCTION ei(x)
+cc------------------------------------------------------------------------
+cc Computes the exponential integral Ei(x) for x > 0.
+cc Parameters: EPS is the relative error, or absolute error near
+cc the zero of Ei at x = 0.3725;
+cc EULER is Euler\x{2019}s constant \x{03B3}
+cc MAXIT is the maximum number of iterations allowed; FPMIN
+cc is a number near the smallest representable floating-point number.
+cc------------------------------------------------------------------------
+c INTEGER MAXIT
+c double precision ei,x,EPS,EULER,FPMIN
+c PARAMETER (EPS=6.d-8,EULER=.57721566d0,MAXIT=100,FPMIN=1.d-30)
+c INTEGER k
+c double precision fact,prev,sum,term
+c if(x.le.0.) pause 'bad argument in ei'
+c if(x.lt.FPMIN)then !Special case: avoid failure of convergence
+c !test becauseof underflow
+c ei=log(x)+EULER
+c else if(x.le.-log(EPS))then !Use power series.
+c sum=0.d0
+c fact=1.d0
+c do k=1,MAXIT
+c fact=fact*x/k
+c term=fact/k
+c sum=sum+term
+c if(term.lt.EPS*sum)goto 1
+c enddo !k
+c pause 'series failed in ei'
+c 1 ei=sum+log(x)+EULER
+c else !Use asymptotic series.
+c sum=0.d0 !Start with second term.
+c term=1.d0
+c do k=1,MAXIT
+c prev=term
+c term=term*k/x
+c if(term.lt.EPS)goto 2 !Since final sum is greater than one, term itself apif(
+c if(term.lt.prev)then !proximates the relative error.
+c sum=sum+term !Still converging: add new term.
+c else
+c sum=sum-prev !Diverging: subtract previous term and exit.
+c goto 2
+c endif
+c enddo !k
+c 2 ei=exp(x)*(1.d0+sum)/x
+c endif
+c return
+c END
+
+#endif
+c 30.11.04 Subroutine and function used by Conex and extracted from Nexus
+c (by K. Werner).
+c author T. Pierog
+c Last modifications 28.06.2017 add DPMJETIII by T.Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+c-----------------------------------------------------------------------
+ subroutine cxidmass(idi,amass)
+c returns the mass of the particle with ident code id.
+c (deuteron, triton and alpha mass come from Gheisha ???)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ dimension ammes0(15),ammes1(15),ambar0(30),ambar1(30)
+ dimension amlep(52)
+ parameter ( nqlep=41,nmes=2)
+c-c data amlep/.3,.3,.5,1.6,4.9,30.,-1.,-1.,0.,0.,
+ data amlep/.005,.009,.180,1.6,4.9,170.,-1.,-1.,0.,0.,0.
+ * ,.5109989e-3,0.,.105658,0.,1.777,1.87656,2.8167,3.755,.49767
+ * ,.49767,100.3,100.3,100.5,101.6,104.9,130.,2*-1.,100.,0.,
+ * 100.,100.005,100.,100.1,100.,101.8,2*-1.,100.,100.,
+ * 11*0./
+c 0- meson mass table
+ data ammes0/.1349766,.13957018,.547853 !pi0,pi+-,eta
+ * ,.493677,.497614,.95778 !K+-, K0,eta'
+ * ,1.86483,1.86960,1.96847,2.9803 !D0,D+-,Ds,etac
+ 1 ,5.27917,5.27950,5.3663,6.277,9.390/ !B+-,B0,Bs,Bc,etab
+c 1- meson mass table
+ data ammes1/.77549,.77549,.78265 !rho0,rho+-,omega
+ * ,.889166,.89594,1.019455 !K*+-,K0*,phi
+ 1 ,2.00693,2.01022,2.1123,3.096916 !D0*,D*+-,D*s,j/psi
+ * ,5.3251,5.3251,5.4154,6.610,9.46030/ !B*+-,B0*,B*s,B*c,upsilon
+c 1/2+ baryon mass table
+ data ambar0/-1.,.93828,.93957,2*-1.,1.1894,1.1925,1.1974
+ 1 ,1.1156,1.3149,1.3213,3*-1.
+ $ ,2.453 !15 sigma_c++!
+ $ ,2.454 ! sigma_c+
+ $ ,2.452 ! sigma_c0
+ $ ,2.286 ! lambda_c+
+ 2 ,2.576 !19 1340 !Xi'_c+
+ $ ,2.578 !20 2340 !Xi'_c0
+ $ ,2.695 !21 3340 !omegac0
+ $ ,2.471 !22 3240 !Xi_c0
+ $ ,2.468 !23 3140 !Xi_c+
+ $ ,3.55 !24 1440
+ $ ,3.55 !25 2440
+ $ ,3.70 !26 3440
+ $ ,4*-1./
+c 3/2+ baryon mass table
+ data ambar1/1.232,1.232,1.232,1.232,-1.,1.3823,1.3820
+ 1 ,1.3875,-1.,1.5318,1.5350,1.6722,2*-1.
+ 2 ,2.519 !15 sigma_c++
+ $ ,2.52 ! sigma_c+
+ $ ,2.517 ! sigma_c0
+ $ ,-1.
+ $ ,2.645
+ $ ,2.644
+ $ ,2.80
+ $ ,2*-1.
+ $ ,3.75
+ $ ,3.75
+ 3 ,3.90
+ $ ,4.80
+ $ ,3*-1./
+c entry
+ id=idi
+ if(idi.eq.0)id=1120 !for air target
+ if(id.eq.41) goto 500 !41, 43 and 50000 <= id <= 100000 exotics
+ if(id.eq.43) goto 600
+ if(id.lt.0.and.mod(id,100).eq.0) goto 700 !strangelet
+ if(id.ne.0.and.mod(id,100).eq.0) goto 400
+ call cxidflav(id,ifl1,ifl2,ifl3,jspin,ind)
+ if(iabs(ifl1).gt.5.or.iabs(ifl2).gt.5.or.iabs(ifl3).gt.5)
+ 1 goto 300
+ if(ifl2.eq.0) goto 200
+ if(ifl1.eq.0) goto 100
+c baryons
+ ind=ind-109*jspin-36*nmes-nqlep
+ ind=ind-11
+ amass=(1-jspin)*ambar0(ind)+jspin*ambar1(ind)
+ return
+c mesons
+100 continue
+ ind=ind-36*jspin-nqlep
+ ind=ind-11
+ amass=(1-jspin)*ammes0(ind)+jspin*ammes1(ind)
+ return
+c quarks and leptons (+deuteron, triton, alpha, Ks and Kl)
+200 continue
+ amass=amlep(ind)
+ return
+c b and t particles
+300 continue
+ amass=amlep(iabs(ifl2))+amlep(iabs(ifl3))-.03d0+.04d0*jspin
+ if(ifl1.ne.0) amass=amass+amlep(iabs(ifl1))
+ return
+c nuclei
+400 anbrpro=dble(id/100)/2.15d0+0.7d0
+ anbrneu=dble(id/100)-anbrpro
+ amass=anbrpro*ambar0(2)+anbrneu*ambar0(3)
+ return
+c q-ball
+500 amass=1.d9
+ return
+c magnetic monopole
+600 amass=pmassmm
+ return
+c strangelet
+700 amass=dble(abs(id)/100)*ambar0(9)
+ return
+ end
+
+
+
+c-----------------------------------------------------------------------
+ subroutine cxidflav(id,ifl1,ifl2,ifl3,jspin,index)
+c unpacks the ident code id=+/-ijkl
+c
+c mesons--
+c i=0, j<=k, +/- is sign for j
+c id=110 for pi0, id=220 for eta, etc.
+c
+c baryons--
+c i<=j<=k in general
+c j<i<k for second state antisymmetric in (i,j), eg. l = 2130
+c
+c other--
+c id=1,...,6 for quarks
+c id=9 for gluon
+c id=10 for photon
+c id=11,...,16 for leptons
+c i=17 for deuteron
+c i=18 for triton
+c i=19 for alpha
+c id=20 for ks, id=-20 for kl
+c
+c i=21...26 for scalar quarks
+c i=29 for gluino
+c i=30 for photino
+c i=31...36 for scalar leptons
+c i=39 for wino
+c i=40 for zino
+c id=41 for q-ball
+c id=43 for magnetic monopole
+c id=-(#hyp)*100 for strangelet (500<#hyp<1000)
+c
+c id=80 for w+
+c id=81,...,83 for higgs mesons (h0, H0, A0, H+)
+c id=84,...,87 for excited bosons (Z'0, Z''0, W'+)
+c id=90 for z0
+c
+c diquarks--
+c id=+/-ij00, i<j for diquark composed of i,j.
+c
+c
+c index is a sequence number used internally
+c (index=-1 if id doesn't exist)
+c
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ parameter ( nqlep=41,nmes=2)
+ ifl1=0
+ ifl2=0
+ ifl3=0
+ jspin=0
+ idabs=iabs(id)
+ i=idabs/1000
+ j=mod(idabs/100,10)
+ k=mod(idabs/10,10)
+ jspin=mod(idabs,10)
+ if(id.eq.41.or.id.eq.43)return
+ if(id.ge.10000) goto 400
+ if(id.gt.100.and.mod(id,100).eq.0) goto 300
+ if(id.lt.-100.and.mod(id,100).eq.0) goto 500
+ if(j.eq.0) goto 200
+ if(i.eq.0) goto 100
+c baryons
+c only x,y baryons are qqx, qqy, q=u,d,s.
+ ifl1=isign(i,id)
+ ifl2=isign(j,id)
+ ifl3=isign(k,id)
+ if(k.le.6) then
+ index=max0(i-1,j-1)**2+i+max0(i-j,0)+(k-1)*k*(2*k-1)/6
+ 1 +109*jspin+36*nmes+nqlep+11
+ else
+ index=max0(i-1,j-1)**2+i+max0(i-j,0)+9*(k-7)+91
+ 1 +109*jspin+36*nmes+nqlep+11
+ endif
+ return
+c mesons
+100 continue
+ ifl1=0
+ ifl2=isign(j,id)
+ ifl3=isign(k,-id)
+ index=j+k*(k-1)/2+36*jspin+nqlep
+ index=index+11
+ return
+c quarks, leptons, etc
+200 continue
+ ifl1=0
+ ifl2=0
+ ifl3=0
+ jspin=0
+ index=idabs
+ if(idabs.lt.20) return
+c define index=20 for ks, index=21 for kl
+ index=idabs+1
+ if(id.eq.20) index=20
+c index=nqlep+1,...,nqlep+11 for w+, higgs, z0
+ if(idabs.lt.80) return
+ index=nqlep+idabs-79
+ return
+300 ifl1=isign(i,id)
+ ifl2=isign(j,id)
+ ifl3=0
+ jspin=0
+ index=0
+ return
+400 index=-1
+ return
+500 ifl1=-id/100
+ ifl2=ifl1
+ ifl3=ifl1
+ index=0
+ jspin=0
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxhdecin(lprint)
+c-----------------------------------------------------------------------
+c sets up /xsdkytab/
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+#include "conex.h"
+ dimension imode(6)
+ character*8 cxidlabl,lmode(6),lres
+ character*8 iblank
+ logical lprint
+ parameter (ndectb=1189)
+ real dectab(7,ndectb)
+
+ data ((dectab(i,j),i=1,7),j= 1, 18)/
+ * 110., .98850, 10., 10., 0., 0., 0.
+ *, 110.,1.00000, 10., 12., -12., 0., 0.
+ *, 220., .38000, 10., 10., 0., 0., 0.
+ *, 220., .71000, 110., 110., 110., 0., 0.
+ *, 220., .94600, 120.,-120., 110., 0., 0.
+ *, 220., .99500, 120.,-120., 10., 0., 0.
+ *, 220.,1.00000, 10., 12., -12., 0., 0.
+ *, 330., .44100, 220., 120.,-120., 0., 0.
+ *, 330., .66100, 220., 110., 110., 0., 0.
+ *, 330., .95900, 111., 10., 0., 0., 0.
+ *, 330., .98000, 221., 10., 0., 0., 0.
+ *, 330.,1.00000, 10., 10., 0., 0., 0.
+ *, 121.,1.00000, 120., 110., 0., 0., 0.
+ *, 111., .99989, 120.,-120., 0., 0., 0.
+ *, 111., .99993, 12., -12., 0., 0., 0.
+ *, 111.,1.00000, 14., -14., 0., 0., 0.
+ *, 221., .89900, 120.,-120., 110., 0., 0.
+ *, 221., .91200, 120.,-120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j= 19, 36)/
+ * 221., .99992, 110., 10., 0., 0., 0.
+ *, 221.,1.00000, 12., -12., 0., 0., 0.
+ *, 331., .48600, 130.,-130., 0., 0., 0.
+ *, 331., .83700, 230.,-230., 0., 0., 0.
+ *, 331., .98400, 120.,-120., 110., 0., 0.
+ *, 331., .99944, 220., 10., 0., 0., 0.
+ *, 331., .99975, 12., -12., 0., 0., 0.
+ *, 331.,1.00000, 14., -14., 0., 0., 0.
+ *, 230., .50000, 20., 0., 0., 0., 0.
+ *, 230.,1.00000, -20., 0., 0., 0., 0.
+ *, 131., .66670, 230., 120., 0., 0., 0.
+ *, 131.,1.00000, 130., 110., 0., 0., 0.
+ *, 231., .66670, 130.,-120., 0., 0., 0.
+ *, 231.,1.00000, 230., 110., 0., 0., 0.
+ *, 240., .11000, 12., -11., 230., 0., 0.
+ *, 240., .17000, 12., -11., 231., 0., 0.
+ *, 240., .28000, 14., -13., 230., 0., 0.
+ *, 240., .34000, 14., -13., 231., 0., 0./
+ data ((dectab(i,j),i=1,7),j= 37, 54)/
+ * 240., .37800, 230.,-120., 0., 0., 0.
+ *, 240., .56300, 230.,-121., 0., 0., 0.
+ *, 240., .60800, 231.,-120., 0., 0., 0.
+ *, 240., .62100, 230.,-120., 110., 0., 0.
+ *, 240., .71000, 130.,-120.,-120., 0., 0.
+ *, 240., .80100, 230.,-120.,-120., 120., 0.
+ *, 240., .87900, 130.,-120.,-120., 110., 0.
+ *, 240., .95400, 230.,-120., 110., 110., 0.
+ *, 240., .96600, 230.,-130., 0., 0., 0.
+ *, 240., .97600, 331.,-120., 0., 0., 0.
+ *, 240., .98800,-130., 231., 0., 0., 0.
+ *, 240.,1.00000,-131., 230., 0., 0., 0.
+ *, 140., .04500, -12., 11., 130., 0., 0.
+ *, 140., .07500, -12., 11., 131., 0., 0.
+ *, 140., .12000, -14., 13., 130., 0., 0.
+ *, 140., .15000, -14., 13., 131., 0., 0.
+ *, 140., .20300, 130.,-120., 0., 0., 0.
+ *, 140., .22700, 230., 110., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j= 55, 72)/
+ * 140., .24700, 230., 220., 0., 0., 0.
+ *, 140., .28900, 230., 221., 0., 0., 0.
+ *, 140., .45100, 130.,-121., 0., 0., 0.
+ *, 140., .53600, 131.,-120., 0., 0., 0.
+ *, 140., .56200, 231., 110., 0., 0., 0.
+ *, 140., .57600, 230., 111., 0., 0., 0.
+ *, 140., .58700, 130.,-120., 110., 0., 0.
+ *, 140., .60300, 230.,-120., 120., 0., 0.
+ *, 140., .72700, 130.,-120.,-120., 120., 0.
+ *, 140., .87600, 230.,-120., 120., 110., 0.
+ *, 140., .96900, 130.,-120., 110., 110., 0.
+ *, 140.,1.00000, 230., 110., 110., 110., 0.
+ *, 340., .03250, 12., -11., 220., 0., 0.
+ *, 340., .06500, 12., -11., 331., 0., 0.
+ *, 340., .09750, 14., -13., 220., 0., 0.
+ *, 340., .13000, 14., -13., 331., 0., 0.
+ *, 340., .17900,-130., 230., 0., 0., 0.
+ *, 340., .22800,-120., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j= 73, 90)/
+ * 340., .33800,-131., 230., 0., 0., 0.
+ *, 340., .44800,-130., 231., 0., 0., 0.
+ *, 340., .55800,-120., 331., 0., 0., 0.
+ *, 340., .57500,-130., 230., 110., 0., 0.
+ *, 340., .59200,-230., 230.,-120., 0., 0.
+ *, 340., .69400,-130., 230.,-120., 120., 0.
+ *, 340., .79600,-130., 230., 110., 110., 0.
+ *, 340., .89800,-130., 130.,-120., 110., 0.
+ *, 340.,1.00000,-230., 230.,-120., 110., 0.
+ *, 241., .64000, 140.,-120., 0., 0., 0.
+ *, 241., .92000, 240., 110., 0., 0., 0.
+ *, 241.,1.00000, 240., 10., 0., 0., 0.
+ *, 141., .55000, 140., 110., 0., 0., 0.
+ *, 141.,1.00000, 140., 10., 0., 0., 0.
+ *, 341.,1.00000, 340., 10., 0., 0., 0.
+ *, 441., .07400, 12., -12., 0., 0., 0.
+ *, 441., .14800, 14., -14., 0., 0., 0.
+ *, 441., .15210,-121., 120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j= 91,108)/
+ * 441., .15620, 111., 110., 0., 0., 0.
+ *, 441., .16020, 121.,-120., 0., 0., 0.
+ *, 441., .16300,-121., 111., 120., 0., 0.
+ *, 441., .16580, 121.,-121., 110., 0., 0.
+ *, 441., .16860, 121., 111.,-120., 0., 0.
+ *, 441., .28740, 120.,-120., 130.,-130., 0.
+ *, 441., .40620, 110., 110., 130.,-130., 0.
+ *, 441., .52500, 120.,-120., 120.,-120., 0.
+ *, 441., .64380, 120.,-120., 110., 110., 0.
+ *, 441., .76260, 110., 110., 110., 110., 0.
+ *, 441., .88130, 120.,-120., 230.,-230., 0.
+ *, 441.,1.00000, 110., 110., 230., 230., 0.
+ *, 150., .06000, -12., 11., 140., 0., 0.
+ *, 150., .12000, -12., 11., 141., 0., 0.
+ *, 150., .18000, -14., 13., 140., 0., 0.
+ *, 150., .24000, -14., 13., 141., 0., 0.
+ *, 150., .25500, -16., 15., 140., 0., 0.
+ *, 150., .27000, -16., 15., 141., 0., 0./
+ data ((dectab(i,j),i=1,7),j=109,122)/
+ * 150., .28050, 140., 120., 0., 0., 0.
+ *, 150., .29100, 140., 121., 0., 0., 0.
+ *, 150., .30150, 141., 120., 0., 0., 0.
+ *, 150., .31200, 141., 121., 0., 0., 0.
+ *, 150., .32650, 140.,-340., 0., 0., 0.
+ *, 150., .34100, 140.,-341., 0., 0., 0.
+ *, 150., .35550, 141.,-340., 0., 0., 0.
+ *, 150., .37000, 141.,-341., 0., 0., 0.
+ *, 150., 0.820 , 1., -4., 1., -2., 0.
+ *, 150., 0.920 , 1., -2., 1., -4., 0.
+ *, 150., 0.975 , 1., -4., 4., -3., 0.
+ *, 150., 0.985 , 1., -3., 4., -4., 0.
+ *, 150., 0.995 , 1., -1., 1., -2., 0.
+ *, 150., 1. , 1., -1., 4., -3., 0./
+ data ((dectab(i,j),i=1,7),j=123,142)
+ */ 250., .06000, -12., 11., 240., 0., 0.
+ *, 250., .12000, -12., 11., 241., 0., 0.
+ *, 250., .18000, -14., 13., 240., 0., 0.
+ *, 250., .24000, -14., 13., 241., 0., 0.
+ *, 250., .25500, -16., 15., 240., 0., 0.
+ *, 250., .27000, -16., 15., 241., 0., 0.
+ *, 250., .28050, 240., 120., 0., 0., 0.
+ *, 250., .29100, 240., 121., 0., 0., 0.
+ *, 250., .30150, 241., 120., 0., 0., 0.
+ *, 250., .31200, 241., 121., 0., 0., 0.
+ *, 250., .32650, 240.,-340., 0., 0., 0.
+ *, 250., .34100, 240.,-341., 0., 0., 0.
+ *, 250., .35550, 241.,-340., 0., 0., 0.
+ *, 250., .37000, 241.,-341., 0., 0., 0.
+ *, 250., 0.820 , 2., -4., 1., -2., 0.
+ *, 250., 0.920 , 2., -2., 1., -4., 0.
+ *, 250., 0.975 , 2., -4., 4., -3., 0.
+ *, 250., 0.985 , 2., -3., 4., -4., 0.
+ *, 250., 0.995 , 2., -1., 1., -2., 0.
+ *, 250., 1. , 2., -1., 4., -3., 0./
+ data ((dectab(i,j),i=1,7),j=143,176)/
+ * 238*1. /
+ data ((dectab(i,j),i=1,7),j=177,190)
+ * /350., .06000, 12., -11., 340., 0., 0.
+ *, 350., .12000, 12., -11., 341., 0., 0.
+ *, 350., .18000, 14., -13., 340., 0., 0.
+ *, 350., .24000, 14., -13., 341., 0., 0.
+ *, 350., .25500, 16., -15., 340., 0., 0.
+ *, 350., .27000, 16., -15., 341., 0., 0.
+ *, 350., .28050, 340., 120., 0., 0., 0.
+ *, 350., .29100, 340., 121., 0., 0., 0.
+ *, 350., .30150, 341., 120., 0., 0., 0.
+ *, 350., .31200, 341., 121., 0., 0., 0.
+ *, 350., .32650, 340.,-340., 0., 0., 0.
+ *, 350., .34100, 340.,-341., 0., 0., 0.
+ *, 350., .35550, 341.,-340., 0., 0., 0.
+ *, 350., .37000, 341.,-341., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=191,196)/
+ * 350., 0.820 , 3., -4., 1., -2., 0.
+ *, 350., 0.920 , 3., -2., 1., -4., 0.
+ *, 350., 0.975 , 3., -4., 4., -3., 0.
+ *, 350., 0.985 , 3., -3., 4., -4., 0.
+ *, 350., 0.995 , 3., -1., 1., -2., 0.
+ *, 350., 1. , 3., -1., 4., -3., 0./
+ data ((dectab(i,j),i=1,7),j=197,244)/
+ * 336*1. /
+ data ((dectab(i,j),i=1,7),j=245,262)/
+ * 160., .33330, -1., 2., -5., 0., 0.
+ *, 160., .66660, -4., 3., -5., 0., 0.
+ *, 160., .77770, 11., -12., -5., 0., 0.
+ *, 160., .88880, 13., -14., -5., 0., 0.
+ *, 160.,1.00000, -15., 16., -5., 0., 0.
+ *, 260., .33330, -1., 2., -5., 0., 0.
+ *, 260., .66660, -4., 3., -5., 0., 0.
+ *, 260., .77770, -11., 12., -5., 0., 0.
+ *, 260., .88880, -13., 14., -5., 0., 0.
+ *, 260.,1.00000, -15., 16., -5., 0., 0.
+ *, 360., .33330, -1., 2., -5., 0., 0.
+ *, 360., .66660, -4., 3., -5., 0., 0.
+ *, 360., .77770, -11., 12., -5., 0., 0.
+ *, 360., .88880, -13., 14., -5., 0., 0.
+ *, 360.,1.00000, -15., 16., -5., 0., 0.
+ *, 151.,1.00000, 150., 10., 0., 0., 0.
+ *, 251.,1.00000, 250., 10., 0., 0., 0.
+ *, 351.,1.00000, 350., 10., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=263,280)/
+ * 161.,1.00000, 160., 10., 0., 0., 0.
+ *, 261.,1.00000, 260., 10., 0., 0., 0.
+ *, 361.,1.00000, 360., 10., 0., 0., 0.
+ *,1230.,1.00000,2130., 10., 0., 0., 0.
+ *,1111.,1.00000,1120., 120., 0., 0., 0.
+ *,1121., .66670,1120., 110., 0., 0., 0.
+ *,1121.,1.00000,1220., 120., 0., 0., 0.
+ *,1221., .66670,1220., 110., 0., 0., 0.
+ *,1221.,1.00000,1120.,-120., 0., 0., 0.
+ *,2221.,1.00000,1220.,-120., 0., 0., 0.
+ *,1131., .88000,2130., 120., 0., 0., 0.
+ *,1131., .94000,1130., 110., 0., 0., 0.
+ *,1131.,1.00000,1230., 120., 0., 0., 0.
+ *,1231., .88000,2130., 110., 0., 0., 0.
+ *,1231., .94000,1130.,-120., 0., 0., 0.
+ *,1231.,1.00000,2230., 120., 0., 0., 0.
+ *,2231., .88000,2130.,-120., 0., 0., 0.
+ *,2231., .94000,1230.,-120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=281,298)/
+ * 2231.,1.00000,2230., 110., 0., 0., 0.
+ *,1331., .66670,2330., 120., 0., 0., 0.
+ *,1331.,1.00000,1330., 110., 0., 0., 0.
+ *,2331., .66670,1330.,-120., 0., 0., 0.
+ *,2331.,1.00000,2330., 110., 0., 0., 0.
+ *, 16., .18000, 12., -11., 15., 0., 0.
+ *, 16., .36000, 14., -13., 15., 0., 0.
+ *, 16., .45100,-120., 15., 0., 0., 0.
+ *, 16., .66000,-121., 15., 0., 0., 0.
+ *, 16., .78000, 110., 110.,-120., 15., 0.
+ *, 16., .83600, 120.,-120.,-120., 15., 0.
+ *, 16.,1.00000, 120., 110.,-120.,-120., 15.
+ *,2140., .03750, -12., 11.,2130., 0., 0.
+ *,2140., .07500, -12., 11.,1231., 0., 0.
+ *,2140., .11250, -14., 13.,2130., 0., 0.
+ *,2140., .15000, -14., 13.,1231., 0., 0.
+ *,2140., .18200,2130., 120., 0., 0., 0.
+ *,2140., .21300,1230., 120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=299,316)/
+ * 2140., .24400,1120.,-230., 0., 0., 0.
+ *,2140., .29500,1131., 110., 0., 0., 0.
+ *,2140., .34600,1231., 120., 0., 0., 0.
+ *,2140., .39700,1121.,-230., 0., 0., 0.
+ *,2140., .44800,1111.,-130., 0., 0., 0.
+ *,2140., .49900,1130., 111., 0., 0., 0.
+ *,2140., .55000,1230., 121., 0., 0., 0.
+ *,2140., .60100,1120.,-231., 0., 0., 0.
+ *,2140., .65800,1120.,-230., 120.,-120., 0.
+ *,2140., .71500,1120.,-230., 110., 110., 0.
+ *,2140., .77200,1120.,-130., 120., 110., 0.
+ *,2140., .82900,1220.,-230., 120., 110., 0.
+ *,2140., .88600,1220.,-130., 120., 120., 0.
+ *,2140., .94300,2130., 120., 120.,-120., 0.
+ *,2140.,1.00000,2130., 120., 110., 110., 0.
+ *,1140.,1.00000,2140., 120., 0., 0., 0.
+ *,1240.,1.00000,2140., 110., 0., 0., 0.
+ *,2240.,1.00000,2140.,-120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=317,334)/
+ * 1340., .03750, -12., 11.,1330., 0., 0.
+ *,1340., .07500, -12., 11.,1331., 0., 0.
+ *,1340., .11250, -14., 13.,1330., 0., 0.
+ *,1340., .15000, -14., 13.,1331., 0., 0.
+ *,1340., .19900,1330., 120., 0., 0., 0.
+ *,1340., .24800,1231., 130., 0., 0., 0.
+ *,1340., .28800,1330., 120., 0., 0., 0.
+ *,1340., .32800,1131.,-230., 0., 0., 0.
+ *,1340., .36800,1330., 121., 0., 0., 0.
+ *,1340., .40800,1130.,-230., 0., 0., 0.
+ *,1340., .44800,1330., 120., 110., 0., 0.
+ *,1340., .48800,2330., 120., 120., 0., 0.
+ *,1340., .52800,1130.,-130., 120., 0., 0.
+ *,1340., .56800,1130.,-230., 110., 0., 0.
+ *,1340., .60800,1230.,-230., 120., 0., 0.
+ *,1340., .66400,2130.,-230., 120., 110., 0.
+ *,1340., .72000,2130.,-130., 120., 120., 0.
+ *,1340., .77600,1130.,-230., 120.,-120., 0./
+ data ((dectab(i,j),i=1,7),j=335,352)/
+ * 1340., .83200,1130.,-230., 110., 110., 0.
+ *,1340., .88800,1330., 120., 120.,-120., 0.
+ *,1340., .94400,1330., 120., 110., 110., 0.
+ *,1340.,1.00000,2330., 120., 120., 110., 0.
+ *,3140., .03750, -12., 11.,1330., 0., 0.
+ *,3140., .07500, -12., 11.,1331., 0., 0.
+ *,3140., .11250, -14., 13.,1330., 0., 0.
+ *,3140., .15000, -14., 13.,1331., 0., 0.
+ *,3140., .19900,1330., 120., 0., 0., 0.
+ *,3140., .24800,1231., 130., 0., 0., 0.
+ *,3140., .28800,1330., 120., 0., 0., 0.
+ *,3140., .32800,1131.,-230., 0., 0., 0.
+ *,3140., .36800,1330., 121., 0., 0., 0.
+ *,3140., .40800,1130.,-230., 0., 0., 0.
+ *,3140., .44800,1330., 120., 110., 0., 0.
+ *,3140., .48800,2330., 120., 120., 0., 0.
+ *,3140., .52800,1130.,-130., 120., 0., 0.
+ *,3140., .56800,1130.,-230., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=353,370)/
+ * 3140., .60800,1230.,-230., 120., 0., 0.
+ *,3140., .66400,2130.,-230., 120., 110., 0.
+ *,3140., .72000,2130.,-130., 120., 120., 0.
+ *,3140., .77600,1130.,-230., 120.,-120., 0.
+ *,3140., .83200,1130.,-230., 110., 110., 0.
+ *,3140., .88800,1330., 120., 120.,-120., 0.
+ *,3140., .94400,1330., 120., 110., 110., 0.
+ *,3140.,1.00000,2330., 120., 120., 110., 0.
+ *,2340., .03750, -12., 11.,2330., 0., 0.
+ *,2340., .07500, -12., 11.,2331., 0., 0.
+ *,2340., .11250, -14., 13.,2330., 0., 0.
+ *,2340., .15000, -14., 13.,2331., 0., 0.
+ *,2340., .17500,2330., 120., 0., 0., 0.
+ *,2340., .20000,1330., 110., 0., 0., 0.
+ *,2340., .22500,1130.,-130., 0., 0., 0.
+ *,2340., .25000,1230.,-230., 0., 0., 0.
+ *,2340., .29500,2331., 120., 0., 0., 0.
+ *,2340., .34000,1331., 110., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=371,388)/
+ * 2340., .38500,1131.,-130., 0., 0., 0.
+ *,2340., .43000,1231.,-230., 0., 0., 0.
+ *,2340., .47500,2330., 121., 0., 0., 0.
+ *,2340., .52000,1330., 111., 0., 0., 0.
+ *,2340., .56500,1130.,-131., 0., 0., 0.
+ *,2340., .61000,1230.,-231., 0., 0., 0.
+ *,2340., .64900,2130.,-230., 120.,-120., 0.
+ *,2340., .68800,2130.,-230., 110., 110., 0.
+ *,2340., .72700,2130.,-130., 120., 110., 0.
+ *,2340., .76600,1130.,-230.,-120., 110., 0.
+ *,2340., .80500,1130.,-130., 120.,-120., 0.
+ *,2340., .84400,1130.,-130., 110., 110., 0.
+ *,2340., .88300,1330., 120.,-120., 110., 0.
+ *,2340., .92200,1330., 110., 110., 110., 0.
+ *,2340., .96100,2330., 120., 120.,-120., 0.
+ *,2340.,1.00000,2330., 120., 110., 110., 0.
+ *,3240., .03750, -12., 11.,2330., 0., 0.
+ *,3240., .07500, -12., 11.,2331., 0., 0./
+ data ((dectab(i,j),i=1,7),j=389,406)/
+ * 3240., .11250, -14., 13.,2330., 0., 0.
+ *,3240., .15000, -14., 13.,2331., 0., 0.
+ *,3240., .17500,2330., 120., 0., 0., 0.
+ *,3240., .20000,1330., 110., 0., 0., 0.
+ *,3240., .22500,1130.,-130., 0., 0., 0.
+ *,3240., .25000,1230.,-230., 0., 0., 0.
+ *,3240., .29500,2331., 120., 0., 0., 0.
+ *,3240., .34000,1331., 110., 0., 0., 0.
+ *,3240., .38500,1131.,-130., 0., 0., 0.
+ *,3240., .43000,1231.,-230., 0., 0., 0.
+ *,3240., .47500,2330., 121., 0., 0., 0.
+ *,3240., .52000,1330., 111., 0., 0., 0.
+ *,3240., .56500,1130.,-131., 0., 0., 0.
+ *,3240., .61000,1230.,-231., 0., 0., 0.
+ *,3240., .64900,2130.,-230., 120.,-120., 0.
+ *,3240., .68800,2130.,-230., 110., 110., 0.
+ *,3240., .72700,2130.,-130., 120., 110., 0.
+ *,3240., .76600,1130.,-230.,-120., 110., 0./
+ data ((dectab(i,j),i=1,7),j=407,424)/
+ * 3240., .80500,1130.,-130., 120.,-120., 0.
+ *,3240., .84400,1130.,-130., 110., 110., 0.
+ *,3240., .88300,1330., 120.,-120., 110., 0.
+ *,3240., .92200,1330., 110., 110., 110., 0.
+ *,3240., .96100,2330., 120., 120.,-120., 0.
+ *,3240.,1.00000,2330., 120., 110., 110., 0.
+ *,3340., .07500, -12., 11.,3331., 0., 0.
+ *,3340., .15000, -12., 11.,3331., 0., 0.
+ *,3340., .25000,1330.,-230., 0., 0., 0.
+ *,3340., .31000,3331., 120., 0., 0., 0.
+ *,3340., .37000,1331.,-230., 0., 0., 0.
+ *,3340., .43000,1330.,-231., 0., 0., 0.
+ *,3340., .49000,2330.,-230., 120., 0., 0.
+ *,3340., .55000,1330.,-230., 110., 0., 0.
+ *,3340., .61000,1330.,-130., 120., 0., 0.
+ *,3340., .67500,3331., 120., 120.,-120., 0.
+ *,3340., .74000,3331., 120., 110., 110., 0.
+ *,3340., .80500,1330.,-230., 120.,-120., 0./
+ data ((dectab(i,j),i=1,7),j=425,442)/
+ * 3340., .87000,1330.,-230., 110., 110., 0.
+ *,3340., .93500,2330.,-230., 120., 110., 0.
+ *,3340.,1.00000,2330.,-130., 120., 120., 0.
+ *,1141.,1.00000,2140., 120., 0., 0., 0.
+ *,1241.,1.00000,2140., 110., 0., 0., 0.
+ *,2241.,1.00000,2140.,-120., 0., 0., 0.
+ *,1341., .66670,2340., 120., 0., 0., 0.
+ *,1341.,1.00000,1340., 110., 0., 0., 0.
+ *,2341., .66670,1340.,-120., 0., 0., 0.
+ *,2341.,1.00000,2340., 110., 0., 0., 0.
+ *,3341.,1.00000,3340., 110., 0., 0., 0.
+ *,1150., .06000, 12., -11.,1140., 0., 0.
+ *,1150., .12000, 12., -11.,1141., 0., 0.
+ *,1150., .18000, 14., -13.,1140., 0., 0.
+ *,1150., .24000, 14., -13.,1141., 0., 0.
+ *,1150., .25500, 16., -15.,1140., 0., 0.
+ *,1150., .27000, 16., -15.,1141., 0., 0.
+ *,1150., .28925,1140.,-120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=443,460)/
+ * 1150., .30850,1140.,-121., 0., 0., 0.
+ *,1150., .32775,1141.,-120., 0., 0., 0.
+ *,1150., .34700,1141.,-121., 0., 0., 0.
+ *,1150., .35775,1140., 340., 0., 0., 0.
+ *,1150., .36850,1140., 341., 0., 0., 0.
+ *,1150., .37925,1141., 340., 0., 0., 0.
+ *,1150., .39000,1141., 341., 0., 0., 0.
+ *,1150., .42050,1140.,-120., 110., 0., 0.
+ *,1150., .45100,1140.,-120., 220., 0., 0.
+ *,1150., .48150,1140.,-120., 111., 0., 0.
+ *,1150., .51200,1140.,-120., 221., 0., 0.
+ *,1150., .54250,1140.,-121., 110., 0., 0.
+ *,1150., .57300,1140.,-121., 220., 0., 0.
+ *,1150., .60350,1140.,-121., 111., 0., 0.
+ *,1150., .63400,1140.,-121., 221., 0., 0.
+ *,1150., .66450,1141.,-120., 110., 0., 0.
+ *,1150., .69500,1141.,-120., 220., 0., 0.
+ *,1150., .72550,1141.,-120., 111., 0., 0./
+ data ((dectab(i,j),i=1,7),j=461,478)/
+ * 1150., .75600,1141.,-120., 221., 0., 0.
+ *,1150., .78650,1141.,-121., 110., 0., 0.
+ *,1150., .81700,1141.,-121., 220., 0., 0.
+ *,1150., .84750,1141.,-121., 111., 0., 0.
+ *,1150., .87800,1141.,-121., 221., 0., 0.
+ *,1150., .89325,1140.,-130., 230., 0., 0.
+ *,1150., .90850,1140.,-130., 231., 0., 0.
+ *,1150., .92375,1140.,-131., 230., 0., 0.
+ *,1150., .93900,1140.,-131., 231., 0., 0.
+ *,1150., .95425,1141.,-130., 230., 0., 0.
+ *,1150., .96950,1141.,-130., 231., 0., 0.
+ *,1150., .98475,1141.,-131., 230., 0., 0.
+ *,1150.,1.00000,1141.,-131., 231., 0., 0.
+ *,1250., .06000, 12., -11.,1240., 0., 0.
+ *,1250., .12000, 12., -11.,1241., 0., 0.
+ *,1250., .18000, 14., -13.,1240., 0., 0.
+ *,1250., .24000, 14., -13.,1241., 0., 0.
+ *,1250., .25500, 16., -15.,1240., 0., 0./
+ data ((dectab(i,j),i=1,7),j=479,496)/
+ * 1250., .27000, 16., -15.,1241., 0., 0.
+ *,1250., .28925,1240.,-120., 0., 0., 0.
+ *,1250., .30850,1240.,-121., 0., 0., 0.
+ *,1250., .32775,1241.,-120., 0., 0., 0.
+ *,1250., .34700,1241.,-121., 0., 0., 0.
+ *,1250., .35775,1240., 340., 0., 0., 0.
+ *,1250., .36850,1240., 341., 0., 0., 0.
+ *,1250., .37925,1241., 340., 0., 0., 0.
+ *,1250., .39000,1241., 341., 0., 0., 0.
+ *,1250., .42050,1240.,-120., 110., 0., 0.
+ *,1250., .45100,1240.,-120., 220., 0., 0.
+ *,1250., .48150,1240.,-120., 111., 0., 0.
+ *,1250., .51200,1240.,-120., 221., 0., 0.
+ *,1250., .54250,1240.,-121., 110., 0., 0.
+ *,1250., .57300,1240.,-121., 220., 0., 0.
+ *,1250., .60350,1240.,-121., 111., 0., 0.
+ *,1250., .63400,1240.,-121., 221., 0., 0.
+ *,1250., .66450,1241.,-120., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=497,514)/
+ * 1250., .69500,1241.,-120., 220., 0., 0.
+ *,1250., .72550,1241.,-120., 111., 0., 0.
+ *,1250., .75600,1241.,-120., 221., 0., 0.
+ *,1250., .78650,1241.,-121., 110., 0., 0.
+ *,1250., .81700,1241.,-121., 220., 0., 0.
+ *,1250., .84750,1241.,-121., 111., 0., 0.
+ *,1250., .87800,1241.,-121., 221., 0., 0.
+ *,1250., .89325,1240.,-130., 230., 0., 0.
+ *,1250., .90850,1240.,-130., 231., 0., 0.
+ *,1250., .92375,1240.,-131., 230., 0., 0.
+ *,1250., .93900,1240.,-131., 231., 0., 0.
+ *,1250., .95425,1241.,-130., 230., 0., 0.
+ *,1250., .96950,1241.,-130., 231., 0., 0.
+ *,1250., .98475,1241.,-131., 230., 0., 0.
+ *,1250.,1.00000,1241.,-131., 231., 0., 0.
+ *,1350., .06000, 12., -11.,1340., 0., 0.
+ *,1350., .12000, 12., -11.,1341., 0., 0.
+ *,1350., .18000, 14., -13.,1340., 0., 0./
+ data ((dectab(i,j),i=1,7),j=515,532)/
+ * 1350., .24000, 14., -13.,1341., 0., 0.
+ *,1350., .25500, 16., -15.,1340., 0., 0.
+ *,1350., .27000, 16., -15.,1341., 0., 0.
+ *,1350., .28925,1340.,-120., 0., 0., 0.
+ *,1350., .30850,1340.,-121., 0., 0., 0.
+ *,1350., .32775,1341.,-120., 0., 0., 0.
+ *,1350., .34700,1341.,-121., 0., 0., 0.
+ *,1350., .35775,1340., 340., 0., 0., 0.
+ *,1350., .36850,1340., 341., 0., 0., 0.
+ *,1350., .37925,1341., 340., 0., 0., 0.
+ *,1350., .39000,1341., 341., 0., 0., 0.
+ *,1350., .42050,1340.,-120., 110., 0., 0.
+ *,1350., .45100,1340.,-120., 220., 0., 0.
+ *,1350., .48150,1340.,-120., 111., 0., 0.
+ *,1350., .51200,1340.,-120., 221., 0., 0.
+ *,1350., .54250,1340.,-121., 110., 0., 0.
+ *,1350., .57300,1340.,-121., 220., 0., 0.
+ *,1350., .60350,1340.,-121., 111., 0., 0./
+ data ((dectab(i,j),i=1,7),j=533,550)/
+ * 1350., .63400,1340.,-121., 221., 0., 0.
+ *,1350., .66450,1341.,-120., 110., 0., 0.
+ *,1350., .69500,1341.,-120., 220., 0., 0.
+ *,1350., .72550,1341.,-120., 111., 0., 0.
+ *,1350., .75600,1341.,-120., 221., 0., 0.
+ *,1350., .78650,1341.,-121., 110., 0., 0.
+ *,1350., .81700,1341.,-121., 220., 0., 0.
+ *,1350., .84750,1341.,-121., 111., 0., 0.
+ *,1350., .87800,1341.,-121., 221., 0., 0.
+ *,1350., .89325,1340.,-130., 230., 0., 0.
+ *,1350., .90850,1340.,-130., 231., 0., 0.
+ *,1350., .92375,1340.,-131., 230., 0., 0.
+ *,1350., .93900,1340.,-131., 231., 0., 0.
+ *,1350., .95425,1341.,-130., 230., 0., 0.
+ *,1350., .96950,1341.,-130., 231., 0., 0.
+ *,1350., .98475,1341.,-131., 230., 0., 0.
+ *,1350.,1.00000,1341.,-131., 231., 0., 0.
+ *,2150., .06000, 12., -11.,2140., 0., 0./
+ data ((dectab(i,j),i=1,7),j=551,568)/
+ * 2150., .12000, 12., -11.,1241., 0., 0.
+ *,2150., .18000, 14., -13.,2140., 0., 0.
+ *,2150., .24000, 14., -13.,1241., 0., 0.
+ *,2150., .25500, 16., -15.,2140., 0., 0.
+ *,2150., .27000, 16., -15.,1241., 0., 0.
+ *,2150., .28925,2140.,-120., 0., 0., 0.
+ *,2150., .30850,2140.,-121., 0., 0., 0.
+ *,2150., .32775,1241.,-120., 0., 0., 0.
+ *,2150., .34700,1241.,-121., 0., 0., 0.
+ *,2150., .35775,2140., 340., 0., 0., 0.
+ *,2150., .36850,2140., 341., 0., 0., 0.
+ *,2150., .37925,1241., 340., 0., 0., 0.
+ *,2150., .39000,1241., 341., 0., 0., 0.
+ *,2150., .42050,2140.,-120., 110., 0., 0.
+ *,2150., .45100,2140.,-120., 220., 0., 0.
+ *,2150., .48150,2140.,-120., 111., 0., 0.
+ *,2150., .51200,2140.,-120., 221., 0., 0.
+ *,2150., .54250,2140.,-121., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=569,586)/
+ * 2150., .57300,2140.,-121., 220., 0., 0.
+ *,2150., .60350,2140.,-121., 111., 0., 0.
+ *,2150., .63400,2140.,-121., 221., 0., 0.
+ *,2150., .66450,1241.,-120., 110., 0., 0.
+ *,2150., .69500,1241.,-120., 220., 0., 0.
+ *,2150., .72550,1241.,-120., 111., 0., 0.
+ *,2150., .75600,1241.,-120., 221., 0., 0.
+ *,2150., .78650,1241.,-121., 110., 0., 0.
+ *,2150., .81700,1241.,-121., 220., 0., 0.
+ *,2150., .84750,1241.,-121., 111., 0., 0.
+ *,2150., .87800,1241.,-121., 221., 0., 0.
+ *,2150., .89325,2140.,-130., 230., 0., 0.
+ *,2150., .90850,2140.,-130., 231., 0., 0.
+ *,2150., .92375,2140.,-131., 230., 0., 0.
+ *,2150., .93900,2140.,-131., 231., 0., 0.
+ *,2150., .95425,1241.,-130., 230., 0., 0.
+ *,2150., .96950,1241.,-130., 231., 0., 0.
+ *,2150., .98475,1241.,-131., 230., 0., 0./
+ data ((dectab(i,j),i=1,7),j=587,604)/
+ * 2150.,1.00000,1241.,-131., 231., 0., 0.
+ *,2250., .06000, 12., -11.,2240., 0., 0.
+ *,2250., .12000, 12., -11.,2241., 0., 0.
+ *,2250., .18000, 14., -13.,2240., 0., 0.
+ *,2250., .24000, 14., -13.,2241., 0., 0.
+ *,2250., .25500, 16., -15.,2240., 0., 0.
+ *,2250., .27000, 16., -15.,2241., 0., 0.
+ *,2250., .28925,2240.,-120., 0., 0., 0.
+ *,2250., .30850,2240.,-121., 0., 0., 0.
+ *,2250., .32775,2241.,-120., 0., 0., 0.
+ *,2250., .34700,2241.,-121., 0., 0., 0.
+ *,2250., .35775,2240., 340., 0., 0., 0.
+ *,2250., .36850,2240., 341., 0., 0., 0.
+ *,2250., .37925,2241., 340., 0., 0., 0.
+ *,2250., .39000,2241., 341., 0., 0., 0.
+ *,2250., .42050,2240.,-120., 110., 0., 0.
+ *,2250., .45100,2240.,-120., 220., 0., 0.
+ *,2250., .48150,2240.,-120., 111., 0., 0./
+ data ((dectab(i,j),i=1,7),j=605,622)/
+ * 2250., .51200,2240.,-120., 221., 0., 0.
+ *,2250., .54250,2240.,-121., 110., 0., 0.
+ *,2250., .57300,2240.,-121., 220., 0., 0.
+ *,2250., .60350,2240.,-121., 111., 0., 0.
+ *,2250., .63400,2240.,-121., 221., 0., 0.
+ *,2250., .66450,2241.,-120., 110., 0., 0.
+ *,2250., .69500,2241.,-120., 220., 0., 0.
+ *,2250., .72550,2241.,-120., 111., 0., 0.
+ *,2250., .75600,2241.,-120., 221., 0., 0.
+ *,2250., .78650,2241.,-121., 110., 0., 0.
+ *,2250., .81700,2241.,-121., 220., 0., 0.
+ *,2250., .84750,2241.,-121., 111., 0., 0.
+ *,2250., .87800,2241.,-121., 221., 0., 0.
+ *,2250., .89325,2240.,-130., 230., 0., 0.
+ *,2250., .90850,2240.,-130., 231., 0., 0.
+ *,2250., .92375,2240.,-131., 230., 0., 0.
+ *,2250., .93900,2240.,-131., 231., 0., 0.
+ *,2250., .95425,2241.,-130., 230., 0., 0./
+ data ((dectab(i,j),i=1,7),j=623,640)/
+ * 2250., .96950,2241.,-130., 231., 0., 0.
+ *,2250., .98475,2241.,-131., 230., 0., 0.
+ *,2250.,1.00000,2241.,-131., 231., 0., 0.
+ *,2350., .06000, 12., -11.,2340., 0., 0.
+ *,2350., .12000, 12., -11.,2341., 0., 0.
+ *,2350., .18000, 14., -13.,2340., 0., 0.
+ *,2350., .24000, 14., -13.,2341., 0., 0.
+ *,2350., .25500, 16., -15.,2340., 0., 0.
+ *,2350., .27000, 16., -15.,2341., 0., 0.
+ *,2350., .28925,2340.,-120., 0., 0., 0.
+ *,2350., .30850,2340.,-121., 0., 0., 0.
+ *,2350., .32775,2341.,-120., 0., 0., 0.
+ *,2350., .34700,2341.,-121., 0., 0., 0.
+ *,2350., .35775,2340., 340., 0., 0., 0.
+ *,2350., .36850,2340., 341., 0., 0., 0.
+ *,2350., .37925,2341., 340., 0., 0., 0.
+ *,2350., .39000,2341., 341., 0., 0., 0.
+ *,2350., .42050,2340.,-120., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=641,658)/
+ * 2350., .45100,2340.,-120., 220., 0., 0.
+ *,2350., .48150,2340.,-120., 111., 0., 0.
+ *,2350., .51200,2340.,-120., 221., 0., 0.
+ *,2350., .54250,2340.,-121., 110., 0., 0.
+ *,2350., .57300,2340.,-121., 220., 0., 0.
+ *,2350., .60350,2340.,-121., 111., 0., 0.
+ *,2350., .63400,2340.,-121., 221., 0., 0.
+ *,2350., .66450,2341.,-120., 110., 0., 0.
+ *,2350., .69500,2341.,-120., 220., 0., 0.
+ *,2350., .72550,2341.,-120., 111., 0., 0.
+ *,2350., .75600,2341.,-120., 221., 0., 0.
+ *,2350., .78650,2341.,-121., 110., 0., 0.
+ *,2350., .81700,2341.,-121., 220., 0., 0.
+ *,2350., .84750,2341.,-121., 111., 0., 0.
+ *,2350., .87800,2341.,-121., 221., 0., 0.
+ *,2350., .89325,2340.,-130., 230., 0., 0.
+ *,2350., .90850,2340.,-130., 231., 0., 0.
+ *,2350., .92375,2340.,-131., 230., 0., 0./
+ data ((dectab(i,j),i=1,7),j=659,720)/
+ * 434*1./
+ data ((dectab(i,j),i=1,7),j=721,738)/
+ * 2350., .93900,2340.,-131., 231., 0., 0.
+ *,2350., .95425,2341.,-130., 230., 0., 0.
+ *,2350., .96950,2341.,-130., 231., 0., 0.
+ *,2350., .98475,2341.,-131., 230., 0., 0.
+ *,2350.,1.00000,2341.,-131., 231., 0., 0.
+ *,3150., .06000, 12., -11.,3140., 0., 0.
+ *,3150., .12000, 12., -11.,1341., 0., 0.
+ *,3150., .18000, 14., -13.,3140., 0., 0.
+ *,3150., .24000, 14., -13.,1341., 0., 0.
+ *,3150., .25500, 16., -15.,3140., 0., 0.
+ *,3150., .27000, 16., -15.,1341., 0., 0.
+ *,3150., .28925,3140.,-120., 0., 0., 0.
+ *,3150., .30850,3140.,-121., 0., 0., 0.
+ *,3150., .32775,1341.,-120., 0., 0., 0.
+ *,3150., .34700,1341.,-121., 0., 0., 0.
+ *,3150., .35775,3140., 340., 0., 0., 0.
+ *,3150., .36850,3140., 341., 0., 0., 0.
+ *,3150., .37925,1341., 340., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=739,756)/
+ * 3150., .39000,1341., 341., 0., 0., 0.
+ *,3150., .42050,3140.,-120., 110., 0., 0.
+ *,3150., .45100,3140.,-120., 220., 0., 0.
+ *,3150., .48150,3140.,-120., 111., 0., 0.
+ *,3150., .51200,3140.,-120., 221., 0., 0.
+ *,3150., .54250,3140.,-121., 110., 0., 0.
+ *,3150., .57300,3140.,-121., 220., 0., 0.
+ *,3150., .60350,3140.,-121., 111., 0., 0.
+ *,3150., .63400,3140.,-121., 221., 0., 0.
+ *,3150., .66450,1341.,-120., 110., 0., 0.
+ *,3150., .69500,1341.,-120., 220., 0., 0.
+ *,3150., .72550,1341.,-120., 111., 0., 0.
+ *,3150., .75600,1341.,-120., 221., 0., 0.
+ *,3150., .78650,1341.,-121., 110., 0., 0.
+ *,3150., .81700,1341.,-121., 220., 0., 0.
+ *,3150., .84750,1341.,-121., 111., 0., 0.
+ *,3150., .87800,1341.,-121., 221., 0., 0.
+ *,3150., .89325,3140.,-130., 230., 0., 0./
+ data ((dectab(i,j),i=1,7),j=757,774)/
+ * 3150., .90850,3140.,-130., 231., 0., 0.
+ *,3150., .92375,3140.,-131., 230., 0., 0.
+ *,3150., .93900,3140.,-131., 231., 0., 0.
+ *,3150., .95425,1341.,-130., 230., 0., 0.
+ *,3150., .96950,1341.,-130., 231., 0., 0.
+ *,3150., .98475,1341.,-131., 230., 0., 0.
+ *,3150.,1.00000,1341.,-131., 231., 0., 0.
+ *,3250., .06000, 12., -11.,3240., 0., 0.
+ *,3250., .12000, 12., -11.,2341., 0., 0.
+ *,3250., .18000, 14., -13.,3240., 0., 0.
+ *,3250., .24000, 14., -13.,2341., 0., 0.
+ *,3250., .25500, 16., -15.,3240., 0., 0.
+ *,3250., .27000, 16., -15.,2341., 0., 0.
+ *,3250., .28925,3240.,-120., 0., 0., 0.
+ *,3250., .30850,3240.,-121., 0., 0., 0.
+ *,3250., .32775,2341.,-120., 0., 0., 0.
+ *,3250., .34700,2341.,-121., 0., 0., 0.
+ *,3250., .35775,3240., 340., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=775,792)/
+ * 3250., .36850,3240., 341., 0., 0., 0.
+ *,3250., .37925,2341., 340., 0., 0., 0.
+ *,3250., .39000,2341., 341., 0., 0., 0.
+ *,3250., .42050,3240.,-120., 110., 0., 0.
+ *,3250., .45100,3240.,-120., 220., 0., 0.
+ *,3250., .48150,3240.,-120., 111., 0., 0.
+ *,3250., .51200,3240.,-120., 221., 0., 0.
+ *,3250., .54250,3240.,-121., 110., 0., 0.
+ *,3250., .57300,3240.,-121., 220., 0., 0.
+ *,3250., .60350,3240.,-121., 111., 0., 0.
+ *,3250., .63400,3240.,-121., 221., 0., 0.
+ *,3250., .66450,2341.,-120., 110., 0., 0.
+ *,3250., .69500,2341.,-120., 220., 0., 0.
+ *,3250., .72550,2341.,-120., 111., 0., 0.
+ *,3250., .75600,2341.,-120., 221., 0., 0.
+ *,3250., .78650,2341.,-121., 110., 0., 0.
+ *,3250., .81700,2341.,-121., 220., 0., 0.
+ *,3250., .84750,2341.,-121., 111., 0., 0./
+ data ((dectab(i,j),i=1,7),j=793,810)/
+ * 3250., .87800,2341.,-121., 221., 0., 0.
+ *,3250., .89325,3240.,-130., 230., 0., 0.
+ *,3250., .90850,3240.,-130., 231., 0., 0.
+ *,3250., .92375,3240.,-131., 230., 0., 0.
+ *,3250., .93900,3240.,-131., 231., 0., 0.
+ *,3250., .95425,2341.,-130., 230., 0., 0.
+ *,3250., .96950,2341.,-130., 231., 0., 0.
+ *,3250., .98475,2341.,-131., 230., 0., 0.
+ *,3250.,1.00000,2341.,-131., 231., 0., 0.
+ *,3350., .06000, 12., -11.,3340., 0., 0.
+ *,3350., .12000, 12., -11.,3341., 0., 0.
+ *,3350., .18000, 14., -13.,3340., 0., 0.
+ *,3350., .24000, 14., -13.,3341., 0., 0.
+ *,3350., .25500, 16., -15.,3340., 0., 0.
+ *,3350., .27000, 16., -15.,3341., 0., 0.
+ *,3350., .28925,3340.,-120., 0., 0., 0.
+ *,3350., .30850,3340.,-121., 0., 0., 0.
+ *,3350., .32775,3341.,-120., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=811,828)/
+ * 3350., .34700,3341.,-121., 0., 0., 0.
+ *,3350., .35775,3340., 340., 0., 0., 0.
+ *,3350., .36850,3340., 341., 0., 0., 0.
+ *,3350., .37925,3341., 340., 0., 0., 0.
+ *,3350., .39000,3341., 341., 0., 0., 0.
+ *,3350., .42050,3340.,-120., 110., 0., 0.
+ *,3350., .45100,3340.,-120., 220., 0., 0.
+ *,3350., .48150,3340.,-120., 111., 0., 0.
+ *,3350., .51200,3340.,-120., 221., 0., 0.
+ *,3350., .54250,3340.,-121., 110., 0., 0.
+ *,3350., .57300,3340.,-121., 220., 0., 0.
+ *,3350., .60350,3340.,-121., 111., 0., 0.
+ *,3350., .63400,3340.,-121., 221., 0., 0.
+ *,3350., .66450,3341.,-120., 110., 0., 0.
+ *,3350., .69500,3341.,-120., 220., 0., 0.
+ *,3350., .72550,3341.,-120., 111., 0., 0.
+ *,3350., .75600,3341.,-120., 221., 0., 0.
+ *,3350., .78650,3341.,-121., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=829,846)/
+ * 3350., .81700,3341.,-121., 220., 0., 0.
+ *,3350., .84750,3341.,-121., 111., 0., 0.
+ *,3350., .87800,3341.,-121., 221., 0., 0.
+ *,3350., .89325,3340.,-130., 230., 0., 0.
+ *,3350., .90850,3340.,-130., 231., 0., 0.
+ *,3350., .92375,3340.,-131., 230., 0., 0.
+ *,3350., .93900,3340.,-131., 231., 0., 0.
+ *,3350., .95425,3341.,-130., 230., 0., 0.
+ *,3350., .96950,3341.,-130., 231., 0., 0.
+ *,3350., .98475,3341.,-131., 230., 0., 0.
+ *,3350.,1.00000,3341.,-131., 231., 0., 0.
+ *,1160., .33300, 1., -2.,1500., 0., 0.
+ *,1160., .66700, 4., -3.,1500., 0., 0.
+ *,1160., .77800, -12., 11.,1500., 0., 0.
+ *,1160., .88900, -14., 13.,1500., 0., 0.
+ *,1160.,1.00000, -16., 15.,1500., 0., 0.
+ *,1260., .33300, 1., -2.,2500., 0., 0.
+ *,1260., .66700, 4., -3.,2500., 0., 0./
+ data ((dectab(i,j),i=1,7),j=847,864)/
+ * 1260., .77800, -12., 11.,2500., 0., 0.
+ *,1260., .88900, -14., 13.,2500., 0., 0.
+ *,1260.,1.00000, -16., 15.,2500., 0., 0.
+ *,2260., .33300, 1., -2.,2500., 0., 0.
+ *,2260., .66700, 4., -3.,2500., 0., 0.
+ *,2260., .77800, -12., 11.,2500., 0., 0.
+ *,2260., .88900, -14., 13.,2500., 0., 0.
+ *,2260.,1.00000, -16., 15.,2500., 0., 0.
+ *,2160., .33300, 1., -2.,1500., 0., 0.
+ *,2160., .66700, 4., -3.,1500., 0., 0.
+ *,2160., .77800, -12., 11.,1500., 0., 0.
+ *,2160., .88900, -14., 13.,1500., 0., 0.
+ *,2160.,1.00000, -16., 15.,1500., 0., 0.
+ *,1360., .33300, 1., -2.,3500., 0., 0.
+ *,1360., .66700, 4., -3.,3500., 0., 0.
+ *,1360., .77800, -12., 11.,3500., 0., 0.
+ *,1360., .88900, -14., 13.,3500., 0., 0.
+ *,1360.,1.00000, -16., 15.,3500., 0., 0./
+ data ((dectab(i,j),i=1,7),j=865,882)/
+ * 2360., .33300, 1., -2.,3500., 0., 0.
+ *,2360., .66700, 4., -3.,3500., 0., 0.
+ *,2360., .77800, -12., 11.,3500., 0., 0.
+ *,2360., .88900, -14., 13.,3500., 0., 0.
+ *,2360.,1.00000, -16., 15.,3500., 0., 0.
+ *,3360., .33300, 1., -2.,3500., 0., 0.
+ *,3360., .66700, 4., -3.,3500., 0., 0.
+ *,3360., .77800, -12., 11.,3500., 0., 0.
+ *,3360., .88900, -14., 13.,3500., 0., 0.
+ *,3360.,1.00000, -16., 15.,3500., 0., 0.
+ *,1151.,1.00000,1150., 10., 0., 0., 0.
+ *,1251.,1.00000,1250., 10., 0., 0., 0.
+ *,2251.,1.00000,2250., 10., 0., 0., 0.
+ *,1351.,1.00000,1350., 10., 0., 0., 0.
+ *,2351.,1.00000,2350., 10., 0., 0., 0.
+ *,3351.,1.00000,3350., 10., 0., 0., 0.
+ *,1161.,1.00000,1160., 10., 0., 0., 0.
+ *,1261.,1.00000,1260., 10., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=883,886)/
+ * 2261.,1.00000,2260., 10., 0., 0., 0.
+ *,1361.,1.00000,1360., 10., 0., 0., 0.
+ *,2361.,1.00000,2360., 10., 0., 0., 0.
+ *,3361.,1.00000,3360., 10., 0., 0., 0./
+c *---------------------------------------------
+c * delta++ resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=887,900)/
+c *--dl++(1620)---------------------------------
+ * 1112., .30000,1120., 120., 0., 0., 0.
+ *,1112., .66000,1111., 110., 0., 0., 0.
+ *,1112., .90000,1121., 120., 0., 0., 0.
+ *,1112.,1.00000,1120., 120., 110., 0., 0.
+c *--dl++(1700)---------------------------------
+ *,1113., .15000,1120., 120., 0., 0., 0.
+ *,1113., .51000,1111., 110., 0., 0., 0.
+ *,1113., .75000,1121., 120., 0., 0., 0.
+ *,1113.,1.00000,1120., 120., 110., 0., 0.
+c *--dl++(1925)---------------------------------
+ *,1114., .28000,1120., 120., 0., 0., 0.
+ *,1114., .40600,1111., 110., 0., 0., 0.
+ *,1114., .49000,1121., 120., 0., 0., 0.
+ *,1114., .69000,1120., 121., 0., 0., 0.
+ *,1114., .70000,1130., 130., 0., 0., 0.
+ *,1114.,1.00000,1122., 120., 0., 0., 0./
+c *---------------------------------------------
+c * delta- resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=901,914)/
+c *--dl-(1620)----------------------------------
+ * 2222., .30000,1220.,-120., 0., 0., 0.
+ *,2222., .66000,2221., 110., 0., 0., 0.
+ *,2222., .90000,1221.,-120., 0., 0., 0.
+ *,2222.,1.00000,1220., 110.,-120., 0., 0.
+c *--dl-(1700)----------------------------------
+ *,2223., .15000,1220.,-120., 0., 0., 0.
+ *,2223., .51000,2221., 110., 0., 0., 0.
+ *,2223., .75000,1221.,-120., 0., 0., 0.
+ *,2223.,1.00000,1220., 110.,-120., 0., 0.
+c *--dl-(1925)----------------------------------
+ *,2224., .28000,1220.,-120., 0., 0., 0.
+ *,2224., .40600,2221., 110., 0., 0., 0.
+ *,2224., .49000,1221.,-120., 0., 0., 0.
+ *,2224., .69000,1220.,-121., 0., 0., 0.
+ *,2224., .70000,2230., 230., 0., 0., 0.
+ *,2224.,1.00000,1222.,-120., 0., 0., 0./
+c *---------------------------------------------
+c * n*+ resonances + delta+ resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=915,931)/
+c *--n*+(1440)----------------------------------
+ * 1122., .20000,1120., 110., 0., 0., 0.
+ *,1122., .60000,1220., 120., 0., 0., 0.
+ *,1122., .68000,1111.,-120., 0., 0., 0.
+ *,1122., .73000,1121., 110., 0., 0., 0.
+ *,1122., .76000,1221., 120., 0., 0., 0.
+ *,1122., .84000,1120., 120.,-120., 0., 0.
+ *,1122., .87000,1120., 110., 110., 0., 0.
+ *,1122.,1.00000,1220., 120., 110., 0., 0.
+c *--n*+(1530)----------------------------------
+ *,1123., .17000,1120., 110., 0., 0., 0.
+ *,1123., .51000,1220., 120., 0., 0., 0.
+ *,1123., .57000,1111.,-120., 0., 0., 0.
+ *,1123., .61000,1121., 110., 0., 0., 0.
+ *,1123., .63000,1221., 120., 0., 0., 0.
+ *,1123., .67000,1120., 120.,-120., 0., 0.
+ *,1123., .68000,1120., 110., 110., 0., 0.
+ *,1123., .75000,1220., 120., 110., 0., 0.
+ *,1123.,1.00000,1120., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=932,948)/
+c *--dl+(1620)----------------------------------
+ * 1124., .20000,1120., 110., 0., 0., 0.
+ *,1124., .30000,1220., 120., 0., 0., 0.
+ *,1124., .54000,1111.,-120., 0., 0., 0.
+ *,1124., .58000,1121., 110., 0., 0., 0.
+ *,1124., .90000,1221., 120., 0., 0., 0.
+ *,1124., .96000,1120., 120.,-120., 0., 0.
+ *,1124.,1.00000,1220., 120., 110., 0., 0.
+c *--n*+(1665)----------------------------------
+ *,1125., .16700,1120., 110., 0., 0., 0.
+ *,1125., .49970,1220., 120., 0., 0., 0.
+ *,1125., .62470,1111.,-120., 0., 0., 0.
+ *,1125., .70800,1121., 110., 0., 0., 0.
+ *,1125., .74970,1221., 120., 0., 0., 0.
+ *,1125., .82080,1120., 120.,-120., 0., 0.
+ *,1125., .85190,1120., 110., 110., 0., 0.
+ *,1125., .96300,1220., 120., 110., 0., 0.
+ *,1125., .97300,1120., 220., 0., 0., 0.
+ *,1125.,1.00000,2130., 130., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=949,955)/
+c *--dl+(1700)----------------------------------
+ * 1126., .10000,1120., 110., 0., 0., 0.
+ *,1126., .15000,1220., 120., 0., 0., 0.
+ *,1126., .39000,1111.,-120., 0., 0., 0.
+ *,1126., .43000,1121., 110., 0., 0., 0.
+ *,1126., .75000,1221., 120., 0., 0., 0.
+ *,1126., .91500,1120., 120.,-120., 0., 0.
+ *,1126.,1.00000,1220., 120., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=956,969)/
+c *--n*+(1710)----------------------------------
+ * 1127., .04430,1120., 110., 0., 0., 0.
+ *,1127., .13290,1220., 120., 0., 0., 0.
+ *,1127., .23790,1111.,-120., 0., 0., 0.
+ *,1127., .30790,1121., 110., 0., 0., 0.
+ *,1127., .34290,1221., 120., 0., 0., 0.
+ *,1127., .41190,1120., 120.,-120., 0., 0.
+ *,1127., .48090,1120., 110., 110., 0., 0.
+ *,1127., .54990,1220., 120., 110., 0., 0.
+ *,1127., .66070,1120., 220., 0., 0., 0.
+ *,1127., .72800,2130., 130., 0., 0., 0.
+ *,1127., .74930,1230., 130., 0., 0., 0.
+ *,1127., .76000,1130., 230., 0., 0., 0.
+ *,1127., .84000,1120., 111., 0., 0., 0.
+ *,1127.,1.00000,1220., 121., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=970,980)/
+c *--dl+(1925)----------------------------------
+ * 1128., .18700,1120., 110., 0., 0., 0.
+ *,1128., .28000,1220., 120., 0., 0., 0.
+ *,1128., .36400,1111.,-120., 0., 0., 0.
+ *,1128., .37800,1121., 110., 0., 0., 0.
+ *,1128., .49000,1221., 120., 0., 0., 0.
+ *,1128., .62300,1120., 111., 0., 0., 0.
+ *,1128., .69000,1220., 121., 0., 0., 0.
+ *,1128., .69350,1130., 230., 0., 0., 0.
+ *,1128., .69900,1230., 130., 0., 0., 0.
+ *,1128., .89900,1122., 110., 0., 0., 0.
+ *,1128.,1.00000,1222., 120., 0., 0., 0./
+c *---------------------------------------------
+c * n*0 resonances + delta0 resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=981,997)/
+c *----------n*0(1440)--------------------------
+ * 1222., .20000,1220., 110., 0., 0., 0.
+ *,1222., .60000,1120.,-120., 0., 0., 0.
+ *,1222., .68000,2221., 120., 0., 0., 0.
+ *,1222., .73000,1221., 110., 0., 0., 0.
+ *,1222., .76000,1121.,-120., 0., 0., 0.
+ *,1222., .84000,1220., 120.,-120., 0., 0.
+ *,1222., .87000,1220., 110., 110., 0., 0.
+ *,1222.,1.00000,1120.,-120., 110., 0., 0.
+c *----------n*0(1530)--------------------------
+ *,1223., .17000,1220., 110., 0., 0., 0.
+ *,1223., .51000,1120.,-120., 0., 0., 0.
+ *,1223., .57000,2221., 120., 0., 0., 0.
+ *,1223., .61000,1221., 110., 0., 0., 0.
+ *,1223., .63000,1121.,-120., 0., 0., 0.
+ *,1223., .67000,1220., 120.,-120., 0., 0.
+ *,1223., .68000,1220., 110., 110., 0., 0.
+ *,1223., .75000,1120.,-120., 110., 0., 0.
+ *,1223.,1.00000,1220., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=998,1014)/
+c *----------dl0(1620)--------------------------
+ * 1224., .20000,1220., 110., 0., 0., 0.
+ *,1224., .30000,1120.,-120., 0., 0., 0.
+ *,1224., .54000,2221., 120., 0., 0., 0.
+ *,1224., .58000,1221., 110., 0., 0., 0.
+ *,1224., .90000,1121.,-120., 0., 0., 0.
+ *,1224., .96500,1220., 120.,-120., 0., 0.
+ *,1224.,1.00000,1120.,-120., 110., 0., 0.
+c *----------n*0(1665)--------------------------
+ *,1225., .16700,1220., 110., 0., 0., 0.
+ *,1225., .49970,1120.,-120., 0., 0., 0.
+ *,1225., .62470,2221., 120., 0., 0., 0.
+ *,1225., .70800,1221., 110., 0., 0., 0.
+ *,1225., .74970,1121.,-120., 0., 0., 0.
+ *,1225., .82080,1220., 120.,-120., 0., 0.
+ *,1225., .85190,1220., 110., 110., 0., 0.
+ *,1225., .96300,1120.,-120., 110., 0., 0.
+ *,1225., .97300,1220., 220., 0., 0., 0.
+ *,1225.,1.00000,2130., 230., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1015,1021)/
+c *----------dl0(1700)--------------------------
+ * 1226., .10000,1220., 110., 0., 0., 0.
+ *,1226., .15000,1120.,-120., 0., 0., 0.
+ *,1226., .39000,2221., 120., 0., 0., 0.
+ *,1226., .43000,1221., 110., 0., 0., 0.
+ *,1226., .75000,1121.,-120., 0., 0., 0.
+ *,1226., .91500,1220., 120.,-120., 0., 0.
+ *,1226.,1.00000,1120.,-120., 110., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1022,1035)/
+c *----------n*0(1710)--------------------------
+ * 1227., .04430,1220., 110., 0., 0., 0.
+ *,1227., .13290,1120.,-120., 0., 0., 0.
+ *,1227., .23790,2221., 120., 0., 0., 0.
+ *,1227., .30790,1221., 110., 0., 0., 0.
+ *,1227., .34290,1121.,-120., 0., 0., 0.
+ *,1227., .41190,1220., 120.,-120., 0., 0.
+ *,1227., .48090,1220., 110., 110., 0., 0.
+ *,1227., .54990,1120.,-120., 110., 0., 0.
+ *,1227., .66070,1220., 220., 0., 0., 0.
+ *,1227., .72800,2130., 230., 0., 0., 0.
+ *,1227., .73870,1230., 230., 0., 0., 0.
+ *,1227., .76000,2230., 130., 0., 0., 0.
+ *,1227., .92000,1120.,-121., 0., 0., 0.
+ *,1227.,1.00000,1220., 111., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1036,1046)/
+c *----------dl0(1925)--------------------------
+ * 1228., .18700,1220., 110., 0., 0., 0.
+ *,1228., .28000,1120.,-120., 0., 0., 0.
+ *,1228., .36400,2221., 120., 0., 0., 0.
+ *,1228., .37800,1221., 110., 0., 0., 0.
+ *,1228., .49000,1121.,-120., 0., 0., 0.
+ *,1228., .55700,1220., 111., 0., 0., 0.
+ *,1228., .69000,1120.,-121., 0., 0., 0.
+ *,1228., .69350,2230., 130., 0., 0., 0.
+ *,1228., .70000,1230., 230., 0., 0., 0.
+ *,1228., .80000,1122.,-120., 0., 0., 0.
+ *,1228.,1.00000,1222., 110., 0., 0., 0./
+c *---------------------------------------------
+c * lambda resonances + sigma0 resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1047,1059)/
+c *----------lambda(1405)-----------------------
+ * 1233., .33000,1230., 110., 0., 0., 0.
+ *,1233., .66000,2230., 120., 0., 0., 0.
+ *,1233.,1.00000,1130.,-120., 0., 0., 0.
+c *----------lambda(1520)-----------------------
+ *,1234., .22500,1120.,-130., 0., 0., 0.
+ *,1234., .48000,1220.,-230., 0., 0., 0.
+ *,1234., .62000,1230., 110., 0., 0., 0.
+ *,1234., .76000,2230., 120., 0., 0., 0.
+ *,1234., .90000,1130.,-120., 0., 0., 0.
+ *,1234., .96000,2130., 120.,-120., 0., 0.
+ *,1234., .99000,2130., 110., 110., 0., 0.
+ *,1234., .99330,1130.,-120., 110., 0., 0.
+ *,1234., .99660,2230., 120., 110., 0., 0.
+ *,1234.,1.00000,1230., 120.,-120., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1060,1075)/
+c *----------lambda(1645)-----------------------
+ * 1235., .10000,1120.,-130., 0., 0., 0.
+ *,1235., .20000,1220.,-230., 0., 0., 0.
+ *,1235., .35000,1230., 110., 0., 0., 0.
+ *,1235., .50000,2230., 120., 0., 0., 0.
+ *,1235., .65000,1130.,-120., 0., 0., 0.
+ *,1235., .75000,2130., 120.,-120., 0., 0.
+ *,1235., .80000,2130., 110., 110., 0., 0.
+ *,1235., .84500,1130.,-120., 110., 0., 0.
+ *,1235., .89000,2230., 120., 110., 0., 0.
+ *,1235., .93500,1230., 120.,-120., 0., 0.
+ *,1235.,1.00000,2130., 220., 0., 0., 0.
+c *----------sigma0(1665)-----------------------
+ *,1236., .10000,1120.,-130., 0., 0., 0.
+ *,1236., .20000,1220.,-230., 0., 0., 0.
+ *,1236., .40000,2230., 120., 0., 0., 0.
+ *,1236., .60000,1130.,-120., 0., 0., 0.
+ *,1236.,1.00000,2130., 110., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1076,1084)/
+c *----------sigma0(1776)-----------------------
+ * 1237., .17500,1120.,-130., 0., 0., 0.
+ *,1237., .35000,1220.,-230., 0., 0., 0.
+ *,1237., .38750,2230., 120., 0., 0., 0.
+ *,1237., .42500,1130.,-120., 0., 0., 0.
+ *,1237., .57500,2130., 110., 0., 0., 0.
+ *,1237., .60000,2231., 120., 0., 0., 0.
+ *,1237., .62500,1131.,-120., 0., 0., 0.
+ *,1237., .75000,1234., 110., 0., 0., 0.
+ *,1237.,1.00000,1230., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1085,1094)/
+c *----------lambda(1845)-----------------------
+ * 1238., .17000,1120.,-130., 0., 0., 0.
+ *,1238., .34000,1220.,-230., 0., 0., 0.
+ *,1238., .44000,1230., 110., 0., 0., 0.
+ *,1238., .54000,2230., 120., 0., 0., 0.
+ *,1238., .64000,1130.,-120., 0., 0., 0.
+ *,1238., .70000,1231., 110., 0., 0., 0.
+ *,1238., .76000,2231., 120., 0., 0., 0.
+ *,1238., .82000,1131.,-120., 0., 0., 0.
+ *,1238., .91000,1120.,-131., 0., 0., 0.
+ *,1238.,1.00000,1220.,-231., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1095,1106)/
+c *----------sigma0(1930)-----------------------
+ * 1239., .07500,1120.,-130., 0., 0., 0.
+ *,1239., .15000,1220.,-230., 0., 0., 0.
+ *,1239., .20000,1121.,-130., 0., 0., 0.
+ *,1239., .25000,1221.,-230., 0., 0., 0.
+ *,1239., .32500,1120.,-131., 0., 0., 0.
+ *,1239., .40000,1220.,-231., 0., 0., 0.
+ *,1239., .47500,2230., 120., 0., 0., 0.
+ *,1239., .55000,1130.,-120., 0., 0., 0.
+ *,1239., .70000,2130., 110., 0., 0., 0.
+ *,1239., .77500,2231., 120., 0., 0., 0.
+ *,1239., .85000,1131.,-120., 0., 0., 0.
+ *,1239.,1.00000,1234., 110., 0., 0., 0./
+c *---------------------------------------------
+c * sigma+ resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1107,1118)/
+c *----------sigma+(1665)-----------------------
+ * 1132., .20000,1120.,-230., 0., 0., 0.
+ *,1132., .40000,1130., 110., 0., 0., 0.
+ *,1132., .60000,1230., 120., 0., 0., 0.
+ *,1132.,1.00000,2130., 120., 0., 0., 0.
+c *----------sigma+(1776)-----------------------
+ *,1133., .35000,1120.,-230., 0., 0., 0.
+ *,1133., .38750,1130., 110., 0., 0., 0.
+ *,1133., .42500,1230., 120., 0., 0., 0.
+ *,1133., .57500,2130., 120., 0., 0., 0.
+ *,1133., .60000,1131., 110., 0., 0., 0.
+ *,1133., .62500,1231., 120., 0., 0., 0.
+ *,1133., .75000,1234., 120., 0., 0., 0.
+ *,1133.,1.00000,1130., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1119,1128)/
+c *----------sigma+(1930)-----------------------
+ * 1134., .15000,1120.,-230., 0., 0., 0.
+ *,1134., .22500,1111.,-130., 0., 0., 0.
+ *,1134., .25000,1121.,-230., 0., 0., 0.
+ *,1134., .40000,1120.,-231., 0., 0., 0.
+ *,1134., .47500,1130., 110., 0., 0., 0.
+ *,1134., .55000,1230., 120., 0., 0., 0.
+ *,1134., .70000,2130., 120., 0., 0., 0.
+ *,1134., .77500,1131., 110., 0., 0., 0.
+ *,1134., .85000,1231., 120., 0., 0., 0.
+ *,1134.,1.00000,1234., 120., 0., 0., 0./
+c *---------------------------------------------
+c * sigma- resonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1129,1140)/
+c *----------sigma-(1665)-----------------------
+ * 2232., .20000,1220.,-130., 0., 0., 0.
+ *,2232., .40000,2230., 110., 0., 0., 0.
+ *,2232., .60000,1230.,-120., 0., 0., 0.
+ *,2232.,1.00000,2130.,-120., 0., 0., 0.
+c *----------sigma-(1776)-----------------------
+ *,2233., .35000,1220.,-130., 0., 0., 0.
+ *,2233., .38750,2230., 110., 0., 0., 0.
+ *,2233., .42500,1230.,-120., 0., 0., 0.
+ *,2233., .57500,2130.,-120., 0., 0., 0.
+ *,2233., .60000,2231., 110., 0., 0., 0.
+ *,2233., .62500,1231.,-120., 0., 0., 0.
+ *,2233., .75000,1234.,-120., 0., 0., 0.
+ *,2233.,1.00000,2230., 220., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1141,1150)/
+c *----------sigma-(1930)-----------------------
+ * 2234., .15000,1220.,-130., 0., 0., 0.
+ *,2234., .17500,1221.,-130., 0., 0., 0.
+ *,2234., .25000,2221.,-230., 0., 0., 0.
+ *,2234., .40000,1220.,-131., 0., 0., 0.
+ *,2234., .47500,2230., 110., 0., 0., 0.
+ *,2234., .55000,1230.,-120., 0., 0., 0.
+ *,2234., .70000,2130.,-120., 0., 0., 0.
+ *,2234., .77500,2231., 110., 0., 0., 0.
+ *,2234., .85000,1231.,-120., 0., 0., 0.
+ *,2234.,1.00000,1234.,-120., 0., 0., 0./
+c *---------------------------------------------
+c * additional mesonresonances
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1151,1159)/
+c *-----------f0(975)---------------------------
+ * 332., .50000, 120.,-120., 0., 0., 0.
+ *, 332., .75000, 110., 110., 0., 0., 0.
+ *, 332., .87500, 130.,-130., 0., 0., 0.
+ *, 332.,1.00000, 230.,-230., 0., 0., 0.
+c *-----------a0(980)---------------------------
+ *, 112., .56000, 110., 220., 0., 0., 0.
+ *, 112., .78000, 130.,-130., 0., 0., 0.
+ *, 112.,1.00000, 230.,-230., 0., 0., 0.
+c *-----------a+(980)---------------------------
+ *, 122., .60000, 120., 220., 0., 0., 0.
+ *, 122.,1.00000, 130.,-230., 0., 0., 0./
+c *---------------------------------------------
+c * weak baryon decays
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1160,1169)/
+c *-----------lambda(1116)----------------------
+ * 2130.,0.64200,1120.,-120., 0., 0., 0.
+ *,2130.,1.00000,1220., 110., 0., 0., 0.
+c *-----------sigma+(1180)----------------------
+ *,1130.,0.51580,1120., 110., 0., 0., 0.
+ *,1130.,1.00000,1220., 120., 0., 0., 0.
+c *-----------sigma-(1180)----------------------
+ *,2230.,1.00000,1220.,-120., 0., 0., 0.
+c *---------kaskade-(1360)----------------------
+ *,2330.,1.00000,2130.,-120., 0., 0., 0.
+c *---------kaskade0(1360)----------------------
+ *,1330.,1.00000,2130., 110., 0., 0., 0.
+c *---------omega-(1680)------------------------
+ *,3331.,0.68000,2130.,-130., 0., 0., 0.
+ *,3331.,0.82000,1330.,-120., 0., 0., 0.
+ *,3331.,1.00000,2330., 110., 0., 0., 0./
+c *---------------------------------------------
+c * weak meson decays
+c *---------------------------------------------
+ data ((dectab(i,j),i=1,7),j=1170,1171)/
+c *-----------k0s()--------------------------
+ * 20., .68610, 120.,-120., 0., 0., 0.
+ *, 20.,1.00000, 110., 110., 0., 0., 0./
+ data ((dectab(i,j),i=1,7),j=1172,1189)/
+c *-----------k0l-------------------------------
+ * 320., .2113, 110., 110., 110., 0., 0.
+ *, 320., .2113, 110., 110., 110., 0., 0.
+ *, 320., .2120, 110., 110., 110., 0., 0.
+ *, 320., .3380, 120.,-120., 110., 0., 0.
+ *, 320., .4744, 120., 14., -13., 0., 0.
+ *, 320., .6108,-120., -14., 13., 0., 0.
+ *, 320., .8054, 120., 12., -11., 0., 0.
+ *, 320.,1.0000,-120., -12., 11., 0., 0.
+c *-----------k+-------------------------------
+ *, 130., .6352 , -14., 13., 0., 0., 0.
+ *, 130., .8468 , 120., 110., 0., 0., 0.
+ *, 130., .9027 , 120., 120.,-120., 0., 0.
+ *, 130., .92 , 120., 110., 110., 0., 0.
+ *, 130., .9518 , 110., -14., 13., 0., 0.
+ *, 130.,1. , 110., -12., 11., 0., 0.
+c *-----------pi+------------------------------
+ *, 120., 1. , -14., 13., 0., 0., 0.
+c *-----------mu-------------------------------
+ *, 14., 1. , 12., -11., 13., 0., 0.
+c *-----------neutron---------------------------
+ *,1220., 1. , 1120., -12.,-11., 0., 0.
+c *-----------proton---------------------------
+ *,1120., 1. , 110., -12., 0., 0., 0./
+
+
+ call cxidresi
+
+c parameter (see epos-bas)
+ xspud=0.435d0
+ xspdiqua=.06d0
+ xstaunll=1.d0
+ xsasuha(1)=0.940d0 !lowest multiplet
+ xsasuha(2)=1.200d0
+ xsasuha(3)=1.322d0
+ xsasuha(4)=1.673d0
+ xsasuha(5)=0.1400d0
+ xsasuha(6)=0.4977d0
+ xsasuha(7)=1.2320d0
+
+c determine xswmass2,xswgam2
+c ----------------------
+ alfa=1.d0/137.036d0
+ gf=1.16570d-5
+ sin2w=.215d0
+ sinw=sqrt(sin2w)
+ amw=sqrt(xspi*alfa/(.9304d0*sqrt(2.d0)*gf))/sinw
+ xswmass2=amw
+ call cxidmass(5,amlep5)
+ call cxidmass(6,amlep6)
+ ngam=12
+ if(amlep5+amlep6.gt.amw) ngam=9
+ xswgam2=gf*amw**3/(6.d0*xspi*sqrt(2.d0))*ngam
+
+ data iblank/' '/
+ ird=0
+ do 1 i=1,mxlookxs
+1 lookxs(i)=0
+ do 2 i=1,mxdkyxs
+ do 3 j=1,5
+3 modexs(j,i)=0
+2 cbrxs(i)=0.d0
+ nodcayxs=.false.
+ noetaxs=.false.
+ nopi0xs=.false.
+ nonunuxs=.false.
+ noevolxs=.false.
+ nohadrxs=.false.
+#ifdef __CXDEBUG__
+ if(lprint) write(ifck,10)
+10 format('1',30('*')/' *',28x,'*'/
+ 1' *',5x,'isajet decay table',5x,'*'/
+ 2' *',28x,'*'/' ',30('*')//
+ 36x,'part',18x,'decay mode',19x,'cum br',15x,'ident',17x,
+ 4'decay ident')
+#endif
+ loop=0
+ iold=0
+ if(nodcayxs) return
+
+200 loop=loop+1
+ if(loop.gt.mxdkyxs) goto 9999
+220 do 210 i=1,5
+ imode(i)=0
+ lmode(i)=iblank
+210 continue
+ ird=ird+1
+ if(ird.gt.ndectb)return
+ ires=nint(dectab(1,ird))
+ br=dble(dectab(2,ird))
+ do 215 i=1,5
+215 imode(i)=nint(dectab(2+i,ird))
+ if(nopi0xs.and.ires.eq.110) goto 220
+ if(noetaxs.and.ires.eq.220) goto 220
+ if(ires.eq.iold) goto 230
+ if(ires.lt.0.or.ires.gt.mxlookxs)
+ *stop 'cxhdecin: ires out of range'
+ lookxs(ires)=loop
+230 iold=ires
+ cbrxs(loop)=br
+ do 240 i=1,5
+ modexs(i,loop)=imode(i)
+ if(imode(i).ne.0) lmode(i)=cxidlabl(imode(i))
+240 continue
+ lres=cxidlabl(ires)
+#ifdef __CXDEBUG__
+ if(lprint) write(ifck,20) lres,(lmode(k),k=1,5),
+ 1br,ires,(imode(k),k=1,5)
+20 format(6x,a5,6x,5(a5,2x),3x,f8.5,15x,i5,4x,5(i5,2x))
+#endif
+ goto 200
+
+9999 continue
+#ifdef __CXDEBUG__
+ write(ifck,*)'loop=', loop
+#else
+ write(*,*)'loop=', loop
+#endif
+ stop'cxhdecin: loop > mxdkyxs'
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidresi
+c-----------------------------------------------------------------------
+c initializes /xscrema/
+c width for B+* and B-* arbitrary (no data found) !!!!!!!!!!!
+c-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ parameter (n=32)
+ dimension remai(n,mxmaxs),rewii(n,mxmaxs),idmxi(mxmaxs,mxmxs)
+ *,icrei(n,2*mxmaxs)
+
+ data (idmxi(j,1),j=1,mxmaxs)/ 11, 110, 111, 0, 0, 0, 0, 4*0/
+ data (idmxi(j,2),j=1,mxmaxs)/ 22, 220, 330, 331, 0, 0, 0, 4*0/
+ data (idmxi(j,3),j=1,mxmaxs)/123,2130,1230,1231, 0, 0, 0, 4*0/
+ data (idmxi(j,4),j=1,mxmaxs)/124,2140,1240,1241, 0, 0, 0, 4*0/
+ data (idmxi(j,5),j=1,mxmaxs)/134,3140,1340,1341, 0, 0, 0, 4*0/
+ data (idmxi(j,6),j=1,mxmaxs)/234,3240,2340,2341, 0, 0, 0, 4*0/
+
+ data ((icrei(k,m),m=1,2*mxmaxs),k=1,10)/
+ *111,000000, 9*300000, 11*0,
+ *222,000000, 9*030000, 11*0,
+ *112, 10*210000, 11*0,
+ *122, 10*120000, 11*0,
+ *113, 10*201000, 11*0,
+ *223, 10*021000, 11*0,
+ *123, 10*111000, 11*0,
+ *133, 10*102000, 11*0,
+ *233, 10*012000, 11*0,
+ *333,000000, 9*003000, 11*0/
+ data ((icrei(k,m),m=1,2*mxmaxs),k=11,20)/
+ *114, 10*200100, 11*0,
+ *124, 10*110100, 11*0,
+ *224, 10*020100, 11*0,
+ *134, 10*101100, 11*0,
+ *234, 10*011100, 11*0,
+ *334, 10*002100, 11*0,
+ *144, 10*100200, 11*0,
+ *244, 10*010200, 11*0,
+ *344, 10*001200, 11*0,
+ *444,000000, 9*000300, 11*0/
+ data ((icrei(k,m),m=1,2*mxmaxs),k=21,29)/
+ * 11, 10*100000, 0, 10*100000,
+ * 22, 10*001000, 0, 10*001000,
+ * 12, 10*100000, 0, 10*010000,
+ * 13, 10*100000, 0, 10*001000,
+ * 23, 10*010000, 0, 10*001000,
+ * 14, 10*100000, 0, 10*000100,
+ * 24, 10*010000, 0, 10*000100,
+ * 34, 10*001000, 0, 10*000100,
+ * 44, 10*000100, 0, 10*000100/
+ data ((icrei(k,m),m=1,2*mxmaxs),k=30,32)/
+ * 15, 10*100000, 0, 10*000010,
+ * 25, 10*010000, 0, 10*000010,
+ * 35, 10*001000, 0, 10*000010/
+
+ data ((remai(k,m),m=1,mxmaxs),k=1,10)/
+ *111.,0.000,1.425,1.660,1.825,2.000,0.000,0.000,0.000,0.000,0.000,
+ *222.,0.000,1.425,1.660,1.825,2.000,0.000,0.000,0.000,0.000,0.000,
+ *112.,1.080,1.315,1.485,1.575,1.645,1.685,1.705,1.825,2.000,0.000,
+ *122.,1.080,1.315,1.485,1.575,1.645,1.685,1.705,1.825,2.000,0.000,
+ *113.,1.300,1.500,1.700,1.850,2.000,0.000,0.000,0.000,0.000,0.000,
+ *223.,1.300,1.500,1.700,1.850,2.000,0.000,0.000,0.000,0.000,0.000,
+ *123.,1.117,1.300,1.395,1.465,1.540,1.655,1.710,1.800,1.885,2.000,
+ *133.,1.423,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *233.,1.428,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+c *133.,1.423,1.638,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+c *233.,1.427,1.634,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *333.,0.000,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/
+ data ((remai(k,m),m=1,mxmaxs),k=11,20)/
+ *114.,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *124.,2.345,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *224.,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *134.,2.450,2.600,2.800,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *234.,2.450,2.600,2.800,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *334.,2.700,2.900,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *144.,3.650,3.850,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *244.,3.650,3.850,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *344.,3.800,4.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ *444.,0.000,5.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/
+ data ((remai(k,m),m=1,mxmaxs),k=21,29)/
+ * 11.,0.450,0.950,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+c * 22.,0.753,0.965,1.080,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 22.,0.750,0.965,1.380,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 12.,0.450,0.950,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 13.,0.700,1.050,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 23.,0.700,1.050,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 14.,1.935,2.150,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 24.,1.938,2.150,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 34.,2.085,2.370,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 44.,3.037,3.158,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/
+ data ((remai(k,m),m=1,mxmaxs),k=30,32)/
+ * 15.,5.302,5.348,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 25.,5.302,5.348,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
+ * 35.,5.390,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/
+
+ data ((rewii(k,m),m=1,mxmaxs),k=1,5)/
+ *111.,0.000e+00,0.115e+00,0.140e+00,0.250e+00,0.250e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *222.,0.000e+00,0.115e+00,0.140e+00,0.250e+00,0.250e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *112.,0.000e+00,0.115e+00,0.200e+00,0.140e+00,0.140e+00,
+ * 0.145e+00,0.250e+00,0.140e+00,0.250e+00,0.000e+00,
+ *122.,0.000e+00,0.115e+00,0.200e+00,0.140e+00,0.140e+00,
+ * 0.145e+00,0.250e+00,0.140e+00,0.250e+00,0.000e+00,
+ *113.,0.824e-14,0.036e+00,0.080e+00,0.100e+00,0.170e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=6,10)/
+ *223.,0.445e-14,0.039e+00,0.080e+00,0.100e+00,0.170e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *123.,0.250e-14,0.890e-05,0.036e+00,0.040e+00,0.016e+00,
+ * 0.090e+00,0.080e+00,0.100e+00,0.145e+00,0.170e+00,
+ *133.,0.227e-14,0.009e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *233.,0.400e-14,0.010e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *333.,0.000e+00,0.800e-14,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=11,15)/
+ *114.,0.400e-11,0.010e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *124.,0.400e-11,0.400e-11,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *224.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *134.,0.150e-11,0.400e-11,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *234.,0.150e-11,0.400e-11,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=16,20)/
+ *334.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *144.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *244.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *344.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ *444.,0.400e-11,0.010e+00,0.010e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=21,25)/
+ * 11.,0.757e-08,0.153e+00,0.057e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 22.,0.105e-05,0.210e-03,0.034e+00,0.004e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 12.,0.000e+00,0.153e+00,0.057e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 13.,0.000e+00,0.051e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 23.,0.197e-02,0.051e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=26,29)/
+ * 14.,0.154e-11,0.002e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 24.,0.615e-12,0.002e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 34.,0.150e-11,0.020e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 44.,0.010e+00,0.068e-03,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+ data ((rewii(k,m),m=1,mxmaxs),k=30,32)/
+ * 15.,0.426e-12,0.426e-12,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 25.,0.426e-12,0.426e-12,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 35.,0.408e-12,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
+ * 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00/
+
+ do 3 i=1,mxindxs
+3 indxs(i)=0
+ do 4 k=1,mxrexs
+ do 4 m=1,mxmaxs
+4 remaxs(k,m)=0
+
+ do 2 j=1,mxmaxs
+ do 2 i=1,mxmxs
+2 idmxs(j,i)=idmxi(j,i)
+
+ ntec=n
+ if(ntec.gt.mxrexs)stop'cxidresi: dimension mxrexs too small'
+ do 1 k=1,n
+ ix=nint(remai(k,1))
+ ix2=nint(rewii(k,1))
+ ix3=icrei(k,1)
+ if(ix.ne.ix2)stop'idresi: ix /= ix2'
+ if(ix.ne.ix3)stop'idresi: ix /= ix3'
+ if(ix.lt.1.or.ix.gt.mxindxs)
+ *stop'cxidresi: ix out of range.'
+ indxs(ix)=k
+ remaxs(k,1)=0.d0
+ rewixs(k,1)=0.d0
+ icre1xs(k,1)=0
+ icre2xs(k,1)=0
+ do 1 m=2,mxmaxs
+ remaxs(k,m)=remai(k,m)
+ rewixs(k,m)=rewii(k,m)
+ icre1xs(k,m)=icrei(k,m)
+1 icre2xs(k,m)=icrei(k,mxmaxs+m)
+
+ indxs(33) =indxs(22)
+ indxs(213)=indxs(123)
+ indxs(214)=indxs(124)
+ indxs(314)=indxs(134)
+ indxs(324)=indxs(234)
+
+ return
+ end
+
+#ifdef __CXDEBUG__
+c----------------------------------------------------------------------
+ subroutine cxalist(text,n1,n2,iimode)
+c----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ parameter(itext=40)
+ character text*(*)
+ dimension pp(5),erest(5)
+ if(n1.gt.n2)return
+ imax=index(text,'&')
+ if(imax.gt.1)then
+ write(ifck,'(/1x,75a1/1x,a,a,a,70a1)')
+ *('#',k=1,75),'############# ',text(1:imax-1),' '
+ *,('#',k=1,59-imax)
+ write(ifck,'(1x,75a1/)')('#',k=1,75)
+ endif
+ if(n1.eq.0.and.n2.eq.0)return
+ if(imax.gt.1)then
+ write(ifck,'(1x,a,a,a/1x,118a1)')
+ *' ior jor i ifr1 ifr2 id ist ity',
+ *' px py pz p0 mass',
+ *' rap'
+ *,('-',k=1,118)
+ endif
+
+ do j=1,5
+ pp(j)=0.d0
+ enddo
+ nqu=0
+ nqd=0
+ nqs=0
+ nqup=0
+ nqdp=0
+ nqsp=0
+ nqut=0
+ nqdt=0
+ nqst=0
+ do i=n1,n2
+ amtptl=xsptl(1,i)**2+xsptl(2,i)**2+xsptl(5,i)**2
+ if(amtptl.le.0.d0)then
+ if(idptlxs(i).lt.10000)then
+ call cxidmass(idptlxs(i),amtptl)
+ endif
+ amtptl=sqrt(amtptl*amtptl+xsptl(1,i)**2+xsptl(2,i)**2)
+ else
+ amtptl=sqrt(amtptl)
+ endif
+ rap=0.d0
+ if(amtptl.gt.0.d0.and.xsptl(4,i).gt.0.d0)
+ & rap=sign(1.d0,xsptl(3,i))*log((xsptl(4,i)+abs(xsptl(3,i)))
+ & /amtptl)
+ write(ifck,125)iorptlxs(i),jorptlxs(i),i,ifrptlxs(1,i)
+ & ,ifrptlxs(2,i),idptlxs(i),istptlxs(i),ityptlxs(i)
+ & ,(xsptl(j,i),j=1,5),rap
+c &,(xsorptl(j,i),j=1,4)
+ if(mod(istptlxs(i),10).eq.0.and.n1.eq.1.and.n2.eq.nptlxs)then
+ do j=1,4
+ pp(j)=pp(j)+xsptl(j,i)
+ enddo
+ if(istptlxs(i).ne.40.and.istptlxs(i).ne.30)then
+ call cxidqufl(i,idptlxs(i),ifl1,ifl2,ifl3)
+ nqu=nqu+ifl1
+ nqd=nqd+ifl2
+ nqs=nqs+ifl3
+ endif
+ endif
+ enddo
+ 125 format (1x,i5,i5,3x,i5,3x,i5,i5,i12,2i4,4x,5(e11.4,1x)
+ * ,f9.2,4x,4(e9.2,1x))
+ 126 format (21x,5(e17.10,1x))
+ 128 format (51x,70('-'))
+ pp2=(pp(4)+pp(3))*(pp(4)-pp(3))-pp(2)**2-pp(1)**2
+ if(pp2.lt.0.d0)then
+ write(*,'(a,5e23.15)')'Warning : total squared mass < 0 ! :'
+ & ,pp2,pp(1),pp(2),pp(3),pp(4)
+ pp2=0.d0
+ endif
+ pp(5)=sqrt(pp2)
+ if(n1.ne.n2)write (ifck,128)
+ if(n1.ne.n2)write (ifck,126) (pp(i),i=1,5)
+ if(n1.eq.1.and.n2.eq.nptlxs)then
+ if(iimode.eq.1)then
+ erest(1)=0.d0
+ erest(2)=0.d0
+ erest(3)=0.d0
+ erest(4)=0.d0
+ erest(5)=0.d0
+ do i=1,iabs(maprojxs)+iabs(matargxs)
+ do j=1,4
+ erest(j)=erest(j)+xsptl(j,i)
+ enddo
+ enddo
+ erest(5)=sqrt((erest(4)+erest(3))*(erest(4)-erest(3))
+ $ -erest(2)**2-erest(1)**2)
+ write (ifck,129) (erest(j),j=1,5)
+ if(idprojxs.eq.1120)then
+ nqup=iabs(laprojxs)*2+(maprojxs-iabs(laprojxs))
+ nqdp=iabs(laprojxs)+(maprojxs-iabs(laprojxs))*2
+ else
+ call cxidqufl(1,idprojxs,nqup,nqdp,nqsp)
+ endif
+ if(idtargxs.eq.1120)then
+ nqut=iabs(latargxs)*2+(matargxs-iabs(latargxs))
+ nqdt=iabs(latargxs)+(matargxs-iabs(latargxs))*2
+ else
+ call cxidqufl(2,idtargxs,nqut,nqdt,nqst)
+ endif
+ else
+ do j=1,5
+ erest(j)=xsptl(j,1)
+ enddo
+ write (ifck,129) (erest(j),j=1,5)
+ call cxidqufl(1,idptlxs(1),nqup,nqdp,nqsp)
+ endif
+ 129 format (20x,'(',5(e17.10,1x),')')
+ nqu=nqu-nqup-nqut
+ nqd=nqd-nqdp-nqdt
+ nqs=nqs-nqsp-nqst
+ write(ifck,*)'Quark number conservation (u,d,s) :',nqu,nqd,nqs
+ endif
+ end
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine cxidqufl(n,id,nqu,nqd,nqs)
+c unpacks the ident code of particle (n) and give the number of
+c quarks of each flavour(only u,d,s)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ integer jc(nflavxs,2),ic(2)
+
+ nqu=0
+ nqd=0
+ nqs=0
+ if(iabs(id).ge.7.and.iabs(id).lt.100.and.iabs(id).ne.20)return
+ if(iabs(id)/10.eq.11.or.iabs(id)/10.eq.22)return
+ if(iabs(id).eq.20)then
+ if(iorptlxs(n).gt.0)then
+ if(idptlxs(iorptlxs(n)).gt.0)then
+ nqd=1
+ nqs=-1
+ elseif(iorptlxs(n).gt.0)then
+ nqd=-1
+ nqs=1
+ else
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*)'Cannot count the number of quark'
+#endif
+ endif
+ endif
+ return
+ endif
+ if(id.ne.0.and.mod(id,100).eq.0.and.id.le.10**8) goto 300
+c write(ifck,*)'test',id
+ call cxidtr4(id,ic)
+ call cxiddeco(ic,jc)
+ nqu=jc(1,1)-jc(1,2)
+ nqd=jc(2,1)-jc(2,2)
+ nqs=jc(3,1)-jc(3,2)
+c write(ifck,*)'id',id,nqu,nqd,nqs
+ return
+ 300 i=iabs(id)/1000
+ j=mod(iabs(id)/100,10)
+ ifl1=isign(i,id)
+ ifl2=isign(j,id)
+ if(iabs(ifl1).eq.1)nqu=isign(1,ifl1)
+ if(iabs(ifl1).eq.2)nqd=isign(1,ifl1)
+ if(iabs(ifl1).eq.3)nqs=isign(1,ifl1)
+ if(iabs(ifl2).eq.1)nqu=nqu+isign(1,ifl2)
+ if(iabs(ifl2).eq.2)nqd=nqd+isign(1,ifl2)
+ if(iabs(ifl2).eq.3)nqs=nqs+isign(1,ifl2)
+c write(ifck,*)'id',id,ifl1,ifl2,nqu,nqd,nqs
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidtr4(id,ic)
+c transforms generalized paige_id -> werner_id (for < 4 flv)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ integer ic(2)
+
+ ic(1)=000000
+ ic(2)=000000
+ if(iabs(id).lt.20)then
+ if(id.eq.1)then
+ ic(1)=100000
+ ic(2)=000000
+ elseif(id.eq.-1)then
+ ic(1)=000000
+ ic(2)=100000
+ elseif(id.eq.2)then
+ ic(1)=010000
+ ic(2)=000000
+ elseif(id.eq.-2)then
+ ic(1)=000000
+ ic(2)=010000
+ elseif(id.eq.3)then
+ ic(1)=001000
+ ic(2)=000000
+ elseif(id.eq.-3)then
+ ic(1)=000000
+ ic(2)=001000
+ elseif(id.eq.4)then
+ ic(1)=000100
+ ic(2)=000000
+ elseif(id.eq.-4)then
+ ic(1)=000000
+ ic(2)=000100
+ elseif(id.eq.5)then
+ ic(1)=000010
+ ic(2)=000000
+ elseif(id.eq.-5)then
+ ic(1)=000000
+ ic(2)=000010
+ elseif(id.eq.17)then
+ ic(1)=330000
+ ic(2)=000000
+ elseif(id.eq.-17)then
+ ic(1)=000000
+ ic(2)=330000
+ elseif(id.eq.18)then
+ ic(1)=450000
+ ic(2)=000000
+ elseif(id.eq.-18)then
+ ic(1)=000000
+ ic(2)=450000
+ elseif(id.eq.19)then
+ ic(1)=660000
+ ic(2)=000000
+ elseif(id.eq.-19)then
+ ic(1)=000000
+ ic(2)=660000
+ endif
+ return
+ endif
+ if(iabs(id).lt.1e8)then
+ ix=iabs(id)/10
+ if(ix.lt.1.or.ix.gt.mxindxs)goto 9999
+ ii=indxs(ix)
+ if(ii.eq.0)goto 9998
+ jj=mod(iabs(id),10)+2
+ do 27 imx=1,mxmxs
+ do 27 ima=2,mxmaxs
+ if(iabs(id).eq.idmxs(ima,imx))jj=ima
+ 27 continue
+ if(id.gt.0)then
+ ic(1)=icre1xs(ii,jj)
+ ic(2)=icre2xs(ii,jj)
+ else
+ ic(2)=icre1xs(ii,jj)
+ ic(1)=icre2xs(ii,jj)
+ endif
+ if(ic(1).eq.100000.and.ic(2).eq.100000
+ & .and.drangen(dble(id)).lt.0.5d0)
+ $ then
+ ic(1)=010000
+ ic(2)=010000
+ endif
+ elseif(mod(id/10**8,10).eq.8)then
+ ic(1)=mod(id,10**8)/10000*100
+ ic(2)=mod(id,10**4)*100
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*)'***** id: ',id
+#else
+ write(*,*)'***** id: ',id
+#endif
+ stop'cxidtr4: unrecognized id'
+ endif
+ return
+
+ 9998 continue
+#ifdef __CXDEBUG__
+ write(ifck,*)'id: ',id
+#else
+ write(*,*)'id: ',id
+#endif
+ stop'idtr4: indx=0.'
+
+ 9999 continue
+#ifdef __CXDEBUG__
+ write(ifck,*)'id: ',id
+#else
+ write(*,*)'id: ',id
+#endif
+ stop'idtr4: ix out of range.'
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxiddeco(ic,jc)
+c decode particle id
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ integer jc(nflavxs,2),ic(2)
+ ici=ic(1)
+ jc(6,1)=mod(ici,10)
+ jc(5,1)=mod(ici/10,10)
+ jc(4,1)=mod(ici/100,10)
+ jc(3,1)=mod(ici/1000,10)
+ jc(2,1)=mod(ici/10000,10)
+ jc(1,1)=mod(ici/100000,10)
+ ici=ic(2)
+ jc(6,2)=mod(ici,10)
+ jc(5,2)=mod(ici/10,10)
+ jc(4,2)=mod(ici/100,10)
+ jc(3,2)=mod(ici/1000,10)
+ jc(2,2)=mod(ici/10000,10)
+ jc(1,2)=mod(ici/100000,10)
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxconre
+c-----------------------------------------------------------------------
+c initializes remnants
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+
+c proj
+c ----
+ la=laprojxs
+ ma=iabs(maprojxs)
+ las=0
+ mas=0
+ do l=1,ma
+ if(la.ge.0)then
+ id=1220
+ if(drangen(dble(id)).le.(la-las)*1./(ma-mas))id=1120
+ if(id.eq.1120)las=las+1
+ mas=mas+1
+ ic1=idtraicx(1,id,1)
+ ic2=idtraicx(2,id,1)
+ icprojxs(1,l)=ic1
+ icprojxs(2,l)=ic2
+ endif
+ enddo
+
+c targ
+c ----
+ la=latargxs
+ ma=iabs(matargxs)
+ las=0
+ mas=0
+ do l=1,ma
+ if(la.ge.0)then
+ id=1220
+ if(drangen(dble(la)).le.(la-las)*1./(ma-mas))id=1120
+ if(id.eq.1120)las=las+1
+ mas=mas+1
+ ic1=idtraicx(1,id,1)
+ ic2=idtraicx(2,id,1)
+ ictargxs(1,l)=ic1
+ ictargxs(2,l)=ic2
+ endif
+ enddo
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxconwr(ist)
+c-----------------------------------------------------------------------
+c writes /cptl/
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+
+ double precision XA(64,3),XB(64,3),BQGS
+ COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX !ctp
+#ifdef __QGSJETII__
+ parameter(iapmax=208)
+ double precision bqgs2,bmaxqgs2,bmaxnex2,bminnex2,xan,xbn
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)
+ *,bqgs2,bmaxqgs2,bmaxnex2,bminnex2
+#endif
+ integer ic(2)
+
+ bx=cos(xsphi)*xsbimp
+ by=sin(xsphi)*xsbimp
+
+c write /cptl/
+c ------------
+ nptlxs=0
+
+
+ do 6 i=1,maprojxs
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=ist
+ iorptlxs(nptlxs)=-1
+ jorptlxs(nptlxs)=0
+#ifndef __CXCORSIKA__
+ if(modelxs.eq.2)then !QGSJet
+ xsxproj(i)=XA(i,1)
+ xsyproj(i)=XA(i,2)
+ xszproj(i)=XA(i,3)
+#ifdef __QGSJETII__
+ elseif(modelxs.eq.6)then !QGSJetII
+ xsxproj(i)=xan(i,1)
+ xsyproj(i)=xan(i,2)
+ xszproj(i)=xan(i,3)
+#endif
+ elseif(modelxs.eq.3.or.modelxs.ge.5)then !Gheisha, Sibyll, DPMJET, FLUKA and UrQMD
+#endif
+ xsxproj(i)=0.d0
+ xsyproj(i)=0.d0
+ xszproj(i)=0.d0
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ xsorptl(1,nptlxs)=xsxproj(i)+bx/2
+ xsorptl(2,nptlxs)=xsyproj(i)+by/2
+ xsorptl(3,nptlxs)=xszproj(i)
+ xsorptl(4,nptlxs)=0
+ xstivptl(1,nptlxs)=-xsainfin
+c for visualisation uncomment
+c-c xstivptl(1,nptlxs)=-100
+ xstivptl(2,nptlxs)= xsainfin
+6 continue
+ do 7 i=1,matargxs
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=ist
+ iorptlxs(nptlxs)=-1
+ jorptlxs(nptlxs)=0
+#ifndef __CXCORSIKA__
+ if(modelxs.eq.2)then !QGSJet
+ xsxtarg(i)=XB(i,1)
+ xsytarg(i)=XB(i,2)
+ xsztarg(i)=XB(i,3)
+#ifdef __QGSJETII__
+ elseif(modelxs.eq.6)then !QGSJetII
+ xsxtarg(i)=xbn(i,1)
+ xsytarg(i)=xbn(i,2)
+ xsztarg(i)=xbn(i,3)
+#endif
+ elseif(modelxs.ge.3.or.modelxs.ge.5)then !Gheisha, Sibyll, DPMJET, FLUKA and UrQMD
+#endif
+ xsxtarg(i)=0.d0
+ xsytarg(i)=0.d0
+ xsztarg(i)=0.d0
+#ifndef __CXCORSIKA__
+ endif
+#endif
+ xsorptl(1,nptlxs)=xsxtarg(i)-bx/2
+ xsorptl(2,nptlxs)=xsytarg(i)-by/2
+ xsorptl(3,nptlxs)=xsztarg(i)
+ xsorptl(4,nptlxs)=0
+ xstivptl(1,nptlxs)=-xsainfin
+c for visualisation uncomment
+c-c xstivptl(1,nptlxs)=-100
+ xstivptl(2,nptlxs)= xsainfin
+7 continue
+
+ nptlxs=0
+ do i=1,maprojxs
+ nptlxs=nptlxs+1
+ if(laprojxs.lt.0)then
+ id=idprojxs
+ ams=xsamproj
+ else
+ ic(1)=icprojxs(1,i)
+ ic(2)=icprojxs(2,i)
+ id=idtracx(ic,0,0,3)
+ call cxidmass(id,ams)
+ endif
+ idptlxs(nptlxs)=id
+ xsptl(1,nptlxs)=0.d0
+ xsptl(2,nptlxs)=0.d0
+ if(iframexs.eq.0)then
+ xsptl(3,nptlxs)=xspnll
+ xsptl(4,nptlxs)=sqrt(xspnll**2+ams**2)
+ else
+ xsptl(3,nptlxs)=xspnullx
+ xsptl(4,nptlxs)=sqrt(xspnullx**2+ams**2)
+ endif
+ xsptl(5,nptlxs)=ams
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ ityptlxs(nptlxs)=0
+ enddo
+ do i=1,matargxs
+ nptlxs=nptlxs+1
+ if(latargxs.lt.0)then
+ id=idtargxs
+ ams=xsamtarg
+ else
+ ic(1)=ictargxs(1,i)
+ ic(2)=ictargxs(2,i)
+ id=idtracx(ic,0,0,3)
+ call cxidmass(id,ams)
+ endif
+ idptlxs(nptlxs)=id
+ xsptl(1,nptlxs)=0.d0
+ xsptl(2,nptlxs)=0.d0
+ if(iframexs.eq.0)then
+ xsptl(3,nptlxs)=0d0
+ xsptl(4,nptlxs)=ams
+ else
+ xsptl(3,nptlxs)=-xspnullx
+ xsptl(4,nptlxs)=sqrt(xspnullx**2+ams**2)
+ endif
+ xsptl(5,nptlxs)=ams
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ ityptlxs(nptlxs)=0
+ enddo
+
+
+c exit
+c ----
+ return
+ end
+
+
+c-----------------------------------------------------------------------
+ integer function idtracx(ic,ier,ires,imix)
+c tranforms from werner-id to paige-id
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+ parameter (nidt=54)
+ integer idt(3,nidt),ic(2)!,icm(2)
+ data idt/
+ * 100000,100000, 110 ,100000,010000, 120 ,010000,010000, 220
+ *,100000,001000, 130 ,010000,001000, 230 ,001000,001000, 330
+ *,100000,000100, 140 ,010000,000100, 240 ,001000,000100, 340
+ *,000100,000100, 440
+ *,100000,000010, 150 ,010000,000010, 250 ,001000,000010, 350
+ *,000100,000010, 450 ,000010,000010, 550
+ *,100000,000000, 1 ,010000,000000, 2 ,001000,000000, 3
+ *,000100,000000, 4 ,000010,000000, 5 ,000001,000000, 6
+ *,330000,000000, 17 ,450000,000000, 18 ,660000,000000, 19
+ *,200000,000000,1100 ,110000,000000,1200 ,020000,000000,2200
+ *,101000,000000,1300 ,011000,000000,2300 ,002000,000000,3300
+ *,100100,000000,1400 ,010100,000000,2400 ,001100,000000,3400
+ *,000200,000000,4400
+ *,300000,000000,1111 ,210000,000000,1120 ,120000,000000,1220
+ *,030000,000000,2221 ,201000,000000,1130 ,111000,000000,1230
+ *,021000,000000,2230 ,102000,000000,1330 ,012000,000000,2330
+ *,003000,000000,3331 ,200100,000000,1140 ,110100,000000,1240
+ *,020100,000000,2240 ,101100,000000,1340 ,011100,000000,2340
+ *,002100,000000,3340 ,100200,000000,1440 ,010200,000000,2440
+ *,001200,000000,3440 ,000300,000000,4441/
+
+ if(ires.eq.1)stop'ires=1 not supported any more'
+
+ idtracx=0
+ if(ic(1).eq.0.and.ic(2).eq.0)return
+ i=1
+ do while(i.le.nidt.and.idtracx.eq.0)
+ if(ic(2).eq.idt(1,i).and.ic(1).eq.idt(2,i))idtracx=-idt(3,i)
+ if(ic(1).eq.idt(1,i).and.ic(2).eq.idt(2,i))idtracx=idt(3,i)
+ i=i+1
+ enddo
+ isi=1
+ if(idtracx.ne.0)isi=idtracx/iabs(idtracx)
+
+ jspin=0
+
+ if(imix.eq.1)stop'imix=1 no longer supported'
+ if(imix.eq.2)then
+ if(idtracx.eq.220)idtracx=110
+ if(idtracx.eq.330)idtracx=110
+ elseif(imix.eq.3)then
+ if(idtracx.eq.220)idtracx=110
+ if(idtracx.eq.330)idtracx=220
+ endif
+
+ if(idtracx.ne.0)idtracx=idtracx+jspin*isi
+
+ if(idtracx.ne.0)return
+ if(ier.ne.1)return
+#ifdef __CXDEBUG__
+ write(ifck,*)'***** error in idtracx: unknown code'
+ write(ifck,*)'ic = ',ic
+#else
+ write(*,*)'***** error in idtracx: unknown code'
+ write(*,*)'ic = ',ic
+#endif
+ return
+
+ entry idtraicx(num,id,ier)
+ idtraicx=0
+ if(iabs(id).eq.20)then
+ j=5
+ else
+ j=0
+ do 2 i=1,nidt
+ if(iabs(id).eq.idt(3,i))j=i
+2 continue
+ endif
+ if(j.ne.0)then
+ if(id.lt.0)then
+ idtraicx=idt(3-num,j)
+ else
+ idtraicx=idt(num,j)
+ endif
+ return
+ endif
+ if(ier.ne.1)return
+#ifdef __CXDEBUG__
+ write(ifck,*)'***** error in idtraicx: unknown code'
+ write(ifck,*)'id = ',id
+#else
+ write(*,*)'***** error in idtraicx: unknown code'
+ write(*,*)'id = ',id
+#endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxutlob5(yboost,x1,x2,x3,x4,x5)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ amt=x5**2+x1**2+x2**2
+ if(amt.gt.0.d0)then
+ amt=sqrt(x5**2+x1**2+x2**2)
+ else
+ amt=max(1d-15,sqrt(abs((x4+x3)*(x4-x3))))
+ endif
+ y=sign(1.d0,x3)*log((x4+abs(x3))/amt)
+ y=y-yboost
+ x4=amt*cosh(y)
+ x3=amt*sinh(y)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ integer function idtrafocx(code1,code2,idi)
+c------------------------------------------------------------------------------
+c wrapper for idtrafo to catch if ID not found
+ character*3 code1,code2
+ integer istatus=0
+ idtrafocx = idtrafostatuscx(code1,code2,idi,istatus)
+ if (istatus.ne.0) then
+ print *,'idtrafocx: ',code1,' -> ', code2,idi,' not found.'
+ stop'idtrafocx'
+ endif
+ return
+ end
+
+c------------------------------------------------------------------------------
+ integer function idtrafostatuscx(code1,code2,idi,istatus)
+ + result(idtrafocx)
+c------------------------------------------------------------------------------
+c.....tranforms id of code1 (=idi) into id of code2 (=idtrafocx)
+c.....supported codes:
+c.....'nxs' = epos
+c.....'pdg' = PDG 1996 (DPMJET)
+c.....'qgs' = QGSJet
+c.....'ghe' = Gheisha
+c.....'sib' = Sibyll
+c.....'cor' = Corsika (GEANT)
+c.....'flk' = Fluka
+
+c.....returns status 0 if ID could be converted and 1 if it was not found in table
+
+C --- ighenex(I)=EPOS CODE CORRESPONDING TO GHEISHA CODE I ---
+
+ common /cxighnx/ ighenexs(35)
+
+C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
+C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I ---
+C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I ---
+ DIMENSION KIPART(48)!,IKPART(35)
+ DATA KIPART/
+ $ 1, 3, 4, 2, 5, 6, 8, 7,
+ $ 9, 12, 10, 13, 16, 14, 15, 11,
+ $ 35, 18, 20, 21, 22, 26, 27, 33,
+ $ 17, 19, 23, 24, 25, 28, 29, 34,
+ $ 35, 35, 35, 35, 35, 35, 35, 35,
+ $ 35, 35, 35, 35, 30, 31, 32, 35/
+
+c DATA IKPART/
+c $ 1, 4, 2, 3, 5, 6, 8, 7,
+c $ 9, 11, 16, 10, 12, 14, 15, 13,
+c $ 25, 18, 26, 19, 20, 21, 27, 28,
+c $ 29, 22, 23, 30, 31, 45, 46, 47,
+c $ 24, 32, 48/
+ INTEGER ICFTABL(200),IFCTABL(-6:100)
+C ICTABL CONVERTS CORSIKA PARTICLES INTO FLUKA PARTICLES
+C FIRST TABLE ONLY IF CHARMED PARTICLES CAN BE TREATED
+ DATA ICFTABL/
+ * 7, 4, 3, 0, 10, 11, 23, 13, 14, 12, ! 10
+ * 15, 16, 8, 1, 2, 19, 0, 17, 21, 22, ! 20
+ * 20, 34, 36, 38, 9, 18, 31, 32, 33, 34, ! 30
+ * 37, 39, 24, 25, 6*0,
+ * 0, 0, 0, 0, -3, -4, -6, -5, 0, 0, ! 50
+ * 10*0,
+ * 0, 0, 0, 0, 0, 5, 6, 27, 28, 0, ! 70
+ * 10*0,
+ * 10*0,
+ * 10*0, !100
+ * 10*0,
+ * 0, 0, 0, 0, 0, 47, 45, 46, 48, 49, !120
+ * 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, !130
+ * 41, 42, 43, 44, 0, 0, 51, 52, 53, 0, !140
+ * 0, 0, 54, 55, 56, 0, 0, 0, 57, 58, !150
+ * 59, 0, 0, 0, 60, 61, 62, 0, 0, 0, !160
+ * 40*0/
+C IFCTABL CONVERTS FLUKA PARTICLES INTO CORSIKA PARTICLES
+ DATA IFCTABL/
+ * 402, 302, 301, 201, 0, 0, 0,
+ * 14, 15, 3, 2, 66, 67, 1, 13, 25, 5,
+ * 6, 10, 8, 9, 11, 12, 18, 26, 16, 21,
+ * 19, 20, 7, 33, 34, 0, 68, 69, 0, 0,
+ * 27, 28, 29, 22, 30, 23, 31, 24, 32, 0,
+ * 131, 132, 133, 134, 117, 118, 116, 119, 120, 121,
+ * 137, 138, 139, 143, 144, 145, 149, 150, 151, 155,
+ * 156, 157, 0, 0, 36*0/
+c-------------------------------------------------------------------------------
+
+ integer istatus
+ character*3 code1,code2
+ parameter (ncode=5,nidt=353)
+ integer idt(ncode,nidt)
+ double precision drangen,dummy
+
+c nxs|pdg|qgs|cor|sib
+ data ((idt(i,j),i=1,ncode),j= 1,70)/
+ * 1,2,99,99,99 !u quark
+ * , 2,1,99,99,99 !d
+ * , 3,3,99,99,99 !s
+ * , 4,4,99,99,99 !c
+ * , 5,5,99,99,99 !b
+ * , 6,6,99,99,99 !t
+ * , 10,22,99,1,1 !gamma
+ * , 9 ,21,99,99,99 !gluon
+ * , 12,11,11,3,3 !e-
+ * , -12,-11,-11,2,2 !e+
+ * , 11,12,99,66,15 !nu_e-
+ * , -11,-12,99,67,16 !nu_e+
+ * , 14,13,99,6,5 !mu-
+ * , -14,-13,99,5,4 !mu+
+ * , 13,14,99,68,17 !nu_mu-
+ * , -13,-14,99,69,18 !nu_mu+
+ * , 16,15,99,132,19 !tau-
+ * , -16,-15,99,131,-19 !tau+
+ * , 15,16,99,133,20 !nu_tau-
+ * , -15,-16,99,134,-20 !nu_tau+
+ * , 110,111,0,7,6 !pi0
+ * , 120,211,1,8,7 !pi+
+ * , -120,-211,-1,9,8 !pi-
+ * , 220,221,10,17,23 !eta
+ * , 130,321,4,11,9 !k+
+ * , -130,-321,-4,12,10 !k-
+ * , 230,311,5,33,21 !k0
+ * , -230,-311,-5,34,22 !k0b
+ * , 20,310,5,16,12 !kshort
+ * , -20,130,-5,10,11 !klong
+ * , 330,331,99,99,24 !etaprime
+ * , 111,113,19,51,27 !rho0 (=-10 in QII (See below))
+ * , 121,213,99,52,25 !rho+
+ * , -121,-213,99,53,26 !rho-
+ * , 221,223,99,50,32 !omega
+ * , 131,323,99,63,28 !k*+
+ * , -131,-323,99,64,29 !k*-
+ * , 231,313,99,62,30 !k*0
+ * , -231,-313,99,65,31 !k*0b
+ * , 331,333,99,99,33 !phi
+ * , -140,421,8,116,71 !D0(1.864)
+ * , 140,-421,8,119,72 !D0b(1.864)
+ * , -240,411,7,117,59 !D(1.869)+
+ * , 240,-411,7,118,60 !Db(1.869)-
+ * , 1120,2212,2,14,13 !proton
+ * , 1220,2112,3,13,14 !neutron
+ * , 2130,3122,6,18,39 !lambda
+ * , 1130,3222,99,19,34 !sigma+
+ * , 1230,3212,99,20,35 !sigma0
+ * , 2230,3112,99,21,36 !sigma-
+ * , 1330,3322,99,22,37 !xi0
+ * , 2330,3312,99,23,38 !xi-
+ * , 1111,2224,99,54,40 !delta++
+ * , 1121,2214,99,55,41 !delta+
+ * , 1221,2114,99,56,42 !delta0
+ * , 2221,1114,99,57,43 !delta-
+ * , 1131,3224,99,99,44 !sigma*+
+ * , 1231,3214,99,99,45 !sigma*0
+ * , 2231,3114,99,99,46 !sigma*-
+ * , 1331, 3324,99,99,47 !xi*0
+ * , 2331, 3314,99,99,48 !xi*-
+ * , 3331, 3334,99,24,49 !omega-
+ * , 2140, 4122,9,137,89 !LambdaC(2.285)+
+ * ,17,1000010020,99,201,1002 !Deuteron
+ * ,18,1000010030,99,301,1003 !Triton
+ * ,19,1000020040,99,402,1004 !Alpha
+ * ,0,0,99,0,0 !Air
+ $ ,41,99,99,41,99 !QBall
+ $ ,43,99,99,43,99 !Monopole
+ * ,99,99,99,99,100 / !unknown
+ data ((idt(i,j),i=1,ncode),j= 71,91)/
+ $ -340,431,99,120,74 ! Ds+
+ $ ,340,-431,99,121,75 ! Ds-
+ $ ,-241,413,99,124,78 ! D*+
+ $ ,241,-413,99,125,79 ! D*-
+ $ ,-141,423,99,123,80 ! D*0
+ $ ,141,-423,99,126,81 ! D*0b
+ $ ,-341,433,99,127,76 ! Ds*+
+ $ ,341,-433,99,128,77 ! Ds*-
+ $ ,440,441,99,122,73 ! etac
+ $ ,441,443,99,130,83 ! J/psi
+ $ ,2240,4112,99,142,86 ! sigmac0
+ $ ,1240,4212,99,141,85 ! sigmac+
+ $ ,1140,4222,99,140,84 ! sigmac++
+ $ ,2241,4114,99,163,96 ! sigma*c0
+ $ ,1241,4214,99,162,95 ! sigma*c+
+ $ ,1141,4224,99,161,94 ! sigma*c++
+ $ ,3240,4132,99,139,88 ! Xic0
+ $ ,2340,4312,99,144,98 ! Xi'c0
+ $ ,3140,4232,99,138,87 ! Xic+
+ $ ,1340,4322,99,143,97 ! Xi'c+
+ $ ,3340,4332,99,145,99 / ! omegac0
+ data ((idt(i,j),i=1,ncode),j= 92,nidt)/
+ $ 1112,32224,99,99,99 ! Delta(1600)++
+ $ , 1112, 2222,99,99,99 ! Delta(1620)++
+ $ , 1113,12224,99,99,99 ! Delta(1700)++
+ $ , 1114,12222,99,99,99 ! Delta(1900)++
+ $ , 1114, 2226,99,99,99 ! Delta(1905)++
+ $ , 1114,22222,99,99,99 ! Delta(1910)++
+ $ , 1114,22224,99,99,99 ! Delta(1920)++
+ $ , 1114,12226,99,99,99 ! Delta(1930)++
+ $ , 1114, 2228,99,99,99 ! Delta(1950)++
+ $ , 2222,31114,99,99,99 ! Delta(1600)-
+ $ , 2222, 1112,99,99,99 ! Delta(1620)-
+ $ , 2223,11114,99,99,99 ! Delta(1700)-
+ $ , 2224,11112,99,99,99 ! Delta(1900)-
+ $ , 2224, 1116,99,99,99 ! Delta(1905)-
+ $ , 2224,21112,99,99,99 ! Delta(1910)-
+ $ ,2224,21114,99,99,99 ! Delta(1920)-
+ $ ,2224,11116,99,99,99 ! Delta(1930)-
+ $ ,2224, 1118,99,99,99 ! Delta(1950)-
+ $ ,1122,12212,99,99,51 ! N(1440)+
+ $ ,1123, 2124,99,99,99 ! N(1520)+
+ $ ,1123,22212,99,99,99 ! N(1535)+
+ $ ,1124,32214,99,99,99 ! Delta(1600)+
+ $ ,1124, 2122,99,99,99 ! Delta(1620)+
+ $ ,1125,32212,99,99,99 ! N(1650)+
+ $ ,1125, 2216,99,99,99 ! N(1675)+
+ $ ,1125,12216,99,99,99 ! N(1680)+
+ $ ,1126,12214,99,99,99 ! Delta(1700)+
+ $ ,1127,22124,99,99,99 ! N(1700)+
+ $ ,1127,42212,99,99,53 ! N(1710)+
+ $ ,1127,32124,99,99,99 ! N(1720)+
+ $ ,1128,12122,99,99,99 ! Delta(1900)+
+ $ ,1128, 2126,99,99,99 ! Delta(1905)+
+ $ ,1128,22122,99,99,99 ! Delta(1910)+
+ $ ,1128,22214,99,99,99 ! Delta(1920)+
+ $ ,1128,12126,99,99,99 ! Delta(1930)+
+ $ ,1128, 2218,99,99,99 ! Delta(1950)+
+ $ ,1222,12112,99,99,52 ! N(1440)0
+ $ ,1223, 1214,99,99,99 ! N(1520)0
+ $ ,1223,22112,99,99,99 ! N(1535)0
+ $ ,1224,32114,99,99,99 ! Delta(1600)0
+ $ ,1224, 1212,99,99,99 ! Delta(1620)0
+ $ ,1225,32112,99,99,99 ! N(1650)0
+ $ ,1225, 2116,99,99,99 ! N(1675)0
+ $ ,1225,12116,99,99,99 ! N(1680)0
+ $ ,1226,12114,99,99,99 ! Delta(1700)0
+ $ ,1227,21214,99,99,99 ! N(1700)0
+ $ ,1227,42112,99,99,54 ! N(1710)0
+ $ ,1227,31214,99,99,99 ! N(1720)0
+ $ ,1228,11212,99,99,99 ! Delta(1900)0
+ $ ,1228, 1216,99,99,99 ! Delta(1905)0
+ $ ,1228,21212,99,99,99 ! Delta(1910)0
+ $ ,1228,22114,99,99,99 ! Delta(1920)0
+ $ ,1228,11216,99,99,99 ! Delta(1930)0
+ $ ,1228, 2118,99,99,99 ! Delta(1950)0
+ $ ,1233,13122,99,99,99 ! Lambda(1405)0
+ $ ,1234, 3124,99,99,99 ! Lambda(1520)0
+ $ ,1235,23122,99,99,99 ! Lambda(1600)0
+ $ ,1235,33122,99,99,99 ! Lambda(1670)0
+ $ ,1235,13124,99,99,99 ! Lambda(1690)0
+ $ ,1236,13212,99,99,99 ! Sigma(1660)0
+ $ ,1236,13214,99,99,99 ! Sigma(1670)0
+ $ ,1237,23212,99,99,99 ! Sigma(1750)0
+ $ ,1237, 3216,99,99,99 ! Sigma(1775)0
+ $ ,1238,43122,99,99,99 ! Lambda(1800)0
+ $ ,1238,53122,99,99,99 ! Lambda(1810)0
+ $ ,1238, 3126,99,99,99 ! Lambda(1820)0
+ $ ,1238,13126,99,99,99 ! Lambda(1830)0
+ $ ,1238,23124,99,99,99 ! Lambda(1890)0
+ $ ,1239,13216,99,99,99 ! Sigma(1915)0
+ $ ,1239,23214,99,99,99 ! Sigma(1940)0
+ $ ,1132,13222,99,99,99 ! Sigma(1660)+
+ $ ,1132,13224,99,99,99 ! Sigma(1670)+
+ $ ,1133,23222,99,99,99 ! Sigma(1750)+
+ $ ,1133,3226,99,99,99 ! Sigma(1775)+
+ $ ,1134,13226,99,99,99 ! Sigma(1915)+
+ $ ,1134,23224,99,99,99 ! Sigma(1940)+
+ $ ,2232,13112,99,99,99 ! Sigma(1660)-
+ $ ,2232,13114,99,99,99 ! Sigma(1670)-
+ $ ,2233,23112,99,99,99 ! Sigma(1750)-
+ $ ,2233,3116,99,99,99 ! Sigma(1775)-
+ $ ,2234,13116,99,99,99 ! Sigma(1915)-
+ $ ,2234,23114,99,99,99 ! Sigma(1940)-
+ $ ,5,7,99,99,99 ! quark b'
+ $ ,6,8,99,99,99 ! quark t'
+ $ ,16,17,99,99,99 ! lepton tau'
+ $ ,15,18,99,99,99 ! lepton nu' tau
+ $ ,90,23,99,99,99 ! Z0
+ $ ,80,24,99,99,99 ! W+
+ $ ,81,25,99,99,99 ! h0
+ $ ,85,32,99,99,99 ! Z'0
+ $ ,86,33,99,99,99 ! Z''0
+ $ ,87,34,99,99,99 ! W'+
+ $ ,82,35,99,99,99 ! H0
+ $ ,83,36,99,99,99 ! A0
+ $ ,84,37,99,99,99 ! H+
+ $ ,1200,2101,99,99,99 ! diquark ud_0
+ $ ,2300,3101,99,99,99 ! diquark sd_0
+ $ ,1300,3201,99,99,99 ! diquark su_0
+ $ ,2400,4101,99,99,99 ! diquark cd_0
+ $ ,1400,4201,99,99,99 ! diquark cu_0
+ $ ,3400,4301,99,99,99 ! diquark cs_0
+ $ ,2500,5101,99,99,99 ! diquark bd_0
+ $ ,1500,5201,99,99,99 ! diquark bu_0
+ $ ,3500,5301,99,99,99 ! diquark bs_0
+ $ ,4500,5401,99,99,99 ! diquark bc_0
+ $ ,2200,1103,99,99,99 ! diquark dd_1
+ $ ,1200,2103,99,99,99 ! diquark ud_1
+ $ ,1100,2203,99,99,99 ! diquark uu_1
+ $ ,2300,3103,99,99,99 ! diquark sd_1
+ $ ,1300,3203,99,99,99 ! diquark su_1
+ $ ,3300,3303,99,99,99 ! diquark ss_1
+ $ ,2400,4103,99,99,99 ! diquark cd_1
+ $ ,1400,4203,99,99,99 ! diquark cu_1
+ $ ,3400,4303,99,99,99 ! diquark cs_1
+ $ ,4400,4403,99,99,99 ! diquark cc_1
+ $ ,2500,5103,99,99,99 ! diquark bd_1
+ $ ,1500,5203,99,99,99 ! diquark bu_1
+ $ ,3500,5303,99,99,99 ! diquark bs_1
+ $ ,4500,5403,99,99,99 ! diquark bc_1
+ $ ,5500,5503,99,99,99 ! diquark bb_1
+ $ ,800000088,88,99,99,99 ! string junction (pythia)
+ $ ,800099999,99999,99,99,99 ! string (dmpjet)
+ $ ,800000090,90,99,99,99 ! string (phojet)
+ $ ,800000091,91,99,99,99 ! parton system in cluster fragmentation (pythia)
+ $ ,800000092,92,99,99,99 ! parton system in string fragmentation (pythia)
+ $ ,800000093,93,99,99,99 ! parton system in independent system (pythia)
+ $ ,800000094,94,99,99,99 ! CMshower (pythia)
+ $ ,250,511,99,99,99 ! B0
+ $ ,150,521,99,99,99 ! B+
+ $ ,350,531,99,99,99 ! B0s+
+ $ ,450,541,99,99,99 ! Bc+
+ $ ,251,513,99,99,99 ! B*0
+ $ ,151,523,99,99,99 ! B*+
+ $ ,351,533,99,99,99 ! B*0s+
+ $ ,451,543,99,99,99 ! B*c+
+ $ ,550,551,99,99,99 ! etab
+ $ ,551,553,99,99,99 ! Upsilon
+ $ ,2341,4314,99,99,99 ! Xi*c0(2645)
+ $ ,1341,4324,99,99,99 ! Xi*c+(2645)
+ $ ,3341,4334,99,99,99 ! omega*c0
+ $ ,2440,4412,99,99,99 ! dcc
+ $ ,2441,4414,99,99,99 ! dcc*
+ $ ,1440,4422,99,99,99 ! ucc
+ $ ,1441,4424,99,99,99 ! ucc*
+ $ ,3440,4432,99,99,99 ! scc
+ $ ,3441,4434,99,99,99 ! scc*
+ $ ,4441,4444,99,99,99 ! ccc*
+ $ ,2250,5112,99,99,99 ! sigmab-
+ $ ,2150,5122,99,99,99 ! lambdab0
+ $ ,3250,5132,99,99,99 ! sdb
+ $ ,4250,5142,99,99,99 ! cdb
+ $ ,1250,5212,99,99,99 ! sigmab0
+ $ ,1150,5222,99,99,99 ! sigmab+
+ $ ,3150,5232,99,99,99 ! sub
+ $ ,4150,5242,99,99,99 ! cub
+ $ ,2350,5312,99,99,99 ! dsb
+ $ ,1350,5322,99,99,99 ! usb
+ $ ,3350,5332,99,99,99 ! ssb
+ $ ,4350,5342,99,99,99 ! csb
+ $ ,2450,5412,99,99,99 ! dcb
+ $ ,1450,5422,99,99,99 ! ucb
+ $ ,3450,5432,99,99,99 ! scb
+ $ ,4450,5442,99,99,99 ! ccb
+ $ ,2550,5512,99,99,99 ! dbb
+ $ ,1550,5522,99,99,99 ! ubb
+ $ ,3550,5532,99,99,99 ! sbb
+ $ ,3550,5542,99,99,99 ! scb
+ $ ,2251,5114,99,99,99 ! sigma*b-
+ $ ,1251,5214,99,99,99 ! sigma*b0
+ $ ,1151,5224,99,99,99 ! sigma*b+
+ $ ,2351,5314,99,99,99 ! dsb*
+ $ ,1351,5324,99,99,99 ! usb*
+ $ ,3351,5334,99,99,99 ! ssb*
+ $ ,2451,5414,99,99,99 ! dcb*
+ $ ,1451,5424,99,99,99 ! ucb*
+ $ ,3451,5434,99,99,99 ! scb*
+ $ ,4451,5444,99,99,99 ! ccb*
+ $ ,2551,5514,99,99,99 ! dbb*
+ $ ,1551,5524,99,99,99 ! ubb*
+ $ ,3551,5534,99,99,99 ! sbb*
+ $ ,4551,5544,99,99,99 ! cbb*
+ $ ,5551,5554,99,99,99 ! bbb*
+ $ ,123,10213,99,99,99 ! b_1+
+ $ ,122,10211,99,99,62 ! a_0+
+ $ ,-122,-10211,99,99,63 ! a_0-
+ $ ,232,10311,99,99,66 ! K*0_1
+ $ ,-232,-10311,99,99,67 ! K*0b_1
+ $ ,132,10321,99,99,64 ! K*+_1
+ $ ,-132,-10321,99,99,65 ! K*-_1
+ $ ,143,10423,99,99,99 ! D0_1
+ $ ,142,10421,99,99,99 ! D*0_1
+ $ ,243,10413,99,99,99 ! D+_1
+ $ ,242,10411,99,99,99 ! D*+_1
+ $ ,343,10433,99,99,99 ! D+s_1
+ $ ,342,10431,99,99,99 ! D*0s+_1
+ $ ,113,10113,99,99,99 ! b_10
+ $ ,112,10111,99,99,61 ! a_00
+ $ ,443,10443,99,99,99 ! h_1c0
+ $ ,442,10441,99,99,99 ! Xi_0c0
+ $ ,444,10443,99,99,99 ! psi'
+ $ ,253,10513,99,99,99 ! db_10
+ $ ,252,10511,99,99,99 ! db*_00
+ $ ,153,10523,99,99,99 ! ub_10
+ $ ,152,10521,99,99,99 ! ub*_00
+ $ ,353,10533,99,99,99 ! sb_10
+ $ ,352,10531,99,99,99 ! sb*_00
+ $ ,453,10543,99,99,99 ! cb_10
+ $ ,452,10541,99,99,99 ! cb*_00
+ $ ,553,10553,99,99,99 ! Upsilon'
+ $ ,552,10551,99,99,99 ! Upsilon'*
+ $ ,124,20213,99,99,99 ! a_1+
+ $ ,125,215,99,99,99 ! a_2+
+ $ ,126,10215,99,99,99 ! pi_2+(1670)
+ $ ,127,217,99,99,99 ! rho_3+(1690)
+ $ ,232,20313,99,99,99 ! K*0_1(1400)
+ $ ,233,315,99,99,99 ! K*0_2(1430)
+ $ ,234,10311,99,99,99 ! K*0_0(1430)
+ $ ,132,20323,99,99,99 ! K*+_1(1400)
+ $ ,133,325,99,99,99 ! K*+_2(1430)
+ $ ,134,10321,99,99,99 ! K*+_0(1430)
+ $ ,144,20423,99,99,99 ! D*_10
+ $ ,145,425,99,99,99 ! D*_20
+ $ ,244,20413,99,99,99 ! D*_1+
+ $ ,245,415,99,99,99 ! D*_2+
+ $ ,344,20433,99,99,99 ! D*_1s+
+ $ ,345,435,99,99,99 ! D*_2s+
+ $ ,114,20113,99,99,99 ! a_10
+ $ ,115,115,99,99,99 ! a_20
+ $ ,116,10115,99,99,99 ! pi_20(1670)
+ $ ,117,117,99,99,99 ! rho_30(1690)
+ $ ,222,9010221,99,99,99 ! f_00(980)
+ $ ,223,10223,99,99,99 ! h_10(1170)
+ $ ,224,225,99,99,99 ! f_20(1270)
+ $ ,225,20223,99,99,99 ! f_10(1285)
+ $ ,226,9030221,99,99,99 ! f_00(1500)
+ $ ,332,20333,99,99,99 ! f_10(1420)
+ $ ,333,335,99,99,99 ! f'_20(1525)
+ $ ,444,20443,99,99,99 ! Xi_1c0
+ $ ,445,445,99,99,99 ! Xi_2c0
+ $ ,254,20513,99,99,99 ! db*_10
+ $ ,255,515,99,99,99 ! db*_20
+ $ ,154,20523,99,99,99 ! ub*_10
+ $ ,155,525,99,99,99 ! ub*_20
+ $ ,354,20533,99,99,99 ! sb*_10
+ $ ,355,535,99,99,99 ! sb*_20
+ $ ,454,20543,99,99,99 ! cb*_10
+ $ ,455,545,99,99,99 ! cb*_20
+ $ ,554,20553,99,99,99 ! bb*_10
+ $ ,555,555,99,99,99 ! bb*_20
+ $ ,11099,9900110,99,99,99 ! diff pi0 state
+ $ ,12099,9900210,99,99,99 ! diff pi+ state
+ $ ,13099,9900320,99,99,99 ! diff K+ state
+ $ ,22099,9900220,99,99,99 ! diff omega state
+ $ ,2099,9900310,99,99,99 ! diff K0 state
+ $ ,-2099,9900130,99,99,99 ! diff pi+ state
+ $ ,33099,9900330,99,99,99 ! diff phi state
+ $ ,44099,9900440,99,99,99 ! diff J/psi state
+ $ ,112099,9902210,99,99,99 ! diff proton state
+ $ ,122099,9902110,99,99,99 ! diff neutron state
+ $ ,213099,9903120,99,99,99 ! diff lambda state
+ $ ,800000110,110,99,99,99 ! Reggeon
+ $ ,800000990,990,99,99,99 / ! Pomeron
+
+
+
+c print *,'idtrafo',' ',code1,' ',code2,idi
+ istatus=0
+ idtrafocx=0
+ nidtmx=68
+ id1=idi
+ if(code1.eq.'nxs')then
+ i=1
+ if(mod(id1,100).eq.0)then !nucleus from Werner code
+ if(id1.gt.0)then
+ idtrafocx=id1+int(dble(id1/100)/2.15d0+0.7d0)
+ else
+ idtrafocx=id1 !strangelet
+ endif
+ return
+ endif
+ elseif(code1.eq.'pdg')then
+ i=2
+ elseif(code1.eq.'qgs')then
+ i=3
+ if(id1.eq.-10)id1=19
+ elseif(code1.eq.'cor')then
+ i=4
+ elseif(code1.eq.'sib')then
+ i=5
+ elseif(code1.eq.'ghe')then
+ id1=ighenexs(id1)
+ i=1
+ elseif(code1.eq.'flk')then
+ id1=IFCTABL(id1) !convert to corsika code
+ i=4
+ else
+ stop "unknown code in idtrafocx"
+ endif
+ if(code2.eq.'nxs')then
+ j=1
+ ji=j
+ if(i.eq.2.and.id1.gt.1000000000)then !nucleus from PDG
+ idtrafocx=mod(id1,10000)*10
+ return
+ elseif(i.eq.4.and.id1.gt.402)then !nucleus from Corsika
+ idtrafocx=id1/100 !remove Z information
+ idtrafocx=idtrafocx*100
+ return
+ elseif(i.eq.5.and.id1.gt.1004)then !nucleus from Sibyll
+ idtrafocx=(id1-1000)*100
+ return
+ elseif(id1.eq.130.and.i.eq.2)then
+ idtrafocx=-20
+ return
+ endif
+ if(i.eq.2) nidtmx=nidt
+ if(i.eq.4) nidtmx=89
+ if(i.eq.5) nidtmx=nidt ! maximal reach in conversion table
+ elseif(code2.eq.'pdg')then
+ j=2
+ ji=j
+ if(i.eq.1.and.id1.gt.1000000000)then !nucleus from EPOS
+ idtrafocx=id1
+ return
+ elseif(i.eq.1.and.id1.gt.100.and.mod(id1,100).eq.0)then !nucleus from CONEX
+ id1=id1/100
+ idtrafocx=1000000000+int(dble(id1)/2.15d0+0.7d0)*10000+id1*10!charge is approximative
+ return
+ elseif(i.eq.4.and.id1.gt.402)then !nucleus from Corsika
+ idtrafocx=1000000000+mod(id1,100)*10000+(id1/100)*10
+ return
+ elseif(i.eq.5.and.id1.gt.1004)then !nucleus from Sibyll
+ id1=(id1-1000)
+ idtrafocx=1000000000+id1/2*10000+id1*10
+ return
+ elseif(id1.eq.-20.and.i.eq.1)then
+ idtrafocx=130
+ return
+ endif
+ if(i.eq.1) nidtmx=nidt
+ if(i.eq.4) nidtmx=89
+ elseif(code2.eq.'qgs')then
+ j=3
+ ji=j
+ elseif(code2.eq.'cor')then
+ j=4
+ ji=j
+ elseif(code2.eq.'sib')then
+ j=5
+ ji=j
+ elseif(code2.eq.'ghe')then
+ j=4
+ ji=6
+ elseif(code2.eq.'flk')then
+ j=4
+ ji=7
+ if(i.le.2) nidtmx=89
+ else
+ stop "unknown code in idtrafocx"
+ endif
+ if(i.eq.4)then !corsika id always >0 so convert antiparticles
+ iadtr=id1
+ if(iadtr.eq.25)then
+ id1=-13
+ elseif(iadtr.eq.15)then
+ id1=-14
+ elseif(iadtr.ge.26.and.iadtr.le.32)then
+ id1=-iadtr+8
+ elseif(iadtr.ge.58.and.iadtr.le.61)then
+ id1=-iadtr+4
+ elseif(iadtr.ge.149.and.iadtr.le.157)then
+ id1=-iadtr+12
+ elseif(iadtr.ge.171.and.iadtr.le.173)then
+ id1=-iadtr+10
+ endif
+ endif
+ iad1=abs(id1)
+ isi=sign(1,id1)
+
+ if(i.ne.j)then
+ do n=1,nidtmx
+ if(iad1.eq.abs(idt(i,n)))then
+ m=1
+ if(n+m.lt.nidt)then
+ do while(abs(idt(i,n+m)).eq.iad1)
+ m=m+1
+ enddo
+ endif
+ mm=0
+ if(m.gt.1)then
+ if(m.eq.2.and.idt(i,n)*idt(i,n+1).lt.0)then
+ if(id1.eq.idt(i,n+1))mm=1
+ isi=1
+ else
+ mm=int(drangen(dummy)*dble(m))
+ endif
+ else !m=0 only one line, take care of sign
+ if(idt(i,n).lt.0)isi=-isi
+ endif
+ idtrafocx=idt(j,n+mm)*isi
+ if(abs(idtrafocx).eq.99)then
+ write(*,*)'Idtrafocx : ',code1,' ',code2,idi
+ stop'New particle not allowed '
+ endif
+ if(idtrafocx.lt.0.and.j.eq.4)then !corsika id always >0
+ iadtr=abs(idtrafocx)
+ if(iadtr.eq.13)then
+ idtrafocx=25
+ elseif(iadtr.eq.14)then
+ idtrafocx=15
+ elseif(iadtr.ge.18.and.iadtr.le.24)then
+ idtrafocx=iadtr+8
+ elseif(iadtr.ge.54.and.iadtr.le.57)then
+ idtrafocx=iadtr+4
+ elseif(iadtr.ge.137.and.iadtr.le.145)then
+ idtrafocx=iadtr+12
+ elseif(iadtr.ge.161.and.iadtr.le.163)then
+ idtrafocx=iadtr+10
+ else
+ idtrafocx=iadtr
+ endif
+ elseif(idtrafocx.eq.19.and.j.eq.3)then
+ idtrafocx=-10
+ endif
+ if(j.ne.ji)goto 100
+ return
+ endif
+ enddo
+ else
+ idtrafocx=id1
+ if(j.ne.ji)goto 100
+ return
+ endif
+
+ istatus=1
+c idtrafocx=0
+ return
+
+ 100 if(j.eq.4)then !corsika
+ if(idtrafocx.eq.201)then
+ idtrafocx=45
+ elseif(idtrafocx.eq.301)then
+ idtrafocx=46
+ elseif(idtrafocx.eq.402)then
+ idtrafocx=47
+ elseif(idtrafocx.eq.302)then
+ idtrafocx=48
+ endif
+ if(idtrafocx.ne.0)then !air
+ if(ji.eq.6)then
+ idtrafocx=kipart(idtrafocx)
+ elseif(ji.eq.7)then
+ idtrafocx=ICFTABL(idtrafocx)
+ endif
+ endif
+ return
+ else
+ stop'Should not happen in idtrafocx !'
+ endif
+
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine cxiclass(id,icl)
+c-----------------------------------------------------------------------
+c determines hadron class
+c (note : here we use nexus code which is the same as QGSjet code for
+c pion(icl=1), nucleon(icl=2) and kaon(icl=3). Higher icl are
+c not used in Conex and are different in Nexus (icl=4 for jpsi
+c (id=441)) and QGSJet (icl=4 for D-meson (id=240) and icl=5
+c for Lambda-C (id=2140)).)
+c-----------------------------------------------------------------------
+ ida=iabs(id)
+ if(ida.eq.0.or.(ida.ge.17.and.ida.le.19))then
+ icl=2
+ elseif(ida.eq.130.or.ida.eq.230.or.ida.eq.20)then
+ icl=3
+ elseif(ida.ge.100.and.ida.le.999)then
+ icl=1
+ elseif(ida.ge.1000.and.ida.le.9999)then
+ icl=2
+ else
+ stop'iclass: id not known'
+ endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxainit
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+#ifdef __CXDEBUG__
+ call utisx1('cxainit ',6)
+#endif
+
+ ntevtxs=0
+
+ n1sttr=0
+ if(lxfirstin.and.XfirstIn.gt.0d0)then
+ n1sttr=nint(XfirstIn)
+ XfirstIn=-1d0 !reinitize value
+ endif
+
+ if(n1sttr.ne.0)then !fix first interaction target
+ idtargxs=1120
+ if(n1sttr.eq.1)then
+ latargxs=7
+ matargxs=14
+ elseif(n1sttr.eq.2)then
+ latargxs=8
+ matargxs=16
+ elseif(n1sttr.eq.3)then
+ latargxs=18
+ matargxs=40
+ else
+ stop"incorrect value of n1sttr in cxainit"
+ endif
+ else
+ idtargxs=0 !air (for sibyll)
+ call cxgetairmol(latargxs,matargxs)
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*)'Air Target, select (Z,A) :'
+ & ,latargxs,matargxs
+#endif
+
+ call cxidmass(idprojxs,xsamproj)
+ call cxidmass(idtargxs,xsamtarg)
+ ifirstghe=0
+ 101 continue
+ xspnll=sqrt(max(0.d0,xselab**2-xsamproj**2))
+ xsengy=sqrt( 2*xselab*xsamtarg+xsamtarg**2+xsamproj**2 )
+ xsecms=xsengy
+ xsekin=xselab-xsamproj
+
+ if((modelxs.eq.3.or.modelxs.eq.7).and.ifirstghe.eq.0)then !Gheisha(FLUKA): det, trit and alp
+ if(maprojxs.eq.2.and.laprojxs.eq.1)idprojxs=17
+ if(maprojxs.eq.3.and.laprojxs.eq.1)idprojxs=18
+ if(maprojxs.eq.4.and.laprojxs.eq.2)idprojxs=19
+ if(idprojxs.ge.17.and.idprojxs.le.19)then
+ xselab=xselab*maprojxs
+ call cxidmass(idprojxs,xsamproj)
+ maprojxs=1
+ laprojxs=-1
+ ifirstghe=1
+ goto 101
+ endif
+ endif
+
+c write(ifck,*)'min e:',xsekin,xsegymin
+ if(xsekin.lt.xsegymin)then
+ print *,xsekin,xsegymin,idprojxs,xselab,modelxs,dptl
+ stop'cxainit: energy too low'
+ endif
+ if(xsekin.gt.xsegymax)stop'cxainit: energy too high'
+ s=xsengy**2
+ xspnullx=cxutpcm(xsengy,xsamproj,xsamtarg)
+ xsyhaha=log((sqrt(xspnll**2+s)+xspnll)/sqrt(s))
+ xsypjtl=log((sqrt(xspnll**2+xsamproj**2)+xspnll)/xsamproj)
+
+ xsdetap=(xsypjtl-xsyhaha)
+ xsdetat=-xsyhaha
+ xstpro=dcosh(xsdetap)
+ xszpro=dsinh(xsdetap)
+ xsttar=dcosh(xsdetat)
+ xsztar=dsinh(xsdetat)
+
+ fctrmx=10.d0
+ facnuc=0.d0
+
+ if(maprojxs.gt.1)then
+ rpj=1.19d0*maprojxs**(1.d0/3.d0)-1.61d0*maprojxs**(-1.d0/3.d0)
+ xsrmproj=rpj+fctrmx*.54d0
+ xsrcproj=rpj/cosh(xsyhaha)*facnuc
+ else
+ xsrmproj=0
+ xsrcproj=0.8d0/cosh(xsyhaha)*facnuc
+ endif
+ if(matargxs.gt.1)then
+ rtg=1.19d0*matargxs**(1.d0/3.d0)-1.61d0*matargxs**(-1.d0/3.d0)
+ xsrmtarg=rtg+fctrmx*.54d0
+ xsrctarg=rtg/cosh(xsyhaha)*facnuc
+ else
+ xsrmtarg=0
+ xsrctarg=0.8d0/cosh(xsyhaha)*facnuc
+ endif
+
+c additional initialization procedure
+
+ call IniEvtModel(modelxs)
+
+
+ if(idtargxs.eq.0)idtargxs=1120 !air = nucleus
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+
+ return
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine cxgetairmol(iz,ia)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air (Sibyll)
+ i=0
+ r=drangen(dble(i))
+ do while(r.gt.0.d0) ! choose air-molecule
+ i=i+1
+ if(MCmodel.eq.5)then
+ r=r-(1d0-FOX)
+ else
+ r=r-airw(i)
+ endif
+ enddo
+ iz = nint(airz(i))
+ ia = nint(aira(i))
+ end
+
+c-----------------------------------------------------------------------
+ double precision function cxutpcm(a,b,c)
+c-----------------------------------------------------------------------
+c calculates cm momentum for a-->b+c
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ val=(a*a-b*b-c*c)*(a*a-b*b-c*c)-(2.d0*b*c)*(2.d0*b*c)
+ if(val.lt.0..and.val.gt.-1e-4)then
+ cxutpcm=0
+ return
+ endif
+ cxutpcm=sqrt(val)/(2.d0*a)
+ return
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine cxanexus
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ call cxalist('start event&',0,0,0)
+ endif
+#endif
+
+ ntry=0
+ naevt=0
+ ntevt=ntevtxs
+ ntevt0=ntevt
+ ntevt=ntevt0
+ 2 ntevt=ntevt+1
+ iret=0
+ ntry=ntry+1
+ naevt=naevt+1
+ nevtxs=0
+ 3 nptlxs=0
+
+ if(ntry.lt.10000.and.xsekin.ge.xsegymin.and.iret.ge.0)then !if no inel scattering -> nothing !
+ call emsModel(modelxs,iret)
+ if(iret.gt.0)goto 2
+ if(iret.lt.0)goto 3
+ else !set initial particle as final one
+ if(iret.eq.0)ntevt=ntevt0+1
+ iret=0
+ nevtxs=1
+ ist=0
+ call cxconre
+ call cxconwr(ist)
+#ifdef __CXDEBUG__
+ if(isx.ge.4)
+ & write(ifck,*)'Elastic scattering (no interaction) !'
+#endif
+ endif
+
+ if(nevtxs.eq.0)stop'************ should not be ***************'
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)call cxalist('cxanexus&',1,nptlxs,1)
+#endif
+
+ if(modelxs.eq.2.or.modelxs.eq.6)then !if qgsjet (can not be in nexus or Sibyll and not enought info from gheisha)
+
+c Energy and baryon conservation (if violated)
+ Etot=0.d0
+ P3tot=0.d0
+ Etotini=0.d0
+ P3ini=0.d0
+ do j=1,iabs(maprojxs)+iabs(matargxs)
+ EtotIni=EtotIni+xsptl(4,j)
+ P3Ini=P3Ini+xsptl(3,j)
+ enddo
+ numbar=0
+ do j=1,nptlxs
+ if(istptlxs(j).eq.0)then
+ Etot=Etot+xsptl(4,j)
+ P3tot=P3tot+xsptl(3,j)
+ if(idptlxs(j).gt. 1000.and.idptlxs(j).lt. 10000)then
+ if(mod(idptlxs(j),100).eq.0)then
+ numbar=numbar+abs(idptlxs(j))/100
+ else
+ numbar=numbar+1
+ endif
+ elseif(mod(idptlxs(j),100).eq.0)then
+ numbar=numbar+abs(idptlxs(j))/100
+ elseif(idptlxs(j).eq.17)then
+ numbar=numbar+2
+ elseif(idptlxs(j).eq.18)then
+ numbar=numbar+3
+ elseif(idptlxs(j).eq.19)then
+ numbar=numbar+4
+ endif
+ if(idptlxs(j).lt.-1000.and.idptlxs(j).gt.-10000)numbar=numbar-1
+ endif
+ enddo
+ nvio=isign(matargxs,idtargxs)-numbar
+ if(iabs(idprojxs).gt.1000)nvio=nvio+isign(maprojxs,idprojxs)
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ write (ifck,*)'- Baryon number conservation : '
+ & ,nvio,' -'
+
+ endif
+#endif
+
+c If missing baryon and energy, add baryons by sharing energy
+c (possibly missing projectile fragments)
+ Ediff=EtotIni-Etot
+ if(nvio.gt.0.and.Ediff.gt.dble(nvio))then
+ Pdiff=P3Ini-P3tot
+#ifdef __CXDEBUG__
+ if(isx.ge.6)
+ & write (ifck,*)'-> missing baryon and energy : ',nvio,Ediff
+ & ,Pdiff
+#endif
+ jmax=nvio
+ Enew=Ediff/dble(nvio)
+ do j=1,jmax
+ nptlxs=nptlxs+1
+ id=1120
+ id=id+100*nint(drangen(dble(j)))
+ call cxidmass(id,am)
+ Pnew=sqrt((Enew+am)*(Enew-am))
+ if(Pdiff.gt.am)then
+ P3sign=Pnew
+ else
+ P3sign=-Pnew
+ endif
+ Pdiff=Pdiff-P3sign
+ xsptl(1,nptlxs)=0.d0 !P_x
+ xsptl(2,nptlxs)=0.d0 !P_y
+ xsptl(3,nptlxs)=P3sign !P_z
+ xsptl(4,nptlxs)=Enew !E
+ xsptl(5,nptlxs)=am !mass
+ istptlxs(nptlxs)=0
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ write (ifck,*)'- new Fragment : '
+ & ,nptlxs,' - with id, E and sign(Pz) :',id,Enew,P3sign
+
+ endif
+#endif
+ enddo
+ endif
+
+ endif
+
+
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxafinal
+c-----------------------------------------------------------------------
+c does some final calculations.
+c Last modification : 12.04.05 : discard particles with E<0
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#ifdef CONEX_EXTENSIONS
+ common/cxNnucleon/aNbrNucl
+ common/cossins/s0xs,c0xs,s0s,c0s ! need to save these...
+#endif
+#include "conex.h"
+#include "conex.incnex"
+#if __COAST__
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+c definition of the COAST crs::CInteraction class
+ COMMON/coastInteraction/coastX, coastY, coastZ,
+ & coastE, coastCX, coastEl, coastProjId, coastTargId
+ double precision coastX, coastY, coastZ
+ double precision coastE, coastCX, coastEl
+ integer coastProjId, coastTargId
+#endif
+ logical boost
+#ifdef LEADING_INTERACTIONS_TREE
+ integer multxs
+ multxs=0
+#endif
+ boost=iframexs.ne.0
+
+ Etot=0.d0
+ Emax=0.d0
+c first loop: check and boost particles
+ do i=1,nptlxs
+ if(idptlxs(i).ne.0.and.istptlxs(i).le.1)then
+ if( xsptl(5,i).le.xsainfin.and.xsptl(5,i).ge.0.d0
+ * .and.abs(xsptl(1,i)).le.xsainfin
+ * .and.abs(xsptl(2,i)).le.xsainfin
+ * .and.abs(xsptl(3,i)).le.xsainfin
+ * .and.xsptl(4,i).gt.0.d0)then
+ if(boost)then
+ call cxutlob5(-xsyhaha
+ * , xsptl(1,i), xsptl(2,i), xsptl(3,i), xsptl(4,i), xsptl(5,i))
+ endif
+ else ! if something is wrong with 5-momentum
+#ifdef __CXDEBUG__
+ if(isx.ge.2)then
+ if(iorptlxs(i).gt.0)idior=idptlxs(iorptlxs(i))
+ write(*,1)i,idptlxs(i),idior,ityptlxs(i)
+ *,xsptl(1,i),xsptl(2,i),xsptl(3,i),xsptl(4,i),xsptl(5,i)
+ write(ifck,1)i,idptlxs(i),idior,ityptlxs(i)
+ *,xsptl(1,i),xsptl(2,i),xsptl(3,i),xsptl(4,i),xsptl(5,i)
+ 1 format('*** warning (cxafinal): ',i6,i10,i10,i3,1x,5(e8.1,1x))
+ endif
+#endif
+
+ call cxidmass(idptlxs(i),am)
+ xstivptl(1,i)=0.d0
+ xsorptl(1,i)=0.d0
+ xsorptl(2,i)=0.d0
+ xsorptl(3,i)=0.d0
+ xsorptl(4,i)=0.d0
+ xsptl(1,i)=0.d0
+ xsptl(2,i)=0.d0
+ xsptl(3,i)=0.d0
+ xsptl(4,i)=am
+ xsptl(5,i)=am
+
+ endif
+ endif
+ enddo
+
+
+
+#if CONEX_EXTENSIONS
+ if (modelxs.ne.5) then
+ call resampleCONEX(xsptl(1,1), xselab, idprojxs)
+ else ! SIBYLL
+ call resampleSibyllLab(xsptl(1,1),idnucrct(1),xselab,idprojxs)
+ endif
+#endif
+
+c now loop particles again to compute multiplicity, inelasticity etc.
+ do i=1,nptlxs
+
+ if(idptlxs(i).ne.0.and.istptlxs(i).eq.0)then
+
+ if (lxfirstIn.or.writeFirstIntPart.gt.0) then
+ Etot=Etot+xsptl(4,i)
+ Emax=max(Emax,xsptl(4,i))
+ endif
+
+! if(xstivptl(1,i).ne.0.d0)
+#ifdef LEADING_INTERACTIONS_TREE
+ if (leadingParticle.or.writeFirstIntPart.gt.0) then
+ multxs=multxs+1
+#ifdef LEADING_INTERACTIONS_CORSIKA
+ if(mod(idptlxs(i),100).ne.0)then !not a nucleus
+ idxs=idtrafocx("nxs","cor",idptlxs(i))
+ elseif(idptlxs(i).lt.0)then !strangelet
+ idxs=idptlxs(i)
+ else !nucleus
+ idxs=idptlxs(i)+int(dble(idptlxs(i)/100)/2.15d0+0.7d0)
+ endif
+#else
+ idxs=idptlxs(i)
+c LEADING_INTERACTIONS_CORSIKA
+#endif
+#ifdef CONEX_EXTENSIONS
+ if (writeFirstIntPart.gt.0) then
+ call write_particle_cx(interactionCounter,
+ * xsptl(1,1), i)
+ endif
+#endif
+ if (countInt.le.maxDetail) then
+ call outpart1(xsptl(4,i),idxs,xsptl(5,i),
+ * xsptl(1,i),xsptl(2,i),xsptl(3,i),ityptlxs(i),
+ * countInt)
+ endif
+ endif
+c LEADING_INTERACTIONS_TREE
+#endif
+ endif
+ enddo
+
+#ifdef CONEX_EXTENSIONS
+ if (writeFirstIntPart.gt.0) then
+ call write_projectile(interactionCounter, dptl, s0xs)
+ call write_interaction(interactionCounter, xselab,
+ + xsecms, Etot, idprojxs,
+ + matargxs, multxs)
+ endif
+#endif
+
+ ptlIntIn=0
+ if (Etot.gt.0.d0)then
+ ptlIntIn=1.d0-Emax/Etot
+ if (XfirstIn.lt.0.d0)XfirstIn=ptlIntIn
+ endif
+ if (isx.ge.5) then
+ write(ifck,*) 'cxafinal:ptlIntIn,Emax,Etot,X1In',
+ + ptlIntIn, Emax, Etot, XfirstIn
+ endif
+#ifdef LEADING_INTERACTIONS_TREE
+ if(leadingParticle) then
+ call outpart2(xsecms,ptlIntIn,multxs,matargxs,dptl(13),dptl(8))
+ countInt=countInt+1
+ leadingParticle=.false.
+ endif
+#endif
+ lxfirstIn=.false. !to be sure not to have it true later
+
+#if __COAST__
+ if(mod(idprojxs,100).ne.0)then !not a nucleus
+ coastProjId=-idtrafocx("nxs","cor",idprojxs)
+ else !nucleus
+ coastProjId=-idprojxs-int(dble(idprojxs/100)/2.15d0+0.7d0)
+ endif
+
+ coastTargId = matargxs
+#ifdef __CXCORSIKA__
+ coastX = dptl(7)*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ coastY = -dptl(6)*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+#else
+ coastX = dptl(6)*100d0 !(distance in cm in COAST)
+ coastY = dptl(7)*100d0 !(distance in cm in COAST)
+#endif
+ rdist=sqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7))
+ radh=dptl(8)+radearth
+ if(radh.gt.rdist)then
+ coastZ = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ coastZ = (coastZ-radearth)*100d0
+ else
+ coastZ = dptl(8)*100d0 !(distance in cm in COAST)
+ endif
+ coastE = dptl(4)
+ coastCX = Siginemb
+ coastEl = Emax/Etot
+ call interaction(coastX)
+#endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)call cxalist('cxafinal&',1,nptlxs,1)
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxlownuc
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+ nptlxs=0
+
+ iret=0
+ nevtxs=1
+ ist=0
+ call cxconre
+ call cxconwr(ist)
+#ifdef __CXDEBUG__
+ if(isx.ge.4)
+ & write(ifck,*)'Nucleus quasi-elastic !'
+
+ if(isx.ge.7)call cxalist('cxanexus&',1,nptlxs,1)
+#endif
+
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxhdecas(i,iret)
+c-----------------------------------------------------------------------
+c decay of object i (main decay routine)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ integer jcdu(nflavxs,2)
+
+ iret=0
+ nptlb=nptlxs
+ if(nptlxs.gt.mxptlxs-10)stop 'cxhdecax: mxptlxs too small'
+ if(abs(idptlxs(i)).eq.1120.or.abs(idptlxs(i)).eq.1220
+ & .or.idptlxs(i).eq.10.or.istptlxs(i).ne.0)goto 1000
+ if(mod(idptlxs(i),100).eq.0)goto 1000 !nuclei does not decay
+
+
+c ordinary decay
+
+ if(nrnodyxs.gt.0)then
+ do nod=1,nrnodyxs
+ if(idptlxs(i).eq.nodyxs(nod))goto 1000
+ enddo
+ endif
+
+ call cxhdecay(i,iret)
+ if(iret.eq.1)goto 1000
+ if(nptlxs.le.nptlb) goto 1000
+
+ continue ! ---successful decay---
+
+ istptlxs(i)=1
+ ifrptlxs(1,i)=nptlb+1
+ ifrptlxs(2,i)=nptlxs
+
+ t=xstivptl(2,i)
+ x=xsorptl(1,i)+(t-xsorptl(4,i))*xsptl(1,i)/xsptl(4,i)
+ y=xsorptl(2,i)+(t-xsorptl(4,i))*xsptl(2,i)/xsptl(4,i)
+ z=xsorptl(3,i)+(t-xsorptl(4,i))*xsptl(3,i)/xsptl(4,i)
+
+c loop over decay products
+
+ do 20 n=nptlb+1,nptlxs
+ iorptlxs(n)=i
+ jorptlxs(n)=0
+ istptlxs(n)=0
+ ifrptlxs(1,n)=0
+ ifrptlxs(2,n)=0
+ ti=t
+ zi=z
+ xsorptl(1,n)=x
+ xsorptl(2,n)=y
+ xsorptl(3,n)=zi
+ xsorptl(4,n)=ti
+ io=n
+ 1 io=iorptlxs(io)
+ if(iorptlxs(io).gt.0)goto 1
+ call cxidquac(io,nq,ndummy1,ndummy2,jcdu)
+ xstivptl(1,n)=ti
+ call cxidtau(idptlxs(n),xsptl(4,n),xsptl(5,n),taugm)
+ r=drangen(dble(n))
+ xstivptl(2,n)=t+taugm*(-log(r))
+ ityptlxs(n)=ityptlxs(i)
+ 20 continue
+
+ 1000 continue
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxhdecay(ipi,iret)
+c-----------------------------------------------------------------------
+c decays particle ip from /xscptl/
+c for ip being no resonance: call hnbaaa
+c for ip being resonance: standard resonance decay procedure
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension pgen(5,10),rnd(10),u(3),beta(3)
+ 1 ,reduce(10)
+ dimension prest(4,10),kno(10)
+#ifdef __CXDEBUG__
+ dimension ptest(5)
+#endif
+ data reduce/1.d0,1.d0,2.d0,5.d0,15.d0,60.d0,250.d0,1500.d0
+ *,1.2D4,1.2D5/
+ data twome/1.022006d-3/
+
+c fctn definitions
+ dot(i1,i2)=prest(4,i1)*prest(4,i2)-prest(1,i1)*prest(1,i2)
+ *-prest(2,i1)*prest(2,i2)-prest(3,i1)*prest(3,i2)
+c charged w propagator.
+ wprop(z)=(z-xswmass2**2)**2+(xswmass2*xswgam2)**2
+
+#ifdef __CXDEBUG__
+ call utisx1('cxhdecay ',5)
+#endif
+
+ ip=ipi
+ ipp=ip
+ iret=0
+ nptlb=nptlxs
+
+ if(nptlb+4.gt.mxptlxs)then
+ iret=1
+ goto 1000
+ endif
+
+ if(isx.ge.6)write(ifck,*)'decay id,mass: ',idptlxs(ip),xsptl(5,ip)
+
+c no k_long decay
+c ---------------
+c if(idptlxs(ip).eq.-20)goto 1000
+
+c select decay mode
+c -----------------
+ ntry=0
+2 ntry=ntry+1
+ if(ntry.gt.100)then
+#ifdef __CXDEBUG__
+ if(isx.ge.2)then
+ write(ifck,*)'***** decay not possible. iret = 1.'
+ write(ifck,*)'id,mass: ',idptlxs(ip),xsptl(5,ip)
+ stop
+ endif
+#endif
+ iret=1
+ goto 1000
+ endif
+ idlv1=idptlxs(ip)
+ amss=xsptl(5,ip)
+
+c Decay of deuteron
+
+ if(idlv1.eq.17)then
+ amss=1.01d0*amss
+ naddptl=2
+ call cxidmass(1120,amnew)
+ xsptl(5,nptlxs+1)=amnew
+ idptlxs(nptlxs+1)=1120
+ sum=amnew
+ call cxidmass(1220,amnew)
+ xsptl(5,nptlxs+2)=amnew
+ idptlxs(nptlxs+2)=1220
+ sum=sum+amnew
+ goto 111
+ endif
+
+c Decay of triton
+
+ if(idlv1.eq.18)then
+ amss=1.01d0*amss
+ naddptl=3
+ call cxidmass(1120,amnew)
+ xsptl(5,nptlxs+1)=amnew
+ idptlxs(nptlxs+1)=1120
+ sum=amnew
+ call cxidmass(1220,amnew)
+ xsptl(5,nptlxs+2)=amnew
+ idptlxs(nptlxs+2)=1220
+ sum=sum+amnew
+ call cxidmass(1220,amnew)
+ xsptl(5,nptlxs+3)=amnew
+ idptlxs(nptlxs+3)=1220
+ sum=sum+amnew
+ goto 111
+ endif
+
+c Decay of alpha
+
+ if(idlv1.eq.19)then
+ amss=1.01d0*amss
+ naddptl=4
+ call cxidmass(1120,amnew)
+ xsptl(5,nptlxs+1)=amnew
+ idptlxs(nptlxs+1)=1120
+ sum=amnew
+ call cxidmass(1220,amnew)
+ xsptl(5,nptlxs+2)=amnew
+ idptlxs(nptlxs+2)=1220
+ sum=sum+amnew
+ call cxidmass(1120,amnew)
+ xsptl(5,nptlxs+3)=amnew
+ idptlxs(nptlxs+3)=1120
+ sum=sum+amnew
+ call cxidmass(1220,amnew)
+ xsptl(5,nptlxs+4)=amnew
+ idptlxs(nptlxs+4)=1220
+ sum=sum+amnew
+ goto 111
+ endif
+
+c select one of the decay channel
+ ipoint=lookxs(iabs(idlv1))-1
+ if(idlv1.eq.-20)ipoint=lookxs(320)-1
+ if(ipoint.lt.0) goto 1000
+ try=drangen(dble(ipoint))
+100 ipoint=ipoint+1
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'ipoint,cbr,try',ipoint,cbrxs(ipoint),try
+#endif
+ if(try.gt.cbrxs(ipoint)) goto 100
+
+ naddptl=0
+ sum=0.d0
+ do 110 i=1,5
+ if(modexs(i,ipoint).eq.0) goto 110
+ if(nptlxs+naddptl+1.gt.mxptlxs) goto 9999
+ if(iabs( modexs(1,ipoint)) .le. 6.and.i.eq.2)then !decay into quark ???
+ call cxvedi(modexs(1,ipoint),modexs(2,ipoint),k3,idlv1)
+ idptlxs(new)=idlv1
+ call cxidmass(idlv1,amnew)
+ xsptl(5,new)=amnew
+ sum=xsptl(5,new)
+ else !decay into particles
+ naddptl=naddptl+1
+ new=nptlxs+naddptl
+ idptlxs(new)=modexs(i,ipoint)
+ idlv1=idptlxs(new)
+ call cxidmass(idlv1,xsptl(5,new))
+ sum=sum+xsptl(5,new)
+ endif
+ 110 continue
+ 111 continue
+ if(naddptl.ne.1.and.sum.ge.amss)goto 2
+ 112 naddptl1=naddptl-1
+ do 120 j=1,5
+ pgen(j,1)=xsptl(j,ip)
+120 continue
+ pgen(5,1)=amss !needed because of deuteron, triton and alpha decay and OK
+
+ pgen(5,naddptl)=xsptl(5,nptlxs+naddptl)
+ if(naddptl.eq.1) goto 700 !one body decay
+ if(naddptl.eq.2) goto 400 !two body decay
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'>= 3 body decay'
+#endif
+c use kroll-wada distribution for pi0 and eta dalitz decays.
+c ----------------------------------------------
+ if(.not.((idptlxs(ip).eq.110.or.idptlxs(ip).eq.220).and.
+ 1iabs(idptlxs(nptlxs+2)).eq.12)) goto 130
+ ntry=0 !decay of pi0 or eta into electron
+125 ntry=ntry+1
+ if(ntry.gt.10)then
+#ifdef __CXDEBUG__
+ if(isx.ge. 0)then
+ write(ifck,*)'***** cxhdecay : ntry > 10. iret = 1.'
+ write(ifck,*)'***** amee,ree,wtee',amee,ree,wtee
+ endif
+#endif
+ iret=1
+ goto 1000
+ endif
+ amee=twome*(xsptl(5,ip)/twome)**drangen(dble(ip))
+ ree=(twome/amee)**2
+ wtee=(1.d0-(amee/xsptl(5,ip))**2)**3*sqrt(1.d0-ree)
+ & *(1.d0+.5d0*ree)
+ if(wtee.lt.drangen(dble(ip))) goto 125
+ pgen(5,2)=amee
+ goto 400
+130 continue
+
+c calculate maximum phase-space weight
+c ------------------------------------
+ wtpsmax=1.d0/reduce(naddptl)
+ sum1=pgen(5,1)
+ sum2=sum-xsptl(5,nptlxs+1)
+ do 200 i=1,naddptl1
+ wtpsmax=wtpsmax*cxutpcm(sum1,sum2,xsptl(5,nptlxs+i))
+ sum1=sum1-xsptl(5,nptlxs+i)
+ sum2=sum2-xsptl(5,nptlxs+i+1)
+200 continue
+
+c generate uniform naddptl-body phase space
+c --------------------------------------
+ ntry=0
+300 ntry=ntry+1
+ if(ntry.gt.10000)then
+#ifdef __CXDEBUG__
+ if(isx.ge. 0)then
+ write(ifck,*)'***** cxhdecay : infinite loop (2). iret = 1.'
+ write(ifck,*)'***** ip,idptlxs(ip),xsptl(5,ip):'
+ *,ip,idptlxs(ip),xsptl(5,ip)
+ write(ifck,*)'***** wt,wtpsmax:',wt,wtpsmax
+ write(ifck,*)
+ *'***** i,pgen(5,i),xsptl(5,nptlxs+i),idptlxs(nptlxs+i):'
+ do i=1,naddptl
+ write(ifck,*)i,pgen(5,i),xsptl(5,nptlxs+i),idptlxs(nptlxs+i)
+ enddo
+ endif
+#endif
+ iret=1
+ goto 1000
+ endif
+ rnd(1)=1.d0
+ do 310 i=2,naddptl1
+ rnew=drangen(dble(i))
+ i1=i-1
+ do 320 jj1=1,i1
+ j=i-jj1
+ jsave=j+1
+ if(rnew.le.rnd(j)) goto 310
+ rnd(jsave)=rnd(j)
+320 continue
+310 rnd(jsave)=rnew
+ rnd(naddptl)=0.d0
+ wt=1.d0
+ sum1=sum
+ do 330 i=2,naddptl
+ sum1=sum1-xsptl(5,nptlxs+i-1)
+ pgen(5,i)=sum1+rnd(i)*(pgen(5,1)-sum)
+ a=pgen(5,i-1)
+ b=pgen(5,i)
+ c=xsptl(5,nptlxs+i-1)
+ wt=wt*cxutpcm(a,b,c)
+330 continue
+ if(wt.lt.drangen(wt)*wtpsmax) goto 300
+
+c carry out two-body decays in pgen frames
+c ----------------------------------------
+400 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'2 body decay'
+#endif
+ do 410 i=1,naddptl1
+ qcm=cxutpcm(pgen(5,i),pgen(5,i+1),xsptl(5,nptlxs+i))
+ u(3)=2.d0*drangen(dble(i))-1.d0
+ phi=2.d0*xspi*drangen(dble(i))
+ u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
+ u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
+ do 420 j=1,3
+ xsptl(j,nptlxs+i)=qcm*u(j)
+ pgen(j,i+1)=-xsptl(j,nptlxs+i)
+420 continue
+ xsptl(4,nptlxs+i)=sqrt(qcm**2+xsptl(5,nptlxs+i)**2)
+ pgen(4,i+1)=sqrt(qcm**2+pgen(5,i+1)**2)
+410 continue
+ do 430 j=1,4
+ xsptl(j,nptlxs+naddptl)=pgen(j,naddptl)
+430 continue
+
+c boost pgen frames to lab frame
+c also save momenta in rest frame (last frame)
+c -------------------------------------------------
+ do 500 ii=1,naddptl1
+ i=naddptl-ii
+ do 510 j=1,3
+ beta(j)=pgen(j,i)/pgen(4,i)
+510 continue
+ gamma=pgen(4,i)/pgen(5,i)
+ do 520 k=i,naddptl
+ k1=nptlxs+k
+ bp=beta(1)*xsptl(1,k1)+beta(2)*xsptl(2,k1)+beta(3)*xsptl(3,k1)
+ do 530 j=1,3
+ prest(j,k)=xsptl(j,k1)
+ xsptl(j,k1)=xsptl(j,k1)+gamma*beta(j)*(xsptl(4,k1)
+ *+bp*gamma/(gamma+1.d0))
+530 continue
+ prest(4,k)=xsptl(4,k1)
+ xsptl(4,k1)=gamma*(xsptl(4,k1)+bp)
+ if(xsptl(4,k1).lt.1.d-9)then
+ xsptl(4,k1)=sqrt(xsptl(1,k1)*xsptl(1,k1)+xsptl(2,k1)*xsptl(2,k1)
+ & +xsptl(3,k1)*xsptl(3,k1))
+ endif
+520 continue
+500 continue
+
+c matrix elements
+c ---------------
+ if(iabs(idptlxs(ip)).eq.14)then !muon decay
+ goto 650
+ elseif(naddptl.eq.3)then
+ if(idptlxs(ip).eq.221.or.idptlxs(ip).eq.331)then !omeg and phi decay
+ goto 610
+ elseif(iabs(idptlxs(ip)).eq.130.or. !Kl and K decay
+ 1 idptlxs(ip).eq.-20)then
+ if(iabs(idptlxs(nptlxs+2)).lt.20)then !semi-leptonic
+ goto 630
+ else !hadronic
+ goto 640
+ endif
+ elseif(iabs(idptlxs(nptlxs+1)).lt.20.and. !other semi-leptonic decay
+ 1 idptlxs(nptlxs+1).ne.10)then
+ goto 620
+ elseif(iabs(idptlxs(nptlxs+2)).le.6)then
+ goto 605 !decay into quark
+ else
+ goto 800
+ endif
+ else
+ goto 800
+ endif
+
+ 605 wt=xsptl(5,ip)*xsptl(5,nptlxs+1)*dot(2,3)
+ IF(wt.LT.drangen(wt)*xsptl(5,ip)**4/16.d0) goto 300
+ ams=sqrt(dot(2,2)+dot(3,3)+2.d0*dot(2,3))
+ kno(1)=idptlxs(nptlxs+2)
+ kno(2)=idptlxs(nptlxs+3)
+ if(cxammin(kno(1),kno(2)).gt.ams)then
+ call cxvedi(kno(1),kno(2),iddum,idlv2)
+ idptlxs(nptlxs+2)=idlv2
+ call cxidmass(idlv2,amnew2)
+ xsptl(5,nptlxs+2)=amnew2
+ naddptl=2
+ goto 112
+ endif
+c......multiplicity
+ PS =sqrt(dot(2,2))
+ psq=sqrt(dot(3,3))
+ np=0 !!!!?????
+ nq=2
+ CNDE=4.5d0*LOG(MAX((ams-PS-PSQ)/0.7d0,1.1d0))
+c IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
+ 769 NTRY=NTRY+1
+ IF(NTRY.GT.1000) THEN
+ write(*,*)'cxhdecay caught in infinite loop'
+ goto 1000
+ ENDIF
+ GAUSS=SQRT(-2.d0*CNDE*LOG(MAX(1d-10,drangen(cnde))))*
+ & SIN(2.d0*xspi*drangen(ps))
+ ND=int(0.5d0+0.5d0*dble(NP)+0.25d0*dble(NQ)+CNDE+GAUSS)
+ IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 769
+
+
+c......choose hadrons
+
+
+ kno(3)=kno(1)
+ kno(4)=kno(2)
+
+ CONTINUE
+ IF(ND.EQ.NP+NQ/2) GOTO 773
+ DO I=nptlxs+2,nptlxs+2+nd-nq/2-1
+ JT=2+1+INT((NQ-1) * drangen(gauss) )
+ CALL cxvedi(kno(JT),0,KFL2,idlv3)
+ idptlxs(i)=idlv3
+c IF(K(I,2).EQ.0) GOTO 769
+ kno(JT)=-KFL2
+ enddo
+ 773 CONTINUE
+ CALL cxvedi(kno(3),kno(4),KFLDMP,idlv4)
+ idptlxs(nptlxs+2+nd-nq/2)=idlv4
+ sum=0.d0
+ do i=nptlxs+2,nptlxs+2+nd-nq/2
+ call cxidmass(idptlxs(i),am)
+ xsptl(5,i)=am
+ sum=sum+am
+ enddo
+ if(sum.gt.ams) goto 769
+c......goto phase space dis....
+ ip=nptlxs+2+nd-nq/2+1
+ do j=1,4
+ xsptl(j,ip)=xsptl(j,ipp)-xsptl(j,nptlxs+1)
+ enddo
+ xsptl(5,ip)=ams
+ idptlxs(ip)=sign(80,idptlxs(ipp))
+ nptlxs=nptlxs+1
+ naddptl=nd
+ goto 112
+
+
+c omeg and phi decay
+c use vectors in rest frame
+c ------------------------------
+610 wt=(xsptl(5,nptlxs+1)*xsptl(5,nptlxs+2)*xsptl(5,nptlxs+3))**2
+ 1-(xsptl(5,nptlxs+1)*dot(2,3))**2
+ 2-(xsptl(5,nptlxs+2)*dot(1,3))**2
+ 3-(xsptl(5,nptlxs+3)*dot(1,2))**2
+ 4+2.d0*dot(1,2)*dot(2,3)*dot(1,3)
+ if(wt.lt.drangen(wt)*xsptl(5,ip)**6/108.d0) goto 300
+ goto 800
+
+c semileptonic and quark decays
+c use vectors in rest frame, where ip has (m,0,0,0)
+c include w propagator
+c ------------------------------------------------------
+620 wt=(xsptl(5,ip)*prest(4,2))*dot(1,3)
+ s12=xsptl(5,nptlxs+1)**2+xsptl(5,nptlxs+2)**2+2.d0*dot(1,2)
+ s12max=xsptl(5,ip)**2
+ wt=wt*wprop(s12max)/wprop(s12)
+ if(wt.lt.drangen(wt)*xsptl(5,ip)**4/16.d0) goto 300
+ goto 800
+
+c semileptonic kaon decays
+c use vectors in rest frame, where ip has (m,0,0,0)
+c include form factor CXFML
+c ------------------------------------------------------
+630 if(iabs(idptlxs(ip)).eq.130)then
+ if(iabs(idptlxs(nptlxs+2)).eq.12)then
+ ncha=1 !K -> Pi0 + e + Nu
+ else
+ ncha=2 !K -> Pi0 + Mu + Nu
+ endif
+ else
+ if(iabs(idptlxs(nptlxs+2)).eq.12)then
+ ncha=3 !K0 -> Pi + e + Nu
+ else
+ ncha=4 !K0 -> Pi + Mu + Nu
+ endif
+ endif
+
+
+ wt=CXFML(ncha,xsptl(5,ip),xsptl(5,nptlxs+1),xsptl(5,nptlxs+2)
+ & ,prest(4,1),prest(4,2),prest(4,3))
+ if(wt.lt.drangen(wt)) goto 300
+ goto 800
+
+c hadronic kaon decays
+c use vectors in rest frame, where ip has (m,0,0,0)
+c include form factor CXFM
+c ------------------------------------------------------
+640 if(iabs(idptlxs(ip)).eq.130)then
+ if(iabs(idptlxs(nptlxs+3)).eq.120)then
+ ncha=1 !K -> 3 Pi
+ else
+ ncha=2 !K -> Pi + 2 Pi0
+ endif
+ else
+ if(iabs(idptlxs(nptlxs+1)).eq.110)then
+ ncha=3 !K0 -> 3 Pi0
+ else
+ ncha=4 !K0 -> 2 Pi + Pi0
+ endif
+ endif
+ amsip=xsptl(5,ip)**2
+ ams1=xsptl(5,nptlxs+1)**2
+ ams2=xsptl(5,nptlxs+2)**2
+ ams3=xsptl(5,nptlxs+3)**2
+ S0=(amsip+ams1+ams2+ams3)/3.d0
+ S1=amsip+ams1-2.d0*prest(4,1)*xsptl(5,ip)
+ S2=amsip+ams2-2.d0*prest(4,2)*xsptl(5,ip)
+ S3=amsip+ams3-2.d0*prest(4,3)*xsptl(5,ip)
+ wt=CXFM(ncha,S0,S1,S2,S3)
+ if(wt.lt.drangen(wt)) goto 300
+ goto 800
+
+c muon decays
+c use vectors in rest frame, where ip has (m,0,0,0)
+c include form factor CXFMU
+c ------------------------------------------------------
+650 xxx=2.d0*prest(4,1)/xsptl(5,ip) !reduced energy of electron
+ if(xxx.gt.1.) goto 300
+ wt=CXFMU(xxx)
+ rrr=drangen(wt)
+ if(wt.lt.rrr) goto 300
+ goto 800
+
+c one-particle decays
+c -------------------
+700 continue
+ do 710 j=1,5
+ xsptl(j,nptlxs+1)=xsptl(j,ip)
+710 continue
+
+c swap particles and antiparticles if idptlxs(ip)<0
+c -----------------------------------------------
+ 800 continue
+ if(iabs(idptlxs(ip)).eq.80)then
+ nptlxs=nptlxs-1
+ naddptl=naddptl+1
+ endif
+ if(idptlxs(ipp).ge.0.or.iabs(idptlxs(ipp)).eq.20) goto 900
+ do 810 i=1,naddptl
+ idabs=iabs(idptlxs(nptlxs+i))
+ ifl1=idabs/1000
+ ifl2=mod(idabs/100,10)
+ ifl3=mod(idabs/10,10)
+ if(ifl1.eq.0.and.ifl2.ne.0.and.ifl2.eq.ifl3) goto 810
+ if(idabs.eq.9.or.idabs.eq.10.or.idabs.eq.20) goto 810
+ if(idabs.eq.29.or.idabs.eq.30.or.idabs.eq.40) goto 810
+ idptlxs(nptlxs+i)=-idptlxs(nptlxs+i)
+ 810 continue
+
+ 900 continue
+ nptlxs=nptlxs+naddptl
+ if(nptlxs.gt.mxptlxs)stop'cxhdecay: nptlxs>mxptlxs'
+ if(iabs(idptlxs(nptlxs)).lt.10.or.mod(idptlxs(nptlxs),100).eq.0)
+ & stop 'cxhdecay: decay ptcl is parton'
+
+c print
+c -----
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ write(ifck,*)'decaying object:'
+ call cxalist('&',ip,ip,2)
+ write(ifck,*)'decay products:'
+ call cxalist('&',nptlb+1,nptlxs,2)
+ endif
+ if(isx.ge.7)then
+ do kk=1,4
+ ptest(kk)=0.d0
+ do ii=nptlb+1,nptlxs
+ ptest(kk)=ptest(kk)+xsptl(kk,ii)
+ enddo
+ enddo
+ write(ifck,*)'momentum sum (final-initial):'
+ & ,(ptest(kk)-xsptl(kk,ip),kk=1,4)
+ endif
+#endif
+c exit
+c ----
+
+ 1000 continue
+#ifdef __CXDEBUG__
+ if(iret.ne.0)then
+ if(isx.ge.1)then
+ write(*,'(a)')'cxhdecay: redo event'
+ if(isx.ge.3)write(ifck,'(a)')'cxhdecay: redo event'
+ endif
+ endif
+ call utisx2
+#endif
+ return
+
+ 9999 stop 'cxhdecay: mxptlxs too small'
+ end
+
+c---------------------------------------------------------------------
+ subroutine cxvedi(k1,k2,k3,id)
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ if(k2.eq.0)then
+ if(drangen(dble(k2)).lt.xspdiqua.and.iabs(k1).lt.6)then
+ ifl1=int(drangen(dble(k2))/xspud)+1
+ ifl2=int(drangen(dble(ifl1))/xspud)+1 !link to fra ????
+ k3=-min(ifl1,ifl2)*1000-max(ifl1,ifl2)*100
+ else
+ k3=int(drangen(dble(k2))/xspud)+1
+ endif
+ if(k1.gt.0.and.k1.le.6)k3=-k3
+ if(k1.lt.-1000)k3=-k3
+ else
+ k3=k2
+ endif
+ id=idspcx(k1,k3)
+ if(iabs(id).le.999) then
+ ids=max(mod(iabs(id)/100,10),mod(iabs(id)/10,10))
+ if(ids.le.2)then
+ idr=sign(iabs(id)+int(drangen(dble(id))+0.5d0),id)
+ elseif(ids.eq.3)then
+ idr=sign(iabs(id)+int(drangen(dble(id))+0.6d0),id)
+ else
+ idr=sign(iabs(id)+int(drangen(dble(id))+0.75d0),id)
+ endif
+ else
+ idr=sign(iabs(id)+int(0.5d0+drangen(dble(id))),id)
+ endif
+ id=idr
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidtau(id,p4,p5,taugm)
+c returns lifetime*gamma for id with energy p4, mass p5
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ if(iabs(id).lt.100.and.id.ne.20)then
+ wi=0.d0
+ elseif(id.eq.20)then
+ wi=.197d0/2.675d13
+ elseif(iabs(id).lt.1e8)then
+ ix=iabs(id)/10
+ if(ix.lt.1.or.ix.gt.mxindxs)
+ *stop'cxidtau: ix out of range.'
+ ii=indxs(ix)
+ jj=mod(iabs(id),10)+2
+
+ m1=1
+ if(iabs(id).ge.1000)m1=3
+ m2=2
+ if(iabs(id).ge.1000)m2=mxmxs
+ do 75 imx=m1,m2
+ do 75 ima=2,mxmaxs
+ if(iabs(id).eq.idmxs(ima,imx))then
+ jj=ima
+ goto 75
+ endif
+75 continue
+ if(ii.lt.1.or.ii.gt.mxrexs.or.jj.lt.1.or.jj.gt.mxmaxs)then
+#ifdef __CXDEBUG__
+ write(ifck,*)'id,ii,jj:',id,' ',ii,jj
+#else
+ write(*,*)'id,ii,jj:',id,' ',ii,jj
+#endif
+ stop 'cxidtau: ii or jj out of range'
+ endif
+ wi=rewixs(ii,jj)
+ else
+ tauz=xstaunll
+c-c tauz=amin1(9./p5**2,tauz)
+c-c tauz=amax1(.2,tauz)
+ wi=.197d0/tauz
+ endif
+ if(wi.eq.0.)then
+ tau=xsainfin
+ else
+ tau=.197d0/wi
+ endif
+ if(p5.ne.0.d0)then
+ gm=p4/p5
+ else
+ gm=xsainfin
+ endif
+ if(tau.ge.xsainfin.or.gm.ge.xsainfin)then
+ taugm=xsainfin
+ else
+ taugm=tau*gm
+ endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidquac(i,nq,ns,na,jc)
+c returns quark content of ptl i from /cxcptl/ .
+c nq = # quarks - # antiquarks
+c ns = # strange quarks - # strange antiquarks
+c na = # quarks + # antiquarks
+c jc(nflavxs,2) = jc-type particle identification code.
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ integer jc(nflavxs,2),ic(2)
+
+ if(iabs(idptlxs(i)).eq.20)then
+ idptlxs(i)=230
+ if(drangen(dble(i)).lt..5d0)idptlxs(i)=-230
+ goto 9999
+ endif
+
+ if(iabs(idptlxs(i)).lt.100)then
+ nq=0
+ ns=0
+ do 1 n=1,nflavxs
+ jc(n,1)=0
+1 jc(n,2)=0
+ return
+ endif
+
+9999 call cxidtr4(idptlxs(i),ic)
+ call cxiddeco(ic,jc)
+ na=0
+ nq=0
+ do 53 n=1,nflavxs
+ na=na+jc(n,1)+jc(n,2)
+53 nq=nq+jc(n,1)-jc(n,2)
+ ns= jc(3,1)-jc(3,2)
+ return
+ end
+
+c-----------------------------------------------------------------------
+ integer function idspcx(id1,id2)
+c-----------------------------------------------------------------------
+c From nexus-fra
+c-----------------------------------------------------------------------
+ ia1=iabs(id1)
+ ia2=iabs(id2)
+ if(ia1.ge.1000.and.ia2.ge.1000)then
+ idspcx=0
+ isign=0
+ elseif(ia1.le.1000.and.ia2.le.1000)then
+ idspcx=min(ia1,ia2)*100+max(ia1,ia2)*10
+ isign=1
+ if(max(ia1,ia2).ne.-min(id1,id2)) isign = -1
+ if(idspcx.eq.220)idspcx=110
+ if(idspcx.eq.330)idspcx=220
+ else
+ isign=1
+ if(id1.lt.0.and.id2.lt.0)isign=-1
+ idb=min(ia1,ia2)
+ if(idb.eq.5)then
+ idspcx=0
+ return
+ endif
+ ida=max(ia1,ia2)
+ ida1=ida/1000
+ ida2=mod(ida/100,10)
+ if(idb.le.ida1)then
+ idspcx=idb*1000+ida/10
+ elseif(idb.le.ida2)then
+ idspcx=ida1*1000+idb*100+ida2*10
+ else
+ idspcx=ida+idb*10
+ endif
+ if(ida1.eq.ida2.and.ida2.eq.idb)idspcx=idspcx+1
+ endif
+ idspcx=idspcx*isign
+ return
+ end
+
+
+c-----------------------------------------------------------------------
+ double precision function cxammin(id1,id2)
+c-----------------------------------------------------------------------
+c From nexus-fra
+c-----------------------------------------------------------------------
+ dimension ic1(2),ic2(2),jc2(6,2),jc1(6,2)
+ double precision cxutamnx
+ call cxidtr5(id1,ic1)
+ call cxidtr5(id2,ic2)
+ call cxidcomk(ic1)
+ call cxidcomk(ic2)
+ call cxiddeco(ic1,jc1)
+ call cxiddeco(ic2,jc2)
+ cxammin=cxutamnx(jc1,jc2)
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidtr5(id,ic)
+c-----------------------------------------------------------------------
+c From nexus-fra
+c-----------------------------------------------------------------------
+ integer ic(2)
+ ic(1)=0
+ ic(2)=0
+ ii=1
+ if(id.lt.0)ii=2
+ i1=1
+ if(iabs(id).gt.999)i1=3
+ do i=i1,int(log(abs(real(id)))/log(10.))+1
+ j=mod(iabs(id)/10**(i-1),10)
+ if(j.gt.0)then
+ ic(ii)=ic(ii)+10**(6-j)
+ endif
+ enddo
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidcomk(ic)
+c compactifies ic
+c-----------------------------------------------------------------------
+ parameter (nflavxs=6)
+ integer ic(2),icx(2),jc(nflavxs,2)
+ call cxidcomp(ic,icx,jc,1)
+ ic(1)=icx(1)
+ ic(2)=icx(2)
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidcomp(ic,icx,jc,im)
+c-----------------------------------------------------------------------
+c compactifies ic,jc
+c input: im (1 or 2)
+c ic (if im=1)
+c jc (if im=2)
+c output: icx (if im=1)
+c jc
+c-----------------------------------------------------------------------
+ parameter (nflavxs=6)
+ integer ic(2),icx(2),jc(nflavxs,2)
+ if(im.eq.1)call cxiddeco(ic,jc)
+ icx(1)=0
+ icx(2)=0
+ do n=1,nflavxs
+ do j=1,2
+ if(jc(n,j).ne.0)goto 1
+ enddo
+ enddo
+ return
+1 continue
+ nq=0
+ na=0
+ do n=1,nflavxs
+ nq=nq+jc(n,1)
+ na=na+jc(n,2)
+ enddo
+ l=0
+ do n=1,nflavxs
+ k=min0(jc(n,1),jc(n,2))
+ if(nq.eq.1.and.na.eq.1)k=0
+ jc(n,1)=jc(n,1)-k
+ jc(n,2)=jc(n,2)-k
+ if(jc(n,1).lt.0.or.jc(n,2).lt.0)
+ *stop'cxidcomp: jc negative'
+ l=l+jc(n,1)+jc(n,2)
+ enddo
+ if(l.eq.0)then
+ jc(1,1)=1
+ jc(1,2)=1
+ endif
+ if(im.eq.1)then
+ call cxidenco(jc,icx,ireten)
+ if(ireten.eq.1)stop'cxidcomp: cxidenco ret code = 1'
+ endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine cxidenco(jc,ic,ireten)
+c encode particle id
+c-----------------------------------------------------------------------
+ parameter (nflavxs=6)
+ integer jc(nflavxs,2),ic(2)
+ ireten=0
+ ic(1)=0
+ do 20 i=1,nflavxs
+ if(jc(i,1).ge.10)goto 22
+20 ic(1)=ic(1)+jc(i,1)*10**(nflavxs-i)
+ ic(2)=0
+ do 21 i=1,nflavxs
+ if(jc(i,2).ge.10)goto 22
+21 ic(2)=ic(2)+jc(i,2)*10**(nflavxs-i)
+ return
+22 ireten=1
+ ic(1)=0
+ ic(2)=0
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function cxutamnx(jcp,jcm)
+c-----------------------------------------------------------------------
+c returns minimum mass for the decay of jcp---jcm (by calling utamnu).
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ parameter (nflavxs=6)
+ integer jcp(nflavxs,2),jcm(nflavxs,2)
+
+ do i=1,nflavxs
+ do j=1,2
+ if(jcp(i,j).ne.0)goto 1
+ enddo
+ enddo
+ keu=jcm(1,1)-jcm(1,2)
+ ked=jcm(2,1)-jcm(2,2)
+ kes=jcm(3,1)-jcm(3,2)
+ kec=jcm(4,1)-jcm(4,2)
+ keb=jcm(5,1)-jcm(5,2)
+ ket=jcm(6,1)-jcm(6,2)
+ cxutamnx=cxutamnu(keu,ked,kes,kec,keb,ket)
+ return
+1 continue
+
+ do i=1,nflavxs
+ do j=1,2
+ if(jcm(i,j).ne.0)goto 2
+ enddo
+ enddo
+ keu=jcp(1,1)-jcp(1,2)
+ ked=jcp(2,1)-jcp(2,2)
+ kes=jcp(3,1)-jcp(3,2)
+ kec=jcp(4,1)-jcp(4,2)
+ keb=jcp(5,1)-jcp(5,2)
+ ket=jcp(6,1)-jcp(6,2)
+ cxutamnx=cxutamnu(keu,ked,kes,kec,keb,ket)
+ return
+2 continue
+
+ keu=jcp(1,1)-jcp(1,2)
+ ked=jcp(2,1)-jcp(2,2)
+ kes=jcp(3,1)-jcp(3,2)
+ kec=jcp(4,1)-jcp(4,2)
+ keb=jcp(5,1)-jcp(5,2)
+ ket=jcp(6,1)-jcp(6,2)
+ ke=keu+ked+kes+kec+keb+ket
+ if(mod(ke+1,3).eq.0)then
+ keu=keu+1
+ amms1=cxutamnu(keu,ked,kes,kec,keb,ket)
+ keu=keu-1
+ ked=ked+1
+ amms2=cxutamnu(keu,ked,kes,kec,keb,ket)
+ elseif(mod(ke-1,3).eq.0)then
+ keu=keu-1
+ amms1=cxutamnu(keu,ked,kes,kec,keb,ket)
+ keu=keu+1
+ ked=ked-1
+ amms2=cxutamnu(keu,ked,kes,kec,keb,ket)
+ else
+ stop 'cxutamnx: no singlet possible (1)'
+ endif
+ keu=jcm(1,1)-jcm(1,2)
+ ked=jcm(2,1)-jcm(2,2)
+ kes=jcm(3,1)-jcm(3,2)
+ kec=jcm(4,1)-jcm(4,2)
+ keb=jcm(5,1)-jcm(5,2)
+ ket=jcm(6,1)-jcm(6,2)
+ ke=keu+ked+kes+kec+keb+ket
+ if(mod(ke+1,3).eq.0)then
+ keu=keu+1
+ amms3=cxutamnu(keu,ked,kes,kec,keb,ket)
+ keu=keu-1
+ ked=ked+1
+ amms4=cxutamnu(keu,ked,kes,kec,keb,ket)
+ elseif(mod(ke-1,3).eq.0)then
+ keu=keu-1
+ amms3=cxutamnu(keu,ked,kes,kec,keb,ket)
+ keu=keu+1
+ ked=ked-1
+ amms4=cxutamnu(keu,ked,kes,kec,keb,ket)
+ else
+ stop 'cxutamnx: no singlet possible (2)'
+ endif
+ cxutamnx=min(amms1+amms3,amms2+amms4)
+c print *,amms1,amms3,amms2,amms4,jcp,jcm
+ return
+ end
+
+c----------------------------------------------------------------------
+ function cxutamnu(keux,kedx,kesx,kecx,kebx,ketx)
+c----------------------------------------------------------------------
+c returns min mass of droplet with given u,d,s,c content
+c keux: net u quark number
+c kedx: net d quark number
+c kesx: net s quark number
+c kecx: net c quark number
+c kebx: net b quark number
+c ketx: net t quark number
+c----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+
+c 1 format(' flavours:',6i5 )
+c 100 format(' flavours+mass:',6i5,f8.2 )
+c write(ifch,1)keux,kedx,kesx,kecx,kebx,ketx c write(ifmt,*)'wrong mass in gethad ',damss
+
+ amnull=0.d0
+
+ ke=iabs(keux+kedx+kesx+kecx+kebx+ketx)
+
+ if(keux+kedx+kesx+kecx+kebx+ketx.ge.0)then
+ keu=keux
+ ked=kedx
+ kes=kesx
+ kec=kecx
+ keb=kebx
+ ket=ketx
+ else
+ keu=-keux
+ ked=-kedx
+ kes=-kesx
+ kec=-kecx
+ keb=-kebx
+ ket=-ketx
+ endif
+
+c write(ifch,*)keu,ked,kes,kec,keb,ket
+
+c removing top mesons to remove t quarks or antiquarks
+ if(ket.ne.0)then
+12 continue
+ ii=sign(1,ket)
+ ket=ket-ii
+ if(ii*keu.le.ii*ked)then
+ keu=keu+ii
+ else
+ ked=ked+ii
+ endif
+ amnull=amnull+180.d0 ! top mass
+ if(ket.ne.0)goto 12
+ endif
+
+c removing bottom mesons to remove b quarks or antiquarks
+ if(keb.ne.0)then
+11 continue
+ ii=sign(1,keb)
+ keb=keb-ii
+ if(ii*keu.le.ii*ked)then
+ keu=keu+ii
+ else
+ ked=ked+ii
+ endif
+ amnull=amnull+5.28d0 ! (B-meson)
+ if(keb.ne.0)goto 11
+ endif
+
+c removing charm mesons to remove c quarks or antiquarks
+ if(kec.ne.0)then
+10 continue
+ ii=sign(1,kec)
+ kec=kec-ii
+ if(keu*ii.le.ked*ii)then
+ keu=keu+ii
+ else
+ ked=ked+ii
+ endif
+ amnull=amnull+1.87d0 ! (D-meson)
+ if(kec.ne.0)goto 10
+ endif
+
+c write(ifch,100)keu,ked,kes,kec,keb,ket,amnull
+
+c removing mesons to remove s antiquarks
+5 continue
+ if(kes.lt.0)then
+ amnull=amnull+xsasuha(6)
+ if(keu.ge.ked)then
+ keu=keu-1
+ else
+ ked=ked-1
+ endif
+ kes=kes+1
+ goto 5
+ endif
+
+c removing mesons to remove d antiquarks
+6 continue
+ if(ked.lt.0)then
+ if(keu.ge.kes)then
+ amnull=amnull+xsasuha(5)
+ keu=keu-1
+ else
+ amnull=amnull+xsasuha(6)
+ kes=kes-1
+ endif
+ ked=ked+1
+ goto 6
+ endif
+
+c removing mesons to remove u antiquarks
+7 continue
+ if(keu.lt.0)then
+ if(ked.ge.kes)then
+ amnull=amnull+xsasuha(5)
+ ked=ked-1
+ else
+ amnull=amnull+xsasuha(6)
+ kes=kes-1
+ endif
+ keu=keu+1
+ goto 7
+ endif
+
+c write(ifch,100)keu,ked,kes,kec,keb,ket,amnull
+
+ if(keu+ked+kes+kec+keb+ket.ne.ke)
+ *stop'cxutamnu: sum_kei /= ke'
+ keq=keu+ked
+ keqx=keq
+ amnux=0.d0
+
+c removing strange baryons
+ i=4
+2 i=i-1
+3 continue
+ if((4-i)*kes.gt.(i-1)*keq)then
+ amnux=amnux+xsasuha(1+i)
+ kes=kes-i
+ keq=keq-3+i
+ if(kes.lt.0)stop 'cxutamnu: negative kes'
+ if(keq.lt.0)stop 'cxutamnu: negative keq'
+ goto 3
+ endif
+ if(i.gt.1)goto 2
+ if(keqx.gt.keq)then
+ do 8 k=1,keqx-keq
+ if(keu.ge.ked)then
+ keu=keu-1
+ else
+ ked=ked-1
+ endif
+8 continue
+ endif
+
+ if(keu+ked.ne.keq)stop 'cxutamnu: keu+ked /= keq'
+c write(ifch,100)keu,ked,kes,kec,keb,ket,amnull+amnux
+
+c removing nonstrange baryons
+9 continue
+ if(keu.gt.2*ked)then
+ amnux=amnux+xsasuha(7)
+ keu=keu-3
+ if(keu.lt.0)stop 'cxutamnu: negative keu'
+ goto 9
+ endif
+ if(ked.gt.2*keu)then
+ amnux=amnux+xsasuha(7)
+ ked=ked-3
+ if(ked.lt.0)stop 'cxutamnu: negative ked'
+ goto 9
+ endif
+ keq=keu+ked
+
+c write(ifch,100)keu,ked,kes,kec,keb,ket,amnull+amnux
+
+ if(mod(keq,3).ne.0)stop 'cxutamnu: mod(keq,3) /= 0'
+ amnux=amnux+xsasuha(1)*keq/3
+
+c write(ifch,100)keu,ked,kes,kec,keb,ket,amnull+amnux
+
+ amnull=amnull+amnux
+
+ if(amnull.eq.0)amnull=xsasuha(5)
+
+ cxutamnu=amnull
+ return
+ end
+
+c-----------------------------------------------------------------------
+ function cxidlabl(id)
+c returns the character*8 label for the particle id
+c-----------------------------------------------------------------------
+ parameter ( nqlep=41,nmes=2)
+c
+ character*8 cxidlabl
+ character*8 llep,lmes0,lmes1,lbar0,labar0,lbar1,labar1
+ character*8 lqq,laqq
+ dimension llep(104)
+ dimension lmes0(64),lmes1(64)
+ dimension lbar0(109),labar0(109),lbar1(109),labar1(109)
+ dimension lqq(21),laqq(21)
+c diquark labels
+ data lqq/
+ 1'uu0. ','ud0. ','dd0. ','us0. ','ds0. ','ss0. ','uc0. ','dc0. ',
+ 2'sc0. ','cc0. ','ub0. ','db0. ','sb0. ','cb0. ','bb0. ','ut0. ',
+ 3'dt0. ','st0. ','ct0. ','bt0. ','tt0. '/
+ data laqq/
+ 1'auu0.','aud0.','add0.','aus0.','ads0.','ass0.','auc0.','adc0.',
+ 2'asc0.','acc0.','aub0.','adb0.','asb0.','acb0.','abb0.','aut0.',
+ 3'adt0.','ast0.','act0.','abt0.','att0.'/
+c quark and lepton labels
+ data llep/
+ *' ','up ','ub ','dn ','db ','st ','sb ','ch ',
+ *'cb ','bt ','bb ','tp ','tb ','y ','yb ','x ',
+ *'xb ','gl ','err ','gm ','err ','nue ','anue ','e- ',
+ *'e+ ','num ','anum ','mu- ','mu+ ','nut ','anut ','tau- ',
+ *'tau+ ','deut ','adeut','trit ','atrit','alph ','aalph','ks ',
+ *'err ','err ','kl ',
+ *'upss ','ubss ','dnss ','dbss ','stss ','sbss ','chss ','cbss ',
+ *'btss ','bbss ','tpss ','tbss ','err ','err ','err ','err ',
+ *'glss ','err ','gmss ','err ','ness ','aness','e-ss ','e+ss ',
+ *'nmss ','anmss','mu-ss','mu+ss','ntss ','antss','t-ss ','t+ss ',
+ *'err ','err ','err ','err ','w+ss ','w-ss ','z0ss ','err ',
+ *'w+ ','w- ','h0 ','ah0 ','H0 ','aH0 ','A0 ','aA0 ',
+ *'H+ ','H- ','Zp0 ','aZp0 ','Zpp0 ','aZpp0','Wp+ ','Wp- ',
+ *'err ','err ','err ','err ','z0 '/
+c 0- meson labels
+ data lmes0/
+ 1'pi0 ','pi+ ','eta ','pi- ','k+ ','k0 ','etap ','ak0 ',
+ 2'k- ','ad0 ','d- ','f- ','etac ','f+ ','d+ ','d0 ',
+ 2'ub. ','db. ','sb. ','cb. ','bb. ','bc. ','bs. ','bd. ',
+ 3'bu. ','ut. ','dt. ','st. ','ct. ','bt. ','tt. ','tb. ',
+ 4'tc. ','ts. ','td. ','tu. ','uy. ','dy. ','sy. ','cy. ',
+ 5'by. ','ty. ','yy. ','yt. ','yb. ','yc. ','ys. ','yd. ',
+ 6'yu. ','ux. ','dx. ','sx. ','cx. ','bx. ','tx. ','yx. ',
+ 7'xx. ','xy. ','xt. ','xb. ','xc. ','xs. ','xd. ','xu. '/
+c 1- meson labels
+ data lmes1/
+ 1'rho0 ','rho+ ','omeg ','rho- ','k*+ ','k*0 ','phi ','ak*0 ',
+ 2'k*- ','ad*0 ','d*- ','f*- ','jpsi ','f*+ ','d*+ ','d*0 ',
+ 3'ub* ','db* ','sb* ','cb* ','upsl ','bc* ','bs* ','bd* ',
+ 4'bu* ','ut* ','dt* ','st* ','ct* ','bt* ','tt* ','tb* ',
+ 5'tc* ','ts* ','td* ','tu* ','uy* ','dy* ','sy* ','cy* ',
+ 6'by* ','ty* ','yy* ','yt* ','yb* ','yc* ','ys* ','yd* ',
+ 7'yu* ','ux* ','dx* ','sx* ','cx* ','bx* ','tx* ','yx* ',
+ 8'xx* ','xy* ','xt* ','xb* ','xc* ','xs* ','xd* ','xu* '/
+c 1/2+ baryon labels
+ data lbar0/
+ 1'err ','p ','n ','err ','err ','s+ ','s0 ','s- ',
+ 2'l ','xi0 ','xi- ','err ','err ','err ','sc++ ','sc+ ',
+ 3'sc0 ','lc+ ','usc. ','dsc. ','ssc. ','sdc. ','suc. ','ucc. ',
+ 4'dcc. ','scc. ','err ','err ','err ','err ','uub. ','udb. ',
+ 5'ddb. ','dub. ','usb. ','dsb. ','ssb. ','sdb. ','sub. ','ucb. ',
+ 6'dcb. ','scb. ','ccb. ','csb. ','cdb. ','cub. ','ubb. ','dbb. ',
+ 7'sbb. ','cbb. ','err ','err ','err ','err ','err ','utt. ',
+ 8'udt. ','ddt. ','dut. ','ust. ','dst. ','sst. ','sdt. ','sut. ',
+ 9'uct. ','dct. ','sct. ','cct. ','cst. ','cdt. ','cut. ','ubt. ',
+ 1'dbt. ','sbt. ','cbt. ','bbt. ','bct. ','bst. ','bdt. ','but. ',
+ 2'utt. ','dtt. ','stt. ','ctt. ','btt. ','err ','err ','err ',
+ 3'err ','err ','err ','uuy. ','udy. ','ddy. ','duy. ','usy. ',
+ 4'dsy. ','ssy. ','sdy. ','suy. ','uux. ','udx. ','ddx. ','dux. ',
+ 5'usx. ','dsx. ','ssx. ','sdx. ','sux. '/
+ data labar0/
+ 1'err ','ap ','an ','err ','err ','as- ','as0 ','as+ ',
+ 2'al ','axi0 ','axi+ ','err ','err ','err ','asc--','asc- ',
+ 3'asc0 ','alc- ','ausc.','adsc.','assc.','asdc.','asuc.','aucc.',
+ 4'adcc.','ascc.','err ','err ','err ','err ','auub.','audb.',
+ 5'addb.','adub.','ausb.','adsb.','assb.','asdb.','asub.','aucb.',
+ 6'adcb.','ascb.','accb.','acsb.','acdb.','acub.','aubb.','adbb.',
+ 7'asbb.','acbb.','err ','err ','err ','err ','err ','autt.',
+ 8'audt.','addt.','adut.','aust.','adst.','asst.','asdt.','asut.',
+ 9'auct.','adct.','asct.','acct.','acst.','acdt.','acut.','aubt.',
+ 1'adbt.','asbt.','acbt.','abbt.','abct.','abst.','abdt.','abut.',
+ 2'autt.','adtt.','astt.','actt.','abtt.','err ','err ','err ',
+ 3'err ','err ','err ','auuy.','audy.','addy.','aduy.','ausy.',
+ 4'adsy.','assy.','asdy.','asuy.','auux.','audx.','addx.','adux.',
+ 5'ausx.','adsx.','assx.','asdx.','asux.'/
+c 3/2+ baryon labels
+ data lbar1/
+ 1'dl++ ','dl+ ','dl0 ','dl- ','err ','s*+ ','s*0 ','s*- ',
+ 2'err ','xi*0 ','xi*- ','om- ','err ','err ','uuc* ','udc* ',
+ 3'ddc* ','err ','usc* ','dsc* ','ssc* ','err ','err ','ucc* ',
+ 4'dcc* ','scc* ','ccc* ','err ','err ','err ','uub* ','udb* ',
+ 5'ddb* ','err ','usb* ','dsb* ','ssb* ','err ','err ','ucb* ',
+ 6'dcb* ','scb* ','ccb* ','err ','err ','err ','ubb* ','dbb* ',
+ 7'sbb* ','cbb* ','bbb* ','err ','err ','err ','err ','utt* ',
+ 8'udt* ','ddt* ','err ','ust* ','dst* ','sst* ','err ','err ',
+ 9'uct* ','dct* ','sct* ','cct* ','err ','err ','err ','ubt* ',
+ 1'dbt* ','sbt* ','cbt* ','bbt* ','err ','err ','err ','err ',
+ 2'utt* ','dtt* ','stt* ','ctt* ','btt* ','ttt* ','err ','err ',
+ 3'err ','err ','err ','uuy* ','udy* ','ddy* ','err ','usy* ',
+ 4'dsy* ','ssy* ','err ','err ','uux* ','udx* ','ddx* ','err ',
+ 5'usx* ','dsx* ','ssx* ','err ','err '/
+ data labar1/
+ 1'adl--','adl- ','adl0 ','adl+ ','err ','as*- ','as*0 ','as*+ ',
+ 2'err ','axi*0','axi*+','aom+ ','err ','err ','auuc*','audc*',
+ 3'addc*','err ','ausc*','adsc*','assc*','err ','err ','aucc*',
+ 4'adcc*','ascc*','accc*','err ','err ','err ','auub*','audb*',
+ 5'addb*','err ','ausb*','adsb*','assb*','err ','err ','aucb*',
+ 6'adcb*','ascb*','accb*','err ','err ','err ','aubb*','adbb*',
+ 7'asbb*','acbb*','abbb*','err ','err ','err ','err ','autt*',
+ 8'audt*','addt*','err ','aust*','adst*','asst*','err ','err ',
+ 9'auct*','adct*','asct*','acct*','err ','err ','err ','aubt*',
+ 1'adbt*','asbt*','acbt*','abbt*','err ','err ','err ','err ',
+ 2'autt*','adtt*','astt*','actt*','abtt*','attt*','err ','err ',
+ 3'err ','err ','err ','auuy*','audy*','addy*','err ','ausy*',
+ 4'adsy*','assy*','err ','err ','auux*','audx*','addx*','err ',
+ 5'ausx*','adsx*','assx*','err ','err '/
+c entry
+ call cxidflav(id,ifl1,ifl2,ifl3,jspin,ind)
+ if(iabs(id).lt.100) goto 200
+ if(iabs(id).lt.1000) goto 100
+ if(id.ne.0.and.mod(id,100).eq.0) goto 300
+c baryons
+ ind=ind-109*jspin-36*nmes-nqlep
+ ind=ind-11
+ if(jspin.eq.0.and.id.gt.0) cxidlabl=lbar0(ind)
+ if(jspin.eq.0.and.id.lt.0) cxidlabl=labar0(ind)
+ if(jspin.eq.1.and.id.gt.0) cxidlabl=lbar1(ind)
+ if(jspin.eq.1.and.id.lt.0) cxidlabl=labar1(ind)
+ return
+c mesons
+100 continue
+ i=max0(ifl2,ifl3)
+ j=-min0(ifl2,ifl3)
+ ind=max0(i-1,j-1)**2+i+max0(i-j,0)
+ if(jspin.eq.0) cxidlabl=lmes0(ind)
+ if(jspin.eq.1) cxidlabl=lmes1(ind)
+ return
+c quarks, leptons, etc.
+200 continue
+ ind=2*ind
+ if(id.le.0) ind=ind+1
+ cxidlabl=llep(ind)
+ return
+300 i=iabs(ifl1)
+ j=iabs(ifl2)
+ ind=i+j*(j-1)/2
+ if(id.gt.0) cxidlabl=lqq(ind)
+ if(id.lt.0) cxidlabl=laqq(ind)
+ return
+ end
+
+C -----------------------------------------------
+ Double precision FUNCTION CXFM(NQ,S0,S1,S2,S3)
+C -----------------------------------------------
+C Normalized TRANSITION MATRIX FOR THE DALIZT PLOT DISTRI.
+C OF K -> 3 PIONS. PARAMETRIZATION OF WEINBERG
+C AS DESCRIBE IN PARTICLE DATA BOOK.
+C G IS THE LINEAR COEFFICIENT (SLOPE g)
+C H IS THE QUADRATIC COEFFICIENT h
+C D IS THE QUADRATIC COEFFICIENT k
+C Amax is the maximum of this amplitude (taken from Corsika by D. Heck)
+C NQ is the decay channel :
+C 1 - K -> 3 Pi
+C 2 - K -> Pi + 2 Pi0
+C 3 - K0 -> 3 Pi0
+C 4 - K0 -> 2 Pi + Pi0
+C -----------------------------------------------
+ implicit double precision (a-h,o-z)
+ DIMENSION G(4),H(4),D(4),Amax(4)
+ PARAMETER (PIM=139.57D-3)
+ DATA G/-0.2154d0,0.594d0,0.,0.67d0/
+ DATA H/0.01d0,0.035d0,0.d0,0.079d0/
+ DATA D/-0.01d0,0.d0,0.d0,0.0098d0/
+ DATA Amax/1.27d0,1.84d0,1.d0,2.22d0/
+
+ CXFM=1.d0+G(NQ)*(S3-S0)/(PIM*PIM)+H(NQ)*((S3-S0)/(PIM*PIM))**2
+ *+D(NQ)*((S2-S1)/(PIM*PIM))**2
+ CXFM=CXFM/Amax(NQ)
+
+ RETURN
+ END
+C -----------------------------------------------
+ Double precision FUNCTION CXFML(N,AM,RM1,RM2,E1S,E2S,E3S)
+C -----------------------------------------------
+C Normalized DALITZ PLOT DENSITY (RHO)
+C OF K -> 1 PION + 2 LEPTONS
+C AS DESCRIBE IN PARTICLE DATA BOOK.
+C CLP IS THE LAMBDA + FORM FACTOR COEFFICIENT
+C CLN IS THE LAMBDA 0 FORM FACTOR COEFFICIENT
+C EEP IS E'pion
+C GP IS THE F+(t) FORM FACTOR (t=AM*AM+SM1-2.D0*AM*E1S)
+C H IS EPS(t)=F-(t)/F+(t) WHERE F- IS CALCULATED FROM F0
+C Amax is the maximum of this density (taken from Corsika by D. Heck)
+C N is the decay channel :
+C 1 - K -> Pi0 + e + Nu
+C 2 - K -> Pi0 + Mu + Nu
+C 3 - K0 -> Pi + e + Nu
+C 4 - K0 -> Pi + Mu + Nu
+C -----------------------------------------------
+ implicit double precision (a-h,o-z)
+ DIMENSION CLP(4),CLN(4),Amax(4)
+ DATA CLP/0.0276d0,0.031d0,0.0288d0,0.034d0/
+ DATA CLN/0.0d0,0.006d0,0.d0,0.025d0/
+ DATA Amax/1.28d-2,1.194d-2,1.31d-2,1.241d-2/
+
+ SM1=RM1*RM1
+ SM2=RM2*RM2
+ EEP=0.5D0*(AM*AM+SM1-SM2)/AM-E1S
+C GM=1.D0-CLP(N)*(AM*AM+SM1-2.D0*AM*E1S)/SM1
+ GP=1.D0+CLP(N)*(AM*AM+SM1-2.D0*AM*E1S)/SM1
+C H=(AM*AM-SM1)/SM1*(CLN(N)-CLP(N))*GM
+ H=(AM*AM-SM1)/SM1*(CLN(N)-CLP(N))/GP
+ CXFML=GP*GP*(AM*(2.D0*E2S*E3S-AM*EEP)+
+ *SM2*(0.25d0*EEP-E3S)+H*SM2*(E3S-0.5d0*EEP)+
+ *0.25d0*H*H*SM2*EEP)
+ CXFML=CXFML/Amax(N)
+ RETURN
+ END
+C -----------------------------------------------
+ Double precision FUNCTION CXFMU(X)
+C -----------------------------------------------
+C PROBABILITY DISTRI. FOR ELECTRON ENERGY FROM MUON DECAY :
+C MU -> 2NU + E. DESCRIBE IN PARTICLE DATA BOOK.
+C (SIMPLIFY DIFFERENTIAL DECAY RATE INTEGRATED)
+C X REDUCED ENERGY OF PARTICLE
+C -----------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ CXFMU=2.d0*(3.d0-2.d0*X)*X*X
+
+ RETURN
+ END
+c Utilities routines
+c (created by K. Werner; updated by S. Ostapchenko, T. Pierog,
+c V. Chernatkin and D. Heck (Corsika parts))
+c Last modifications 28.06.2017 add DPMJETIII by T.Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c---------------------------------------------------------------------
+ double precision function rlam(npi,ek,am)
+c---------------------------------------------------------------------
+c inelastic interaction path for different models
+c projectile np= -3 : magnetic monopole
+c -1 : q-ball
+c 1 : proton
+c 2 : charged pions
+c 3 : charged kaons
+c 4 : K-long
+c 5 : K-short
+c 6 : neutral pion
+c 7 : neutron
+c 9 : muon
+c >10 : nuclei
+c <-10 : strangelet
+c
+c ek=kinetic energy per nucleon
+c am=mass
+c below 1 GeV, cross section is the one at 1 GeV ...
+c---------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+#include "conex.incnex"
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+#ifdef CONEX_EXTENSIONS
+ double precision factMod
+c CONEX_EXTENSIONS
+#endif
+
+ np=npi
+ rlam = 1.d+35
+ if(np.eq.6)then
+ rlam=1.d0
+ return
+ endif
+ if(ek.lt.enymin*0.9999999d0.and.(np.eq.1.or.np.ge.7))return
+
+
+ Ameanair=airava
+ model=MCModel
+ if(ek.lt.EgyHiLoLim.and.ilowegy.eq.1.and.np.lt.20)model=MCleModel
+
+c interactions for muons
+ if(np.eq.9)then
+ if(iMuInt.gt.0)then
+ call MUSIGMA(ek,Siginemb)
+ else
+ return
+ endif
+c Exotic Interactions
+ elseif(np.eq.-1)then !q-ball interactions
+ call QBALLSIGMA(Siginemb)
+ elseif(np.eq.-3)then !magnetic monopole interactions
+ call MMSIGMA(ek,Siginemb)
+ elseif(np.le.-10)then !strangelets
+ call STRANGELETSIGMA(np,Siginemb)
+c hadronic interactions
+ else
+ call MODELSIGMA(model,np,ek,am,Siginemb)
+ endif
+
+
+C interaction length in g/cm^2
+
+#ifdef CONEX_EXTENSIONS
+ factMod=1.d0
+ if (np.le.7) then ! excludes muons + nuclei !
+ call modifiercx(factMod, ek, np)
+ endif
+ if(Siginemb.gt.0.d0) then
+ rlam = Ameanair/(avog*Siginemb*factMod)
+ endif
+#else
+ if(Siginemb.gt.0.d0)rlam = Ameanair/(avog*Siginemb)
+c CONEX_EXTENSIONS
+#endif
+
+c if(np.gt.10)write(*,*) 'logE,np', log10(ek),np,rlam,siginemb
+ if (rlam.lt.1.d-35) then
+ write(*,*) 'logE,np,factMod', log10(ek),np,factMod
+ stop'rlam=0 !'
+ endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function heightt(dist,radt) !so180903
+c-----------------------------------------------------------------------
+c heightt - height above sea level (m)
+c dist - slant distance to the obs level (to the impact point) (m)
+c radt - impact radius (m)
+C NB : dist used as positive value
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ if(radt.ge.RadGrd)then
+ heightt=(dist**2+(radt-radearth)*(radt+radearth))
+ * /(dsqrt(dist**2+radt**2)+radearth)
+ else
+ heightt=(dist**2+2.d0*abs(dist)*dsqrt(max(0.d0,RadGrd-radt)
+ * )*dsqrt(RadGrd+radt)+HGrd**2+2.d0*radearth*HGrd)
+ * /(dsqrt((abs(dist)+dsqrt(max(0.d0,RadGrd-radt))
+ * *dsqrt(RadGrd+radt))**2+radt**2)+radearth)
+ endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function distant(h,radt) !so180903
+c-----------------------------------------------------------------------
+c distant - slant distance to the obs level (to the impact point) (m)
+c h - height above sea level (m)
+c radt - impact radius (m)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ if(radt.ge.RadGrd)then
+ distant=dsqrt(max(0.d0,radearth-radt+h))
+ * *dsqrt(radearth+radt+h)
+ else
+ distant=(h**2+2.d0*(h-HGrd)*radearth-HGrd**2)
+ * /(dsqrt(max(0.d0,radearth-radt+h))*dsqrt(radearth+radt+h)
+ * +dsqrt(max(0.d0,RadGrd-radt))
+ * *dsqrt(RadGrd+radt))
+ endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function depthmax(radt)
+c-----------------------------------------------------------------------
+c depthmax - slant depth down to the obs level (to the impact point)(g/cm^2)
+c radt - impact radius (m)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+ depthmax=deptht(0.d0,radt)
+ return
+ end
+
+c---------------------------------------------------------------
+ double precision function distance(t,radt)
+c---------------------------------------------------------------
+c distance - slant distance (m) to the obs level corresp. to given slant depth
+c t - slant depth (g/cm^2)
+c radt - impact radius (m)
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ a=radt
+ Rt=radearth
+ hbeg=eatm(mxatm+1)
+ hmin=a-Rt
+ dZ=t-dphmin0
+ if(dZ.le.0.d0)then
+ distance=distant(hbeg,a)
+ return
+ endif
+
+ is=-1 !direction of propagation
+ ds=0.d0 !depth crossed
+ R=hbeg+Rt !actual height
+ j=mxatm
+ do !how many layers we cross?
+ R2=max(hmin,eatm(j))+Rt
+ j2=j
+ if(is.eq.1)j2=j-1
+ dds=depth0(R,R2,a,j2) !crossed depth
+ if (ds+dds.ge.dZ) goto 12 !bounded
+ if (j.eq.mxatm+1) goto 12 !infinity reached
+ ds=ds+dds
+ R=R2
+ if (hmin.ge.eatm(j)) then
+ is=-is !middle point reached
+ else
+ if ((a.le.RadGrd).and.(j.eq.1)) then !ground
+ distance=0.d0
+ return
+ endif
+ endif
+ j=j+is
+ enddo
+ 12 continue !bounded an interval
+ if(j.eq.mxatm+1)then
+ R2=hbeg+Rt
+ else
+ j2=j
+ if(is.eq.1)j2=j-1
+ if (dZ-ds.lt.ds+dds-dZ) then
+ R2=Radius0(R,dZ-ds,is,a,j2)
+ else
+ R2=Radius0(R2,ds+dds-dZ,-is,a,j2)
+ endif
+ endif
+ distance=R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ if (RadGrd.gt.a) distance=distance-RadGrd
+ & *sqrt((1.d0-a/RadGrd)*(1.d0+a/RadGrd))
+ distance=-distance*dble(is)
+ return
+ end
+
+c---------------------------------------------------------------
+ double precision function distance0(t)
+c---------------------------------------------------------------
+c distance0 - slant distance (m) to the obs level corresp.
+c to given slant depth on shower axis
+c (signed : + before middle point in shower direction, - otherwise)
+c t - slant depth (g/cm^2)
+c by T. Pierog (08.2005)
+c---------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ fsi=1.d0
+ dZ=t
+ if(dZ.ge.dphlim0)then
+ dZ=dphmaxi0-dZ
+ fsi=-1.d0
+ endif
+
+ distance0=fsi*distance(dZ,radtr0)
+
+ return
+ end
+
+c---------------------------------------------------------------
+ subroutine dz2dl(dZ,dl,h1,h2,a,jinv)
+c---------------------------------------------------------------
+c convert a slant depth interval into a slant distance interval.
+c dZ - slant depth interval (g/cm^2) (input) (updated if border reached)
+c (>0 go towards the middle point, <0 go backwards)
+c dl - slant distance interval (m) (always positive) (ouput)
+c h1 - height above sea level of starting point (m) (input)
+c h2 - height above sea level of ending point (m) (output)
+c a - impact radius (m) (input).
+c jinv - if not 0, middle point crossed (output).
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision dZ,dl,h1,h2,a,depth0,Radius0
+ double precision Rt,adz,ds,dds,hmin,R1,R2,R,fs
+ integer is,j,ja,j2,jinv,iret
+
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'dz2dl in',dZ,h1,a
+#endif
+ jinv=0
+ iret=0
+ if(abs(dZ).lt.1d-15)then
+ dl=0d0
+ h2=h1
+ iret=1
+ goto 999
+ elseif(abs(dZ).gt.1.d20)then
+ dl=1.d30
+ h2=h1
+ iret=2
+ goto 999
+ endif
+
+ Rt=radearth
+ R1=h1+Rt
+ hmin=a-Rt
+ adz=abs(dZ)
+ is=-int(sign(1.d0,dZ)) !direction of propagation
+ fs=1.d0
+ do ja=mnatm,mxatm !starting layer
+ if(eatm(ja+1)-h1.gt.-1d-7)goto 1
+ enddo
+1 continue
+ j=ja
+
+c test dZ, if last point still in layer, it's finish (faster)
+
+ R2=Radius0(R1,adZ,is,a,-j)
+ if(is.eq.-1)then !going towards middle point
+ if(eatm(j).ge.hmin.and.R2.ge.eatm(j)+Rt)then
+ dl=abs(R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ & -R1*sqrt((1.d0-a/R1)*(1.d0+a/R1)))
+ h2=R2-Rt
+ iret=3
+ goto 999
+ else
+ R2=max(hmin,eatm(j))+Rt
+ endif
+ else
+ if(R2.gt.0.d0)then !going backwards middle point
+ if(R2.le.eatm(j+1)+Rt)then
+ dl=abs(R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ & -R1*sqrt((1.d0-a/R1)*(1.d0+a/R1)))
+ h2=R2-Rt
+ iret=4
+ goto 999
+ elseif(j+1.eq.mxatm+1)then !leave atmo.
+ R2=eatm(mxatm+1)+Rt
+ dl=abs(R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ & -R1*sqrt((1.d0-a/R1)*(1.d0+a/R1)))*1.000001d0 !to avoid precision problem
+ h2=eatm(mxatm+1)
+ dZ=-depth0(R1,R2,a,j)
+ iret=5
+ goto 999
+ endif
+ endif
+ j=j+1
+ R2=eatm(j)+Rt
+ endif
+
+ R=R1 !actual height
+ ds=0.d0 !depth crossed
+ do !how many layers we cross?
+ j2=j
+ if(is.eq.1)j2=j-1
+ dds=depth0(R,R2,a,j2) !crossed depth
+ if (ds+dds.ge.adZ) goto 12 !bounded
+ if (j.eq.mxatm+1) goto 12 !infinity reached
+ ds=ds+dds
+ R=R2
+ if (hmin.gt.eatm(j)) then
+ is=-is !middle point reached
+ fs=-1.d0
+ jinv=1
+ else
+ if ((a.le.RadGrd).and.(j.eq.1)) then !ground
+ R2=RadGrd
+ dl=abs(R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ & -fs*R1*sqrt((1.d0-a/R1)*(1.d0+a/R1)))*1.000001d0 !to avoid precision problem
+ h2=HGrd
+ dZ=sign(ds,dZ)
+ iret=6
+ goto 999
+ endif
+ endif
+ j=j+is
+ R2=max(hmin,eatm(j))+Rt
+ enddo
+ 12 continue !bounded an interval
+ if(j.eq.mxatm+1.and.ds+dds.lt.adz)then !leave atmo.
+ h2=eatm(mxatm+1)
+ dZ=sign(ds+dds,dZ)
+ else
+ j2=j
+ if(is.eq.1)j2=j-1
+ if (adZ-ds.lt.ds+dds-adZ) then
+ R2=Radius0(R,adZ-ds,is,a,j2)
+ else
+ R2=Radius0(R2,ds+dds-adZ,-is,a,j2)
+ endif
+ h2=R2-Rt
+ endif
+ dl=abs(R2*sqrt((1.d0-a/R2)*(1.d0+a/R2))
+ & -fs*R1*sqrt((1.d0-a/R1)*(1.d0+a/R1)))
+
+
+ 999 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'dz2dl out',dZ,h2,dl,jinv,iret
+#endif
+ return
+ end
+
+
+c---------------------------------------------------------------
+ subroutine dl2dz(dl,dZ,h1,h2,d1,d2,a)
+c---------------------------------------------------------------
+c convert a slant distance interval into a slant depth interval.
+c dl - slant distance interval (m) (input) (updated if border reached)
+c (>0 go towards the middle point, <0 go backwards)
+c dZ - slant depth interval (g/cm^2) (sign given by dl) (output),
+c h1 - height above sea level of starting point (m) (input)
+c h2 - height above sea level of ending point (m) (output)
+c d1 - slant distance of starting point (m) (input)
+c d2 - slant distance of ending point (m) (output)
+c a - impact radius (m) (input).
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision dZ,dl,h1,h2,d1,d2,depth0,adl,distant
+ double precision Rt,a,ds,dss,hmin,R1,R2,R0,R02,heightt,dll,dls
+ integer is,j,ja,j1,j2,iret
+
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'dl2dz in',dl,h1,d1,a
+#endif
+
+ iret=0
+ if(abs(dl).lt.1d-15)then
+ dZ=0d0
+ h2=h1
+ d2=d1
+ iret=1
+ goto 999
+ endif
+
+ Rt=radearth
+ R1=h1+Rt
+ do ja=mnatm,mxatm !starting layer
+ if(eatm(ja+1)-h1.gt.-1d-7)goto 1
+ enddo
+1 continue
+ j1=ja
+
+ d2=d1-dl !can be negative
+ if(d2.gt.0.d0.or.a.gt.Rt)then
+ h2=heightt(d2,a) !new height
+ else
+ h2=-1d0
+ endif
+ if(h2.le.HGrd)then !reach ground
+ h2=HGrd
+ d2=0.d0
+ dl=sign(d1,dl)
+ j2=mnatm
+ elseif(h2.ge.eatm(mxatm+1))then !leave atmo.
+ h2=eatm(mxatm+1)
+ d2=distant(h2,a)
+ dl=sign(d2-d1,dl)
+ j2=mxatm+1
+ else
+ do ja=mnatm,mxatm !ending layer
+ if(h2.le.eatm(ja+1))goto 2
+ enddo
+ 2 continue
+ j2=ja
+ endif
+ R2=h2+Rt
+
+ if(j1.eq.j2.and.d2.ge.0.d0)then!same layer and do not cross middle point
+
+ ds=depth0(R1,R2,a,j2)
+
+ else
+
+ hmin=a-Rt
+ is=-int(sign(1.d0,dl)) !direction of propagation
+ j=j1
+ R0=R1
+ ds=0.d0
+ dls=0.d0
+ adl=abs(dl)
+ if(is.eq.-1)then
+ R02=max(hmin,eatm(j))+Rt
+ else
+ j=j+1
+ R02=eatm(j)+Rt
+ endif
+ do
+ dll=abs(R02*sqrt((1.d0-a/R02)*(1.d0+a/R02))
+ & -R0*sqrt((1.d0-a/R0)*(1.d0+a/R0)))
+ dls=dls+dll
+ if (dls.ge.adl) goto 12 !bounded
+ if (j.eq.mxatm+1) goto 12 !infinity reached
+ j2=j
+ if(is.eq.1)j2=j-1
+ dss=depth0(R0,R02,a,j2)
+ ds=ds+dss
+ R0=R02
+ if (hmin.ge.eatm(j)) then
+ is=-is !middle point reached
+ else
+ if ((a.le.RadGrd).and.(j.eq.1)) then !ground
+ dZ=ds
+ iret=2
+ goto 999
+ endif
+ endif
+ j=j+is
+ R02=max(hmin,eatm(j))+Rt
+ enddo
+ 12 continue !bounded an interval
+
+ j2=j
+ if(is.eq.1)j2=j-1
+ ds=ds+depth0(R0,R2,a,j2)
+
+ endif
+
+ dZ=ds
+
+ 999 continue
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'dl2dz out',dl,h2,dZ,d2,iret
+#endif
+ return
+ end
+
+
+c---------------------------------------------------------------
+ double precision function Radius0(RR1,dZ,is,a,ja)
+c---------------------------------------------------------------
+c Radius0 - radius of the ending point (m) corresponding to a given slant depth
+c RR1 - radius of the starting point (m)
+c dZ - slant depth interval (g/cm^2)
+c is - sign for direction (<0 dZ from RR1>Radius0,
+c >0 dZ from Radius0>RR1)
+c a - impact radius (m)
+c ja - atmospheric layer
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ parameter(PRE=1d-5)
+ Rt=radearth
+ R1=RR1
+ ddZ=dZ
+ if(ddZ.eq.0d0)then
+ Radius0=R1
+ return
+ endif
+ s=dble(is)
+ R2=R1
+ j=abs(ja)
+ if (a.gt.R1) then
+ write(*,*) 'dZ, RR1,a', dZ, RR1, a
+ stop 'Radius0: incorrect input R<a!'
+ endif
+ do i=0,100 !typiquement <5
+ R1=R2
+ if(j.eq.mxatm)then !linear evolution
+ x2=s*ddz*sqrt((R1-a)*(R1+a))/R1*catm(mxatm)/batm(mxatm)
+ R2=R1+x2
+ if(ja.lt.0.and.
+ & (R2.lt.eatm(mxatm)+Rt.or.R2.gt.eatm(mxatm+1)+Rt))then !IF NONSENSE ASKED (NOT IN THE SAME LAYER ANYMORE)
+ R2=-1.d0
+ goto 1
+ endif
+ else
+ if (abs(1.d0-a/R1).lt.1d-3) then
+ x2=R1*sqrt((1d0-a/R1)*(1d0+a/R1))
+ & +s*ddZ*exp(bbatm(j)*(R1-Rt))*catm(j)/batm(j)
+ if(ja.lt.0.and.x2.lt.0.d0)then !if non-sense asked ...
+ R2=-1.d0
+ goto 1
+ else
+ x2=abs(x2)
+ R2=(x2+a)*sqrt(1.d0-2.d0*x2/a/(x2/a+1.d0)**2)
+ endif
+ else
+ AI=-bbatm(j)*sqrt((R1-a)*(R1+a))*s*ddZ/R1
+ & +exp(-bbatm(j)*(R1-Rt))*batm(j)*bbatm(j)
+ if(AI.le.0.d0.and.ja.lt.0)then !if non-sense asked ...
+ R2=-1.d0
+ goto 1
+ else
+ R2=Rt+(ccatm(j)-log(AI))*catm(j)
+ endif
+ endif
+ endif
+ R2=max(a,R2)
+ if (abs(R1-R2).lt.1.d-15) goto 1
+ ddZ=ddZ-depth0(R1,R2,a,j)
+ if (ddZ.le.0.d0) then
+ s=-s
+ ddZ=-ddZ
+ endif
+ if (ddZ/dZ.lt.pre) goto 1
+ enddo
+#ifdef __CXDEBUG__
+ if (ddZ/dZ.ge.pre.and.ddZ.gt.1.d0)
+ &write(*,*)'Warning in Radius0',ddZ,dZ,RR1-Rt,a-Rt,eatm(j)
+ & ,R1-Rt,R2-Rt,depth0(RR1,max(a,eatm(j)+Rt),a,j)
+#endif
+ 1 Radius0=R2
+ return
+ end
+
+c---------------------------------------------------------------
+ double precision function depth0(RR1,RR2,a,j)
+c---------------------------------------------------------------
+c Optimized for speed ... not the best precision !
+c depth0 - slant depth interval (g/cm^2) between to point defined by their
+c radius
+c RR1 - radius of the starting point (m)
+c RR2 - radius of the ending point (m)
+c a - impact radius (m)
+c j - atmospheric layer
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ Rt=radearth
+ RM=Rt+eatm(mxatm+1)
+ R1=min(RR1,RR2)
+ R2=min(max(RR1,RR2),RM)
+ if (abs(a-R1).lt.1.d-6) then
+ R1=a
+ endif
+ if (a.gt.R1) then
+ write(*,*) 'RR12,a', RR2,RR1, a
+c b=0.d0
+c c=a/b
+ stop 'depth0: incorrect input R<a!'
+ elseif(abs(R1-R2).lt.1.d-10)then
+ depth0=0.d0
+ return
+ endif
+ if(j.eq.mxatm)then !linear evolution
+ depth0= batm(5) * abs(sqrt((R2-a)*(R2+a))-sqrt((R1-a)*(R2+a)))
+ & / catm(5)
+ else
+ R2=min(R2,Rt+eatm(mxatm))
+ rxx1=(R1-a)*(1.d0+a/R1)*0.5d0
+ rxx2=(R2-a)*(R2+a)/R1*0.5d0
+ depth0=exp(-bbatm(j)*(R1-Rt-Rxx1))*batm(j)*bbatm(j)*
+ & (gammq(bbatm(j)*rxx1)-
+ & gammq(bbatm(j)*rxx2))*
+ & sqrt(R1*catm(j))*1.253314137d0 !=sqrt(pi/2)
+
+
+
+ corr=(abs(rxx2-rxx1)/abs(R2-R1)-1.d0)/3.3604d0 !factor fixed to have Z(0 m)=depth(0) for theta=0 deg
+
+ depth0=depth0*(1.d0+corr) !to correct for the approx. on R1-R2 in the integral
+
+ endif
+
+ end
+
+c---------------------------------------------------------------
+ double precision function deptht(dist,radt)
+c---------------------------------------------------------------
+c 5 layers interface to depth0
+c deptht - slant depth corresp. to given slant distance (interpolation)(g/cm^2)
+c dist - slant distance to the obs level (m)
+c radt - impact radius (m)
+c Original work from V. Chernatkin - modified by T. Pierog (07.2004)
+c---------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ Rt=radearth
+ Rmax=Rt+eatm(mxatm+1)
+ s=0.d0
+ xx=abs(dist)
+ a=radt
+ if (a.lt.RadGrd) xx=xx+sqrt((RadGrd-a)*(RadGrd+a))
+ R1=Rmax
+ if(xx.lt.a)then
+ R02=(xx+a)*sqrt(1.d0-2.d0*xx/a/(xx/a+1.d0)**2)
+ else
+ R02=(xx+a)*sqrt(1.d0-2.d0*a/xx/(a/xx+1.d0)**2)
+ endif
+ i=mxatm
+ do
+ R2=max(eatm(i)+Rt, a)
+ xi=sqrt((R2-a)*(R2+a))
+ if (xi.le.xx) goto 10
+ s=s+depth0(R1,R2,a,i)
+ R1=R2
+ if (eatm(i).lt.a-RadGrd) goto 10
+ i=i-1
+ enddo
+ 10 s=s+depth0(R1,R02,a,i)
+ deptht=s+dphmin0
+ end
+
+
+c-----------------------------------------------------------------------
+ double precision function depth(h)
+c-----------------------------------------------------------------------
+c vertical Depth in g/cm^2 for a given altitude h in m
+c (used to calculate vertical depth in EGS4 for Sternheimer correction)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ if ( h .lt. eatm(2) ) then
+ depth = aatm(1) + batm(1) * exp ( -h / catm(1) )
+ elseif ( h .lt. eatm(3) ) then
+ depth = aatm(2) + batm(2) * exp ( -h / catm(2) )
+ elseif ( h .lt. eatm(4) ) then
+ depth = aatm(3) + batm(3) * exp ( -h / catm(3) )
+ elseif ( h .lt. eatm(5) ) then
+ depth = aatm(4) + batm(4) * exp ( -h / catm(4) )
+ else
+ depth = aatm(5) - batm(5) * h / catm(5)
+ endif
+c depth=1030.0*exp(-h/6400.0)
+ end
+
+c-----------------------------------------------------------------------
+ double precision function height(X)
+c-----------------------------------------------------------------------
+c height in m for a given vertical depth X in g/cm^2
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ if ( X .gt. datm(1) ) then
+ height = catm(1) * log ( batm(1) / (X - aatm(1)) )
+ elseif ( X .gt. datm(2) ) then
+ height = catm(2) * log ( batm(2) / (X - aatm(2)) )
+ elseif ( X .gt. datm(3) ) then
+ height = catm(3) * log ( batm(3) / (X - aatm(3)) )
+ elseif ( X .gt. datm(4) ) then
+ height = catm(4) * log ( batm(4) / (X - aatm(4)) )
+ else
+ height = (aatm(5) - X) * catm(5) / batm(5)
+ endif
+c height=-6400.0*log(x/1030.)
+ end
+
+c-----------------------------------------------------------------------
+ double precision function rhoair(h)
+c-----------------------------------------------------------------------
+c air density in g/(cm^2 m) for a height h in meter
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ if ( h .lt. eatm(2) ) then
+ rhoair = batm(1) / catm(1) * exp ( -h / catm(1) )
+ elseif ( h .lt. eatm(3) ) then
+ rhoair = batm(2) / catm(2) * exp ( -h / catm(2) )
+ elseif ( h .lt. eatm(4) ) then
+ rhoair = batm(3) / catm(3) * exp ( -h / catm(3) )
+ elseif ( h .lt. eatm(5) ) then
+ rhoair = batm(4) / catm(4) * exp ( -h / catm(4) )
+ else
+ rhoair = batm(5) / catm(5)
+ endif
+
+c rhoair = 1030.0/6400.*exp(-h/6400.0)
+ end
+
+c-----------------------------------------------------------------------
+ double precision function rhoaiX(X)
+c-----------------------------------------------------------------------
+c argument is vertical depth (g/cm^2)
+c units are g/(cm^2 m)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ if ( X .gt. datm(1) ) then
+ rhoaiX = (X - aatm(1)) / catm(1)
+ elseif ( X .gt. datm(2) ) then
+ rhoaiX = (X - aatm(2)) / catm(2)
+ elseif ( X .gt. datm(3) ) then
+ rhoaiX = (X - aatm(3)) / catm(3)
+ elseif ( X .gt. datm(4) ) then
+ rhoaiX = (X - aatm(4)) / catm(4)
+ else
+ rhoaiX = batm(5) / catm(5)
+ endif
+c rhoaiX = X/6400.
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine FromObs(ep,S0X,C0X,S0,C0)
+c-----------------------------------------------------------------------
+c projection from the obser.' frame (X Y Z) to the frame (x y z).
+c reduced form of the product of the coordinates with a transformation
+c matrix defined as :
+c | sinphi -costhet*cosphi -sinthet*cosphi |
+c (x y z) = (X Y Z) . | -cosphi -costhet*sinphi -sinthet*sinphi |
+c | 0 sinthet -costhet |
+c where theta and phi are defined like the shower axis angles.
+c It's not the standart inverse transformation because Euler_theta is
+c here = (pi-theta) and Euler_phi is here = (phi-pi/2).
+c Author : T. Pierog - 17.11.2004
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension ep(3),ep1(3)
+ EP1(3)=EP(3)
+ EP1(2)=-EP(1)*C0X-EP(2)*S0X
+ EP1(1)=EP(1)*S0X-EP(2)*C0X
+
+ EP(1)=EP1(1)
+ EP(2)=EP1(2)*C0+EP1(3)*S0
+ EP(3)=EP1(2)*S0-EP1(3)*C0
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ToObs(ep,S0X,C0X,S0,C0)
+c-----------------------------------------------------------------------
+c projection from the (x y z) frame to the obser.' frame (X Y Z).
+c reduced form of the product of the coordinates with a transformation
+c matrix defined as :
+c | sinphi -cosphi 0 |
+c (X Y Z) = (x y z) . | -costhet*cosphi -costhet*sinphi sinthet |
+c | -sinthet*cosphi -sinthet*sinphi -costhet |
+c where theta and phi are defined like the shower axis angles.
+c It's not the standart transformation because Euler_theta is
+c here = (pi-theta) and Euler_phi is here = (phi-pi/2)
+c Author : T. Pierog - 17.11.2004
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension ep(3),ep1(3)
+ EP1(3)=EP(1)
+ EP1(2)=-EP(2)*C0-EP(3)*S0
+ EP1(1)=EP(2)*S0-EP(3)*C0
+
+ EP(3)=EP1(1)
+ EP(1)=EP1(2)*C0X+EP1(3)*S0X
+ EP(2)=EP1(2)*S0X-EP1(3)*C0X
+ end
+
+
+C=======================================================================
+
+ SUBROUTINE CXDEFROT(EP,S0X,C0X,S0,C0)
+c-----------------------------------------------------------------------
+c Determination of the parameters for a spacial rotation to the lab. system
+c for 3-vector EP (to get pt=0).
+c output : Euler angles :
+c C0X = cos phi,
+c S0X = sin phi,
+c C0 = cos theta,
+c S0 = sin theta.
+c Adapted by T. Pierog from subroutine PSDEFROT from qgsjet model - 17.09.2003
+c and updated to standart Euler rotation the 17.11.2004.
+c-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+#include "conex.h"
+ DIMENSION EP(3)
+
+#ifdef __CXDEBUG__
+ IF(isx.GE.9)WRITE (ifck,201)EP
+201 FORMAT(2X,'CXDEFROT - SPACIAL ROTATION PARAMETERS'/4X,
+ * '4-VECTOR EP=',2X,3(E10.3,1X))
+#endif
+c Transverse momentum square for the current particle (EP)
+ PT2=EP(1)**2+EP(2)**2
+ IF(PT2.NE.0.D0)THEN
+ PT=DSQRT(PT2)
+c System rotation to get Pt=0 - Euler angles are determined (C0 = cos theta,
+c S0 = sin theta, C0 = cos phi, S0 = sin phi)
+ C0X=EP(2)/PT
+ S0X=EP(1)/PT
+c Total momentum
+ PL=DSQRT(PT2+EP(3)**2)
+ S0=PT/PL
+ C0=EP(3)/PL
+ ELSE
+ C0X=1.D0
+ S0X=0.D0
+ PL=ABS(EP(3))
+ S0=0.D0
+ C0=EP(3)/PL
+ ENDIF
+
+ EP(3)=PL
+ EP(1)=0.D0
+ EP(2)=0.D0
+#ifdef __CXDEBUG__
+ IF(isx.GE.9)WRITE (ifck,202)S0X,C0X,S0,C0,EP
+202 FORMAT(2X,'CXDEFROT: SPACIAL ROTATION PARAMETERS'/
+ * 4X,'S0X=',E10.3,2X,'C0X=',E10.3,2X,'S0=',E10.3,2X,'C0=',E10.3/
+ * 4X,'ROTATED 4-VECTOR EP=',3(E10.3,1X))
+#endif
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXROTAT(EP,S0X,C0X,S0,C0)
+c-----------------------------------------------------------------------
+c Spacial rotation to the lab. system for 3-vector EP
+c input : Euler angles :
+c C0X = cos phi,
+c S0X = sin phi,
+c C0 = cos theta,
+c S0 = sin theta.
+c Adapted by T. Pierog from subroutine PSROTAT from qgsjet model - 17.09.2003
+c and updated to standart Euler rotation the 17.11.2004 :
+c reduced form of the product of the coordinates with a transformation
+c matrix defined as :
+c | cosphi -sinphi 0 |
+c (X Y Z) = (x y z) . | costhet*sinphi costhet*cosphi -sinthet |
+c | sinthet*sinphi sinthet*cosphi costhet |
+c where theta and phi are the Euler angles (0< is trigonometric direction)
+c to go from (x y z) to (X Y Z)
+c-----------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+#include "conex.h"
+ DIMENSION EP(3),EP1(3)
+
+#ifdef __CXDEBUG__
+ IF(isx.GE.9)WRITE (ifck,201)EP,S0X,C0X,S0,C0
+201 FORMAT(2X,'CXROTAT - SPACIAL ROTATION:'/4X,
+ * '4-VECTOR EP=',3(E10.3,1X)/4X,'S0X=',E10.3,'C0X=',E10.3,
+ * 2X,'S0=',E10.3,'C0=',E10.3)
+#endif
+ EP1(3)=EP(1)
+ EP1(2)=EP(3)*S0+EP(2)*C0
+ EP1(1)=EP(3)*C0-EP(2)*S0
+
+ EP(3)=EP1(1)
+ EP(1)=EP1(2)*S0X+EP1(3)*C0X
+ EP(2)=EP1(2)*C0X-EP1(3)*S0X
+#ifdef __CXDEBUG__
+ IF(isx.GE.9)WRITE (ifck,202)EP
+202 FORMAT(2X,'CXROTAT: ROTATED 4-VECTOR EP=',
+ * 2X,3E10.3)
+#endif
+ RETURN
+ END
+
+c-------------------------------------------------------------------
+ subroutine getw(word)
+c-------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character word*(*)
+ parameter(mempty=2)
+ character*1 empty(mempty)
+ character line*1000
+ character*2 mrk
+ data empty/' ',','/
+ save i,j,line
+
+ if(word(1:5).eq.'init ')then
+ j=1000
+ return
+ else
+ i=j
+ goto 1
+ endif
+
+ 5 continue
+#ifdef __CXSUB__
+ read(isubin,'(a1000)',end=9999)line
+#else
+ read(*,'(a1000)',end=9999)line
+#endif
+ kmax=80
+ do k=81,1000
+ if(line(k:k).ne.' ')kmax=k
+ enddo
+ if(line(1:10).eq.'NexusInput'.or.
+ & line(1:13).eq.'EndNexusInput'.or.
+ & line(1:9) .eq.'EposInput'.or.
+ & line(1:12).eq.'EndEposInput'.or.
+ & lwrite)write(6,'(a)')line(1:kmax)
+ if(lheader)then
+ write(ifout,'(2a)')'!',line(1:kmax) !write header in output file
+ if(ifout.ne.ifda.and.ifda.gt.0)
+ & write(ifda,'(2a)')'!',line(1:kmax) !write header in data file
+ if(line(1:10).eq.'NexusInput')then
+ write(ifout,'(a)')'! Cannot be written here...'
+ write(ifout,'(a)')'!EndNexusInput'
+ if(ifout.ne.ifda.and.ifda.gt.0)then
+ write(ifda,'(a)')'! Cannot be written here...'
+ write(ifda,'(a)')'!EndNexusInput'
+ endif
+ endif
+ if(line(1:10).eq.'EposInput')then
+ write(ifout,'(a)')'! Cannot be written here...'
+ write(ifout,'(a)')'!EndEposInput'
+ if(ifout.ne.ifda.and.ifda.gt.0)then
+ write(ifda,'(a)')'! Cannot be written here...'
+ write(ifda,'(a)')'!EndEposInput'
+ endif
+ endif
+ endif
+ i=0
+
+ 1 i=i+1
+ if(i.gt.1000)goto 5
+ if(line(i:i).eq.'!')goto 5
+ do ne=1,mempty
+ if(line(i:i).eq.empty(ne))goto 1
+ enddo
+
+ mrk=' '
+ if(line(i:i+1).eq.'"{')mrk='}"'
+ if(line(i:i+1).eq.'""')mrk='""'
+ if(mrk.ne.' ')goto 10
+ if(line(i:i).eq.'"')goto 8
+ j=i-1
+ 6 j=j+1
+ if(j.gt.1000)goto 7
+ if(line(j:j).eq.'!')goto 7
+ do ne=1,mempty
+ if(line(j:j).eq.empty(ne))goto 7
+ enddo
+ goto 6
+
+ 8 continue
+ if(i.ge.999)stop'STOP: syntax error (getw)'
+ i=i+1
+ j=i
+ if(line(j:j).eq.'"')stop'STOP: syntax error (getw)'
+ 9 j=j+1
+ if(j.gt.1000)goto 7
+ if(line(j:j).eq.'"')then
+ line(i-1:i-1)=' '
+ line(j:j)=' '
+ goto 7
+ endif
+ goto 9
+
+ 10 continue
+ if(i.ge.997)stop'STOP: syntax error (utword)'
+ i=i+2
+ j=i
+ if(line(j:j+1).eq.mrk)stop'STOP: syntax error (utword)'
+ 11 j=j+1
+ if(j+1.gt.1000)goto 7
+ if(line(j:j+1).eq.mrk)then
+ line(i-2:i-1)=' '
+ line(j:j+1)=' '
+ goto 7
+ endif
+ goto 11
+
+ 7 j=j-1
+ if(abs(j-i).ge.500)then
+ print *,'Oops ! Increase dimension of word to more than:',j-i
+ stop
+ endif
+ word=line(i:j)//' '
+ return
+
+9999 word='stop'
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function getvalue()
+c-----------------------------------------------------------------------
+ character word*500
+ call getw(word)
+ read(word,*) getvalue
+ end
+
+
+#ifdef __CXDEBUG__
+c-----------------------------------------------------------------------
+ subroutine utisx1(text,isxx)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ character*(*) text
+ isxsave=isx
+ isxxsave=isxx
+ textisx=text
+ ix=index(text,' ')-1
+ if(nisx.gt.0)then
+ do nr=1,nisx
+ ixs=index(subisx(nr),' ')-1
+ if(subisx(nr)(1:ixs).eq.text(1:ix))isx=isxsub(nr)
+ enddo
+ endif
+ if(isx.ge.isxx)then
+ write(ifck,'(1x,80a)')
+ * ('-',i=1,10),' entry ',text(1:ix),' ',('-',i=1,30)
+ endif
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine utisx2
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ if(isx.ge.isxxsave)then
+ write(ifck,'(1x,47a)')
+ * ('-',i=1,30),' exit ',('-',i=1,11)
+ endif
+ isx=isxsave
+ return
+ end
+
+#endif
+
+c-----------------------------------------------------------------------
+ function cxrangen(dummy)
+c-----------------------------------------------------------------------
+c generates a safe random number simple precision
+c (for EGS4 and gheisha : with argument)
+c-----------------------------------------------------------------------
+ double precision dummy,drangen
+ 1 cxrangen=real(drangen(dummy))
+ if(cxrangen.le.0..or.cxrangen.ge.1.)goto 1
+ return
+ end
+
+
+#ifndef __CXCORSIKA__
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DRANGEN(dummy)
+
+C-----------------------------------------------------------------------
+C RAN(DOM NUMBER) GEN(ERATOR) USED IN CONEX FOR HADRONS
+C
+C If calling this function within a DO-loop
+C you should use an argument which prevents (dummy) to draw this function
+C outside the loop by an optimizing compiler.
+C
+C CHANGES : D. HECK IK3 FZK KARLSRUHE
+C ADAPTATION : T. PIEROG IK3 FZK KARLSRUHE
+C DATE : NOV 24, 2003
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision uni(1),dummy!,dum
+C-----------------------------------------------------------------------
+
+ call RMMARD( uni(1),1,lseq)
+c dum=dummy !floating point exception for some compilers ???
+ DRANGEN = UNI(1)
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DRANEGS(dummy)
+
+C-----------------------------------------------------------------------
+C RAN(DOM NUMBER) GEN(ERATOR) USED IN CONEX FOR EGS4
+C
+C If calling this function within a DO-loop
+C you should use an argument which prevents (dummy) to draw this function
+C outside the loop by an optimizing compiler.
+C
+C CHANGES : D. HECK IK3 FZK KARLSRUHE
+C ADAPTATION : T. PIEROG IK3 FZK KARLSRUHE
+C DATE : NOV 24, 2003
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision uni(1),dummy!,dum
+C-----------------------------------------------------------------------
+
+ call RMMARD( uni(1),1,lseq)
+c dum=dummy !floating point exception for some compilers ???
+ DRANEGS = UNI(1)
+
+ RETURN
+ END
+
+
+c-----------------------------------------------------------------------
+ subroutine ranfgt(seed)
+c-----------------------------------------------------------------------
+c Initialize seed in neXus/EPOS : read seed (output)
+c Since neXus/EPOS original seed and conex (from Corsika) seed are different,
+c define neXus/EPOS seed as : seed=ISEED(3)*1E9+ISEED(2)
+c but only for printing. Important values stored in /cxransto/
+c Important : to be call before ranfst
+c-----------------------------------------------------------------------
+ IMPLICIT NONE
+#include "conex.h"
+ INTEGER KSEQ
+ PARAMETER (KSEQ = 3)
+ COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
+ DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
+ INTEGER MODCNS
+ COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
+ DOUBLE PRECISION C(KSEQ),U(97,KSEQ)
+ INTEGER IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
+ * NTOT(KSEQ),NTOT2(KSEQ),JSEQ
+ common/cxransto/diu0(100),iiseed(3,2)
+ double precision seed,diu0
+ integer iiseed,i
+
+ iiseed(1,LSEQ)=IJKL(LSEQ)
+ iiseed(2,LSEQ)=NTOT(LSEQ)
+ iiseed(3,LSEQ)=NTOT2(LSEQ)
+ seed=dble(iiseed(3,LSEQ))*dble(MODCNS)+dble(iiseed(2,LSEQ))
+ diu0(1)=C(LSEQ)
+ do i=2,98
+ diu0(i)=U(i-1,LSEQ)
+ enddo
+ diu0(99)=dble(I97(LSEQ))
+ diu0(100)=dble(J97(LSEQ))
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ranfst(seed)
+c-----------------------------------------------------------------------
+c Initialize seed in nexus : restore seed (input)
+c Since nexus original seed and conex (from Corsika) seed are different,
+c define nexus seed as : seed=ISEED(3)*1E9+ISEED(2)
+c but only for printing. Important values restored from /cxransto/
+c Important : to be call after ranfgt
+c-----------------------------------------------------------------------
+ IMPLICIT NONE
+#include "conex.h"
+ INTEGER KSEQ
+ PARAMETER (KSEQ = 3)
+ COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
+ DOUBLE PRECISION C(KSEQ),U(97,KSEQ)
+ INTEGER IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
+ * NTOT(KSEQ),NTOT2(KSEQ),JSEQ
+ common/cxransto/diu0(100),iiseed(3,2)
+ double precision seed,diu0,dum
+ integer iiseed,i
+
+ dum=seed
+ IJKL(LSEQ)=iiseed(1,LSEQ)
+ NTOT(LSEQ)=iiseed(2,LSEQ)
+ NTOT2(LSEQ)=iiseed(3,LSEQ)
+ C(LSEQ)=diu0(1)
+ do i=2,98
+ U(i-1,LSEQ)=diu0(i)
+ enddo
+ I97(LSEQ)=nint(diu0(99))
+ J97(LSEQ)=nint(diu0(100))
+ return
+ end
+
+*CMZ : 26/06/2003 10.43.00 by D. HECK IK FZK KARLSRUHE
+*-- Author : D. HECK IK FZK KARLSRUHE 17/03/2003
+C=======================================================================
+
+ SUBROUTINE RMMARD( RVEC,LENV,ISEQ )
+
+C-----------------------------------------------------------------------
+C C(ONE)X
+C R(ANDO)M (NUMBER GENERATOR OF) MAR(SAGLIA TYPE) D(OUBLE PRECISION)
+C
+C THESE ROUTINES (RMMARD,RMMAQD) ARE MODIFIED VERSIONS OF ROUTINES
+C FROM THE CERN LIBRARIES. DESCRIPTION OF ALGORITHM SEE:
+C http://consult.cern.ch/shortwrups/v113/top.html
+C IT HAS BEEN CHECKED THAT RESULTS ARE BIT-IDENTICAL WITH CERN
+C DOUBLE PRECISION RANDOM NUMBER GENERATOR RMM48, DESCRIBED IN
+C http://consult.cern.ch/shortwrups/v116/top.html
+C ARGUMENTS:
+C RVEC = DOUBLE PREC. VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS
+C LENV = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED)
+C ISEQ = # OF RANDOM SEQUENCE
+C
+C VERSION OF D. HECK FOR DOUBLE PRECISION RANDOM NUMBERS.
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003
+ INTEGER KSEQ
+ PARAMETER (KSEQ = 3)
+ COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
+ DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
+ INTEGER MODCNS
+*CMZ : 06/05/2003 15.15.20 by D. HECK IK FZK KARLSRUHE
+*-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003
+ COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
+ DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
+ INTEGER IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
+ * NTOT(KSEQ),NTOT2(KSEQ),JSEQ
+
+ DOUBLE PRECISION RVEC(*)
+ INTEGER ISEQ,IVEC,LENV
+ SAVE
+
+C-----------------------------------------------------------------------
+
+ IF ( ISEQ .GT. 0 .AND. ISEQ .LE. KSEQ ) JSEQ = ISEQ
+
+ DO IVEC = 1, LENV
+ UNI = U(I97(JSEQ),JSEQ) - U(J97(JSEQ),JSEQ)
+ IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0
+ U(I97(JSEQ),JSEQ) = UNI
+ I97(JSEQ) = I97(JSEQ) - 1
+ IF ( I97(JSEQ) .EQ. 0 ) I97(JSEQ) = 97
+ J97(JSEQ) = J97(JSEQ) - 1
+ IF ( J97(JSEQ) .EQ. 0 ) J97(JSEQ) = 97
+ C(JSEQ) = C(JSEQ) - CD
+ IF ( C(JSEQ) .LT. 0.D0 ) C(JSEQ) = C(JSEQ) + CM
+ UNI = UNI - C(JSEQ)
+ IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0
+C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE.
+ IF ( UNI .EQ. 0.D0 ) UNI = TWOM48
+ RVEC(IVEC) = UNI
+ ENDDO
+
+ NTOT(JSEQ) = NTOT(JSEQ) + LENV
+ IF ( NTOT(JSEQ) .GE. MODCNS ) THEN
+ NTOT2(JSEQ) = NTOT2(JSEQ) + 1
+ NTOT(JSEQ) = NTOT(JSEQ) - MODCNS
+ ENDIF
+
+ RETURN
+ END
+
+*CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE
+*-- Author : The CORSIKA development group 21/04/94
+C=======================================================================
+
+ SUBROUTINE RMMAQD( ISEED,ISEQ,CHOPT )
+
+C-----------------------------------------------------------------------
+C C(ONEX)X
+C R(ANDO)M (NUMBER GENERATOR OF) MA(RSAGLIA TYPE INITIALIZATION)
+C
+C SUBROUTINE FOR INITIALIZATION OF RMMARD
+C THESE ROUTINE RMMAQD IS A MODIFIED VERSION OF ROUTINE RMMAQ FROM
+C THE CERN LIBRARIES. DESCRIPTION OF ALGORITHM SEE:
+C http://consult.cern.ch/shortwrups/v113/top.html
+C FURTHER DETAILS SEE SUBR. RMMARD
+C ARGUMENTS:
+C ISEED = SEED TO INITIALIZE A SEQUENCE (3 INTEGERS)
+C ISEQ = # OF RANDOM SEQUENCE
+C CHOPT = CHARACTER TO STEER INITIALIZE OPTIONS
+C
+C CERN PROGLIB# V113 RMMAQ .VERSION KERNFOR 1.0
+C ORIG. 01/03/89 FCA + FJ
+C ADAPTATION : T. PIEROG IK3 FZK KARLSRUHE
+C DATE : SEP 18, 2003
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003
+ INTEGER KSEQ
+ PARAMETER (KSEQ = 3)
+ COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
+ DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
+ INTEGER MODCNS
+*CMZ : 06/05/2003 15.15.20 by D. HECK IK FZK KARLSRUHE
+*-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003
+ COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
+ DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
+ INTEGER IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
+ * NTOT(KSEQ),NTOT2(KSEQ),JSEQ
+
+ DOUBLE PRECISION CC,S,T,UU(97)
+ INTEGER ISEED(3),I,IDUM,II,II97,IJ,IJ97,IORNDM,
+ * ISEQ,J,JJ,K,KL,L,LOOP2,M,NITER
+ CHARACTER CHOPT*(*), CCHOPT*12
+ LOGICAL FIRST
+ SAVE
+ DATA FIRST / .TRUE. /, IORNDM/11/, JSEQ/1/
+
+
+C-----------------------------------------------------------------------
+
+ IF ( FIRST ) THEN
+ TWOM24 = 2.D0**(-24)
+ TWOM48 = 2.D0**(-48)
+ CD = 7654321.D0*TWOM24
+ CM = 16777213.D0*TWOM24
+ CINT = 362436.D0*TWOM24
+ MODCNS = 1000000000
+ FIRST = .FALSE.
+ ENDIF
+
+ CCHOPT = CHOPT
+ IF ( CCHOPT .EQ. ' ' ) THEN
+ ISEED(1) = 54217137
+ ISEED(2) = 0
+ ISEED(3) = 0
+ CCHOPT = 'S'
+ JSEQ = 1
+ ENDIF
+
+ IF ( INDEX(CCHOPT,'S') .NE. 0 ) THEN
+ IF ( ISEQ .GT. 0 .AND. ISEQ .LE. KSEQ ) JSEQ = ISEQ
+ IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN
+ READ(IORNDM,'(3Z8)') IJKL(JSEQ),NTOT(JSEQ),NTOT2(JSEQ)
+ READ(IORNDM,'(2Z8,Z16)') I97(JSEQ),J97(JSEQ),C(JSEQ)
+ READ(IORNDM,'(24(4Z16,/),Z16)') U
+ IJ = IJKL(JSEQ)/30082
+ KL = IJKL(JSEQ) - 30082 * IJ
+ I = MOD(IJ/177, 177) + 2
+ J = MOD(IJ, 177) + 2
+ K = MOD(KL/169, 178) + 1
+ L = MOD(KL, 169)
+ CD = 7654321.D0 * TWOM24
+ CM = 16777213.D0 * TWOM24
+ ELSE
+ IJKL(JSEQ) = ISEED(1)
+ NTOT(JSEQ) = ISEED(2)
+ NTOT2(JSEQ) = ISEED(3)
+ IJ = IJKL(JSEQ) / 30082
+ KL = IJKL(JSEQ) - 30082*IJ
+ I = MOD(IJ/177, 177) + 2
+ J = MOD(IJ, 177) + 2
+ K = MOD(KL/169, 178) + 1
+ L = MOD(KL, 169)
+ DO II = 1, 97
+ S = 0.D0
+ T = 0.5D0
+ DO JJ = 1, 48
+ M = MOD(MOD(I*J,179)*K, 179)
+ I = J
+ J = K
+ K = M
+ L = MOD(53*L+1, 169)
+ IF ( MOD(L*M,64) .GE. 32 ) S = S + T
+ T = 0.5D0 * T
+ ENDDO
+ UU(II) = S
+ ENDDO
+ CC = CINT
+ II97 = 97
+ IJ97 = 33
+C COMPLETE INITIALIZATION BY SKIPPING (NTOT2*MODCNS+NTOT) RANDOMNUMBERS
+ NITER = MODCNS
+ DO LOOP2 = 1, NTOT2(JSEQ)+1
+ IF ( LOOP2 .GT. NTOT2(JSEQ) ) NITER = NTOT(JSEQ)
+ DO IDUM = 1, NITER
+ UNI = UU(II97) - UU(IJ97)
+ IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0
+ UU(II97) = UNI
+ II97 = II97 - 1
+ IF ( II97 .EQ. 0 ) II97 = 97
+ IJ97 = IJ97 - 1
+ IF ( IJ97 .EQ. 0 ) IJ97 = 97
+ CC = CC - CD
+ IF ( CC .LT. 0.D0 ) CC = CC + CM
+ ENDDO
+ ENDDO
+ I97(JSEQ) = II97
+ J97(JSEQ) = IJ97
+ C(JSEQ) = CC
+ DO JJ = 1, 97
+ U(JJ,JSEQ) = UU(JJ)
+ ENDDO
+ ENDIF
+ ELSEIF ( INDEX(CCHOPT,'R') .NE. 0 ) THEN
+ IF ( ISEQ .GT. 0 ) THEN
+ JSEQ = ISEQ
+ ELSE
+ ISEQ = JSEQ
+ ENDIF
+ IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN
+ WRITE(IORNDM,'(3Z8)') IJKL(JSEQ),NTOT(JSEQ),NTOT2(JSEQ)
+ WRITE(IORNDM,'(2Z8,Z16)') I97(JSEQ),J97(JSEQ),C(JSEQ)
+ WRITE(IORNDM,'(24(4Z16,/),Z16)') U
+ ELSE
+ ISEED(1) = IJKL(JSEQ)
+ ISEED(2) = NTOT(JSEQ)
+ ISEED(3) = NTOT2(JSEQ)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*-- Author : The CORSIKA development group 21/04/1994
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION RANNOR( A,B )
+
+C-----------------------------------------------------------------------
+C RAN(DOM NUMBER) NOR(MALLY DISTRIBUTED)
+C
+C GENERATES NORMAL DISTRIBUTED RANDOM NUMBER
+C DELIVERS 2 UNCORRELATED RANDOM NUMBERS,
+C THEREFORE RANDOM CALLS ARE ONLY NECESSARY EVERY SECOND TIME.
+C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL.,
+C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X
+C ARGUMENTS:
+C A = MEAN VALUE
+C B = STANDARD DEVIATION
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+
+ DOUBLE PRECISION A,B,RR,RD(2)
+ SAVE
+C-----------------------------------------------------------------------
+
+ IF ( KNORdm ) THEN
+ 1 CONTINUE
+ CALL RMMARD( RD,2,lseq )
+ U1rdm = 2.D0*RD(1) - 1.D0
+ U2rdm = 2.D0*RD(2) - 1.D0
+ RR = U1rdm**2 + U2rdm**2
+ IF ( RR .GE. 1.D0 .OR. RR .EQ. 0.D0 ) GOTO 1
+ FACrdm = SQRT( (-2.D0) * LOG(RR) / RR )
+
+ RANNOR = FACrdm * U1rdm * B + A
+ KNORdm = .FALSE.
+ ELSE
+ RANNOR = FACrdm * U2rdm * B + A
+ KNORdm = .TRUE.
+ ENDIF
+
+ RETURN
+ END
+
+C-----------------------------------------------------------------------
+ double precision function dedxIonMC(np,ee,rho)
+C-----------------------------------------------------------------------
+c ionization loss for air from exact formula to be used in MC
+c (units are GeV g-1 cm2)
+C ee particle kinetic energy (GeV)
+C np particle type (-3-magnetic monopole,1-proton,2-ch_pion,3-ch_kaon,9-muon (4-muon for CE) >10 nuclei,<-10 strangelet)
+C rho air density (for Sternheimer correction for muons)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+
+ if(np.eq.4.or.np.eq.9)then
+ XM=PMASS(9)
+ ETOT=EE+XM
+ dedxIonMC = AIRDEDXMU(Etot,XM,rho)
+ if(iMuInt.gt.0.and.np.eq.9)then
+ dedxIonMC = dedxIonMC + CXDEDXM(Etot)
+ endif
+ elseif(np.lt.10.and.np.ge.1)then
+ XM=PMASS(np)
+ ETOT=EE+XM
+ dedxIonMC = AIRDEDX(Etot,XM)
+ elseif(np.eq.-3)then !magnetic monopole
+ XM=PMASSMM
+ ETOT=EE+XM
+ dedxIonMC = AIRDEDXMM(Etot,XM)*(6.8d1)**2
+ elseif(np.le.-10)then !strangelet
+ nucl=abs(np)/10
+ XM=PMASS(8)*dble(nucl)
+ ETOT=EE+XM
+ dedxIonMC = AIRDEDX(Etot,XM)
+ & *dble(nucl)**0.33333d0
+ else !for nuclei
+ nucl=np/10
+ XM=PMASS(7)*dble(nucl)
+ ETOT=EE+XM
+ dedxIonMC = AIRDEDX(Etot,XM)
+ & *dble(int(dble(nucl)/2.15d0+0.7d0))**2
+ endif
+
+ end
+
+
+#endif
+
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION EIONA (EE,XM,ZZ,AA,AION)
+C-----------------------------------------------------------------------
+C Ionization loss of a singly charged particle (units are GeV g-1 cm2)
+C Input EE (GeV) total particle energy
+C XM (GeV) particle mass
+C ZZ Z of medium
+C AA A of medium
+C AION (eV) average ionization potential
+C
+C from CASC, changed to work for arbitrary particles,
+C R.Engel & T.Pierog 07/2003
+C Used in dtables/ionloss.f for tabulation
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ save
+
+ DATA EME /5.110D-04/
+ DATA EME2 /2.61124474D-07/
+ DATA CONST /1.5350649D-04/ ! 2 pi*alpha**2 N_A L_compt**2 m_e
+
+ XM2 = XM*XM
+ EPS2 = (XM/EE)**2
+ P = EE*SQRT(1.D0-EPS2)
+ BETA = P/EE
+ GAMMA = EE/XM
+ EMAX = (2.d0*EME*P*P)/(EME2+XM2+2.d0*EME*EE)
+ T = 2.d0*LOG(BETA*GAMMA/AION) + LOG(2.d0*EME*EMAX)
+ DELTA = 0.d0
+ F = T - 2.d0*BETA*BETA + 0.25d0*(EMAX/EE)**2 - DELTA
+ EIONA = CONST * ZZ/AA * F /(BETA*BETA)
+
+ END
+
+
+
+C-----------------------------------------------------------------------
+ FUNCTION AIRDEDX(E,XM)
+C-----------------------------------------------------------------------
+C ionization loss for air
+C EE total particle energy (GeV)
+C XM particle mass
+C from CORSIKA
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ DATA C22/ 1.532873D-4 /, C23/ 9.386417D0 /
+
+ gam0=E/XM
+ GAM0 = MAX( GAM0, 1.0001D0 )
+ GAMSQ = GAM0**2
+ GMSQM1 = GAMSQ - 1.D0
+ AIRDEDX = C22 * ( GAMSQ * (LOG(GMSQM1)
+ * - 0.5D0 * LOG( GAM0 * 2.D0 * pmass(10)/XM
+ * + 1.D0 + (pmass(10)/XM)**2 )
+ * + C23) / GMSQM1 - 1.D0 )
+
+
+C from CASC, changed to work for arbitrary particles,
+C R.Engel & T.Pierog 07/2003
+C Used in dtables/ionloss.f for tabulation
+c DEDX = 0.d0
+c DO J=1,3
+c F = EIONA(E,XM,airz(J),aira(J), airi(J))
+c DEDX = DEDX + airw(J)*F
+c ENDDO
+c AIRDEDX = DEDX
+c
+ END
+
+C-----------------------------------------------------------------------
+ FUNCTION AIRDEDXMM(E,XM)
+C-----------------------------------------------------------------------
+C ionization loss in air for Magnetic Monopoles
+C E total particle energy (GeV)
+C XM monopole mass
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ DATA C22/ 5.2117682d-3 /, C23/ 9.386417D0 /
+
+ gam0=E/XM
+ GAM0 = MAX( GAM0, 1.0001D0 )
+ GAMSQ = GAM0**2
+ GMSQM1 = GAMSQ - 1.D0
+ AIRDEDXMM = C22 * ( GAMSQ * (LOG(GMSQM1)
+ * - 0.5D0 * LOG( GAM0 * 2.D0 * pmass(10)/XM
+ * + 1.D0 + (pmass(10)/XM)**2 )
+ * + C23) / GMSQM1 - 1.D0 )
+
+ END
+
+
+C-----------------------------------------------------------------------
+ FUNCTION AIRDEDXMU(E,XM,RHO)
+C-----------------------------------------------------------------------
+C ionization loss for air
+C EE total particle energy (GeV)
+C XM particle mass
+C RHO air density
+C from CORSIKA, with Sternheimer correction by Kokoulin (03.2007)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR
+ DATA CDNS1 / 0.020762D-2 /
+ DATA C22/ 1.532873D-4 /, C23/ 9.386417D0 /
+ DATA C16/ 0.00967269633d0 /
+c C16=2d0*pmass(10)/XM
+
+ gam0=E/XM
+ GAM0 = MAX( GAM0, 1.0001D0 )
+ GAMSQ = GAM0**2
+ GMSQM1 = GAMSQ - 1.D0
+C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006)
+ CDNS = CDNS1 * RHO
+ ARGLOG = GMSQM1**2/( (GAM0*C16+1.D0)*(1.D0+GMSQM1*CDNS) )
+ AIRDEDXMU = C22 * ( GAMSQ * (0.5D0*LOG(ARGLOG)+C23)
+ * / GMSQM1 - 1.D0 )
+
+
+
+ END
+
+
+
+
+C=======================================================================
+
+ subroutine Xmax_fit(k1,k2,nsho)
+
+c-----------------------------------------------------------------------
+c perform fits to get the x_max parameter of the profile
+c distributions of the shower nsho for particle k1 to k2
+c (0=all charged, 1=photons, 2=electrons, 3=muons, 4=all hadrons
+c 5=nucleons, 6=ch pions, 7=ch kaons, 8-protons, 9-neutrons, 10-neut K)
+c forms also the average over all fitted x_max and normalized it for
+c nsho=0
+c
+c subroutine called by depthprofile and AddProfile
+c
+c orig : d. heck <heck@ik3.fzk.de> sept. 13, 2000
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> oct. 15, 2003
+c-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON /CXMAXFIT/ CHAPAR,DEP,ERR,NSTP
+ DIMENSION CHAPAR(MAXIMZ),DEP(MAXIMZ),ERR(MAXIMZ)
+
+ dimension fparam(6)
+
+c-----------------------------------------------------------------------
+
+ nstep=nmaxX-nminX+1
+
+ if(nstep.lt.10)return
+
+ do 10 ip=k1,k2 !for each particle
+
+ if(nsho.ge.1)then !for individual shower
+
+c now perform fit to the all charge distribution Xprof(j,1,0) (first cut)
+ xchamax=0d0
+ nstpmx=maximz
+ do j=1,nstep
+ dep(j)=zha(j+nminX-1)
+ if(ip.eq.3)then !for muons use muon production rate
+ chapar(j)=max(XdMu(j+nminX-1),0.d0)
+ else
+ chapar(j)=max(Xprof(j+nminX-1,1,ip),0.d0)
+ endif
+ if(chapar(j).gt.xchamax)xchamax=chapar(j)
+ if(chapar(j).gt.0.01d0*xchamax)nstpmx=j
+ enddo
+c limit fit down to 1% of Nmax to avoid problems with long tails due to muons
+ nstp=min(nstpmx,nstep)
+ call cxlongft(fparam,chi2)
+
+c write(6,8230) fparam
+c 8230 format(' parameters = ',1p,6e12.4)
+c write(6,103)nsho,ip,fparam(3),chi2,chi2/sqrt(fparam(1))*100.d0
+c 103 format(1h ,i6,i2,3e12.4)
+c$$$ write(6,103) nsho,ip,(fparam(j),j=1,6),chi2,
+c$$$ * chi2/sqrt(fparam(1))*100.d0
+c$$$ 103 format(1h ,i6,i2,1p,8e12.4)
+
+ if(fparam(1).lt.1d-1.or.fparam(3).lt.1.d-1)goto 10 !invalide fit
+
+
+ if(ip.eq.0)then
+ do 2 npar=1,6 !parameter fit for ip=0
+ 2 XmaxShow(4,npar)=fparam(npar)
+ endif
+c store the results of fit for later averaging
+ XmaxShow(1,ip)=fparam(3) !x_max
+ XmaxShow(2,ip)=chi2 !chi2
+ XmaxShow(3,ip)=chi2/sqrt(FPARAM(1)) !err
+ if(XmaxShow(1,ip).lt.XmaxP)then !x_max valide if realistic
+ XmaxMean(1,ip)=XmaxMean(1,ip)+XmaxShow(1,ip)
+ XmaxMean(2,ip)=XmaxMean(2,ip)+XmaxShow(1,ip)**2
+ XmaxMean(3,ip)=XmaxMean(3,ip)+1.d0 !nevt
+ if(XmaxShow(1,ip).le.XmaxMean(4,ip)) !x_max min
+ * XmaxMean(4,ip)=XmaxShow(1,ip)
+ if(XmaxShow(1,ip).ge.XmaxMean(5,ip)) !x_max max
+ * XmaxMean(5,ip)=XmaxShow(1,ip)
+ iz=max(1,int((XmaxShow(1,ip)-zshmin)/delzsh)+1)
+ if(iz.le.maximz)XmaxProf(iz,ip)=XmaxProf(iz,ip)+1.d0
+ endif
+c write parameter of the fit in data file
+C N(X) = NMAX * ((X-X0)/(XMAX-X0))**((XMAX-X0)/(P1+P2*X+P3*X**2))
+C * EXP((XMAX-X)/(P1+P2*X+P3*X**2))
+C X = DEPTH IN G/CM**2
+C X0 = STARTING DEPTH OF SHOWER
+C XMAX = DEPTH OF SHOWER MAXIMUM
+C NMAX = PARTICLE NUMBER AT XMAX
+C P1 .. P3 = PARAMETERS OF A POLYNOMIAL DESCRIBING THE WIDTH
+C X1 = REAL FIRST INTERACTION POINT
+ if(ifout.gt.0.and.ifda.gt.0.and.ip.eq.0)then
+ write(ifda,'(/a,2(10x,a2,8x,a4),3(10x,a2),8x,a4)')
+ *'!No shower Eprima(GeV) theta (deg)','X1'
+ *,'NMAX','X0','XMAX','P1','P2','P3','CHI2'
+ *
+ write(ifda,'(i10,1p,10e12.4)')nsho,eprima,thetas,Xfirst
+ * ,(fparam(k),k=1,6),chi2
+ endif
+
+ else !averaging on valid x_max
+ nevt=max(nint(XmaxMean(3,ip)),1)
+ xnorm=1.d0/dble(nevt)
+ if(nevt.gt.1)then
+ XmaxMean(2,ip)=sqrt(max(0.d0,
+ * (XmaxMean(2,ip)-XmaxMean(1,ip)**2*xnorm)/dble(nevt-1))) !RMS
+ XmaxMean(1,ip)=XmaxMean(1,ip)*xnorm
+ do iz=nminX,nmaxX
+ XmaxProf(iz,ip)=XmaxProf(iz,ip)*xnorm
+ enddo
+ else
+ XmaxMean(2,ip)=XmaxShow(3,ip)*XmaxShow(1,ip)
+ XmaxMean(1,ip)=XmaxShow(1,ip)
+ endif
+c write info about parameter of the fit in data file
+ if(ifout.gt.0.and.ifda.gt.0.and.ip.eq.0)then
+ write(ifda,'(/a/a/a/a,a/a/a/a/a/a)')
+ * '! where :'
+ *,'! X1 = REAL FIRST INTERACTION POINT'
+ *,'! FIT PARAMETERS GIVEN FOR FUNCTION :'
+ *,'! N(X) = NMAX * ((X-X0)/(XMAX-X0))**((XMAX-X0)'
+ *,'/(P1+P2*X+P3*X**2)) * EXP((XMAX-X)/(P1+P2*X+P3*X**2))'
+ *,'! X = DEPTH IN G/CM**2'
+ *,'! NMAX = PARTICLE NUMBER AT XMAX'
+ *,'! X0 = STARTING DEPTH OF SHOWER'
+ *,'! XMAX = DEPTH OF SHOWER MAXIMUM'
+ *,'! P1 .. P3 = PARAMETERS OF A POLYNOMIAL DESCRIBING THE WIDTH'
+ write(ifda,'(a,2(9x,a))')'! Average Xmax (in g/cm**2)'
+ * ,'Min','Max'
+ write(ifda,'(1p,e12.4,a4,3e12.4)')XmaxMean(1,ip),' +/-'
+ *,XmaxMean(2,ip),XmaxMean(4,ip),XmaxMean(5,ip)
+ endif
+ endif
+
+ 10 enddo
+
+ end
+
+C=======================================================================
+
+ SUBROUTINE CXLONGFT(FPARAM,CHI2)
+
+C-----------------------------------------------------------------------
+C C(one)X LONG(ITUDINAL) F(I)T
+C
+C THIS ROUTINE PERFORMS A FIT TO THE LONGITUDINAL DISTRIBUTION OF AN
+C AIR SHOWER. DUE TO THE LARGE PARTICLE NUMBERS IN AN AIR SHOWER THE
+C STATISTICAL ERRORS ON THE PARTICLE NUMBER AT A GIVEN LEVEL ARE
+C MINUTE. THIS LEADS TO RATHER LARGE CHI**2/DOF FOR THE FITS EVEN IF
+C THE FITTED FUNCTION MATCHES THE POINTS BETTER THAN SAY 1%.
+C KEEP IN MIND THAT FITTING IS A DIFFICULT TASK AND THE RESULTS DO NOT
+C NECESSARILY REPRESENT THE ABOLUTE MINIMUM OR EVEN A GOOD
+C APPROXIMATION.
+C
+C IN A FIRST STEP A 4 PARAMETER FIT IS TRIED BASED ON M. HILLAS' CURVE
+C WITH WIDTH PARAMETER LAMBDA :
+C N(T) = ANMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/P) * EXP((TMAX-T)/P)
+C WITH:
+C ANMAX = PARTICLE NUMBER AT TMAX
+C T = DEPTH IN G/CM**2
+C T0 = STARTING DEPTH OF SHOWER
+C TMAX = DEPTH OF SHOWER MAXIMUM
+C P = WIDTH PARAMETER LAMBDA
+C
+C IN A SECOND STEP WE REFINE THE FIT WITH THE START VALUES FROM THE 4
+C PARAMETER FIT AND USE A 6 PARAMETER FIT BASED ON M. HILLAS' CURVE
+C REPLACING HIS WIDTH PARAMETER LAMBDA BY A POLYNOMIAL OF 3. DEGREE.
+C N(T) = ANMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/(P1+P2*T+P3*T**2))
+C * EXP((TMAX-T)/(P1+P2*T+P3*T**2))
+C WITH:
+C ANMAX = PARTICLE NUMBER AT TMAX
+C T = DEPTH IN G/CM**2
+C T0 = STARTING DEPTH OF SHOWER
+C TMAX = DEPTH OF SHOWER MAXIMUM
+C P1 .. P3 = PARAMETERS OF A POLYNOMIAL DESCRIBING THE WIDTH
+C
+C THIS SUBROUTINE IS CALLED FROM Xmax_fit
+C IN A SECOND STEP WE REFINE THE FIT WITH THE START VALUES FROM THE 4
+C PARAMETER FIT AND USE A 6 PARAMETER FIT BASED ON M. HILLAS' CURVE
+C REPLACING HIS WIDTH PARAMETER LAMBDA BY A POLYNOMIAL OF 3. DEGREE.
+C N(T) = ANMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/(P1+P2*T+P3*T**2))
+C * EXP((TMAX-T)/(P1+P2*T+P3*T**2))
+C WITH:
+C ANMAX = PARTICLE NUMBER AT TMAX
+C T = DEPTH IN G/CM**2
+C T0 = STARTING DEPTH OF SHOWER
+C TMAX = DEPTH OF SHOWER MAXIMUM
+C P1 .. P3 = PARAMETERS OF A POLYNOMIAL DESCRIBING THE WIDTH
+C
+C THIS SUBROUTINE IS CALLED FROM Xmax_fit
+C FPARAM = ARRAY WITH THE FINAL FITTED PARAMETERSTHE 6 PARAMETER
+C CHI2 = CHI SQUARED
+C
+C orig : CORSIKA 6.176
+C Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 1st, 2004
+C-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON /CXMAXFIT/ CHAPAR,DEP,ERR,NSTP
+ DIMENSION CHAPAR(MAXIMZ),DEP(MAXIMZ),ERR(MAXIMZ)
+
+ PARAMETER (NPAR=6)
+ DIMENSION F(NPAR),FPARAM(NPAR),P(NPAR+1,NPAR),Y(NPAR+1)
+ DIMENSION p2(npar-1,npar-2),fparam1(npar-2)
+ EXTERNAL CXCHISQ
+ external cxchisq2
+
+C-----------------------------------------------------------------------
+
+C FIND GOOD START VALUES FOR XMAX AND FMAX
+ ANMAX = 0.D0
+ TMAX = 400.D0
+ imax=0
+ do 99 i=1,npar
+ 99 fparam(i)=0.d0
+ chi2=0.d0
+ DO 2 I=1,NSTP
+ ERR(I) = MAX( 1.D0, SQRT(CHAPAR(I)) )
+ IF ( CHAPAR(I) .GT. ANMAX ) THEN
+ ANMAX = CHAPAR(I)
+ TMAX = DEP(I)
+ imax = i
+ ENDIF
+ 2 CONTINUE
+ if(imax.le.0)return !no particle
+C STARTVALUE FOR X0 IS ABOUT WHERE MORE THAN 1 PARTICLE SHOWS UP
+ II = 1
+ DO 3 I=1,NSTP
+ IF ( CHAPAR(I) .GT. 1.D0 ) GOTO 1
+ II = I
+ 3 CONTINUE
+ II = NSTP
+ 1 CONTINUE
+ IF ( II .GT. 1 ) THEN
+ T0 = 0.5d0 * ( DEP(II) + DEP(II-1) )
+ ELSE
+ T0 = DEP(II)
+ ENDIF
+C FIND A START VALUE FOR THE WIDTH PARAMETER AT HALF OF MAXIMUM
+ if ( nstp. gt. 10 ) then
+ do I = 1,imax
+ if (chapar(I) .gt. 0.5d0 * anmax) then
+ iupper = i
+ goto 31
+ endif
+ enddo
+ iupper = imax - 1
+ 31 continue
+ do I = imax, nstp
+ if (chapar(I) .lt. 0.5d0 * anmax) then
+ ilower = i
+ goto 32
+ endif
+ enddo
+ ilower = nstp - 1
+ 32 continue
+ halfw = (dep(ilower) - dep(iupper))/3.9d0
+ else
+C IF WE HAVE ONLY A FEW POINTS, TAKE AN AVERAGE VALUE FOR THE WIDTH
+ halfw = 70.d0
+ endif
+
+C OBVIOUSLY THE DISTRIBUTION CAN NOT BE FITTED
+ if(HALFW.le.0.D0)then
+#ifndef __CXCORSIKA__
+#ifdef __CXDEBUG__
+ write(ifck,*)
+ * 'CXLONGFT: NEGATIVE WIDTH OF LONGITUDINAL DISTRIBUTION'
+ write (ifck,*)' NO FIT POSSIBLE'
+#endif
+#ifdef __CXSUB__
+ write(ifda,*)
+ * 'CXLONGFT: NEGATIVE WIDTH OF LONGITUDINAL DISTRIBUTION'
+ write (ifda,*)' NO FIT POSSIBLE'
+#endif
+#endif
+ return
+ endif
+
+C-----------------------------------------------------------------------
+C FIT IS PERFORMED WITH THE ROUTINE CXAMOEBA FROM:
+C NUMERICAL RECIPES, W.H. PRESS ET AL.,
+C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X
+C SEE THERE HOW IT HAS TO BE USED.
+
+C WE FIRST FIT THE GAISSER-HILLAS CURVE WITH SIMPLE WIDTH PARAMETER
+C THERFORE THE NUMBER OF FREE PARAMETERS IS SET TO 4 = NPAR-2
+C CREATE A SET OF NPAR-1 STARTING VERTICES
+C HERE IS THE FIRST ONE
+ p2(1,1) = ANMAX
+ p2(1,2) = T0
+ p2(1,3) = TMAX
+ p2(1,4) = HALFW
+c$$$ WRITE(IFCK,*) 'START VALUES = ',(sngl(p2(1,i)),i=1,4)
+ chi21=0.d0
+
+C loop over the fitting routine (2 times 3 fits with varying precision)
+ do 210 j = 1,2
+ do 29 jj = 1,3
+C start with crude precision and improve step by step
+C after five steps enlarge again
+ eps = 10.d0**(-3.d0-jj*0.5d0)
+ fac = 1.d0 + 2.d0**(2.1d0*(1.d0-jj))
+C go as well in different directions
+ if ( j .eq. 2 ) fac = 1.d0/fac
+
+C get other npar2 starting vectors from the starting point by variation
+C of only one of the coordinate values
+ do 25 i=2,npar-1
+ do 24 k=1,npar-2
+ p2(i,k) = p2(1,k)
+ 24 continue
+ if ( p2(i,i-1) .eq. 0.d0 ) then
+ p2(i,i-1) = 1.d0
+ else
+ p2(i,i-1) = p2(i,i-1) * fac
+ endif
+ 25 continue
+c$$$ if (isx.ge.6) then
+c$$$ write(ifck,*) 'longft: trial2,fac2,eps2 ',
+c$$$ * j,fac,eps
+c$$$ endif
+
+C calculate function values at the start vertices
+ do 27 i=1,npar-1
+ do 26 k=1,npar-2
+ f(k) = p2(i,k)
+ 26 continue
+ y(i) = cxchisq2(f)
+ 27 continue
+C perform a fit
+ call cxamoeba(p2,y,npar-1,npar-2,npar-2,eps,cxchisq2,iter,iflag)
+c$$$ if (isx.ge.6) then
+c$$$ write(ifck,*) 'longft: iter/iflag =',iter,iflag
+c$$$ write(ifck,*) 'longft: parameters2=',1,(p2(1,k),k=1,4)
+c$$$ write(ifck,*) 'longft: cxchisq2 =',y(1)
+c$$$ endif
+
+C store values at first trial or at improved result
+ if ( j .eq. 1 .or. y(1) .lt. chi21 ) then
+ do i = 1, npar-2
+ fparam1(i) = p2(1,i)
+ enddo
+ chi21 = y(1)
+ endif
+C end of loops over the fitting routine
+ 29 continue
+ 210 continue
+c$$$ if (isx.ge.6) then
+c$$$ write(ifck,103) (fparam1(i),i=1,4),chi21
+c$$$ 103 format(1h ,6x,1p,4e12.4,24x,e12.4)
+c$$$ endif
+c end of the firts fit with 4 parameters
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C CREATE A SET OF NPAR+1 STARTING VERTICES
+C HERE IS THE FIRST ONE
+ P(1,1) = fparam1(1)
+ P(1,2) = fparam1(2)
+ P(1,3) = fparam1(3)
+ P(1,4) = fparam1(4)
+C P(1,5) = -0.01D0 ! GIVES SOMETIMES EXTREMELY BAD FITS (OCT. 00 DH)
+ P(1,5) = 0.D0
+ P(1,6) = 0.D0
+
+C LOOP OVER THE FITTING ROUTINE (2 TIMES 5 FITS WITH VARYING PRECISION)
+ DO 10 J = 1,2
+ DO 9 JJ = 1,5
+C START WITH CRUDE PRECISION AND IMPROVE STEP BY STEP
+C AFTER FIVE STEPS ENLARGE AGAIN
+ EPS = 10.D0**(-3.D0-JJ*0.5D0)
+ FAC = 1.D0 + 2.D0**(2.1D0*(1.D0-JJ))
+C GO AS WELL IN DIFFERENT DIRECTIONS
+ IF ( J .EQ. 2 ) FAC = 1.D0/FAC
+
+C GET OTHER NPAR STARTING VERTICES FROM THE STARTING POINT BY VARIATION
+C OF ONLY ONE OF THE COORDINATE VALUES
+ DO 5 I=2,NPAR+1
+ DO 4 K=1,NPAR
+ P(I,K) = P(1,K)
+ 4 CONTINUE
+ IF ( P(I,I-1) .EQ. 0.D0 ) THEN
+ P(I,I-1) = 1.D0
+ ELSE
+ P(I,I-1) = P(I,I-1) * FAC
+ ENDIF
+ 5 CONTINUE
+c$$$ IF (ISX.GE.6) WRITE(IFCK,*) 'CXLONGFT: TRIAL,FAC,EPS ',J,FAC,EPS
+
+C CALCULATE FUNCTION VALUES AT THE START VERTICES
+ DO 7 I=1,NPAR+1
+ DO 6 K=1,NPAR
+ F(K) = P(I,K)
+ 6 CONTINUE
+ Y(I) = CXCHISQ(F)
+ 7 CONTINUE
+C PERFORM A FIT
+ CALL CXAMOEBA(P,Y,NPAR+1,NPAR,NPAR,EPS,CXCHISQ,ITER,IFLAG)
+c$$$ IF (ISX.GE.6) THEN
+c$$$ WRITE(IFCK,*) 'CXLONGFT: ITER/IFLAG=',ITER,IFLAG
+c$$$ WRITE(IFCK,*) 'CXLONGFT: PARAMETERS=',1,(P(1,K),K=1,6)
+c$$$ WRITE(IFCK,*) 'CXLONGFT: CXCHISQ =',Y(1)
+c$$$ ENDIF
+
+C STORE VALUES AT FIRST TRIAL OR AT IMPROVED RESULT
+ IF ( J .EQ. 1 .OR. Y(1) .LT. CHI2 ) THEN
+ DO 8 I=1,NPAR
+ FPARAM(I) = P(1,I)
+ 8 CONTINUE
+ CHI2 = Y(1)
+ ENDIF
+C END OF LOOPS OVER THE FITTING ROUTINE
+ 9 CONTINUE
+ 10 CONTINUE
+* hier abfragen, welcher fit besser ist und ggf. den Vier-Parameter Fit
+* uebernehmen.
+
+ RETURN
+ END
+C=======================================================================
+
+ SUBROUTINE CXAMOEBA(P,Y,MP,NP,NDIM,FTOL,FUNK,ITER,IFLAG)
+
+C-----------------------------------------------------------------------
+C
+C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL.,
+C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X
+C ADAPTED FOR DOUBLE PRECISION
+C USES AMOTRY,FUNK
+C THIS SUBROUTINE IS CALLED FROM CXLONGFT
+C P = ARRAY (NPAR+1,NPAR) WITH PARAMETERS FOR FIT
+C Y = ARRAY WITH ERRORS
+C MP = NUMBER NPAR+1
+C NDIM = NUMBER NPAR OF FREE VARIABLES
+C FTOL = TOLERANCE OF FIT
+C FUNK = EXTERNAL FUNKTION (GIVING DERIVATIVES)
+C ITER = ITERATION COUNTER
+C IFLAG = ERROR FLAG
+c
+c orig : CORSIKA 6.176
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 1st, 2004
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ INTEGER ITMAX,MP,NMAX,NP
+C MAXIMUM NUMBER OF TRIAL PER CALL
+ PARAMETER (ITMAX=5000)
+ PARAMETER (NMAX=20)
+ DOUBLE PRECISION CXAMOTRY,FTOL,FUNK,P(MP,NP),PSUM(NMAX),
+ * RTOL,SUM,SWAP,Y(MP),YSAVE,YTRY
+ INTEGER I,IFLAG,IHI,ILO,INHI,ITER,J,M,N,NDIM
+ EXTERNAL FUNK
+
+CU USES CXAMOTRY,FUNK
+C-----------------------------------------------------------------------
+
+c$$$ WRITE(*,*) 'CXAMOEBA:'
+ IFLAG = 0
+ ITER = 0
+ 1 DO 12 N=1,NDIM
+ SUM = 0.D0
+ DO 11 M=1,NDIM+1
+ SUM = SUM + P(M,N)
+ 11 CONTINUE
+ PSUM(N) = SUM
+ 12 CONTINUE
+ 2 ILO=1
+ IF ( Y(1) .GT. Y(2) ) THEN
+ IHI = 1
+ INHI = 2
+ ELSE
+ IHI = 2
+ INHI = 1
+ ENDIF
+ DO 13 I=1,NDIM+1
+ IF ( Y(I) .LE. Y(ILO) ) ILO = I
+ IF ( Y(I) .GT. Y(IHI) ) THEN
+ INHI = IHI
+ IHI = I
+ ELSEIF ( Y(I) .GT. Y(INHI) ) THEN
+ IF ( I .NE. IHI ) INHI = I
+ ENDIF
+ 13 CONTINUE
+ RTOL = ABS(Y(IHI))+ABS(Y(ILO))
+ IF(RTOL.GT.0.d0)THEN
+ RTOL = 2.D0*ABS(Y(IHI)-Y(ILO))/RTOL
+ ELSE
+c WRITE(ifck,*) 'CXAMOEBA: RTOL < 0 IN CXAMOEBA'
+ IFLAG = 1
+ RETURN
+ ENDIF
+ IF ( RTOL .LT. FTOL ) THEN
+ SWAP = Y(1)
+ Y(1) = Y(ILO)
+ Y(ILO) = SWAP
+ DO 14 N=1,NDIM
+ SWAP = P(1,N)
+ P(1,N) = P(ILO,N)
+ P(ILO,N) = SWAP
+ 14 CONTINUE
+ RETURN
+ ENDIF
+ IF ( ITER .GE.ITMAX ) THEN
+c WRITE(ifck,*) 'CXAMOEBA: ITMAX EXCEEDED IN CXAMOEBA'
+ IFLAG = 1
+ RETURN
+ ENDIF
+ ITER = ITER + 2
+ YTRY = CXAMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,-1.0D0)
+ IF ( YTRY .LE. Y(ILO) ) THEN
+ YTRY = CXAMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,2.0D0)
+ ELSEIF ( YTRY .GE. Y(INHI) ) THEN
+ YSAVE = Y(IHI)
+ YTRY = CXAMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,0.5D0)
+ IF ( YTRY .GE. YSAVE ) THEN
+ DO 16 I=1,NDIM+1
+ IF ( I .NE. ILO ) THEN
+ DO 15 J=1,NDIM
+ PSUM(J) = 0.5D0 * (P(I,J) + P(ILO,J))
+ P(I,J) = PSUM(J)
+ 15 CONTINUE
+ Y(I) = FUNK(PSUM)
+ ENDIF
+ 16 CONTINUE
+ ITER = ITER + NDIM
+ GOTO 1
+ ENDIF
+ ELSE
+ ITER = ITER - 1
+ ENDIF
+ GOTO 2
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXAMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI
+ & ,FAC)
+
+C-----------------------------------------------------------------------
+C
+C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL.,
+C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X
+C ADAPTED FOR DOUBLE PRECISION
+C THIS SUBROUTINE IS CALLED FROM CXAMOEBA
+C
+c
+c orig : CORSIKA 6.176
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 1st, 2004
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ INTEGER MP,NP,NMAX
+ PARAMETER (NMAX=20)
+ DOUBLE PRECISION FAC,P(MP,NP),PSUM(NP),Y(MP),FUNK
+ DOUBLE PRECISION FAC1,FAC2,YTRY,PTRY(NMAX)
+ INTEGER IHI,NDIM,J
+ EXTERNAL FUNK
+CU USES FUNK
+C-----------------------------------------------------------------------
+
+c$$$ WRITE(*,*) 'CXAMOTRY:'
+ FAC1 = (1.D0-FAC)/NDIM
+ FAC2 = FAC1-FAC
+ DO 11 J=1,NDIM
+ PTRY(J) = PSUM(J) * FAC1 - P(IHI,J) * FAC2
+ 11 CONTINUE
+ YTRY = FUNK(PTRY)
+ IF ( YTRY .LT. Y(IHI) ) THEN
+ Y(IHI) = YTRY
+ DO 12 J=1,NDIM
+ PSUM(J) = PSUM(J) - P(IHI,J) + PTRY(J)
+ P(IHI,J) = PTRY(J)
+ 12 CONTINUE
+ ENDIF
+ CXAMOTRY = YTRY
+ RETURN
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXCHISQ(F)
+
+C-----------------------------------------------------------------------
+C C(ONE)X CHI SQ(UARE)
+C
+C THIS FUNCTION CALCULATES THE CHI**2 OBTAINED WITH THE HILLAS
+C FUNCTION AND THE FIT SUBROUT. AMOEBA USING THE PARAMETER SET F
+C SEE: T.K. GAISSER & A.M. HILLAS, PROC. XV ICRC, PLOVDIV, BULGARIA,
+C VOL. 8 (1977) 353
+C THIS FUNCTION IS CALLED FROM LONGFT AND AMOEBA
+C ARGUMETS:
+C F(1) = HEIGHT AT MAXIMUM
+C F(2) = SHOWER STARTING POINT
+C F(3) = T AT MAXIMUM
+C F(4) = WIDTH PARAMETER 1
+C F(5) = WIDTH PARAMETER 2 T
+C F(6) = WIDTH PARAMETER 3 T**2
+C THIS FUNCTION IS CALLED FROM CXLONGFT AND FROM CXAMOEBA
+c
+c orig : CORSIKA 6.176
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 1st, 2004
+C-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON /CXMAXFIT/ CHAPAR,DEP,ERR,NSTP
+ DIMENSION CHAPAR(MAXIMZ),DEP(MAXIMZ),ERR(MAXIMZ)
+
+ DIMENSION F(6)
+C-----------------------------------------------------------------------
+
+c$$$ WRITE(*,*) 'CXCHISQ : PARAMETERS =',F
+C EXCLUDE PATHOLOGICAL PARAMETER SETTINGS
+ IF ( F(1) .LE. 0.D0 .OR. F(2) .GE. F(3) .OR.
+ * (F(4).le.0.D0 .AND. F(5).EQ.0.D0 .AND. F(6).EQ.0.D0) ) THEN
+ CXCHISQ = 1.D16
+ RETURN
+ ENDIF
+
+ CXCHISQ = 0.D0
+C LOOP OVER THE LONGITUDINAL DISTRIBUTION
+ DO 1 I=1,NSTP
+ T = DEP(I)
+ IF ( T .GT. F(2) ) THEN
+ BASE = (T-F(2)) / (F(3)-F(2))
+ WIDTH = F(4) + T*F(5) + T**2*F(6)
+ IF ( WIDTH .LT. 1.D-20 ) THEN
+ CXCHISQ = CXCHISQ + 1.D16
+ GOTO 1
+ ENDIF
+ EXPO = (F(3)-F(2)) / WIDTH
+ AUXIL = (F(3)-T) / WIDTH
+ IF ( ABS(AUXIL) .GT. 20.D0 ) THEN
+ CXCHISQ = CXCHISQ + 1.D16
+ GOTO 1
+ ENDIF
+ BALL = F(1) * BASE ** EXPO * EXP(AUXIL)
+ ELSE
+ BALL = 0.D0
+ ENDIF
+ CXCHISQ = CXCHISQ + ((BALL-CHAPAR(I))/ERR(I))**2
+ 1 CONTINUE
+ CXCHISQ = CXCHISQ / (NSTP-6)
+c$$$ WRITE(*,*) 'CXCHISQ : CHI**2 =',CXCHISQ
+ RETURN
+ END
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXCHISQ2(F)
+
+C-----------------------------------------------------------------------
+C
+C THIS FUNCTION CALCULATES THE CHI**2 OBTAINED WITH THE HILLAS
+C FUNCTION AND THE FIT SUBROUT. AMOEBA USING THE PARAMETER SET F
+C SEE: T.K. GAISSER & A.M. HILLAS, PROC. XV ICRC, PLOVDIV, BULGARIA,
+C VOL. 8 (1977) 353
+C F(1) = HEIGHT AT MAXIMUM
+C F(2) = SHOWER STARTING POINT
+C F(3) = T AT MAXIMUM
+C F(4) = WIDTH PARAMETER 1
+C THIS FUNCTION IS CALLED FROM CXLONGFT AND FROM CXAMOEBA
+c
+c orig : CORSIKA 6.176
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 1st, 2004
+C-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON /CXMAXFIT/ CHAPAR,DEP,ERR,NSTP
+ DIMENSION CHAPAR(MAXIMZ),DEP(MAXIMZ),ERR(MAXIMZ)
+
+ DIMENSION F(6)
+C-----------------------------------------------------------------------
+
+c$$$ WRITE(*,*) 'CXCHISQ2: PARAMETERS,NSTP =',F,NSTP
+C EXCLUDE PATHOLOGICAL PARAMETER SETTINGS
+ IF ( F(1) .LE. 0.D0 .OR. F(2) .GE. F(3) .OR.
+ * (f(4).le.0.D0) ) THEN
+ CXCHISQ2 = 1.D16
+ RETURN
+ ENDIF
+
+ CXCHISQ2 = 0.D0
+C LOOP OVER THE LONGITUDINAL DISTRIBUTION
+ DO 1 I=1,NSTP
+ T = DEP(I)
+ IF ( T .GT. F(2) ) THEN
+ BASE = (T-F(2)) / (F(3)-F(2))
+ AUXIL = F(4)
+ IF ( AUXIL .LT. 1.D-20 ) THEN
+ CXCHISQ2 = CXCHISQ2 + 1.D16
+ GOTO 1
+ ENDIF
+ EXPO = (F(3)-F(2)) / AUXIL
+ AUXIL = (F(3)-T) / AUXIL
+ IF ( ABS(AUXIL) .GT. 20.D0 ) THEN
+ CXCHISQ2 = CXCHISQ2 + 1.D16
+ GOTO 1
+ ENDIF
+ BALL = F(1) * BASE ** EXPO * EXP(AUXIL)
+ ELSE
+ BALL = 0.D0
+ ENDIF
+ CXCHISQ2 = CXCHISQ2 + ((BALL-CHAPAR(I))/ERR(I))**2
+ 1 CONTINUE
+ CXCHISQ2 = CXCHISQ2 / (NSTP-4)
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXPRTIME(iout)
+
+C-----------------------------------------------------------------------
+C C(one)XPR(INT) TIME
+C
+C PRINTS PRESENT DATE AND TIME IN FILE IOUT
+C
+C IF OUR DATE ROUTINE DOES NOT FIT TO YOUR COMPUTER, PLEASE REPLACE
+C IT BY A SUITABLE ROUTINE OF YOUR SYSTEM
+c orig : CORSIKA 6.176 by D.Heck
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> feb. 9th, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ CHARACTER*8 YYYYMMDD
+ CHARACTER*10 HHMMSS
+ INTEGER IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC,iout
+ SAVE
+C-----------------------------------------------------------------------
+
+C FOR COMPILERS WITH NEWER DATE FUNCTIONS, INCLUDING DEC UNIX f77
+C AND RECENT GNU g77 >0.5.21 (egcs 1.1.x, gcc 2.95, ...)
+C IF YOR COMPUTER DOES NOT KNOW SUBROUT. DATE_AND_TIME
+C REPLACE THIS CALL BY A CALL TO YOUR SYSTEM ROUTINES TO
+C FILL THE INTEGERS: IYEAR, MONTH, IDAY, IHOUR, IMINU, ISEC
+#ifndef __CXSUB__
+ CALL DATE_AND_TIME( YYYYMMDD, HHMMSS )
+ READ(YYYYMMDD,'(I4,2I2)') IYEAR,MONTH,IDAY
+ READ(HHMMSS,'(3I2)') IHOUR,IMINU,ISEC
+#else
+ IDAY=0
+ MONTH=0
+ IYEAR=0
+ IHOUR=0
+ IMINU=0
+ ISEC=0
+ YYYYMMDD="Not used"
+ HHMMSS="Not Used"
+#endif
+ WRITE(iout,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC
+ 100 FORMAT('!PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2,
+ * ':',I2.2)
+
+ RETURN
+ END
+
+c-----------------------------------------------------------------------
+ double precision function AlpEdepo(X,Xmax) !tp16.08.04
+c-----------------------------------------------------------------------
+c Effective Alpha to calculate total energy deposit from Number of
+c charged particle with energy above 1 MeV: AlpEdepo=dEdepo/dX/Nch
+c Input :
+c X - slant depth in g/cm2
+c Xmax - slant depth of the shower maximum in g/cm2
+c Output :
+c AlpEdepo in GeV/g.cm2
+c
+c Parameter by R. Engel, 08.2004
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ dimension cfedep(5)
+c data (cfedep(k),k=1,5)/43.2531d0,1.34508d0,11.3005d0,2.44755d0
+c & ,0.122845d0/
+ data (cfedep(k),k=1,5)/3.90883d0,1.05301d0,9.91717d0,2.41715d0
+ & ,0.13180d0/
+
+ AlpEdepo=0.d0
+
+ if(X.le.0.d0.or.Xmax.le.0.d0)return
+
+
+c Calculate shower age
+ s=3.d0*X/(X+2.d0*Xmax)
+
+c Calculate Effective Alpha in MeV/g.cm2
+ AlpEdepo=cfedep(1)/(cfedep(2)+s)**cfedep(3)+cfedep(4)+cfedep(5)*s
+
+c Convert Effective Alpha in GeV/g.cm2
+ AlpEdepo=AlpEdepo*1.d-3
+
+
+ return
+ end
+
+
+
+#ifndef __CXCORSIKA__
+
+C=======================================================================
+
+ SUBROUTINE CXMUPINI
+
+C-----------------------------------------------------------------------
+C C(ONE)X MU(ON) P(ARAMETER) INI(TIALIZATION)
+C
+C ESTABLISHES TABLES FOR CROSS-SECTIONS OF BEMSSTRAHLUNG,
+C PAIR PRODUCTION AND NUCLEAR INTERACTION.
+C ESTABLISHES TABLES FOR MUON ENERGY LOSS FOR BEMSSTRAHLUNG,
+C PAIR PRODUCTION, AND NUCLEAR INTERACTION.
+C THIS SUBROUTINE IS CALLED FROM InitializeOnce.
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION YE,OB3,TB3,cdeca
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+ DOUBLE PRECISION DEDXBR,DEDXNI,DEDXPR,bcuti,bcutn
+ INTEGER J,JE,JJMAT
+ DOUBLE PRECISION DBRELM,DBRSGM,DNIELM,DNUSGM,DPRELM,DPRSGM
+ EXTERNAL DBRELM,DBRSGM,DNIELM,DNUSGM,DPRELM,DPRSGM
+#ifdef __CXDEBUG__
+ DOUBLE PRECISION DEDXMUB(141,3),DEDXMNI(141,3),DEDXMUP(141,3),
+ * DEDXMB(141),DEDXMN(141),DEDXMP(141)
+ DOUBLE PRECISION CXBRSGM,CXNUSGM,CXPRSGM,BREMS,NUCLE,PAIR
+ EXTERNAL CXBRSGM,CXNUSGM,CXPRSGM
+#endif
+C-----------------------------------------------------------------------
+
+#ifdef __CXDEBUG__
+ call utisx1('CXMUPINI ',8)
+#endif
+
+C SET CONSTANTS FOR MUON BREMSSTRAHLUNG
+ CMUON(7) = airz(1)**OB3
+ CMUON(8) = airz(2)**OB3
+ CMUON(9) = airz(3)**OB3
+ CMUON(1) = LOG( 189.D0 * pmass(9) / (CMUON(7)*pmass(10)) )
+ * + LOG( TB3/CMUON(7) )
+ CMUON(2) = LOG( 189.D0 * pmass(9) / (CMUON(8)*pmass(10)) )
+ * + LOG( TB3/CMUON(8) )
+ CMUON(3) = LOG( 189.D0 * pmass(9) / (CMUON(9)*pmass(10)) )
+ * + LOG( TB3/CMUON(9) )
+ SE = SQRT(EXP(1.D0))
+ CMUON(4) = 189.D0 * SE*pmass(9)**2/(2.D0*pmass(10)*CMUON(7))
+ CMUON(5) = 189.D0 * SE*pmass(9)**2/(2.D0*pmass(10)*CMUON(8))
+ CMUON(6) = 189.D0 * SE*pmass(9)**2/(2.D0*pmass(10)*CMUON(9))
+ CMUON(10) = 0.75D0 * pmass(9) * SE
+ CMUON(7) = CMUON(7) * CMUON(10)
+ CMUON(8) = CMUON(8) * CMUON(10)
+ CMUON(9) = CMUON(9) * CMUON(10)
+ CMUON(11) = LOG( MIN( emin, PITHR*1.D-3 )/pmass(9) )
+C MASS RATIO ELETRON BY MUON
+ EBYMU = pmass(10)/pmass(9)
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ if(mode.ne.0)then
+C CALCULATE ENERGY LOSS TABLES INTEGRATED FROM THE MINIMUM TO THE
+C MAXIMUM ENERGY FOR CASCADE EQUATIONS WHERE INTERACTIONS ARE NOT EXPLICIT.
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+C ENERGY LOOP (10 MEV AT J=1; 1 GEV AT J=21; 1000 EEV AT J=141)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,109)
+ 109 FORMAT(' FULL MUON ENERGY LOSS (GEV G**-1 CM**2) FOR AIR'/
+ * ' BIN',1X,'ENERGY (GEV)',5X,'DEDXMB',8X,
+ * 'DEDXMP',8X,'DEDXMN',8X,' SUM')
+#endif
+C CALCULATE ENERGY LOSS IN AIR
+ cdeca=10.d0**(1d0/decade)
+ DO J = 1,maximEd
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = dble(exmin) * cdeca**(J-1) + pmass(9)
+C SET BCUT AT EE
+ BCUT=EE
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C ENERGY LOSS IN MATERIAL COMPONENTS
+ DEDXBR = 0.d0
+ DEDXPR = 0.d0
+ DEDXNI = 0.d0
+ DO JJMAT = 1, 3
+ ZATOM = AIRZ(JJMAT)
+ AATOM = AIRA(JJMAT)
+ CONSTKINE = CMUON(JJMAT+6)
+ DEDXBR = DEDXBR + airw(JJMAT) * DBRELM(JJMAT)
+ DEDXPR = DEDXPR + airw(JJMAT) * DPRELM(JJMAT)
+ DEDXNI = DEDXNI + airw(JJMAT) * DNIELM(JJMAT)
+ ENDDO
+ dedxion(4,J)=DEDXBR+DEDXPR+DEDXNI
+#ifdef __CXDEBUG__
+ IF (isx.ge.8 ) WRITE(ifck,106)
+ * J,EE,DEDXBR,DEDXPR,DEDXNI,dedxion(4,J)
+#endif
+ ENDDO
+ endif
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C SET BCUT BELOW THE PI THRESHOLD
+ BCUT = MIN( emin, PITHR*1.D-3 )
+ bcuti=bcut
+ bcutn=enymin+pmass(5) !for nuclear int, minimum correspond to minimum hadron energy
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,*) 'BCUT MC =',BCUT,' GEV'
+#endif
+
+C CALCULATE CROSS SECTION TABLES
+C MAXIMUM PRIMARY ENERGY DETERMINES MAXIMUM OF TABLE VALUES NEEDED
+C AND WE NEED 2 ADDITIONAL POINTS FOR QUADRATIC INTERPOLATION
+ JE = int (10 * LOG10(eprima) ) + 21 + 2
+ JE = MIN(JE,141)
+
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+ DO JJMAT = 1, 3
+ ZATOM = AIRZ(JJMAT)
+ AATOM = AIRA(JJMAT)
+ CONSTKINE = CMUON(JJMAT+6)
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,101) JJMAT
+ 101 FORMAT(' MUON CROSS SECTIONS (MBARN) FOR MATERIAL ',
+ * 'INDEX = ',I3,/,' BIN',1X,
+ * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL')
+#endif
+
+C ENERGY LOOP (10 MEV AT J=1; 1 GEV AT J=21; 1000 EEV AT J=141)
+ DO J = 1, JE
+ YE = DBLE(J - 21)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C CALCULATE CROSS SECTIONS (MILLIBARN)
+ BCUT=bcuti
+ BREMSTAB(J,JJMAT) = DBRSGM(JJMAT)
+ PAIRTAB(J,JJMAT) = DPRSGM(JJMAT)
+ BCUT=bcutn
+ NUCTAB(J,JJMAT) = DNUSGM(JJMAT)
+ IF ( isx.ge.8 ) WRITE(ifck,102) J,EE,BREMSTAB(J,JJMAT),
+ * PAIRTAB(J,JJMAT),NUCTAB(J,JJMAT)
+ 102 FORMAT(' ',I3,1P,1X,E12.5,3(1X,E13.6))
+ BREMSTAB(J,JJMAT) = LOG(MAX( BREMSTAB(J,JJMAT), 1.D-30 ) )
+ NUCTAB(J,JJMAT) = LOG(MAX( NUCTAB(J,JJMAT), 1.D-30 ) )
+ PAIRTAB(J,JJMAT) = LOG(MAX( PAIRTAB(J,JJMAT), 1.D-30 ) )
+ ENDDO
+ ENDDO
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) THEN
+ WRITE(ifck,103)
+ 103 FORMAT(' MUON CROSS SECTIONS (MBARN) FOR AIR'/' BIN',1X,
+ * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL')
+ DO J = 1, JE
+ YE = DBLE(J - 21)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE
+C CALCULATE THE CROSS SECTIONS FOR AIR
+ BREMS = airw(1) * CXBRSGM( EE,1 )
+ BREMS = BREMS + airw(2) * CXBRSGM( EE,2 )
+ BREMS = BREMS + airw(3) * CXBRSGM( EE,3 )
+ PAIR = airw(1) * CXPRSGM( EE,1 )
+ PAIR = PAIR + airw(2) * CXPRSGM( EE,2 )
+ PAIR = PAIR + airw(3) * CXPRSGM( EE,3 )
+ NUCLE = airw(1) * CXNUSGM( EE,1 )
+ NUCLE = NUCLE + airw(2) * CXNUSGM( EE,2 )
+ NUCLE = NUCLE + airw(3) * CXNUSGM( EE,3 )
+ WRITE(ifck,104) J,EE,BREMS,PAIR,NUCLE
+ 104 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6))
+ ENDDO
+ ENDIF
+#endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C CALCULATE ENERGY LOSS TABLES. AS WE REGARD CUT VALUES ONLY BELOW 152 MEV
+C WE MAY NEGLECT NUCLEAR INTERACTIONS FOR THE ENERGY LOSS TABLES.
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+ DO JJMAT = 1, 3
+ ZATOM = AIRZ(JJMAT)
+ AATOM = AIRA(JJMAT)
+ CONSTKINE = CMUON(JJMAT+6)
+C ENERGY LOOP (10 MEV AT J=1; 1 GEV AT J=21; 1000 EEV AT J=141)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,105) JJMAT
+ 105 FORMAT(' MUON ENERGY LOSS (GEV G**-1 CM**2) FOR ',
+ * 'MATERIAL INDEX = ',I3/' BIN',1X,
+ * 'ENERGY (GEV)',3X,'DEDXBREM',6X,'DEDXPAIR',6X,
+ * 'NUCLEAR',8X,'SUM')
+#endif
+ DO J = 1, JE
+ YE = DBLE(J - 21)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C ENERGY LOSS IN MATERIAL COMPONENTS
+ BCUT=bcuti
+ DEDXBR = DBRELM(JJMAT)
+ DEDXPR = DPRELM(JJMAT)
+ BCUT=bcutn
+ DEDXNI = DNIELM(JJMAT)
+ DEDXMU(J,JJMAT) = DEDXBR + DEDXPR + DEDXNI
+#ifdef __CXDEBUG__
+ DEDXMUB(J,JJMAT) = DEDXBR
+ DEDXMUP(J,JJMAT) = DEDXPR
+ DEDXMNI(J,JJMAT) = DEDXNI
+ IF (isx.ge.8 ) WRITE(ifck,106)
+ * J,EE,DEDXBR,DEDXPR,DEDXNI,DEDXMU(J,JJMAT)
+ 106 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6))
+#endif
+ ENDDO
+ ENDDO
+
+C CALCULATE ENERGY LOSS IN AIR
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,107)
+ 107 FORMAT(' MUON ENERGY LOSS (GEV G**-1 CM**2) FOR AIR'/
+ * ' BIN',1X,'ENERGY (GEV)',5X,'DEDXMB',8X,
+ * 'DEDXMP',8X,'DEDXMN',8X,' SUM')
+#endif
+ DO J = 1, JE
+ YE = DBLE(J - 21)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+C CALCULATE ENERGY LOSS IN AIR
+ EE = 10.D0**YE
+ DEDXM(J) = airw(1) * DEDXMU(J,1)
+ * +airw(2) * DEDXMU(J,2)
+ * +airw(3) * DEDXMU(J,3)
+#ifdef __CXDEBUG__
+ DEDXMB(J) = airw(1) * DEDXMUB(J,1)
+ * +airw(2) * DEDXMUB(J,2)
+ * +airw(3) * DEDXMUB(J,3)
+ DEDXMP(J) = airw(1) * DEDXMUP(J,1)
+ * +airw(2) * DEDXMUP(J,2)
+ * +airw(3) * DEDXMUP(J,3)
+ DEDXMN(J) = airw(1) * DEDXMNI(J,1)
+ * +airw(2) * DEDXMNI(J,2)
+ * +airw(3) * DEDXMNI(J,3)
+ IF ( isx.ge.8 ) WRITE(ifck,108)
+ * J,EE,DEDXMB(J),DEDXMP(J),DEDXMN(J),DEDXM(J)
+ 108 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6))
+#endif
+ ENDDO
+
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+
+ RETURN
+ END
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE MUSIGMA(Elab,SIGINEL)
+C-----------------------------------------------------------------------
+C Muon cross sections
+C
+C Elab Muon total energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+c
+c subroutine called by rlam
+c
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+ common/cxmubrint/cxMuBRPair,cxMuBRBrem
+ double precision Elab,SIGINEL,cxMuBRPair,cxMuBRBrem
+ DOUBLE PRECISION CXBRSGM,CXNUSGM,CXPRSGM
+ EXTERNAL CXBRSGM,CXNUSGM,CXPRSGM
+
+
+C CALCULATE MUON BREMSSTRAHLUNG CROSS-SECTION FOR AIR (MILLIBARN)
+ FRABTN = airw(1) * CXBRSGM( ELAB,1 )
+ FRBTNO = FRABTN + airw(2) * CXBRSGM( ELAB,2 )
+ SIGBRM = FRBTNO + airw(3) * CXBRSGM( ELAB,3 )
+
+C CALCULATE MUON PAIR PRODUCTION CROSS-SECTION FOR AIR (MILLIBARN)
+ FRAPTN = airw(1) * CXPRSGM( ELAB,1 )
+ FRPTNO = FRAPTN + airw(2) * CXPRSGM( ELAB,2 )
+ SIGPRM = FRPTNO + airw(3) * CXPRSGM( ELAB,3 )
+
+C CALCULATE MUON NUCLEAR INTERACTION CROSS-SECTION FOR AIR (MILLIBARN)
+ FRANTN = airw(1) * CXNUSGM( ELAB,1 )
+ FRNTNO = FRANTN + airw(2) * CXNUSGM( ELAB,2 )
+ SIGNUC = FRNTNO + airw(3) * CXNUSGM( ELAB,3 )
+
+ cxMuBRPair=SIGPRM
+ cxMuBRBrem=SIGBRM+SIGPRM
+ SIGINEL=cxMuBRBrem+SIGNUC
+ if(SIGINEL.gt.0.d0)then
+ cxMuBRPair=cxMuBRPair/SIGINEL
+ cxMuBRBrem=cxMuBRBrem/SIGINEL
+ endif
+
+
+ END
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE MuInteraction(id)
+C-----------------------------------------------------------------------
+C Muon Interaction Calculation
+c
+c subroutine called by cnexus
+c
+c by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+ common/cxmubrint/cxMuBRPair,cxMuBRBrem
+ double precision cxMuBRPair,cxMuBRBrem,dummy,rdmBR,ep(5),rd1
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+ integer i,LT,id
+ double precision drangen
+ external drangen
+
+c Initialize temporary stack
+ do i=1,5
+ ep(i)=0.d0
+ istptlxs(i)=1
+ xsptl(1,i)=0.d0 !px
+ xsptl(2,i)=0.d0 !py
+ xsptl(3,i)=0.d0 !pz
+ xsptl(4,i)=0.d0 !E
+ xsptl(5,i)=0.d0 !m
+ ityptlxs(i)=0
+ iorptlxs(i)=1
+ jorptlxs(i)=1
+ ifrptlxs(1,i)=0
+ ifrptlxs(2,i)=0
+ xsorptl(1,i)=0.d0 !x
+ xsorptl(2,i)=0.d0 !y
+ xsorptl(3,i)=0.d0 !z
+ xsorptl(4,i)=0.d0 !t
+ xstivptl(1,i)=0.d0
+ xstivptl(2,i)=0.d0
+ idptlxs(i)=0 !id
+ enddo
+
+ nptlxs=0 !number of secondaries
+ ep(4)=dptl(4) !total E
+ ep(5)=dptl(5) !mass
+ ep(3)=(ep(4)+ep(5))*(ep(4)-ep(5))
+ if(ep(3).ge.0.d0.and.iMuInt.gt.0)then
+ ep(3)=sqrt(ep(3))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*) 'Should not happen !!! Cont. without Mu Inter.'
+#endif
+ write(*,*) 'Should not happen !!! Cont. without Mu Inter.'
+ write(*,*) iMuInt,ep(3),ep(4),ep(5)
+ nptlxs=1
+ xsptl(5,nptlxs)=ep(5)
+ if(ep(3).ge.0.d0)then
+ xsptl(4,nptlxs)=ep(4)
+ xsptl(3,nptlxs)=sqrt(ep(3))
+ else
+ xsptl(4,nptlxs)=ep(5)
+ xsptl(3,nptlxs)=0.d0
+ endif
+ istptlxs(nptlxs)=0
+ idptlxs(nptlxs)=id
+ return
+ endif
+
+
+ rdmBR=drangen(dummy)
+ rd1=drangen(dummy)
+ if(rdmBR.le.cxMuBRPair)then !Pair production
+C TARGET IS CHOSEN AT RANDOM FOR MUON PAIR PRODUCTION
+ IF ( RD1*SIGPRM .LE. FRAPTN ) THEN
+C PAIR PRODUCTION WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGPRM .LE. FRPTNO ) THEN
+C PAIR PRODUCTION WITH OXYGEN
+ LT = 2
+ ELSE
+C PAIR PRODUCTION WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MuInteraction : Pair',LT
+#endif
+ call CXMUPRPR(id,ep,LT)
+
+ elseif(rdmBR.le.cxMuBRBrem)then !Bremstrahlung
+ IF ( RD1*SIGBRM .LE. FRABTN ) THEN
+C BREMSSTRAHLUNG WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGBRM .LE. FRBTNO ) THEN
+C BREMSSTRAHLUNG WITH OXYGEN
+ LT = 2
+ ELSE
+C BREMSSTRAHLUNG WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MuInteraction : Brems',LT
+#endif
+ call CXMUBREM(id,ep,LT)
+
+ else !Nucl. Int
+ IF ( RD1*SIGNUC .LE. FRANTN ) THEN
+C NUCLEAR INTERACTION WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGNUC .LE. FRNTNO ) THEN
+C NUCLEAR INTERACTION WITH OXYGEN
+ LT = 2
+ ELSE
+C NUCLEAR INTERACTION WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MuInteraction : Nuc. Int.',LT
+#endif
+ call CXMUNUCL(id,ep,LT)
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)call cxalist('MuIntera&',1,nptlxs,2)
+#endif
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMUBREM(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X MU(ON) BREM(SSTRAHLUNG)
+C
+C TREATES MUON BREMSSTRAHLUNG (WITHOUT POLARISATION EFFECTS)
+C IN ANALOGY WITH SUBROUT. GBREMM FROM GEANT WRITTEN BY L. URBAN
+C EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013
+C THIS SUBROUTINE IS CALLED FROM MuInteraction.
+c input : id = muon id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION ALFA1,BETA1,COSTH3,CREJ,D,F1,
+ * EKIN,PHI3,SCREJ,signew,sigold,SINTH3,THETA3,
+ * U,UMAX,V,VC,VM,V1,W1,Z,SINPHI3,COSPHI3
+ INTEGER I,JCOUNT,LT,id
+ DOUBLE PRECISION CXBRSGM,drangen
+ EXTERNAL CXBRSGM,drangen
+ DATA ALFA1/0.625D0/
+ SAVE ALFA1
+ double precision epi(5),epf(5),RD(3),PT
+C-----------------------------------------------------------------------
+
+
+C TOTAL AND KINETIC ENERGY OF MUON
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+
+C MUON ENERGY IS TOO LOW TO PRODUCE BREMSSTRAHLUNG
+ IF ( EKIN .LE. BCUT )GOTO 900
+
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+C RESTORE OLD CROSS SECTION
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRABTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRBTNO - FRABTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGBRM - FRBTNO) / airw(3)
+ ELSE
+ WRITE(ifck,*) 'CXMUBREM: WRONG TARGET LT =',LT,' STOP'
+ STOP
+ ENDIF
+C GET NEW CROSS-SECTION
+ SIGNEW = CXBRSGM( EE,LT )
+ RD(1)=drangen(dble(LT))
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW )GOTO 900
+
+ VC = BCUT/EE
+ VM = 1.D0 - CMUON(6+LT)/EE
+C MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG
+ IF ( VM .LE. 0.D0 ) GOTO 900
+ CREJ = CMUON(3+LT)/EE
+
+ JCOUNT = 0
+ 50 CONTINUE
+ JCOUNT = JCOUNT + 1
+ IF ( JCOUNT .GT. 1000 ) GOTO 900
+ RD(1)=drangen(dble(JCOUNT))
+ RD(2)=drangen(dble(JCOUNT))
+ V = VC*(VM/VC)**RD(1)
+ V1 = 1.D0 - V
+C COMPUTE REJECTION FUNCTION
+ F1 = CMUON(LT) - LOG(1.D0 + CREJ*V/V1)
+ SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LT)
+ IF ( RD(2) .GT. SCREJ ) GOTO 50
+
+C GAMMA ENERGY
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = EE * V
+ xsptl(5,nptlxs) = 0.d0
+ idptlxs(nptlxs) = 10
+ istptlxs(nptlxs) = 0
+
+
+C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO
+C TARGET INDEX LT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2
+ Z = airz(LT)
+
+C GENERATE EMITTED GAMMA ANGLES WITH RESPECT TO MUON DIRECTION
+C PHI IS GENERATED ISOTROPICALLY AND THETA IS ASSIGNED A UNIVERSAL
+C ANGULAR DISTRIBUTION WITH D=D(Z,E,V)
+C THIS FUNCTION APPROXIMATES THE REAL DISTRIBUTION FUNCTION WHICH CAN
+C BE FOUND IN: YUNG-SU TSAI, REV. MOD. PHYS. 46(1974)815
+C +ERRATUM: REV. MOD. PHYS. 49(1977)421
+ D = 0.13D0 *(0.8D0 + 1.3D0/Z) * (100.D0 + 1.D0/EE) * (1.D0 + V)
+ W1 = 9.D0 / (9.D0 + D)
+ UMAX = EE * PI / pmass(9)
+ 10 CONTINUE
+ RD(1)=drangen(D)
+ RD(2)=drangen(W1)
+ RD(3)=drangen(UMAX)
+ IF ( RD(1) .LE. W1 ) THEN
+ BETA1 = ALFA1
+ ELSE
+ BETA1 = 3.D0 * ALFA1
+ ENDIF
+ U = (- LOG( RD(2) * RD(3) ) / BETA1)
+C CUT: THETA SHOULD BE .LE. PI !
+C THIS CONDITION DEPENDS ON E IN THE CASE OF D=CONST TOO!
+ IF ( U .GE. UMAX ) GOTO 10
+
+ THETA3 = U * pmass(9) / EE
+ COSTH3 = COS( THETA3 )
+ if(abs(COSTH3).ge.1.d0)COSTH3=sign(1.d0,COSTH3)
+ xsptl(3,nptlxs) = xsptl(4,nptlxs) * COSTH3
+ SINTH3 = sqrt((1.d0-COSTH3)*(1.d0+COSTH3))
+ PT = xsptl(4,nptlxs) * SINTH3
+ RD(1)=drangen(COSTH3)
+ PHI3 = 2.d0 * PI * RD(1)
+ COSPHI3 = COS( PHI3 )
+ if(abs(COSPHI3).ge.1.d0)COSPHI3=sign(1.d0,COSPHI3)
+ SINPHI3 = sqrt((1.d0-COSPHI3)*(1.d0+COSPHI3))
+ xsptl(1,nptlxs) = PT * COSPHI3
+ xsptl(2,nptlxs) = PT * SINPHI3
+
+
+
+C REDUCE ENERGY OF MUON
+ epf(1)= -xsptl(1,nptlxs)
+ epf(2)= -xsptl(2,nptlxs)
+ epf(4)= EE * V1
+ PT=sqrt(PT*PT+epf(5)*epf(5))
+ epf(3)=(epf(4)+PT)*(epf(4)-PT)
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ if(isx.ge.1)then
+ write(*,*) 'Negative Energy in CXMUBREM !!!'
+ write(ifck,*) 'Negative Energy in CXMUBREM !!!'
+ write(ifck,*) jcount,id,epf,V1,ekin,ekin
+ write(ifck,*) 'try again ...'
+ endif
+#endif
+ nptlxs=0
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ goto 50
+ endif
+
+ 900 CONTINUE
+ nptlxs=nptlxs+1
+ idptlxs(nptlxs)=id
+ istptlxs(nptlxs)=0
+ do i=1,5
+ xsptl(i,nptlxs)=epf(i)
+ enddo
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMUNUCL(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X MU(ON) NUCL(EAR INTERATION)
+C
+C TREATES MUON NUCLEAR INTERACTION
+C IN ANALOGY WITH SUBR. GMUNU OF BOTTAI & PERRONE.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C L.B. BEZRUKOV AND E.V. BUGAEV, Yad. Fiz. 33 (1981) 1195
+C THIS SUBROUTINE IS CALLED FROM MuInteraction.
+c input : id = muon id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ double precision XM,YM,ZM,DM,TM
+*EGS4 Stack
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ double precision E,X,Y,Z,U,V,W,DNEAR,WT
+ integer IQ,IR,LATCH,LATCHI,NP
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI,OB3!,ELE1,ELE2
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (ALPHFA = 7.297353D-3)
+C BEZRUKOV'S M1**2 AND M2**2
+ PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (APH = 0.00282D0)
+C BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+ PARAMETER (CSI = 0.25D0)
+c PARAMETER (ELE1 = 0.0808D0)
+c PARAMETER (ELE2 = -0.4525D0)
+
+ DOUBLE PRECISION ARGO,AUXIL1,BPH,COEF,COEF1,CPH,
+ * DPH,EKIN,EPH,E1,FACTO,FPH,GG,GMAX,GMIN,HHH,
+ * SS,SIGN,signew,sigold,SNI,SNIMAX,SNIMIN,
+ * TTT,VPH,VPH1,VPH2,ZZZ,SNIMIN1,SNIMIN2
+ INTEGER I,JCOUNT,id,LT
+#if __MC3D__ || __CXLATCE__
+ double precision rtr1,pinv,sintheP,sinphiP,costheP
+ * ,cosphiP,ep(3)
+#endif
+ DOUBLE PRECISION CXNUSGM,drangen,epi(5),epf(5),RD(2),EGAM
+ EXTERNAL CXNUSGM,drangen
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ integer ifckegs,isxegs
+C-----------------------------------------------------------------------
+
+
+
+C SET MATERIAL CONSTANTS ACCORDING TO TARGET INDEX LT (1=N, 2=O, 3=AR)
+C WHICH HAS BEEN SET IN BOX2, AND RESTORE OLD CROSS-SECTIONS
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRANTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRNTNO - FRANTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGNUC - FRNTNO) / airw(3)
+ ELSE
+ WRITE(*,*) 'MUNUCL: WRONG TARGET LT=',LT,' STOP'
+ STOP
+ ENDIF
+ AATOM=aira(LT)
+
+C TOTAL AND KINETIC ENERGY OF MUON
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ IF ( EKIN .LE. BCUT ) GOTO 900
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+ SIGNEW = CXNUSGM( EE,LT )
+ RD(1)=drangen(dble(LT))
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW ) GOTO 900
+
+C SAMPLE THE ENERGY FRACTION SNI OF VIRTUAL GAMMA
+C LIMITS FOR VIRTUAL GAMMA'S ENERGY ARE SNIMIN AND SNIMAX
+ SNIMIN1 = ( pmass(2) + 0.5D0*pmass(2)**2/pmass(7) )/EE
+ SNIMIN2 = ( enymin + pmass(5) )/EE
+ SNIMIN = MAX( SNIMIN1, SNIMIN2, 1.D-15)
+ SNIMAX = 1.D0 - ( pmass(7) + pmass(9)**2/pmass(7) ) * 0.5D0/EE
+ IF ( SNIMIN .GE. SNIMAX ) GOTO 900
+
+ IF ( EE .LE. 1.D6 ) THEN
+ COEF = 0.073D0 * LOG10(EE) - 1.565D0
+ FACTO = 1.D10 / (10.D0**(8.8D0-0.1D0*(.2D0+LOG10(EE)**2/6.D0)))
+ * * AATOM/22.D0
+ ELSEIF ( EE .GT. 1.D6 ) THEN
+ COEF = 0.063D0 * LOG10(EE) - 1.55326D0
+ FACTO = 1.D10 / (10.D0**(8.8D0-0.1D0*LOG10(EE)))
+ * * AATOM/22.D0
+ ENDIF
+ COEF1 = COEF + 1.D0
+ GMIN = FACTO/COEF1 * SNIMIN**COEF1
+ GMAX = FACTO/COEF1 * SNIMAX**COEF1
+
+ JCOUNT = 0
+ 1 CONTINUE
+ JCOUNT = JCOUNT + 1
+C WRITE MUON UNCHANGED TO STACK
+ IF ( JCOUNT .GT. 1000 ) GOTO 900
+ RD(1)=drangen(dble(JCOUNT))
+ RD(2)=drangen(dble(JCOUNT))
+ ARGO = GMIN + RD(1)*(GMAX-GMIN)
+ SNI = (COEF1*ARGO/FACTO)**(1.D0/COEF1)
+ AUXIL1 = RD(2) * FACTO * SNI**COEF
+
+ IF ( SNI .GE. 1.D0 ) THEN
+ VPH = 0.D0
+ GOTO 99
+ ENDIF
+C CALCULATE BEZRUKOV'S T
+ TTT = pmass(9)**2 * SNI**2 / (1.D0 - SNI)
+C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUON
+ SS = 2.D0 * pmass(7) * SNI * EE
+C CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+C SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+C SEE: PARTICLE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+ SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+C SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+ ZZZ = SIGN * APH * AATOM**OB3
+C CALCULATE BOTTAI'S H(V)
+ HHH = 1.D0 - 2.D0/SNI + 2.D0/SNI**2
+C CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+ GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+C FACTOR BEFORE LARGE BRACKET
+ BPH = AATOM * SNI * SIGN * (ALPHFA/(8.D0*PI))
+C AUXILIARY QUANTITIES
+ CPH = 1.D0 + AM21/TTT
+ DPH = 1.D0 + AM22/TTT
+ EPH = 2.D0 * pmass(9)**2 / TTT
+ FPH = AM21 / (AM21 + TTT)
+C FIRST PART WITHIN LARGE BRACKET
+ VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+C SECOND PART WITHIN LARGE BRACKET
+ VPH2 = (2.D0 * CSI * pmass(9)**2/TTT)
+ * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + TTT/AM22 ) )
+C FINAL CROSS-SECTION
+ VPH = MAX( 0.D0, BPH * (VPH1+VPH2) )
+ 99 CONTINUE
+C USE REJECTION METHOD FOR SAMPLING OF SNI
+ IF ( AUXIL1 .GE. VPH ) GOTO 1
+
+C SNI FINALLY IS ENERGY FRACTION OF VIRTUAL GAMMA
+C ENERGY OF RESIDUAL MUON
+ E1 = EE * (1.D0 - SNI)
+C COSTH3 IS SET TO 1 (FORWARD MOVEMENT WITHOUT TRANSVERSE MOMENTUM)
+ epf(4) = E1
+ epf(3)=(epf(4)+epf(5))*(epf(4)-epf(5))
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*) 'Negative Energy in CXMUNUCL !!!'
+#endif
+ write(*,*) 'Negative Energy in CXMUNUCL !!!'
+ write(*,*) id,epf,SNI
+ write(*,*) 'try again ...'
+ nptlxs=0
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ goto 1
+ endif
+
+C NOW TREAT THE VIRTUAL GAMMA AS REAL GAMMA
+ EGAM = SNI * EE
+C CHECK: ENERGY OF VIRTUAL GAMMA IS SUFFICIENT FOR PION PRODUCTION ?
+ IF ( EGAM .LE. MAX( enymin, PITHR*1.D-3 ) ) THEN
+C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
+ if(iwrt.ge.2)call Profana(dptl(13)-0.0000001d0*dzHa,zshmax
+ & ,EGAM,EGAM,dptl(11),999,1)
+
+ ELSE
+ isxegs=isx
+C STORE VIRTUAL GAMMA INTO EGS STACK AND CALL SUBR. PIGEN
+C FILL IN STARTING COORDINATES
+ NP = 1
+c Particle initialization
+ XM(NP)=dptl(6) !x
+ YM(NP)=dptl(7) !y
+ ZM(NP)=dptl(8) !h
+ Z(NP)=dptl(13) !slant depth along shower axis
+ DM(NP)=dptl(16) !slant distance along shower axis to impact point, m
+ X(NP)=dptl(14) !x to shower axis
+ Y(NP)=dptl(15) !y to shower axis
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.eq.0)then !in case of 3D
+ rtr1=sqrt(XM(NP)*XM(NP)+YM(NP)*YM(NP))
+ if(rtr1.gt.1.d-20)then
+ sinphiP=YM(NP)/rtr1
+ cosphiP=XM(NP)/rtr1
+ sintheP=rtr1/(ZM(NP)+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ pinv=1.d0/sqrt(dptl(1)**2+dptl(2)**2+dptl(3)**2)
+ ep(1)=dptl(1)*pinv
+ ep(2)=dptl(2)*pinv
+ ep(3)=dptl(3)*pinv
+ call ToObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in obs. frame
+ call FromObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P in shower frame
+ U(NP)=ep(2) !in EGS4, left-handed frame y->u
+ V(NP)=ep(1) !in EGS4, left-handed frame x->v
+ W(NP)=ep(3)
+ else !1D all particle along shower axis
+#endif
+ U(NP)=0.d0
+ V(NP)=0.d0
+ W(NP)=1.d0 !direction towards the shower axis
+#if __MC3D__ || __CXLATCE__
+ endif !end 3D or 1D
+#endif
+ WT(NP)=dptl(11)
+ TM(NP)=dptl(9)
+C CONVERSION GEV --> MEV
+ E(NP) = EGAM * 1000.D0
+ IQ(NP) = 0
+C TREAT THE PHOTONUCLEAR INTERACTION WITH EGS BY PIGEN
+ CALL CXPIGEN
+C ALL SECONDARIES ARE WRITTEN TO STACK VIA AUSGAB
+ do while (NP.gt.0)
+ call AUSGABCX(100)
+ enddo
+ ENDIF
+
+ 900 CONTINUE
+ nptlxs=nptlxs+1
+ idptlxs(nptlxs)=id
+ istptlxs(nptlxs)=0
+ do i=1,5
+ xsptl(i,nptlxs)=epf(i)
+ enddo
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMUPRPR(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X MU(ON) P(AI)R PR(ODUCTION)
+C
+C TREATES MUON PAIR PRODUCTION (WITHOUT POLARISATION EFFECTS)
+C IN ANALOGY WITH SUBR. GPAIRM OF BOTTAI & PERRONE.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C IMPROVED SAMPLING BY R.P. KOKOULIN, A.G. BOGDANOV, MARCH 2007
+C THIS SUBROUTINE IS CALLED FROM MuInteraction.
+c input : id = muon id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> 2009
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION COSTH3,EKIN,ENEG,EPOS,EPP,GX,
+ * PHI3,RAT12,RO,ROMAX,ROMIN,SIGNEW,SIGOLD,
+ * SINT1,SINT2,SK,SK1,SK2,SMAX,SMX1,SMX2,SNINT,
+ * TRUR,TRUV,VC,OB3,SINPHI3,COSPHI3,SINTH3
+ PARAMETER (OB3 = 0.3333333333333d0)
+ INTEGER I,JCOUNT,id,LT
+ DOUBLE PRECISION CXPRSGM,DKOKOI,PPCS,drangen,EELOG
+ EXTERNAL CXPRSGM,DKOKOI,PPCS,drangen
+ double precision epi(5),epf(5),RD(3),PT,Ptot
+C-----------------------------------------------------------------------
+
+
+
+C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO TARGET INDEX LT
+C (1=N, 2=O, 3=AR) WHICH WAS SET IN BOX2; RESTORE OLD CROSS-SECTION
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRAPTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRPTNO - FRAPTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGPRM - FRPTNO) / airw(3)
+ ELSE
+ WRITE(*,*) 'CXMUPRPR: WRONG TARGET LT =',LT,' STOP'
+ STOP
+ ENDIF
+ ZATOM = airz(LT)
+
+C TOTAL AND KINETIC ENERGY OF MUON
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ IF ( EKIN .LE. BCUT ) GOTO 900
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+C GET NEW CROSS-SECTION
+ SIGNEW = CXPRSGM( EE,LT )
+ RD(1)=drangen(dble(LT))
+
+
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW ) GOTO 900
+C
+ VMIN = 4.D0 * pmass(10) / EE
+ VC = BCUT / EE
+ VMIN = MAX( VMIN, VC )
+ VMAX = 1.D0 - CMUON(10) * ZATOM**OB3 / EE
+ IF ( VMAX .LE. VMIN ) GOTO 900
+
+ ROMIN = 0.D0
+C CALCULATE AUXILIARY VARIABLES (NEW VERSION R.P.K./A.G.B. MARCH 2007
+ EELOG = LOG10 (EE)
+ SK = ZATOM * (ZATOM + 1.D0)
+ IF ( EELOG .LE. 4.D0 ) THEN
+ SK1 = SK*(EELOG+0.8D0)**2 * 0.868D-29
+ SK2 = SK*(EELOG+0.8D0) * 1.000D-33
+ ELSE
+ SK1 = SK*(EELOG-1.6D0) * 8.33D-29
+ SK2 = SK * 4.80D-33
+ ENDIF
+ SNINT = SQRT( SK2/SK1 )
+ SINT1 = SK1 * LOG( SNINT/VMIN )
+ SINT1 = MAX( 0.D0, SINT1 )
+ SINT2 = -0.5D0 * SK2 * ( 1.D0/VMAX**2 - 1.D0/SNINT**2 )
+ SINT2 = MAX( 0.D0, SINT2 )
+ RAT12 = SINT1 / (SINT1+SINT2)
+
+C SAMPLE THE ENERGY FRACTION VFRAC TRANSFERRED TO THE PAIR
+ JCOUNT = 0
+ 321 CONTINUE
+ JCOUNT = JCOUNT + 1
+ IF ( JCOUNT .GT. 1000 )GOTO 900
+ RD(1)=drangen(SK)
+ RD(2)=drangen(SK1)
+ RD(3)=drangen(SK2)
+ IF ( RD(1) .LT. RAT12 ) THEN
+ VFRAC = EXP( LOG( VMIN) + RD(2) * SINT1/SK1 )
+ ELSE
+ VFRAC = SQRT( 1.D0 / ( 1.D0/SNINT**2 - 2.D0*RD(2)*SINT2/SK2 ) )
+ ENDIF
+ IF ( VFRAC .LT. SNINT ) THEN
+ GX = SK1/VFRAC
+ ELSE
+ GX = SK2/(VFRAC**3)
+ ENDIF
+C NORMALIZATION TO MBARN IS MADE IN DKOKOI
+ TRUV = DKOKOI()
+ IF ( RD(3)*GX .GT. TRUV ) GOTO 321
+
+ IF ( VFRAC .GE. VMAX ) VFRAC = VMAX
+ IF ( VFRAC .LE. VMIN ) VFRAC = VMIN
+
+C WE HAVE VFRAC, NOW SAMPLE THE ENERGY ASYMMETRY RO OF THE PAIR
+ ROMAX = ( 1.D0 - 6.D0*pmass(9)**2/( (1.D0-VFRAC)*EE**2 ) )
+ * * SQRT( 1.D0 - VMIN / VFRAC )
+ ROMIN = -ROMAX
+ SMX1 = PPCS(0.D0)
+ SMX2 = PPCS(ROMIN)
+ SMAX = 2.D0 * MAX( SMX1, SMX2 )
+ 456 CONTINUE
+ RD(1)=drangen(ROMIN)
+ RD(2)=drangen(ROMAX)
+ RO = ROMAX * ( 2.D0*RD(1) - 1.D0 )
+C HERE WE NEED NO NORMALIZATION OF PPCS
+ TRUR = PPCS(RO)
+ IF ( SMAX*RD(2) .GT. TRUR ) GOTO 456
+
+C CALCULATE THE ENERGIES
+ EPP = VFRAC * EE
+ EPOS = 0.5D0 * EPP * (1.D0 + RO)
+ ENEG = EPP - EPOS
+C CALCULATE THE ANGLES
+ COSTH3 = COS( pmass(9)/EE )
+ if(abs(COSTH3).ge.1.d0)COSTH3=sign(1.d0,COSTH3)
+ RD(1)=drangen(COSTH3)
+ PHI3 = 2.d0 * PI * RD(1)
+
+C TREAT THE POSITRON
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = EPOS
+ xsptl(5,nptlxs) = pmass(10)
+ idptlxs(nptlxs) = -12
+ istptlxs(nptlxs) = 0
+ if(xsptl(4,nptlxs).le.xsptl(5,nptlxs)) GOTO 321
+ Ptot = sqrt((xsptl(4,nptlxs)+xsptl(5,nptlxs))
+ & *(xsptl(4,nptlxs)-xsptl(5,nptlxs)))
+ xsptl(3,nptlxs) = Ptot * COSTH3
+ SINTH3 = sqrt((1.d0-COSTH3)*(1.d0+COSTH3))
+ PT = Ptot * SINTH3
+ COSPHI3 = COS( PHI3 )
+ if(abs(COSPHI3).ge.1.d0)COSPHI3=sign(1.d0,COSPHI3)
+ SINPHI3 = sqrt((1.d0-COSPHI3)*(1.d0+COSPHI3))
+ xsptl(1,nptlxs) = PT * COSPHI3
+ xsptl(2,nptlxs) = PT * SINPHI3
+
+
+C TREAT THE ELECTRON
+
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = ENEG
+ xsptl(5,nptlxs) = pmass(10)
+ idptlxs(nptlxs) = 12
+ istptlxs(nptlxs) = 0
+ xsptl(1,nptlxs) = -PT * COSPHI3
+ xsptl(2,nptlxs) = -PT * SINPHI3
+ PT=PT*PT+xsptl(5,nptlxs)*xsptl(5,nptlxs)
+ xsptl(3,nptlxs) = (xsptl(4,nptlxs)+PT)*(xsptl(4,nptlxs)-PT)
+ if(xsptl(3,nptlxs).ge.0.d0)then
+ xsptl(3,nptlxs)=sqrt(xsptl(3,nptlxs))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*)'Negative Energy for muon in CXMUPRPR (1) !!!'
+#endif
+ write(*,*)'Negative Energy for muon in CXMUPRPR (1) !!!'
+ write(*,*) (xsptl(i,nptlxs-1),i=1,5),(xsptl(i,nptlxs),i=1,5)
+ write(*,*) 'try again ...'
+ istptlxs(nptlxs)=1
+ istptlxs(nptlxs-1)=1
+ nptlxs=0
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ goto 321
+ endif
+
+C REDUCE ENERGY OF MUON
+ epf(4)= EE - EPP
+ epf(3)=(epf(4)+epf(5))*(epf(4)-epf(5))
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*)'Negative Energy for muon in CXMUPRPR (2) !!!'
+#endif
+ write(*,*)'Negative Energy for muon in CXMUPRPR (2) !!!'
+ write(*,*) id,epf,EE,EPP
+ write(*,*) 'try again ...'
+ istptlxs(nptlxs)=1
+ istptlxs(nptlxs-1)=1
+ nptlxs=0
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ goto 321
+ endif
+
+C THE CHANGEMENT OF THE MUON ANGLE IS NEGLECTED
+
+ 900 CONTINUE
+ nptlxs=nptlxs+1
+ idptlxs(nptlxs)=id
+ istptlxs(nptlxs)=0
+ do i=1,5
+ xsptl(i,nptlxs)=epf(i)
+ enddo
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXBRSGM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X BR(EMSSTRAHLUNG) S(I)G(MA FOR) M(UONS)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MUON BREMSSTRAHLUNG. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. CXMUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM MUSIGMA.
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MUON
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ YE = 10.D0 * LOG10(ELAB) + 21.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXBRSGM = 0.D0
+ DO I = 1, 3
+ CXBRSGM = CXBRSGM + BREMSTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXBRSGM = EXP(CXBRSGM)
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXDEDXM( ELAB )
+
+C-----------------------------------------------------------------------
+C C(ONE)X DE/DX (FOR) M(UON)
+C
+C CALCULATES THE ENERGY LOSS OF MUONS BY BREMSSTRAHLUNG AND
+C PAIR PRODUCTION IN AIR (IN GEV G**-1 CM**2).
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. CXMUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THIS FUNCTION IS CALLED FROM dedxIonMC
+C ARGUMENT:
+C ELAB = TOTAL ENERGY OF MUON
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ YE = 10.D0 * LOG10(ELAB) + 21.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE DEDXM TABLE
+ CXDEDXM = 0.D0
+ DO I = 1, 3
+ CXDEDXM = CXDEDXM + DEDXM(JE+I-1)*WK(I)
+ ENDDO
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXNUSGM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X NU(CLEAR INTERACTION) S(I)G(MA FOR) M(UONS)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MUON NUCLEAR INTERACTION. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. MUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM BOX2.
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MUON
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ YE = 10.D0 * LOG10(ELAB) + 21.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXNUSGM = 0.D0
+ DO I = 1, 3
+ CXNUSGM = CXNUSGM + NUCTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXNUSGM = EXP(CXNUSGM)
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXPRSGM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X P(AI)R (PRODUCTION) S(I)G(MA FOR) M(UONS)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MUON PAIR PRODUCTION. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. MUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM BOX2.
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MUON
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(141,3),NUCTAB(141,3),PAIRTAB(141,3),
+ * DEDXMU(141,3),DEDXM(141),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ YE = 10.D0 * LOG10(ELAB) + 21.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXPRSGM = 0.D0
+ DO I = 1, 3
+ CXPRSGM = CXPRSGM + PAIRTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXPRSGM = EXP(CXPRSGM)
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE DADMUL( F,N,A,B,MINPTS,MAXPTS,EPS,WK,IWK,RESULT,
+ * RELERR,NFNEVL,IFAIL )
+C-----------------------------------------------------------------------
+C CERN ROUTINE FOR ADAPTIVE QUADRATURE FOR MULTIPLE INTEGRALS OVER
+C N-DIMANSIONAL RECTANGULAR REGIONS.
+C SEE: http://consult.cern.ch/shortwriteups/d120/top.html
+C THIS ROUTINE IS CALLED FROM DBRELM, DBRSGM, DNUSGM, DPRELM, DPRSGM.
+C ARGUMENTS: SEE REFERENCE
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ DOUBLE PRECISION HF,R1,W2,W4,WP2,WP4,XL2,XL4,XL5
+ PARAMETER (R1 = 1.d0)
+ PARAMETER (HF = R1*0.5d0)
+ PARAMETER (W2 = 980.D0*R1/6561.D0)
+ PARAMETER (W4 = 200.D0*R1/19683.D0)
+ PARAMETER (WP2 = 245.D0*R1/486.D0)
+ PARAMETER (WP4 = 25.D0*R1/729.D0)
+ PARAMETER (XL2 = 0.358568582800318073D0)
+ PARAMETER (XL4 = 0.948683298050513796D0)
+ PARAMETER (XL5 = 0.688247201611685289D0)
+
+ DOUBLE PRECISION A(*),B(*),WK(*)
+ DOUBLE PRECISION CTR(15),WTH(15),WTHL(15),Z(15),
+ * W(2:15,5),WP(2:15,3)
+ DOUBLE PRECISION ABSERR,DIF,DIFMAX,EPS,F2,F3,
+ * RELERR,RESULT,RGNCMP,RGNERR,RGNVAL,RGNVOL,
+ * SUM1,SUM2,SUM3,SUM4,SUM5,TWONDM
+ INTEGER IDVAXN,IDVAX0,IFAIL,IFNCLS,IRGNST,IRLCLS,
+ * ISBRGN,ISBRGS,ISBTMP,ISBTPP,IWK,
+ * J,J1,K,L,M,MAXPTS,MINPTS,N,NFNEVL
+ LOGICAL LDV
+ DOUBLE PRECISION F
+ EXTERNAL F
+ SAVE
+
+ DATA (W(N,1),W(N,3),N=2,15)
+ 1/-0.193872885230909911D+00, 0.518213686937966768D-01,
+ 2 -0.555606360818980835D+00, 0.314992633236803330D-01,
+ 3 -0.876695625666819078D+00, 0.111771579535639891D-01,
+ 4 -0.115714067977442459D+01, -0.914494741655235473D-02,
+ 5 -0.139694152314179743D+01, -0.294670527866686986D-01,
+ 6 -0.159609815576893754D+01, -0.497891581567850424D-01,
+ 7 -0.175461057765584494D+01, -0.701112635269013768D-01,
+ 8 -0.187247878880251983D+01, -0.904333688970177241D-01,
+ 9 -0.194970278920896201D+01, -0.110755474267134071D+00,
+ A -0.198628257887517146D+01, -0.131077579637250419D+00,
+ B -0.198221815780114818D+01, -0.151399685007366752D+00,
+ C -0.193750952598689219D+01, -0.171721790377483099D+00,
+ D -0.185215668343240347D+01, -0.192043895747599447D+00,
+ E -0.172615963013768225D+01, -0.212366001117715794D+00/
+
+ DATA (W(N,5),W(N+1,5),N=2,14,2)
+ 1/ 0.871183254585174982D-01, 0.435591627292587508D-01,
+ 2 0.217795813646293754D-01, 0.108897906823146873D-01,
+ 3 0.544489534115734364D-02, 0.272244767057867193D-02,
+ 4 0.136122383528933596D-02, 0.680611917644667955D-03,
+ 5 0.340305958822333977D-03, 0.170152979411166995D-03,
+ 6 0.850764897055834977D-04, 0.425382448527917472D-04,
+ 7 0.212691224263958736D-04, 0.106345612131979372D-04/
+
+ DATA (WP(N,1),WP(N,3),N=2,15)
+ 1/-0.133196159122085045D+01, 0.445816186556927292D-01,
+ 2 -0.229218106995884763D+01, -0.240054869684499309D-01,
+ 3 -0.311522633744855959D+01, -0.925925925925925875D-01,
+ 4 -0.380109739368998611D+01, -0.161179698216735251D+00,
+ 5 -0.434979423868312742D+01, -0.229766803840877915D+00,
+ 6 -0.476131687242798352D+01, -0.298353909465020564D+00,
+ 7 -0.503566529492455417D+01, -0.366941015089163228D+00,
+ 8 -0.517283950617283939D+01, -0.435528120713305891D+00,
+ 9 -0.517283950617283939D+01, -0.504115226337448555D+00,
+ A -0.503566529492455417D+01, -0.572702331961591218D+00,
+ B -0.476131687242798352D+01, -0.641289437585733882D+00,
+ C -0.434979423868312742D+01, -0.709876543209876532D+00,
+ D -0.380109739368998611D+01, -0.778463648834019195D+00,
+ E -0.311522633744855959D+01, -0.847050754458161859D+00/
+C-----------------------------------------------------------------------
+
+ RESULT = 0.D0
+ ABSERR = 0.D0
+ IFAIL = 3
+ IF ( N .LT. 2 .OR. N .GT. 15 ) RETURN
+ IF ( MINPTS .GT. MAXPTS ) RETURN
+
+ IFNCLS = 0
+ LDV = .FALSE.
+ TWONDM = 2.D0**N
+ IRGNST = 2 * N + 3
+ IRLCLS = 2**N + 2 * N * (N+1) + 1
+ ISBRGN = IRGNST
+ ISBRGS = IRGNST
+ IF ( MAXPTS .LT. IRLCLS ) RETURN
+ DO J = 1, N
+ CTR(J) = (B(J)+A(J)) * HF
+ WTH(J) = (B(J)-A(J)) * HF
+ ENDDO
+
+ 20 RGNVOL = TWONDM
+ DO J = 1, N
+ RGNVOL = RGNVOL * WTH(J)
+ Z(J) = CTR(J)
+ ENDDO
+ SUM1 = F(Z)
+c print *,'ici',LDV,IFNCLS,SUM1,Z(2)
+
+ DIFMAX = 0.D0
+ SUM2 = 0.D0
+ SUM3 = 0.D0
+ DO J = 1, N
+ Z(J) = CTR(J) - XL2 * WTH(J)
+ F2 = F(Z)
+ Z(J) = CTR(J) + XL2 * WTH(J)
+ F2 = F2 + F(Z)
+ WTHL(J)= XL4 * WTH(J)
+ Z(J) = CTR(J) - WTHL(J)
+ F3 = F(Z)
+ Z(J) = CTR(J) + WTHL(J)
+ F3 = F3 + F(Z)
+ SUM2 = SUM2 + F2
+ SUM3 = SUM3 + F3
+ DIF = ABS( 7.D0*F2 - F3 - 12.D0*SUM1 )
+ DIFMAX = MAX( DIF, DIFMAX )
+ IF ( DIFMAX .EQ. DIF ) IDVAXN = J
+ Z(J) = CTR(J)
+ ENDDO
+
+ SUM4 = 0.D0
+ DO J = 2, N
+ J1 = J - 1
+ DO K = J, N
+ DO L = 1, 2
+ WTHL(J1) = -WTHL(J1)
+ Z(J1) = CTR(J1) + WTHL(J1)
+ DO M = 1, 2
+ WTHL(K) = -WTHL(K)
+ Z(K) = CTR(K) + WTHL(K)
+ SUM4 = SUM4 + F(Z)
+ ENDDO
+ ENDDO
+ Z(K) = CTR(K)
+ ENDDO
+ Z(J1) = CTR(J1)
+ ENDDO
+
+ SUM5 = 0.D0
+ DO J = 1, N
+ WTHL(J) = -XL5 * WTH(J)
+ Z(J) = CTR(J) + WTHL(J)
+ ENDDO
+ 90 SUM5 = SUM5 + F(Z)
+ DO J = 1, N
+ WTHL(J) = -WTHL(J)
+ Z(J) = CTR(J) + WTHL(J)
+ IF ( WTHL(J) .GT. 0.D0 ) GOTO 90
+ ENDDO
+
+ RGNCMP = RGNVOL*(WP(N,1)*SUM1 + WP2*SUM2 + WP(N,3)*SUM3
+ * + WP4*SUM4)
+ RGNVAL = W(N,1)*SUM1 + W2*SUM2 + W(N,3)*SUM3
+ * + W4*SUM4 + W(N,5)*SUM5
+ RGNVAL = RGNVOL * RGNVAL
+ RGNERR = ABS( RGNVAL - RGNCMP )
+ RESULT = RESULT + RGNVAL
+ ABSERR = ABSERR + RGNERR
+ IFNCLS = IFNCLS + IRLCLS
+
+ IF ( LDV ) THEN
+ 110 ISBTMP = 2 * ISBRGN
+ IF ( ISBTMP .GT. ISBRGS ) GOTO 160
+ IF ( ISBTMP .LT. ISBRGS ) THEN
+ ISBTPP = ISBTMP + IRGNST
+ IF ( WK(ISBTMP) .LT. WK(ISBTPP) ) ISBTMP = ISBTPP
+ ENDIF
+ IF ( RGNERR .GE. WK(ISBTMP) ) GOTO 160
+ DO K = 0, IRGNST-1
+ WK(ISBRGN-K) = WK(ISBTMP-K)
+ ENDDO
+ ISBRGN = ISBTMP
+ GOTO 110
+ ENDIF
+ 140 ISBTMP = (ISBRGN / (2*IRGNST) ) * IRGNST
+ IF ( ISBTMP .GE. IRGNST ) THEN
+ IF( RGNERR .GT. WK(ISBTMP) ) THEN
+ DO K = 0, IRGNST-1
+ WK(ISBRGN-K) = WK(ISBTMP-K)
+ ENDDO
+ ISBRGN = ISBTMP
+ GOTO 140
+ ENDIF
+ ENDIF
+ 160 WK(ISBRGN) = RGNERR
+ WK(ISBRGN-1) = RGNVAL
+ WK(ISBRGN-2) = IDVAXN
+ DO J = 1, N
+ ISBTMP = ISBRGN - 2*J - 2
+ WK(ISBTMP+1) = CTR(J)
+ WK(ISBTMP) = WTH(J)
+ ENDDO
+ IF ( LDV ) THEN
+ LDV = .FALSE.
+ CTR(IDVAX0) = CTR(IDVAX0) + 2.D0 * WTH(IDVAX0)
+ ISBRGS = ISBRGS + IRGNST
+ ISBRGN = ISBRGS
+ GOTO 20
+ ENDIF
+ IF ( RESULT .NE. 0.D0 ) THEN
+ RELERR = ABSERR / ABS(RESULT)
+ ELSE
+ RELERR = 0.D0
+ ENDIF
+ IF ( ISBRGS+IRGNST .GT. IWK ) IFAIL = 2
+ IF ( IFNCLS+2*IRLCLS .GT. MAXPTS ) IFAIL = 1
+ IF ( RELERR .LT. EPS .AND. IFNCLS .GE. MINPTS ) IFAIL = 0
+ IF ( IFAIL .EQ. 3 ) THEN
+ LDV = .TRUE.
+ ISBRGN = IRGNST
+ ABSERR = ABSERR - WK(ISBRGN)
+ RESULT = RESULT - WK(ISBRGN-1)
+ IDVAX0 = int(WK(ISBRGN-2))
+ DO J = 1, N
+ ISBTMP = ISBRGN - 2*J - 2
+ CTR(J) = WK(ISBTMP+1)
+ WTH(J) = WK(ISBTMP)
+ ENDDO
+ WTH(IDVAX0) = HF * WTH(IDVAX0)
+ CTR(IDVAX0) = CTR(IDVAX0) - WTH(IDVAX0)
+ GOTO 20
+ ENDIF
+ NFNEVL = IFNCLS
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DBRELM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) BR(EMSSTRAHLUNG) E(NERGY) L(OSS) M(UONS)
+C
+C FUNCTION TO CALCULATE THE MUON BREMSSTRAHLUNG ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION VBSE
+ EXTERNAL VBSE
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DBRELM = 0.D0
+ ECMIN = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ ECMAX = EE - CONSTKINE
+ XLOW = XLOW0
+ XUPP = BCUT/EE
+ IF ( ECMIN .GE. BCUT ) RETURN
+ IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+ IF ( XUPP .LE. XLOW ) RETURN
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = XLOW
+ B(1) = 1.D0
+ B(2) = XUPP
+ CALL DADMUL( VBSE,N,AA,B,MINPTS,MAXPTS
+ * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DBRELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+C NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2
+ DBRELM = AVOG * RESULT * 1.D27 * EE / AATOM
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DBRSGM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) BR(EMSSTRAHLUNG) S(I)GM(A FOR MUONS)
+C
+C FUNCTION TO CALCULATE THE MUON BREMSSTRAHLUNG CROSS-SECTIONS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION VBSS
+ EXTERNAL VBSS
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DBRSGM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ IF ( EE-pmass(9) .LT. BCUT ) RETURN
+
+ ECMIN = 0.D0
+ ECMAX = EE - CONSTKINE
+ XLOW = BCUT / EE
+ XUPP = ECMAX / EE
+ IF ( ECMAX .LT. BCUT ) RETURN
+ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN/EE
+ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+ IF ( XUPP .LE. XLOW ) RETURN
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = XLOW
+ B(1) = 1.D0
+ B(2) = XUPP
+ CALL DADMUL( VBSS,N,AA,B,MINPTS,MAXPTS
+ * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DBRSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+C CONVERT FROM CM**2 TO MILLIBARN
+ DBRSGM = RESULT * 1.D27
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DNIELM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) N(UCL.) I(NTER.) E(NERGY) L(OSS) M(UONS)
+C
+C FUNCTION TO CALCULATE THE MUON NUCLEAR INTERACTION ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION VPHL
+ EXTERNAL VPHL
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DNIELM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ ECMIN = pmass(2) + 0.5D0 * pmass(2)**2 / pmass(7)
+ ECMAX = EE - 0.5D0 * pmass(7) * ( 1.D0 + (pmass(9)/pmass(7))**2 )
+ XLOW = ECMIN / EE
+ XUPP = BCUT / EE
+ IF ( ECMIN .GE. BCUT ) RETURN
+ IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+ IF ( XUPP .LE. XLOW ) RETURN
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = XLOW
+ B(1) = 1.D0
+ B(2) = XUPP
+ CALL DADMUL(VPHL,N,AA,B,MINPTS,MAXPTS
+ * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL)
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DNIELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+ DNIELM = RESULT * 1.D27 * EE * AVOG / AATOM
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DNUSGM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) NU(CLEAR INTERACTION) S(I)GM(A FOR MUONS)
+C
+C FUNCTION TO CALCULATE THE MUON NUCLEAR INTERACTION CROSS-SECTIONS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION VPHM
+ EXTERNAL VPHM
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DNUSGM = 0.D0
+ ECMIN = pmass(2) + 0.5D0 * pmass(2)**2 / pmass(7)
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ ECMAX = EE - 0.5D0 * pmass(7) * ( 1.D0 + (pmass(9)/pmass(7))**2 )
+ XLOW = BCUT / EE
+ XUPP = ECMAX / EE
+ IF ( ECMAX .LT. BCUT ) RETURN
+ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN/EE
+ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+ IF ( XUPP .LE. XLOW ) RETURN
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = XLOW
+ B(1) = 1.D0
+ B(2) = XUPP
+ CALL DADMUL( VPHM,N,AA,B,MINPTS,MAXPTS,
+ + EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DNUSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+C CONVERT FROM CM**2 TO MILLIBARN
+ DNUSGM = RESULT * 1.D27
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DPRELM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) P(AI)R (PRODUCTION) E(NERGY) L(OSS) M(UONS)
+C
+C FUNCTION TO CALCULATE THE MUON BREMSSTRAHLUNG ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION ALPHFA,EPSPP,RE,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (EPSPP = 1.D-3)
+ PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION DKOKOE
+ EXTERNAL DKOKOE
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DPRELM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ ECMIN = 4.D0 * pmass(10)
+ ECMAX = EE - CONSTKINE
+ XLOW = ECMIN / EE
+ XUPP = BCUT / EE
+
+ IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+ IF ( ECMIN .GT. BCUT ) RETURN
+ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+ IF ( XUPP .LT. XLOW + (ECMIN+0.001D0)/EE ) RETURN
+ VMIN = 4.D0 * pmass(10) / EE
+ VMAX = 1.D0 - CONSTKINE / EE
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = LOG10(XLOW)
+ B(1) = 1.D0
+ B(2) = LOG10(XUPP)
+ CALL DADMUL( DKOKOE,N,AA,B,MINPTS,MAXPTS,
+ + EPSPP,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DPRELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+C NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2
+ DPRELM=AVOG * RESULT * 2.D27 * EE * ALPHFA**4 * (TB3/PI)
+ * * ZATOM * (ZATOM+1.D0) * RE**2 / AATOM
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DPRSGM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) P(AI)R (PRODUCTION) S(I)GM(A FOR MUONS)
+C
+C FUNCTION TO CALCULATE THE MUON PAIR PRODUCTION CROSS-SECTIONS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION ALPHFA,EPSPP,RE,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (EPSPP = 1.D-3)
+ PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+ DOUBLE PRECISION AA(2),B(2),WK(IWK)
+ DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER IFAIL,JJMAT,NFNEVL
+ DOUBLE PRECISION DKOKOS
+ EXTERNAL DKOKOS
+ DATA XLOW0 / 1.D-15 /
+ SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DPRSGM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ IF ( EE-pmass(9) .LT. BCUT ) RETURN
+
+ ECMIN = 4.D0 * pmass(10)
+ ECMAX = EE - CONSTKINE
+ XLOW = BCUT / EE
+ XUPP = ECMAX / EE
+ IF ( ECMAX .LT. BCUT ) RETURN
+ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN / EE
+ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+ IF ( XUPP .LE. XLOW ) RETURN
+ VMIN = 4.D0 * pmass(10) / EE
+ VMAX = 1.D0 - CONSTKINE / EE
+
+C DADMUL INTEGRATION
+ AA(1) = 0.D0
+ AA(2) = LOG10(XLOW)
+ B(1) = 1.D0
+ B(2) = LOG10(XUPP)
+ CALL DADMUL( DKOKOS,N,AA,B,MINPTS,MAXPTS,
+ + EPSPP,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+ IF ( IFAIL .NE. 0 ) THEN
+ WRITE(ifck,*) 'DPRSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+ STOP
+ ENDIF
+C CONVERT FROM CM**2 TO MILLIBARN
+ DPRSGM = RESULT * 2.D27 * ALPHFA**4 * (TB3/PI)
+ * * ZATOM * (ZATOM+1.D0) * RE**2
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DKOKOE( Y )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) E(NERGY LOSS)
+C
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+C TO BE USED FOR ENERGY LOSS CALCULATION OF MUON PAIR PRODUCTION.
+C THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRELM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION Y(2)
+ DOUBLE PRECISION ROMAX,ROMIN
+ INTEGER NPNTS
+ DOUBLE PRECISION DGQUAD,PPCE
+ EXTERNAL DGQUAD,PPCE
+ SAVE ROMIN,NPNTS
+ DATA ROMIN /0.D0/, NPNTS / 64 /
+C-----------------------------------------------------------------------
+
+ VFRAC = 10.D0**Y(2)
+C INITIALISATION FOR GAUSS INTEGRATION
+ ROMAX = SQRT( 1.D0 - 4.D0*pmass(10)/(EE*VFRAC) )
+ * * ( 1.D0 - 6.D0*pmass(9)**2/( (1.D0-VFRAC)*EE**2 ) )
+C INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+ DKOKOE = LOG(10.D0) * VFRAC * DGQUAD( PPCE,ROMIN,ROMAX,NPNTS )
+C NORMALIZATION IS MADE IN DPRELM
+ IF ( DKOKOE .LT. 0.D0 ) DKOKOE = 0.D0
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DKOKOI()
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) KOKO(ULIN) INTEGRATION)
+C
+C FUNCTION FOR INTEGRATION OF PAIR PRODUCTION CROSS SECTION WITH
+C RESPECT TO ENERGY ASYMMETRY PARAMETER RO.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+C TO BE USED FOR SAMPLING OF MUON PAIR PRODUCTION.
+C THIS FUNCTION IS CALLED FROM CXMUPRPR.
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,RE,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+ PARAMETER (TB3 = 0.666666666666D0)
+
+ DOUBLE PRECISION A1,A2,A3,TMAX,TMIN
+ INTEGER NPNTS
+ DOUBLE PRECISION DGQUAD,PPCSL
+ EXTERNAL DGQUAD,PPCSL
+ SAVE
+ DATA TMAX /0.D0/, NPNTS / 8 /
+C-----------------------------------------------------------------------
+
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+
+C INITIALISATION FOR GAUSS INTEGRATION
+ A1 = 4.D0*pmass(10)/(EE*VFRAC)
+ IF ( A1 .GE. 1.D0 ) THEN
+ DKOKOI = 0.D0
+ RETURN
+ ENDIF
+ A2 = SQRT(1.D0 - A1)
+ A3 = 6.D0*pmass(9)**2/( (1.D0-VFRAC) * EE**2 )
+ TMIN = LOG( A1/(1.D0+A2) + A3*A2 )
+C INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+ DKOKOI = 2.D0 * DGQUAD( PPCSL,TMIN,TMAX,NPNTS )
+C NORMALIZATION
+ DKOKOI = DKOKOI * ALPHFA**4 * (TB3/PI)
+ * * ZATOM * (ZATOM+1.D0) * RE**2
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DKOKOS( Y )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) S(IGMA)
+C
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+C TO BE USED FOR CROSS SECTION CALCULATION OF MUON PAIR PRODUCTION.
+C THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRSGM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION Y(2)
+ DOUBLE PRECISION ROMAX,ROMIN
+ INTEGER NPNTS
+ DOUBLE PRECISION DGQUAD,PPCS
+ EXTERNAL DGQUAD,PPCS
+ SAVE ROMIN,NPNTS
+ DATA ROMIN /0.D0/, NPNTS / 64 /
+C-----------------------------------------------------------------------
+
+ VFRAC = 10.D0**Y(2)
+
+C INITIALISATION FOR GAUSS INTEGRATION
+ ROMAX = SQRT( 1.D0 - 4.D0*pmass(10)/(EE*VFRAC) )
+ * * ( 1.D0 - 6.D0*pmass(9)**2/( (1.D0-VFRAC)*EE**2 ) )
+C INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+ DKOKOS = LOG(10.D0) * VFRAC * DGQUAD( PPCS,ROMIN,ROMAX,NPNTS )
+C NORMALIZATION IS MADE IN DPRSGM
+ IF ( DKOKOS .LT. 0.D0 ) DKOKOS = 0.D0
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DGQUAD( F,A,B,N )
+
+C-----------------------------------------------------------------------
+C N-POINT GAUSSIAN QUADRATURE
+C SEE: http://consult.cern.ch/shortwriteups/d107/top.html
+C THIS FUNCTION IS CALLED FROM DKOKOE, DKOKOI, AND DKOKOS.
+C ARGUMENTS: SEE REFERENCE
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ DOUBLE PRECISION A,B,F,W(1),X(1)
+ INTEGER N
+ EXTERNAL F
+ SAVE
+C-----------------------------------------------------------------------
+
+ CALL D107D1( 1,F,A,B,N,X,W )
+ DGQUAD = X(1)
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE D107D1( MODE,F,A,B,N,X,W )
+
+C-----------------------------------------------------------------------
+C
+C N-POINT GAUSSIAN QUADRATURE
+C SEE: http://consult.cern.ch/shortwriteups/d107/top.html
+C ARGUMENTS: SEE REFERENCE
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+ DOUBLE PRECISION Z1,HF
+ PARAMETER (Z1 = 1.D0)
+ PARAMETER (HF = Z1/2.D0)
+ DOUBLE PRECISION U(273),V(273),W(*),X(*)
+ DOUBLE PRECISION A,ALFA,B,BETA,DELTA,SUM,WTEMP
+ INTEGER J,J1,J2,KTBA(97),MODE,N
+ DOUBLE PRECISION F
+ EXTERNAL F
+ SAVE
+
+ DATA KTBA
+ 1/0,1,2,4,6,9,12,16,20,25,30,36,42,49,56,64,3*0,72,3*0,82,7*0,94,
+ 2 7*0,110,7*0,130,15*0,154,15*0,186,15*0,226,0/
+
+C N=2.
+ DATA U(1) /5.7735026918962576D-1/, V(1) /1.D0/
+C N=3.
+ DATA U(2) /7.7459666924148338D-1/, V(2) /5.5555555555555556D-1/
+ DATA U(3) /0.D0/ , V(3) /8.8888888888888889D-1/
+C N=4.
+ DATA U(4) /8.6113631159405258D-1/, V(4) /3.4785484513745386D-1/
+ DATA U(5) /3.3998104358485626D-1/, V(5) /6.5214515486254614D-1/
+C N=5.
+ DATA U(6) /9.0617984593866399D-1/, V(6) /2.3692688505618909D-1/
+ DATA U(7) /5.3846931010568309D-1/, V(7) /4.7862867049936647D-1/
+ DATA U(8) /0.D0/ , V(8) /5.6888888888888889D-1/
+C N=6.
+ DATA U(9) /9.3246951420315203D-1/, V(9) /1.7132449237917035D-1/
+ DATA U(10) /6.6120938646626451D-1/, V(10) /3.6076157304813861D-1/
+ DATA U(11) /2.3861918608319691D-1/, V(11) /4.6791393457269105D-1/
+C N=7.
+ DATA U(12) /9.4910791234275852D-1/, V(12) /1.2948496616886969D-1/
+ DATA U(13) /7.4153118559939444D-1/, V(13) /2.7970539148927667D-1/
+ DATA U(14) /4.0584515137739717D-1/, V(14) /3.8183005050511894D-1/
+ DATA U(15) /0.D0/ , V(15) /4.1795918367346939D-1/
+C N=8.
+ DATA U(16) /9.6028985649753623D-1/, V(16) /1.0122853629037626D-1/
+ DATA U(17) /7.9666647741362674D-1/, V(17) /2.2238103445337447D-1/
+ DATA U(18) /5.2553240991632899D-1/, V(18) /3.1370664587788729D-1/
+ DATA U(19) /1.8343464249564980D-1/, V(19) /3.6268378337836198D-1/
+C N=9.
+ DATA U(20) /9.6816023950762609D-1/, V(20) /8.1274388361574412D-2/
+ DATA U(21) /8.3603110732663579D-1/, V(21) /1.8064816069485740D-1/
+ DATA U(22) /6.1337143270059040D-1/, V(22) /2.6061069640293546D-1/
+ DATA U(23) /3.2425342340380893D-1/, V(23) /3.1234707704000284D-1/
+ DATA U(24) /0.D0/ , V(24) /3.3023935500125976D-1/
+C N=10.
+ DATA U(25) /9.7390652851717172D-1/, V(25) /6.6671344308688138D-2/
+ DATA U(26) /8.6506336668898451D-1/, V(26) /1.4945134915058059D-1/
+ DATA U(27) /6.7940956829902441D-1/, V(27) /2.1908636251598204D-1/
+ DATA U(28) /4.3339539412924719D-1/, V(28) /2.6926671930999636D-1/
+ DATA U(29) /1.4887433898163121D-1/, V(29) /2.9552422471475287D-1/
+C N=11.
+ DATA U(30) /9.7822865814605699D-1/, V(30) /5.5668567116173666D-2/
+ DATA U(31) /8.8706259976809530D-1/, V(31) /1.2558036946490462D-1/
+ DATA U(32) /7.3015200557404932D-1/, V(32) /1.8629021092773425D-1/
+ DATA U(33) /5.1909612920681182D-1/, V(33) /2.3319376459199048D-1/
+ DATA U(34) /2.6954315595234497D-1/, V(34) /2.6280454451024666D-1/
+ DATA U(35) /0.D0/ , V(35) /2.7292508677790063D-1/
+C N=12.
+ DATA U(36) /9.8156063424671925D-1/, V(36) /4.7175336386511827D-2/
+ DATA U(37) /9.0411725637047486D-1/, V(37) /1.0693932599531843D-1/
+ DATA U(38) /7.6990267419430469D-1/, V(38) /1.6007832854334623D-1/
+ DATA U(39) /5.8731795428661745D-1/, V(39) /2.0316742672306592D-1/
+ DATA U(40) /3.6783149899818019D-1/, V(40) /2.3349253653835481D-1/
+ DATA U(41) /1.2523340851146892D-1/, V(41) /2.4914704581340279D-1/
+C N=13.
+ DATA U(42) /9.8418305471858815D-1/, V(42) /4.0484004765315880D-2/
+ DATA U(43) /9.1759839922297797D-1/, V(43) /9.2121499837728448D-2/
+ DATA U(44) /8.0157809073330991D-1/, V(44) /1.3887351021978724D-1/
+ DATA U(45) /6.4234933944034022D-1/, V(45) /1.7814598076194574D-1/
+ DATA U(46) /4.4849275103644685D-1/, V(46) /2.0781604753688850D-1/
+ DATA U(47) /2.3045831595513479D-1/, V(47) /2.2628318026289724D-1/
+ DATA U(48) /0.D0/ , V(48) /2.3255155323087391D-1/
+C N=14.
+ DATA U(49) /9.8628380869681234D-1/, V(49) /3.5119460331751863D-2/
+ DATA U(50) /9.2843488366357352D-1/, V(50) /8.0158087159760210D-2/
+ DATA U(51) /8.2720131506976499D-1/, V(51) /1.2151857068790318D-1/
+ DATA U(52) /6.8729290481168547D-1/, V(52) /1.5720316715819353D-1/
+ DATA U(53) /5.1524863635815409D-1/, V(53) /1.8553839747793781D-1/
+ DATA U(54) /3.1911236892788976D-1/, V(54) /2.0519846372129560D-1/
+ DATA U(55) /1.0805494870734366D-1/, V(55) /2.1526385346315779D-1/
+C N=15.
+ DATA U(56) /9.8799251802048543D-1/, V(56) /3.0753241996117268D-2/
+ DATA U(57) /9.3727339240070590D-1/, V(57) /7.0366047488108125D-2/
+ DATA U(58) /8.4820658341042722D-1/, V(58) /1.0715922046717194D-1/
+ DATA U(59) /7.2441773136017005D-1/, V(59) /1.3957067792615431D-1/
+ DATA U(60) /5.7097217260853885D-1/, V(60) /1.6626920581699393D-1/
+ DATA U(61) /3.9415134707756337D-1/, V(61) /1.8616100001556221D-1/
+ DATA U(62) /2.0119409399743452D-1/, V(62) /1.9843148532711158D-1/
+ DATA U(63) /0.D0/ , V(63) /2.0257824192556127D-1/
+C N=16.
+ DATA U(64) /9.8940093499164993D-1/, V(64) /2.7152459411754095D-2/
+ DATA U(65) /9.4457502307323258D-1/, V(65) /6.2253523938647893D-2/
+ DATA U(66) /8.6563120238783174D-1/, V(66) /9.5158511682492785D-2/
+ DATA U(67) /7.5540440835500303D-1/, V(67) /1.2462897125553387D-1/
+ DATA U(68) /6.1787624440264375D-1/, V(68) /1.4959598881657673D-1/
+ DATA U(69) /4.5801677765722739D-1/, V(69) /1.6915651939500254D-1/
+ DATA U(70) /2.8160355077925891D-1/, V(70) /1.8260341504492359D-1/
+ DATA U(71) /9.5012509837637440D-2/, V(71) /1.8945061045506850D-1/
+C N=20.
+ DATA U(72) /9.9312859918509492D-1/, V(72) /1.7614007139152118D-2/
+ DATA U(73) /9.6397192727791379D-1/, V(73) /4.0601429800386941D-2/
+ DATA U(74) /9.1223442825132591D-1/, V(74) /6.2672048334109064D-2/
+ DATA U(75) /8.3911697182221882D-1/, V(75) /8.3276741576704749D-2/
+ DATA U(76) /7.4633190646015079D-1/, V(76) /1.0193011981724044D-1/
+ DATA U(77) /6.3605368072651503D-1/, V(77) /1.1819453196151842D-1/
+ DATA U(78) /5.1086700195082710D-1/, V(78) /1.3168863844917663D-1/
+ DATA U(79) /3.7370608871541956D-1/, V(79) /1.4209610931838205D-1/
+ DATA U(80) /2.2778585114164508D-1/, V(80) /1.4917298647260374D-1/
+ DATA U(81) /7.6526521133497334D-2/, V(81) /1.5275338713072585D-1/
+C N=24.
+ DATA U(82) /9.9518721999702136D-1/, V(82) /1.2341229799987200D-2/
+ DATA U(83) /9.7472855597130950D-1/, V(83) /2.8531388628933663D-2/
+ DATA U(84) /9.3827455200273276D-1/, V(84) /4.4277438817419806D-2/
+ DATA U(85) /8.8641552700440103D-1/, V(85) /5.9298584915436781D-2/
+ DATA U(86) /8.2000198597390292D-1/, V(86) /7.3346481411080306D-2/
+ DATA U(87) /7.4012419157855436D-1/, V(87) /8.6190161531953276D-2/
+ DATA U(88) /6.4809365193697557D-1/, V(88) /9.7618652104113888D-2/
+ DATA U(89) /5.4542147138883954D-1/, V(89) /1.0744427011596563D-1/
+ DATA U(90) /4.3379350762604514D-1/, V(90) /1.1550566805372560D-1/
+ DATA U(91) /3.1504267969616337D-1/, V(91) /1.2167047292780339D-1/
+ DATA U(92) /1.9111886747361631D-1/, V(92) /1.2583745634682830D-1/
+ DATA U(93) /6.4056892862605626D-2/, V(93) /1.2793819534675216D-1/
+C N=32.
+ DATA U(94) /9.9726386184948156D-1/, V(94) /7.0186100094700966D-3/
+ DATA U(95) /9.8561151154526834D-1/, V(95) /1.6274394730905671D-2/
+ DATA U(96) /9.6476225558750643D-1/, V(96) /2.5392065309262059D-2/
+ DATA U(97) /9.3490607593773969D-1/, V(97) /3.4273862913021433D-2/
+ DATA U(98) /8.9632115576605212D-1/, V(98) /4.2835898022226681D-2/
+ DATA U(99) /8.4936761373256997D-1/, V(99) /5.0998059262376176D-2/
+ DATA U(100)/7.9448379596794241D-1/, V(100)/5.8684093478535547D-2/
+ DATA U(101)/7.3218211874028968D-1/, V(101)/6.5822222776361847D-2/
+ DATA U(102)/6.6304426693021520D-1/, V(102)/7.2345794108848506D-2/
+ DATA U(103)/5.8771575724076233D-1/, V(103)/7.8193895787070306D-2/
+ DATA U(104)/5.0689990893222939D-1/, V(104)/8.3311924226946755D-2/
+ DATA U(105)/4.2135127613063535D-1/, V(105)/8.7652093004403811D-2/
+ DATA U(106)/3.3186860228212765D-1/, V(106)/9.1173878695763885D-2/
+ DATA U(107)/2.3928736225213707D-1/, V(107)/9.3844399080804566D-2/
+ DATA U(108)/1.4447196158279649D-1/, V(108)/9.5638720079274859D-2/
+ DATA U(109)/4.8307665687738316D-2/, V(109)/9.6540088514727801D-2/
+C N=40.
+ DATA U(110)/9.9823770971055920D-1/, V(110)/4.5212770985331913D-3/
+ DATA U(111)/9.9072623869945701D-1/, V(111)/1.0498284531152814D-2/
+ DATA U(112)/9.7725994998377426D-1/, V(112)/1.6421058381907889D-2/
+ DATA U(113)/9.5791681921379166D-1/, V(113)/2.2245849194166957D-2/
+ DATA U(114)/9.3281280827867653D-1/, V(114)/2.7937006980023401D-2/
+ DATA U(115)/9.0209880696887430D-1/, V(115)/3.3460195282547847D-2/
+ DATA U(116)/8.6595950321225950D-1/, V(116)/3.8782167974472018D-2/
+ DATA U(117)/8.2461223083331166D-1/, V(117)/4.3870908185673272D-2/
+ DATA U(118)/7.7830565142651939D-1/, V(118)/4.8695807635072232D-2/
+ DATA U(119)/7.2731825518992710D-1/, V(119)/5.3227846983936824D-2/
+ DATA U(120)/6.7195668461417955D-1/, V(120)/5.7439769099391551D-2/
+ DATA U(121)/6.1255388966798024D-1/, V(121)/6.1306242492928939D-2/
+ DATA U(122)/5.4946712509512820D-1/, V(122)/6.4804013456601038D-2/
+ DATA U(123)/4.8307580168617871D-1/, V(123)/6.7912045815233904D-2/
+ DATA U(124)/4.1377920437160500D-1/, V(124)/7.0611647391286780D-2/
+ DATA U(125)/3.4199409082575847D-1/, V(125)/7.2886582395804059D-2/
+ DATA U(126)/2.6815218500725368D-1/, V(126)/7.4723169057968264D-2/
+ DATA U(127)/1.9269758070137110D-1/, V(127)/7.6110361900626242D-2/
+ DATA U(128)/1.1608407067525521D-1/, V(128)/7.7039818164247966D-2/
+ DATA U(129)/3.8772417506050822D-2/, V(129)/7.7505947978424811D-2/
+C N=48.
+ DATA U(130)/9.9877100725242612D-1/, V(130)/3.1533460523058386D-3/
+ DATA U(131)/9.9353017226635076D-1/, V(131)/7.3275539012762621D-3/
+ DATA U(132)/9.8412458372282686D-1/, V(132)/1.1477234579234539D-2/
+ DATA U(133)/9.7059159254624725D-1/, V(133)/1.5579315722943849D-2/
+ DATA U(134)/9.5298770316043086D-1/, V(134)/1.9616160457355528D-2/
+ DATA U(135)/9.3138669070655433D-1/, V(135)/2.3570760839324379D-2/
+ DATA U(136)/9.0587913671556967D-1/, V(136)/2.7426509708356948D-2/
+ DATA U(137)/8.7657202027424789D-1/, V(137)/3.1167227832798089D-2/
+ DATA U(138)/8.4358826162439353D-1/, V(138)/3.4777222564770439D-2/
+ DATA U(139)/8.0706620402944263D-1/, V(139)/3.8241351065830706D-2/
+ DATA U(140)/7.6715903251574034D-1/, V(140)/4.1545082943464749D-2/
+ DATA U(141)/7.2403413092381465D-1/, V(141)/4.4674560856694280D-2/
+ DATA U(142)/6.7787237963266391D-1/, V(142)/4.7616658492490475D-2/
+ DATA U(143)/6.2886739677651362D-1/, V(143)/5.0359035553854475D-2/
+ DATA U(144)/5.7722472608397270D-1/, V(144)/5.2890189485193667D-2/
+ DATA U(145)/5.2316097472223303D-1/, V(145)/5.5199503699984163D-2/
+ DATA U(146)/4.6690290475095840D-1/, V(146)/5.7277292100403216D-2/
+ DATA U(147)/4.0868648199071673D-1/, V(147)/5.9114839698395636D-2/
+ DATA U(148)/3.4875588629216074D-1/, V(148)/6.0704439165893880D-2/
+ DATA U(149)/2.8736248735545558D-1/, V(149)/6.2039423159892664D-2/
+ DATA U(150)/2.2476379039468906D-1/, V(150)/6.3114192286254026D-2/
+ DATA U(151)/1.6122235606889172D-1/, V(151)/6.3924238584648187D-2/
+ DATA U(152)/9.7004699209462699D-2/, V(152)/6.4466164435950082D-2/
+ DATA U(153)/3.2380170962869362D-2/, V(153)/6.4737696812683923D-2/
+C N=64.
+ DATA U(154)/9.9930504173577214D-1/, V(154)/1.7832807216964329D-3/
+ DATA U(155)/9.9634011677195528D-1/, V(155)/4.1470332605624676D-3/
+ DATA U(156)/9.9101337147674432D-1/, V(156)/6.5044579689783629D-3/
+ DATA U(157)/9.8333625388462596D-1/, V(157)/8.8467598263639477D-3/
+ DATA U(158)/9.7332682778991096D-1/, V(158)/1.1168139460131129D-2/
+ DATA U(159)/9.6100879965205372D-1/, V(159)/1.3463047896718643D-2/
+ DATA U(160)/9.4641137485840282D-1/, V(160)/1.5726030476024719D-2/
+ DATA U(161)/9.2956917213193958D-1/, V(161)/1.7951715775697343D-2/
+ DATA U(162)/9.1052213707850281D-1/, V(162)/2.0134823153530209D-2/
+ DATA U(163)/8.8931544599511412D-1/, V(163)/2.2270173808383254D-2/
+ DATA U(164)/8.6599939815409282D-1/, V(164)/2.4352702568710873D-2/
+ DATA U(165)/8.4062929625258036D-1/, V(165)/2.6377469715054659D-2/
+ DATA U(166)/8.1326531512279756D-1/, V(166)/2.8339672614259483D-2/
+ DATA U(167)/7.8397235894334141D-1/, V(167)/3.0234657072402479D-2/
+ DATA U(168)/7.5281990726053190D-1/, V(168)/3.2057928354851554D-2/
+ DATA U(169)/7.1988185017161083D-1/, V(169)/3.3805161837141609D-2/
+ DATA U(170)/6.8523631305423324D-1/, V(170)/3.5472213256882384D-2/
+ DATA U(171)/6.4896547125465734D-1/, V(171)/3.7055128540240046D-2/
+ DATA U(172)/6.1115535517239325D-1/, V(172)/3.8550153178615629D-2/
+ DATA U(173)/5.7189564620263403D-1/, V(173)/3.9953741132720341D-2/
+ DATA U(174)/5.3127946401989455D-1/, V(174)/4.1262563242623529D-2/
+ DATA U(175)/4.8940314570705296D-1/, V(175)/4.2473515123653589D-2/
+ DATA U(176)/4.4636601725346409D-1/, V(176)/4.3583724529323453D-2/
+ DATA U(177)/4.0227015796399160D-1/, V(177)/4.4590558163756563D-2/
+ DATA U(178)/3.5722015833766812D-1/, V(178)/4.5491627927418144D-2/
+ DATA U(179)/3.1132287199021096D-1/, V(179)/4.6284796581314417D-2/
+ DATA U(180)/2.6468716220876742D-1/, V(180)/4.6968182816210017D-2/
+ DATA U(181)/2.1742364374000708D-1/, V(181)/4.7540165714830309D-2/
+ DATA U(182)/1.6964442042399282D-1/, V(182)/4.7999388596458308D-2/
+ DATA U(183)/1.2146281929612055D-1/, V(183)/4.8344762234802957D-2/
+ DATA U(184)/7.2993121787799039D-2/, V(184)/4.8575467441503427D-2/
+ DATA U(185)/2.4350292663424433D-2/, V(185)/4.8690957009139720D-2/
+C N=80.
+ DATA U(186)/9.9955382265163063D-1/, V(186)/1.1449500031869415D-3/
+ DATA U(187)/9.9764986439823769D-1/, V(187)/2.6635335895126817D-3/
+ DATA U(188)/9.9422754096568828D-1/, V(188)/4.1803131246948952D-3/
+ DATA U(189)/9.8929130249975553D-1/, V(189)/5.6909224514031986D-3/
+ DATA U(190)/9.8284857273862907D-1/, V(190)/7.1929047681173128D-3/
+ DATA U(191)/9.7490914058572779D-1/, V(191)/8.6839452692608584D-3/
+ DATA U(192)/9.6548508904379925D-1/, V(192)/1.0161766041103065D-2/
+ DATA U(193)/9.5459076634363491D-1/, V(193)/1.1624114120797827D-2/
+ DATA U(194)/9.4224276130987267D-1/, V(194)/1.3068761592401339D-2/
+ DATA U(195)/9.2845987717244580D-1/, V(195)/1.4493508040509076D-2/
+ DATA U(196)/9.1326310257175765D-1/, V(196)/1.5896183583725688D-2/
+ DATA U(197)/8.9667557943877068D-1/, V(197)/1.7274652056269306D-2/
+ DATA U(198)/8.7872256767821383D-1/, V(198)/1.8626814208299031D-2/
+ DATA U(199)/8.5943140666311110D-1/, V(199)/1.9950610878141999D-2/
+ DATA U(200)/8.3883147358025528D-1/, V(200)/2.1244026115782006D-2/
+ DATA U(201)/8.1695413868146347D-1/, V(201)/2.2505090246332462D-2/
+ DATA U(202)/7.9383271750460545D-1/, V(202)/2.3731882865930101D-2/
+ DATA U(203)/7.6950242013504137D-1/, V(203)/2.4922535764115491D-2/
+ DATA U(204)/7.4400029758359727D-1/, V(204)/2.6075235767565118D-2/
+ DATA U(205)/7.1736518536209988D-1/, V(205)/2.7188227500486381D-2/
+ DATA U(206)/6.8963764434202760D-1/, V(206)/2.8259816057276862D-2/
+ DATA U(207)/6.6085989898611980D-1/, V(207)/2.9288369583267848D-2/
+ DATA U(208)/6.3107577304687197D-1/, V(208)/3.0272321759557981D-2/
+ DATA U(209)/6.0033062282975174D-1/, V(209)/3.1210174188114702D-2/
+ DATA U(210)/5.6867126812270978D-1/, V(210)/3.2100498673487773D-2/
+ DATA U(211)/5.3614592089713193D-1/, V(211)/3.2941939397645401D-2/
+ DATA U(212)/5.0280411188878499D-1/, V(212)/3.3733214984611523D-2/
+ DATA U(213)/4.6869661517054448D-1/, V(213)/3.4473120451753929D-2/
+ DATA U(214)/4.3387537083175609D-1/, V(214)/3.5160529044747593D-2/
+ DATA U(215)/3.9839340588196923D-1/, V(215)/3.5794393953416055D-2/
+ DATA U(216)/3.6230475349948732D-1/, V(216)/3.6373749905835978D-2/
+ DATA U(217)/3.2566437074770191D-1/, V(217)/3.6897714638276009D-2/
+ DATA U(218)/2.8852805488451185D-1/, V(218)/3.7365490238730490D-2/
+ DATA U(219)/2.5095235839227212D-1/, V(219)/3.7776364362001397D-2/
+ DATA U(220)/2.1299450285766613D-1/, V(220)/3.8129711314477638D-2/
+ DATA U(221)/1.7471229183264681D-1/, V(221)/3.8424993006959423D-2/
+ DATA U(222)/1.3616402280914389D-1/, V(222)/3.8661759774076463D-2/
+ DATA U(223)/9.7408398441584599D-2/, V(223)/3.8839651059051969D-2/
+ DATA U(224)/5.8504437152420669D-2/, V(224)/3.8958395962769531D-2/
+ DATA U(225)/1.9511383256793998D-2/, V(225)/3.9017813656306655D-2/
+C N=96.
+ DATA U(226)/9.9968950388323077D-1/, V(226)/7.9679206555201243D-4/
+ DATA U(227)/9.9836437586318168D-1/, V(227)/1.8539607889469217D-3/
+ DATA U(228)/9.9598184298720929D-1/, V(228)/2.9107318179349464D-3/
+ DATA U(229)/9.9254390032376262D-1/, V(229)/3.9645543384446867D-3/
+ DATA U(230)/9.8805412632962380D-1/, V(230)/5.0142027429275177D-3/
+ DATA U(231)/9.8251726356301468D-1/, V(231)/6.0585455042359617D-3/
+ DATA U(232)/9.7593917458513647D-1/, V(232)/7.0964707911538653D-3/
+ DATA U(233)/9.6832682846326421D-1/, V(233)/8.1268769256987592D-3/
+ DATA U(234)/9.5968829144874254D-1/, V(234)/9.1486712307833866D-3/
+ DATA U(235)/9.5003271778443764D-1/, V(235)/1.0160770535008416D-2/
+ DATA U(236)/9.3937033975275522D-1/, V(236)/1.1162102099838499D-2/
+ DATA U(237)/9.2771245672230869D-1/, V(237)/1.2151604671088320D-2/
+ DATA U(238)/9.1507142312089807D-1/, V(238)/1.3128229566961573D-2/
+ DATA U(239)/9.0146063531585234D-1/, V(239)/1.4090941772314861D-2/
+ DATA U(240)/8.8689451740242042D-1/, V(240)/1.5038721026994938D-2/
+ DATA U(241)/8.7138850590929650D-1/, V(241)/1.5970562902562291D-2/
+ DATA U(242)/8.5495903343460146D-1/, V(242)/1.6885479864245172D-2/
+ DATA U(243)/8.3762351122818712D-1/, V(243)/1.7782502316045261D-2/
+ DATA U(244)/8.1940031073793168D-1/, V(244)/1.8660679627411467D-2/
+ DATA U(245)/8.0030874413914082D-1/, V(245)/1.9519081140145022D-2/
+ DATA U(246)/7.8036904386743322D-1/, V(246)/2.0356797154333325D-2/
+ DATA U(247)/7.5960234117664750D-1/, V(247)/2.1172939892191299D-2/
+ DATA U(248)/7.3803064374440013D-1/, V(248)/2.1966644438744349D-2/
+ DATA U(249)/7.1567681234896763D-1/, V(249)/2.2737069658329374D-2/
+ DATA U(250)/6.9256453664217156D-1/, V(250)/2.3483399085926220D-2/
+ DATA U(251)/6.6871831004391615D-1/, V(251)/2.4204841792364691D-2/
+ DATA U(252)/6.4416340378496712D-1/, V(252)/2.4900633222483610D-2/
+ DATA U(253)/6.1892584012546857D-1/, V(253)/2.5570036005349361D-2/
+ DATA U(254)/5.9303236477757208D-1/, V(254)/2.6212340735672414D-2/
+ DATA U(255)/5.6651041856139717D-1/, V(255)/2.6826866725591762D-2/
+ DATA U(256)/5.3938810832435744D-1/, V(256)/2.7412962726029243D-2/
+ DATA U(257)/5.1169417715466767D-1/, V(257)/2.7970007616848334D-2/
+ DATA U(258)/4.8345797392059636D-1/, V(258)/2.8497411065085386D-2/
+ DATA U(259)/4.5470942216774301D-1/, V(259)/2.8994614150555237D-2/
+ DATA U(260)/4.2547898840730055D-1/, V(260)/2.9461089958167906D-2/
+ DATA U(261)/3.9579764982890860D-1/, V(261)/2.9896344136328386D-2/
+ DATA U(262)/3.6569686147231364D-1/, V(262)/3.0299915420827594D-2/
+ DATA U(263)/3.3520852289262542D-1/, V(263)/3.0671376123669149D-2/
+ DATA U(264)/3.0436494435449635D-1/, V(264)/3.1010332586313837D-2/
+ DATA U(265)/2.7319881259104914D-1/, V(265)/3.1316425596861356D-2/
+ DATA U(266)/2.4174315616384001D-1/, V(266)/3.1589330770727167D-2/
+ DATA U(267)/2.1003131046056720D-1/, V(267)/3.1828758894411006D-2/
+ DATA U(268)/1.7809688236761860D-1/, V(268)/3.2034456231992663D-2/
+ DATA U(269)/1.4597371465489694D-1/, V(269)/3.2206204794030251D-2/
+ DATA U(270)/1.1369585011066592D-1/, V(270)/3.2343822568575928D-2/
+ DATA U(271)/8.1297495464425559D-2/, V(271)/3.2447163714064269D-2/
+ DATA U(272)/4.8812985136049731D-2/, V(272)/3.2516118713868836D-2/
+ DATA U(273)/1.6276744849602970D-2/, V(273)/3.2550614492363166D-2/
+C-----------------------------------------------------------------------
+
+ IF ( KTBA( MIN( MAX(1,N), 97 ) ) .EQ. 0 ) THEN
+ X(1) = 0.D0
+ WRITE(*,101) N
+ 101 FORMAT('DGQUAD: ERROR N = ',I5,' IS NON-PERMISSIBLE')
+ RETURN
+ ENDIF
+ ALFA = HF * (B + A)
+ BETA = HF * (B - A)
+ IF ( MODE .EQ. 1 ) THEN
+ SUM = 0.D0
+ J1 = MOD(N,2)
+ J2 = KTBA(N) + (N-1)/2
+ DO J = KTBA(N), J2-J1
+ DELTA = BETA * U(J)
+ SUM = SUM + V(J) * ( F(ALFA+DELTA) + F(ALFA-DELTA) )
+ ENDDO
+ IF ( J1 .EQ. 1 ) SUM = SUM + V(J2) * F(ALFA)
+ X(1) = BETA * SUM
+ ELSE
+ J1 = KTBA(N) - 1
+ J2 = N + 1
+ DO J = 1, J2/2
+ WTEMP = BETA * V(J1+J)
+ DELTA = BETA * U(J1+J)
+ X(J) = ALFA - DELTA
+ W(J) = WTEMP
+ X(J2-J) = ALFA + DELTA
+ W(J2-J) = WTEMP
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION PPCE( R1 )
+
+C-----------------------------------------------------------------------
+C P(AIR) P(RODUCTION) C(ROSS SECTION FOR GAUSS INTEGR.) E(NERGY LOSS)
+C
+C FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+C PAIR PRODUCTION ENERGY LOSS.
+C PARAMETERS TO BE GIVEN BY COMMON:
+C EE = ENERGY OF INCOMING MUON
+C VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+C ZATOM = ATOMIC NUMBER OF TARGET ATOM
+C THIS FUNCTION IS CALLED FROM DGQUAD (BY DKOKOE)
+C ARGUMENT:
+C R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION R,OB3,TB3
+ PARAMETER (R = 189.D0)
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+ DOUBLE PRECISION R1
+ DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+ * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+ * FIE,FIM,QFIE,QFIM,
+ * RO2,UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+ SAVE
+C-----------------------------------------------------------------------
+
+ RO2 = R1**2
+ AUXIL2 = R / ZATOM**OB3
+ BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+ CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+ UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+ DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+ * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+ YE = UPPYE/DOWNYE
+ UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+ DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+ * + 1.D0 - 1.5D0 * RO2
+ YM = UPPYM/DOWNYM
+ AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+ UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+ DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+ * * AUXIL2 ) * AUXIL
+ ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+ * * (1.D0+YE)
+ ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+ UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+ DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+ * * AUXIL2 ) * AUXIL
+ ALM = LOG(UPPLM/DOWNLM)
+ QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+ FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+ * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+ QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+ * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+ FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+ * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+C NORMALIZATION IS MADE IN DPRELM AND IN DKOKOE
+ PPCE = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION PPCS( R1 )
+
+C-----------------------------------------------------------------------
+C P(AIR) P(RODUCTION) C(ROSS) S(ECTION FOR GAUSS INTEGRATION)
+C
+C FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+C PAIR PRODUCTION CROSS-SECTIONS.
+C PARAMETERS TO BE GIVEN BY COMMON:
+C EE = ENERGY OF INCOMING MUON
+C VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+C ZATOM = ATOMIC NUMBER OF TARGET ATOM
+C THIS FUNCTION IS CALLED FROM DGQUAD (BY CXMUPRPR, DKOKOS, DKOKOS)
+C AND CXMUPRPR.
+C ARGUMENT:
+C R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION R,OB3,TB3
+ PARAMETER (R = 189.D0)
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+ DOUBLE PRECISION R1
+ DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+ * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+ * FIE,FIM,QFIE,QFIM,
+ * RO2,UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+C-----------------------------------------------------------------------
+
+ RO2 = R1**2
+ AUXIL2 = R / ZATOM**OB3
+ BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+ CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+ UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+ DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+ * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+ YE = UPPYE/DOWNYE
+ UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+ DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+ * + 1.D0 - 1.5D0 * RO2
+ YM = UPPYM/DOWNYM
+ AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+ UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+ DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+ * * AUXIL2 ) * AUXIL
+ ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+ * * (1.D0+YE)
+ ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+ UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+ DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+ * * AUXIL2 ) * AUXIL
+ ALM = LOG(UPPLM/DOWNLM)
+ QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+ FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+ * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+ QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+ * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+ FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+ * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+C NORMALIZATION IS MADE IN DPRSGM AND IN DKOKOI
+ PPCS = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC
+
+ RETURN
+ END
+
+*-- Author : R.P. Kokoulin, A.G. Bogdanov MEPhi, Moscow 30/03/2007
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION PPCSL( T )
+
+C-----------------------------------------------------------------------
+C P(AIR) P(RODUCTION) C(ROSS) S(ECTION WITH) L(OGARITHMIC SUBSTITUTION)
+C (FOR GAUSS INTEGRATION)
+C
+C FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+C PAIR PRODUCTION CROSS-SECTIONS.
+C PARAMETERS TO BE GIVEN BY COMMON:
+C EE = ENERGY OF INCOMING MUON
+C VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+C ZATOM = ATOMIC NUMBER OF TARGET ATOM
+C THIS FUNCTION IS CALLED FROM DGQUAD (BY CXMUPRPR) FOR NEW VERSION OF
+C DKOKOI (MARCH 2007)
+C
+C ARGUMENT:
+C T = LOG( 1 - R1) WITH
+C R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION R,OB3,TB3
+ PARAMETER (R = 189.D0)
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+ DOUBLE PRECISION R1,T
+ DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+ * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+ * FIE,FIM,QFIE,QFIM,RO2,R1MN1,
+ * UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+ SAVE
+C-----------------------------------------------------------------------
+C R1MN1 IS 1 - R1
+C T IS ARGUMENT FROM DGQUAD CALLED BY NEW VERSION OF DKOKOI
+
+ R1MN1 = EXP( T )
+ R1 = 1.D0 - R1MN1
+ RO2 = R1**2
+ AUXIL2 = R / ZATOM**OB3
+ BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+ CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+ UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+ DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+ * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+ YE = UPPYE/DOWNYE
+ UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+ DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+ * + 1.D0 - 1.5D0 * RO2
+ YM = UPPYM/DOWNYM
+ AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+ UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+ DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+ * * AUXIL2 ) * AUXIL
+ ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+ * * (1.D0+YE)
+ ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+ UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+ DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+ * * AUXIL2 ) * AUXIL
+ ALM = LOG(UPPLM/DOWNLM)
+ QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+ FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+ * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+ QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+ * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+ FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+ * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+C NORMALIZATION IS MADE IN DPRSGM AND IN DKOKOI
+ PPCSL = R1MN1 * ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION VBSE( Y )
+
+C-----------------------------------------------------------------------
+C
+C FUNCTION TO BE USED FOR INTEGRATION OF MUON BREMSSTRAHLUNG
+C ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+C THIS FUNCTION IS CALLED FROM DADMUL (BY DBRELM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,BBS,CBS,RE,OB3,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (BBS = 184.15D0)
+ PARAMETER (CBS = 1194.0D0)
+ PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+ DOUBLE PRECISION Y(2)
+ DOUBLE PRECISION AA,AASQ,ABS,APAM,A1,A2,C1,C2,CC1,CC2,
+ * D1,D2,DBS,DELTA1,DELTA2,FI1,FI10,FI2,FI20,
+ * QMIN,RA,XX,X1,X1SQ,X2,X2SQ
+C-----------------------------------------------------------------------
+
+ XX = Y(2)
+ ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2
+ DBS = (1.D0 - XX)
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ QMIN = XX * pmass(9)**2 / (2.D0 * EE * DBS)
+ A1 = BBS / ( SE * pmass(10) * ZATOM**OB3 )
+ A2 = CBS / ( SE * pmass(10) * ZATOM**TB3 )
+
+ X1 = A1 * QMIN
+ X1SQ = X1**2
+ X2 = A2 * QMIN
+ X2SQ = X2**2
+ RA = ZATOM**OB3 / 1.9D0
+C ANDREEV EQ. 2.16B
+ AASQ = 1.D0 + 4.D0 * RA**2
+ AA = SQRT(AASQ)
+ APAM = LOG( (AA+1.D0) / (AA-1.D0) )
+C ANDREEV EQ. 2.16A
+ DELTA1= LOG(RA) + 0.5D0 * AA * APAM
+ DELTA2= LOG(RA) + 0.25D0 * AA * APAM * (3.D0-AASQ) + 2.D0*RA**2
+ C1 = LOG( ( (pmass(9)*A1)**2 ) / (1.D0+X1SQ) )
+ C2 = LOG( ( (pmass(9)*A2)**2 ) / (1.D0+X2SQ) )
+ CC1 = ATAN(1.D0/X1)
+ CC2 = ATAN(1.D0/X2)
+C ANDREEV EQ. 2.9A
+ FI10 = ( 0.5D0*(1.D0+C2) - X2*CC2 ) / ZATOM
+ * + 0.5D0*(1.D0+C1) - X1*CC1
+ FI1 = FI10 - DELTA1
+
+ D1 = 0.75D0 * LOG( X1SQ / (1.D0+X1SQ) )
+ D2 = 0.75D0 * LOG( X2SQ / (1.D0+X2SQ) )
+C ANDREEV EQ. 2.9B
+ FI20 = ( 0.5D0*(TB3+C2) + 2.D0*X2SQ * (1.D0-X2*CC2+D2) ) / ZATOM
+ * + 0.5D0*(TB3+C1) + 2.D0*X1SQ * (1.D0-X1*CC1+D1)
+C ANDREEV EQ. 2.6
+ FI2 = FI20 - DELTA2
+C FOR ENERGY LOSSES
+ VBSE = ALPHFA * ABS * ( (1.D0+DBS**2)*FI1 - TB3*DBS*FI2 )
+
+ IF ( VBSE .LE. 0.D0 ) VBSE = 0.D0
+
+ RETURN
+ END
+
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION VBSS( Y )
+
+C-----------------------------------------------------------------------
+C
+C FUNCTION TO BE USED FOR INTEGRATION OF MUON BREMSSTRAHLUNG
+C CROSS SECTION.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+C THIS FUNCTION IS CALLED FROM DADMUL (BY DBRSGM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,BBS,CBS,RE,OB3,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (BBS = 184.15D0)
+ PARAMETER (CBS = 1194.0D0)
+ PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+ DOUBLE PRECISION Y(2)
+ DOUBLE PRECISION AA,AASQ,ABS,APAM,A1,A2,C1,C2,CC1,CC2,
+ * D1,D2,DBS,DELTA1,DELTA2,FI1,FI10,FI2,FI20,
+ * QMIN,RA,XX,X1,X1SQ,X2,X2SQ
+C-----------------------------------------------------------------------
+
+ XX = Y(2)
+ ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2
+ DBS = (1.D0 - XX)
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+ QMIN = XX * pmass(9)**2 / (2.D0 * EE * DBS)
+ A1 = BBS / ( SE * pmass(10) * ZATOM**OB3 )
+ A2 = CBS / ( SE * pmass(10) * ZATOM**TB3 )
+
+ X1 = A1 * QMIN
+ X1SQ = X1**2
+ X2 = A2 * QMIN
+ X2SQ = X2**2
+ RA = ZATOM**OB3 / 1.9D0
+C ANDREEV EQ. 2.16B
+ AASQ = 1.D0 + 4.D0 * RA**2
+ AA = SQRT(AASQ)
+ APAM = LOG( (AA+1.D0) / (AA-1.D0) )
+C ANDREEV EQ. 2.16A
+ DELTA1= LOG(RA) + 0.5D0 * AA * APAM
+ DELTA2= LOG(RA) + 0.25D0 * AA * APAM * (3.D0-AASQ) + 2.D0*RA**2
+ C1 = LOG( ( (pmass(9)*A1)**2 ) / (1.D0+X1SQ) )
+ C2 = LOG( ( (pmass(9)*A2)**2 ) / (1.D0+X2SQ) )
+ CC1 = ATAN(1.D0/X1)
+ CC2 = ATAN(1.D0/X2)
+C ANDREEV EQ. 2.9A
+ FI10 = ( 0.5D0*(1.D0+C2) - X2*CC2 ) / ZATOM
+ * + 0.5D0*(1.D0+C1) - X1*CC1
+ FI1 = FI10 - DELTA1
+
+ D1 = 0.75D0 * LOG( X1SQ / (1.D0+X1SQ) )
+ D2 = 0.75D0 * LOG( X2SQ / (1.D0+X2SQ) )
+C ANDREEV EQ. 2.9B
+ FI20 = ( 0.5D0*(TB3+C2) + 2.D0*X2SQ * (1.D0-X2*CC2+D2) ) / ZATOM
+ * + 0.5D0*(TB3+C1) + 2.D0*X1SQ * (1.D0-X1*CC1+D1)
+C ANDREEV EQ. 2.6
+ FI2 = FI20 - DELTA2
+C FOR ENERGY LOSSES
+ VBSS = ALPHFA * ABS * ( (1.D0+DBS**2)*FI1 - TB3*DBS*FI2 )
+C FOR CROSS-SECTIONS
+ VBSS = VBSS / XX
+
+ IF ( VBSS .LE. 0.D0 ) VBSS = 0.D0
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION VPHL(Y)
+
+C-----------------------------------------------------------------------
+C
+C FUNCTION TO BE USED FOR INTEGRATION OF MUON NUCLEAR INTERACTION
+C ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+C THIS FUNCTION IS CALLED FROM DADMUL (BY DNIELM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI!,ELE1,ELE2
+ PARAMETER (ALPHFA = 7.297353D-3)
+C BEZRUKOV'S M1**2 AND M2**2
+ PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (APH = 0.00282D0)
+C BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+ PARAMETER (CSI = 0.25D0)
+c PARAMETER (ELE1 = 0.0808D0)
+c PARAMETER (ELE2 = -0.4525D0)
+ DOUBLE PRECISION Y(2),OB3
+ PARAMETER (OB3 = 0.3333333333333d0)
+ DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH,
+ * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ
+C-----------------------------------------------------------------------
+
+ XX = Y(2)
+C CALCULATE BEZRUKOV'S T
+ TTT = pmass(9)**2 * XX**2 / (1.D0 - XX)
+C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUO
+ SS = 2.D0 * pmass(7) * XX * EE
+C CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+C SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+C SEE: PARTCIlE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+ SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+C SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+ ZZZ = SIGN * APH * AATOM**OB3
+C CALCULATE BOTTAI'S H(V)
+ HHH = 1.D0 - 2.D0/XX + 2.D0/XX**2
+C CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+ GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+C FACTOR BEFORE LARGE BRACKET
+ BPH = AATOM * XX**2 * SIGN * (ALPHFA/(8.D0*PI)) * 1.D-30
+C AUXILIARY QUANTITIES
+ CPH = 1.D0 + AM21/TTT
+ DPH = 1.D0 + AM22/TTT
+ EPH = 2.D0 * pmass(9)**2 / TTT
+ FPH = AM21 / (AM21 + TTT)
+C FIRST PART WITHIN LARGE BRACKET
+ VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+C SECOND PART WITHIN LARGE BRACKET
+ VPH2 = (2.D0 * CSI * pmass(9)**2/TTT)
+ * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) )
+C FOR ENERGY LOSSES
+ VPHL = BPH * (VPH1+VPH2)
+
+ IF ( VPHL .LE. 0.D0 ) VPHL = 0.D0
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION VPHM( Y )
+
+C-----------------------------------------------------------------------
+C
+C FUNCTION TO BE USED FOR INTEGRATION OF MUON NUCLEAR INTERACTION
+C CROSS SECTION.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C L.B. BEZRUKOV AND E.V. BUGAEV, SOV.J.NUCL.PHYS. 33 (1981) 635
+C THIS FUNCTION IS CALLED FROM DADMUL (BY DNUSGM).
+C ARGUMENTS: (TO BE USED BY DADMUL)
+C N = DIMENSION
+C Y = DUMMY ARRAY OF DIMENSION N
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI!,ELE1,ELE2
+ PARAMETER (ALPHFA = 7.297353D-3)
+C BEZRUKOV'S M1**2 AND M2**2
+ PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (APH = 0.00282D0)
+C BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+ PARAMETER (CSI = 0.25D0)
+c PARAMETER (ELE1 = 0.0808D0)
+c PARAMETER (ELE2 = -0.4525D0)
+ DOUBLE PRECISION Y(2),OB3
+ PARAMETER (OB3 = 0.3333333333333d0)
+ DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH,
+ * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ
+C-----------------------------------------------------------------------
+
+ XX = Y(2)
+C CALCULATE BEZRUKOV'S T
+ TTT = pmass(9)**2 * XX**2 / (1.D0 - XX)
+C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUO
+ SS = 2.D0 * pmass(7) * XX * EE
+C CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+C SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+C SEE: PARTICLE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+ SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+C SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+ ZZZ = SIGN * APH * AATOM**OB3
+C CALCULATE BOTTAI'S H(V)
+ HHH = 1.D0 - 2.D0/XX + 2.D0/XX**2
+C CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+ GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+C FACTOR BEFORE LARGE BRACKET
+ BPH = AATOM * XX**2 * SIGN * (ALPHFA/(8.D0*PI)) * 1.D-30
+C AUXILIARY QUANTITIES
+ CPH = 1.D0 + AM21/TTT
+ DPH = 1.D0 + AM22/TTT
+ EPH = 2.D0 * pmass(9)**2 / TTT
+ FPH = AM21 / (AM21 + TTT)
+C FIRST PART WITHIN LARGE BRACKET
+ VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+C SECOND PART WITHIN LARGE BRACKET
+ VPH2 = (2.D0 * CSI * pmass(9)**2/TTT)
+ * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) )
+C FINAL CROSS-SECTION
+ VPHM = BPH * (VPH1+VPH2) / XX
+ IF ( VPHM .LT. 0.D0 ) VPHM = 0.D0
+
+ RETURN
+ END
+
+#endif
+
+c
+c
+c following functions are standard
+c
+c
+c------------------------------------------------------
+ FUNCTION gammq(x)
+c------------------------------------------------------
+
+ implicit none
+ DOUBLE PRECISION gammq,x
+C USES gcf,gser
+c Returns the incomplete gamma function Q(a, x) a 1-P(a, x).
+ DOUBLE PRECISION gammcf,gamser
+
+ if(x.lt.0)stop 'bad arguments in gammq'
+
+ if(x.lt.1.5)then
+c Use the series representation
+ call gser(gamser,x)
+ gammq=1.d0-gamser
+c and take its complement.
+ else
+c Use the continued fraction representation.
+ call gcf(gammcf,x)
+ gammq=gammcf
+ endif
+
+ return
+
+ END
+
+c------------------------------------------------------
+ SUBROUTINE gser(gamser,x)
+c------------------------------------------------------
+ implicit none
+ INTEGER ITMAX
+ DOUBLE PRECISION gamser,x,EPS,gln
+ PARAMETER (ITMAX=100,EPS=3.d-6)
+C USES gammlncx
+c Returns the incomplete gamma function P(a, x) with a=0.5
+c evaluated by its series representation as gamser.
+c Also returns ln (a) as gln.
+ INTEGER n
+ DOUBLE PRECISION ap,del,sum
+ parameter (gln=0.572364942d0) !gln=log(sqrt(pi))
+c gln=gammlncx(a)
+
+ if(x.le.0.d0)then
+ if(x.lt.0.d0)stop 'x < 0 in gser'
+ gamser=0.d0
+ return
+ endif
+ ap=0.5d0
+ sum=2.d0
+ del=sum
+
+ do n=1,ITMAX
+ ap=ap+1.d0
+ del=del*x/ap
+ sum=sum+del
+ if(abs(del).lt.abs(sum)*EPS)goto 1
+ enddo
+
+ write(*,*) 'Warning : a too large, ITMAX too small in gser'
+ 1 gamser=sum*sqrt(x)*exp(-x-gln)
+ return
+
+ END
+
+c------------------------------------------------------
+ SUBROUTINE gcf(gammcf,x)
+c------------------------------------------------------
+
+ implicit none
+ INTEGER ITMAX
+ DOUBLE PRECISION gammcf,x,EPS,FPMIN,gln
+ PARAMETER (ITMAX=200,EPS=3.d-5,FPMIN=1.d-30)
+C USES gammlncx
+c Returns the incomplete gamma function Q(a, x) with a=0.5
+c evaluated by its continued fraction representation
+c as gammcf. Also returns ln (a) as gln.
+c Parameters:
+c ITMAX is the maximum allowed number of iterations;
+c EPS is the relative accuracy;
+c FPMIN is a number near the smallest representable floating-point number.
+ INTEGER i
+ DOUBLE PRECISION an,b,c,d,del,h
+ parameter (gln=0.572364942d0) !gln=log(sqrt(pi))
+c gln=gammlncx(a)
+
+ b=x+0.5d0
+c Set up for evaluating continued fraction by
+c modified Lentz s method (5.2) with b0 = 0.
+ c=1.d0/FPMIN
+ d=1.d0/b
+ h=d
+ do i=1,ITMAX
+c Iterate to convergence.
+ an=-dble(i)*(dble(i)-0.5d0)
+ b=b+2.d0
+ d=an*d+b
+ if(abs(d).lt.FPMIN)d=FPMIN
+ c=b+an/c
+ if(abs(c).lt.FPMIN)c=FPMIN
+ d=1.d0/d
+ del=d*c
+ h=h*del
+ if(abs(del-1.d0).lt.EPS)goto 1
+ enddo
+ write(*,*) 'Warning : a too large, ITMAX too small in gcf'
+c 1 gammcf=exp(-x+0.5d0*log(x)-gln)*h
+ 1 gammcf=sqrt(x)*exp(-x-gln)*h
+c Put factors in front.
+ return
+ END
+
+c------------------------------------------------------
+ DOUBLE PRECISION FUNCTION gammlncx(xx)
+c------------------------------------------------------
+ implicit none
+ DOUBLE PRECISION xx
+c Returns the value ln[ (xx)] for xx > 0.
+ INTEGER j
+ DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
+c Internal arithmetic will be done in double
+c precision, a nicety that you can omit if ve-
+c gure accuracy is good enough.
+ SAVE cof,stp
+ DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
+ * 24.01409824083091d0,-1.231739572450155d0,
+ * .1208650973866179d-2,
+ * -.5395239384953d-5,2.5066282746310005d0/
+ x=xx
+ y=x
+ tmp=x+5.5d0
+ tmp=(x+0.5d0)*log(tmp)-tmp
+ ser=1.000000000190015d0
+ do j=1,6
+ y=y+1.d0
+ ser=ser+cof(j)/y
+ enddo
+ gammlncx=tmp+log(stp*ser/x)
+
+ return
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMMOLIE( CHI,Emu,P0,OMEGA,DENS )
+
+C-----------------------------------------------------------------------
+C M(UON) MOLIE(RE MULTIPLE SCATTERING)
+C
+C TREATES MOLIERE MULTIPLE SCATTERING FOR MUONS
+C CORRECTED FOR FINITE ANGLE SCATTERING
+C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GMOLIE.
+C (AUTHOR: M.S.DIXIT, NRCC, OTTAWA) OF GEANT321
+C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013
+C THIS SUBROUTINE IS CALLED FROM PROPAGATION.
+C ARGUMENTS:
+C CHI = SLANT DEPTH PASSED
+C Emu = MUON TOTAL ENERGY
+C P0 = MUON MOMENTUM
+C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP
+C DENS = LOCAL DENSITY
+C
+C-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+
+ DOUBLE PRECISION TINT(40),B,BINV,CHIC,CNST,DB,DENS,OMEGA,SINTH,
+ * TEST,TMP,XINT,P0,CHI,RD(2),Emu
+ REAL ARG(4),F0I(40),F1I(40),F2I(40),
+ * THRED(40),VAL(4),F,THRI,XINT2
+ INTEGER IER,JA,L,M,NA,NA3,NA3M,NMAX
+ SAVE
+
+ DATA THRED/ 0.00, 0.10, 0.20, 0.30
+ + , 0.40, 0.50, 0.60, 0.70
+ + , 0.80, 0.90, 1.00, 1.10
+ + , 1.20, 1.30, 1.40, 1.50
+ + , 1.60, 1.70, 1.80, 1.90
+ + , 2.00, 2.20, 2.40, 2.60
+ + , 2.80, 3.00, 3.20, 3.40
+ + , 3.60, 3.80, 4.00, 5.00
+ + , 6.00, 7.00, 8.00, 9.00
+ + , 10.00,11.00,12.00,13.00 /
+ DATA F0I/
+ + 0.000000E+00 ,0.995016E-02 ,0.392106E-01 ,0.860688E-01
+ + ,0.147856E+00 ,0.221199E+00 ,0.302324E+00 ,0.387374E+00
+ + ,0.472708E+00 ,0.555142E+00 ,0.632121E+00 ,0.701803E+00
+ + ,0.763072E+00 ,0.815480E+00 ,0.859142E+00 ,0.894601E+00
+ + ,0.922695E+00 ,0.944424E+00 ,0.960836E+00 ,0.972948E+00
+ + ,0.981684E+00 ,0.992093E+00 ,0.996849E+00 ,0.998841E+00
+ + ,0.999606E+00 ,0.999877E+00 ,0.999964E+00 ,0.999990E+00
+ + ,0.999998E+00 ,0.999999E+00 ,0.100000E+01 ,0.100000E+01
+ + ,0.100000E+01 ,0.100000E+01 ,0.100000E+01 ,0.100000E+01
+ + ,1.000000E+00 ,1.000000E+00 ,1.000000E+00 ,1.000000E+00 /
+ DATA F1I/
+ + 0.000000E+00, 0.414985E-02, 0.154894E-01, 0.310312E-01
+ + , 0.464438E-01, 0.569008E-01, 0.580763E-01, 0.468264E-01
+ + , 0.217924E-01,-0.163419E-01,-0.651205E-01,-0.120503E+00
+ + ,-0.178272E+00,-0.233580E+00,-0.282442E+00,-0.321901E+00
+ + ,-0.350115E+00,-0.366534E+00,-0.371831E+00,-0.367378E+00
+ + ,-0.354994E+00,-0.314803E+00,-0.266539E+00,-0.220551E+00
+ + ,-0.181546E+00,-0.150427E+00,-0.126404E+00,-0.107830E+00
+ + ,-0.933106E-01,-0.817375E-01,-0.723389E-01,-0.436650E-01
+ + ,-0.294700E-01,-0.212940E-01,-0.161406E-01,-0.126604E-01
+ + ,-0.102042E-01,-0.840465E-02,-0.704261E-02,-0.598886E-02/
+ DATA F2I/
+ + 0.000000 , 0.121500E-01, 0.454999E-01, 0.913000E-01
+ + , 0.137300E+00, 0.171400E+00, 0.183900E+00, 0.170300E+00
+ + , 0.132200E+00, 0.763000E-01, 0.126500E-01,-0.473500E-01
+ + ,-0.936000E-01,-0.119750E+00,-0.123450E+00,-0.106300E+00
+ + ,-0.732800E-01,-0.312400E-01, 0.128450E-01, 0.528800E-01
+ + , 0.844100E-01, 0.114710E+00, 0.106200E+00, 0.765830E-01
+ + , 0.435800E-01, 0.173950E-01, 0.695001E-03,-0.809500E-02
+ + ,-0.117355E-01,-0.125449E-01,-0.120280E-01,-0.686530E-02
+ + ,-0.385275E-02,-0.231115E-02,-0.147056E-02,-0.982480E-03
+ + ,-0.682440E-03,-0.489715E-03,-0.361190E-03,-0.272582E-03/
+C-----------------------------------------------------------------------
+
+#ifdef __CXDEBUG__
+ IF (isx.ge.5 ) WRITE(ifck,*) 'CXMMOLIE: OMEGA=',SNGL(OMEGA),
+ * ' DENS=',SNGL(DENS)
+#endif
+C COMPUTE VMSCAT ANGLE FROM MOLIERE DISTRIBUTION
+ VMSCAT = 0.D0
+ IF ( OMEGA .LE. ENEPER1 ) RETURN
+ CNST = LOG(OMEGA)
+ B = 5.D0
+ DO L = 1, 10
+ IF ( ABS(B) .LT. 1.D-10 ) THEN
+ B = 1.D-10
+ ENDIF
+ DB = - ((B - LOG(ABS(B)) - CNST)/(1.D0 - 1.D0/B))
+ B = B + DB
+ IF ( ABS(DB) .LE. 0.0001D0 ) GOTO 20
+ ENDDO
+ RETURN
+ 20 CONTINUE
+ IF ( B .LE. 0.D0 ) RETURN
+C CHC IS DEFINED DIFFERENTLY FROM GEANT
+ CHIC = CHC * SQRT( CHI ) * Emu / ( P0 * P0 ) !E*beta**2=P^2/E
+ BINV = 1.D0/B
+ TINT(1) = 0.D0
+ DO JA = 2, 4
+ TINT(JA) = F0I(JA) + ( F1I(JA) + F2I(JA)*BINV ) * BINV
+ ENDDO
+ NMAX = 4
+ 40 CONTINUE
+ CALL RMMARD( RD,2,lseq )
+ XINT = RD(2)
+ DO NA = 3, 40
+ IF ( NA .GT. NMAX ) THEN
+ TINT(NA) = F0I(NA) + ( F1I(NA) + F2I(NA)*BINV ) * BINV
+ NMAX = NA
+ ENDIF
+ IF ( XINT .LE. TINT(NA-1) ) GOTO 60
+ ENDDO
+ IF ( XINT .LE. TINT(40) ) THEN
+ NA = 40
+ GOTO 60
+ ELSE
+ TMP = 1.D0 - ( 1.D0 - B*(1.D0-XINT) )**5
+ IF ( TMP .LE. 0.D0 ) GOTO 40
+ THRI = 5.D0 / TMP
+ GOTO 80
+ ENDIF
+ 60 CONTINUE
+ NA = MAX(NA-1,3)
+ NA3 = NA-3
+ DO M = 1, 4
+ NA3M = NA3 + M
+ ARG(M) = TINT(NA3M)
+ VAL(M) = THRED(NA3M)**2
+ ENDDO
+ F = THRED(NA) * .02D0
+ XINT2 = XINT
+ CALL CXMMOL4( THRI,XINT2,VAL,ARG,F,IER )
+ 80 CONTINUE
+ VMSCAT = CHIC * SQRT( ABS(B*THRI) )
+ IF ( VMSCAT .GT. PI ) GOTO 40
+ SINTH = SIN( VMSCAT )
+ TEST = VMSCAT * (RD(1))**2
+ IF ( TEST .GT. SINTH ) GOTO 40
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMMOL4( Y,X,VAL,ARG,EPS,IER )
+
+C-----------------------------------------------------------------------
+C M(UON) MOL(IERE SCATTERING) 4 (POINT CONTINUED FRACT. INTERPOLATION)
+C
+C ROUTINE TAKEN FROM IBM SCIENTIFIC SUBROUT. PACKAGE
+C ROUTINE TAKEN FROM GEANT321 (CERN)
+C 4 POINT CONTINUED FRACTION INTERPOLATION.
+C THIS SUBROUTINE IS CALLED FROM MMOLIE.
+C ARGUMENTS:
+C Y = INTERPOLATED VALUE FOR THE ARGUMENT X
+C X = ARGUMENT FOR Y
+C VAL = VALUE ARRAY
+C ARG = ARGUMENT ARRAY
+C EPS = DESIRED ACCURACY
+C IER = OUTPUT ERROR PARAMETER
+C 0 ACCURACY O.K.
+C 1 ACCURACY CAN NOT BE TESTED IN 4TH ORDER INTERPOLATION
+C 2 TWO IDENTICAL ELEMENTS IN THE ARGUMENT ARRAY
+C
+C-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ REAL ARG(4),AUX,DELT,EPS,H,P1,P2,P3,Q1,Q2,Q3,VAL(4),X,Y,Z
+ INTEGER I,II,III,IER,J,JEND
+ SAVE
+C-----------------------------------------------------------------------
+
+ IER = 1
+ Y = VAL(1)
+ P2 = 1.
+ P3 = Y
+ Q2 = 0.
+ Q3 = 1.
+ DO 16 I = 2, 4
+ II = 0
+ P1 = P2
+ P2 = P3
+ Q1 = Q2
+ Q2 = Q3
+ Z = Y
+ JEND = I - 1
+ 3 AUX = VAL(I)
+ DO 10 J = 1, JEND
+ H = VAL(I) - VAL(J)
+ IF ( ABS(H) .GT. 1.E-6*ABS(VAL(I)) ) GOTO 9
+ IF ( ARG(I) .EQ. ARG(J) ) GOTO 17
+ IF ( J .LT. JEND ) GOTO 8
+ II = II + 1
+ III = I + II
+ IF ( III .GT. 4 ) GOTO 19
+ VAL(I) = VAL(III)
+ VAL(III) = AUX
+ AUX = ARG(I)
+ ARG(I) = ARG(III)
+ ARG(III) = AUX
+ GOTO 3
+ 8 VAL(I) = 1.E36
+ GOTO 10
+ 9 VAL(I) = ( ARG(I)-ARG(J) ) / H
+ 10 CONTINUE
+ P3 = VAL(I) * P2 + ( X - ARG(I-1) ) * P1
+ Q3 = VAL(I) * Q2 + ( X - ARG(I-1) ) * Q1
+ IF ( Q3. NE. 0. ) THEN
+ Y = P3 / Q3
+ ELSE
+ Y = 1.E36
+ ENDIF
+ DELT = ABS(Z-Y)
+ IF ( DELT .LE. EPS ) GOTO 19
+ 16 CONTINUE
+ RETURN
+ 17 IER = 2
+ RETURN
+ 19 IER = 0
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMUCOUL( P0,OMEGA,DENS )
+
+C-----------------------------------------------------------------------
+C MU(ON) COUL(OMB SCATTERING OF SINGLE SCATTERING EVENTS)
+C
+C TREATES SINGLE COULOMB SCATTERING FOR MUONS IN SMALL ANGLE
+C APPROXIMATION.
+C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GMCOUL
+C (AUTHOR: G. LYNCH, LBL) OF GEANT321
+C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013
+C THIS SUBROUTINE IS CALLED FROM PROPAGATION.
+C INPUT ARGUMENTS:
+C P0 = MOMENTUM OF MUON
+C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP
+C DENS = LOCAL DENSITY
+C OUTPUT (COMMON):
+C VMSCAT = SCATTERING ANGLE
+C
+C-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+ INTEGER I,NSCMX,NSCA
+ parameter (nscmx=50)
+ DOUBLE PRECISION DENS,OMCF,OMEGA,OMEGA0,PHIS,SUMX,SUMY,
+ * THET,THMIN2,RD(2*nscmx),P0,xNSCA
+ SAVE
+ DATA OMCF/1.167D0/
+C-----------------------------------------------------------------------
+
+#ifdef __CXDEBUG__
+ IF (isx.ge.5) WRITE(ifck,*) 'MUCOUL: OMEGA=',SNGL(OMEGA),
+ * ' DENS=',SNGL(DENS)
+#endif
+C COMPUTE NUMBER OF SCATTERS (POISSON DISTR. WITH MEAN OMEGA0)
+ OMEGA0 = OMCF*OMEGA
+ CALL CXMPOISS( OMEGA0,xNSCA )
+ NSCA=NINT(xNSCA)
+ IF ( NSCA .LE. 0 ) THEN
+ VMSCAT = 0.D0
+ RETURN
+ ENDIF
+ NSCA = MIN( NSCA, NSCMX )
+ CALL RMMARD( RD,2*NSCA,lseq )
+
+C THMIN2 IS THE SCREENING ANGLE
+ THMIN2 = CHC**2/( OMCF*OMC * P0**2 )
+ SUMX = 0.D0
+ SUMY = 0.D0
+ DO I = 1, NSCA
+ THET = SQRT( THMIN2*((1.D0/RD(I)) - 1.D0) )
+ PHIS = 2d0 * PI * RD(NSCA+I)
+ SUMX = SUMX + THET * COS( PHIS )
+ SUMY = SUMY + THET * SIN( PHIS )
+ ENDDO
+ VMSCAT = SQRT( SUMX**2 + SUMY**2 )
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMPOISS( AMEAN,AN )
+
+C-----------------------------------------------------------------------
+C M(UON COULOMB SCATTERING) POISS(ON DISTRIBUTION)
+C
+C GENERATES A RANDOM NUMBER POISSON DISTRIBUTED WITH MEAN VALUE AMEAN.
+C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GPOISS.
+C (AUTHOR: L. URBAN) OF GEANT321
+C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013.
+C THIS SUBROUTINE IS CALLED FROM MUCOUL.
+C ARGUMENTS:
+C AMEAN = MEAN VALUE OF RANDOM NUMBER
+C AN = RANDOM NUMBER POISSON DISTRIBUTED
+C
+C-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+
+ DOUBLE PRECISION AMEAN,AN,P,PLIM,RR,S,X,RD(2),drangen
+ EXTERNAL drangen
+ SAVE
+ DATA PLIM/16.D0/
+C-----------------------------------------------------------------------
+
+C PROTECTION AGAINST NEGATIVE MEAN VALUES
+ AN = 0.D0
+ IF ( AMEAN .GT. 0.D0 ) THEN
+ IF ( AMEAN .LE. PLIM ) THEN
+ RD(1) = drangen(amean)
+ P = EXP(-AMEAN)
+ S = P
+ IF ( RD(1) .LE. S ) GOTO 20
+ 10 AN = AN + 1.D0
+ P = P * AMEAN / AN
+ S = S + P
+ IF ( S .LT. RD(1) .AND. P .GT. 1.D-30 ) GOTO 10
+ ELSE
+ RD(1) = drangen(amean)
+ RD(2)= drangen(an)
+ RR = SQRT( (-2.D0)*LOG(RD(1)) )
+ X = RR * COS( 2d0 * PI * RD(2) )
+ AN = MAX( 0.D0, AMEAN+X*SQRT( AMEAN ) )
+ ENDIF
+ ENDIF
+ 20 CONTINUE
+
+ RETURN
+ END
+
+*-- Author : D. HECK IK FZK KARLSRUHE 27/04/1994
+C=======================================================================
+
+ SUBROUTINE CXVAPOR( MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY )
+
+C-----------------------------------------------------------------------
+C (E)VAPOR(ATION OF NUCLEONS AND ALPHA PARTICLES FROM FRAGMENT)
+C
+C TREATES THE REMAINING UNFRAGMENTED NUCLEUS
+C EVAPORATION FOLLOWING CAMPI APPROXIMATION.
+C SEE: X. CAMPI AND J. HUEFNER, PHYS.REV. C24 (1981) 2199
+C AND J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990)
+C THIS SUBROUTINE IS CALLED FROM SDPM, DPMJST, NSTORE, AND VSTORE.
+C ARGUMENTS INPUT:
+C MAPROJ = NUMBER OF NUCLEONS OF PROJECTILE
+C INEW = PARTICLE TYPE OF SPECTATOR FRAGMENT
+C ARGUMENTS OUTPUT:
+C JFIN = NUMBER OF FRAGMENTS
+C ITYP(1:JFIN) = NATURE (PARTICLE CODE) OF FRAGMENTS
+C PFRX(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN X-DIRECTION
+C PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+
+ DOUBLE PRECISION PFR(mamxs),PFRX(mamxs),PFRY(mamxs),RD(2*mamxs)
+ * ,SPFRY
+ DOUBLE PRECISION AFIN,AGLH,APRF,BGLH,EEX,PHIFR,RANNOR,SPFRX
+ INTEGER ITYP(mamxs),IARM,INEW,ITYPRM,INRM,IS,IZRM,JC,
+ * JFIN,K,L,LS,MAPROJ,MF,NFIN,NINTA,NNUC,NPRF,NNSTEP
+ SAVE
+ EXTERNAL RANNOR
+C-----------------------------------------------------------------------
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) 'CXVAPOR : MAPROJ,INEW=',MAPROJ,INEW
+#endif
+
+ ITYPRM = INEW
+ NPRF = ABS(INEW)/100
+ NINTA = MAPROJ - NPRF
+ IF ( NINTA .EQ. 0 ) THEN
+C NO NUCLEON HAS INTERACTED
+ JFIN = 1
+ PFR(1) = 0.D0
+ ITYP(1) = SIGN(NPRF*100,INEW)
+#ifdef __CXDEBUG__
+ IF (isx.ge.7 ) WRITE(ifck,*) 'CXVAPOR : JFIN,NINTA=',JFIN,NINTA
+#endif
+ RETURN
+ ENDIF
+
+C EXCITATION ENERGY EEX OF PREFRAGMENT
+C SEE: J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990), CHPT. 4.2
+ EEX = 0.D0
+ CALL RMMARD( RD,2*NINTA,lseq )
+ DO L = 1, NINTA
+ IF ( RD(NINTA+L) .LT. RD(L) ) RD(L) = 1.D0 - RD(L)
+ EEX = EEX + RD(L)
+ ENDDO
+C DEPTH OF WOODS-SAXON POTENTIAL TO FERMI SURFACE IS 0.040 GEV
+#ifdef __CXDEBUG__
+ IF (isx.ge.7) WRITE(ifck,*)'CXVAPOR : EEX=',SNGL(EEX*0.04D0),
+ & ' GEV'
+#endif
+ if(ITYPRM.ge.0)then
+C EVAPORATION: EACH EVAPORATION STEP NEEDS ABOUT 0.020 GEV, THEREFORE
+C NNSTEP IS EEX * 0.04/0.02 = EEX * 2.
+ NNSTEP = INT( EEX*2.D0 )
+ else !strangelet
+C EVAPORATION: EACH EVAPORATION STEP NEEDS ABOUT 0.010 GEV, THEREFORE
+C NNSTEP IS EEX * 0.04/0.01 = EEX * 4.
+ NNSTEP = INT( EEX*4.D0 )
+ endif
+
+ IF ( NNSTEP .LE. 0 ) THEN
+C EXCITATION ENERGY TOO SMALL, NO EVAPORATION
+ JFIN = 1
+ PFR(1) = 0.D0
+ ITYP(1) = SIGN(NPRF*100,INEW)
+#ifdef __CXDEBUG__
+ IF (isx.ge.7) WRITE(ifck,*) 'CXVAPOR : JFIN,EEX=',JFIN,SNGL(EEX)
+#endif
+ RETURN
+ ENDIF
+
+C AFIN IS ATOMIC NUMBER OF FINAL NUCLEUS
+ APRF = DBLE(NPRF)
+ AFIN = APRF - 1.6D0 * DBLE(NNSTEP)
+ NFIN = MAX( 0, INT( AFIN+0.5D0 ) )
+C CORRESPONDS TO DEFINITION; FRAGMENTATION-EVAPORATION
+C CONVOLUTION EMU07 /MODEL ABRASION EVAPORATION (JNC FZK APRIL 94)
+C NNUC IS NUMBER OF EVAPORATING NUCLEONS
+ NNUC = NPRF - NFIN
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) 'CXVAPOR : NFIN,NNUC=',NFIN,NNUC
+#endif
+ JC = 0
+
+ if(ITYPRM.ge.0)then
+
+ IF ( NNUC .LE. 0 ) THEN
+C NO EVAPORATION
+ JFIN = 1
+ PFR(1) = 0.D0
+ ITYP(1) = ITYPRM
+ RETURN
+
+ ELSEIF ( NNUC .GE. 4 ) THEN
+C EVAPORATION WITH FORMATION OF ALPHA PARTICLES POSSIBLE
+C IARM, IZRM, INRM ARE NUMBER OF NUCLEONS, PROTONS, NEUTRONS OF
+C REMAINDER
+ DO LS = 1, NNSTEP
+ IARM = ITYPRM/100
+ IF ( IARM .LE. 0 ) GOTO 100
+ IZRM = MOD(ITYPRM,100)
+ INRM = IARM - IZRM
+ JC = JC + 1
+ CALL RMMARD( RD,2,lseq )
+ IF ( RD(1) .LT. 0.2D0 .AND. IZRM .GE. 2
+ * .AND. INRM .GE. 2 ) THEN
+ ITYP(JC) = 400
+ NNUC = NNUC - 4
+ ITYPRM = ITYPRM - 402
+ ELSE
+ IF ( RD(2)*(IZRM+INRM) .LT. IZRM ) THEN
+ ITYP(JC) = 1120
+ ITYPRM = ITYPRM - 101
+ ELSE
+ ITYP(JC) = 1220
+ ITYPRM = ITYPRM - 100
+ ENDIF
+ NNUC = NNUC - 1
+ ENDIF
+ IF ( NNUC .LE. 0 ) GOTO 50
+ ENDDO
+ ENDIF
+
+ IF ( NNUC .LT. 4 ) THEN
+C EVAPORATION WITHOUT FORMATION OF ALPHA PARTICLES
+ CALL RMMARD( RD,NNUC,lseq )
+ DO IS = 1, NNUC
+ IARM = ITYPRM/100
+ IF ( IARM .LE. 0 ) GOTO 100
+ IZRM = MOD(ITYPRM,100)
+ JC = JC + 1
+ IF ( RD(IS)*IARM .LT. IZRM ) THEN
+ ITYP(JC) = 1120
+ ITYPRM = ITYPRM - 101
+ ELSE
+ ITYP(JC) = 1220
+ ITYPRM = ITYPRM - 100
+ ENDIF
+ ENDDO
+ ENDIF
+
+ else
+
+
+C EVAPORATION OF HYPERONS
+ CALL RMMARD( RD,NNUC,1 )
+ DO IS = 1, NNUC
+ JC = JC + 1
+ ITYP(JC) = 2130
+ ITYPRM = ITYPRM + 100
+ ENDDO
+
+ endif
+
+ 50 CONTINUE
+ JC = JC + 1
+ IF ( ITYPRM .GE. 201 ) THEN
+ ITYP(JC) = ITYPRM/100 !Z number useless in CONEX
+ ITYP(JC) = ITYP(JC)*100
+ ELSEIF ( ITYPRM .EQ. 200 ) THEN
+ ITYP(JC) = 1220
+ JC = JC + 1
+ ITYP(JC) = 1220
+ ELSEIF ( ITYPRM .EQ. 101 ) THEN
+ ITYP(JC) = 1120
+ ELSEIF ( ITYPRM .EQ. 100 ) THEN
+ ITYP(JC) = 1220
+ ELSEIF ( ITYPRM .EQ. -100 ) THEN
+ ITYP(JC) = 2130
+ ELSEIF( ITYPRM .LE. -200 ) THEN
+ ITYP(JC) = ITYPRM/100 !Z number useless in CONEX
+ ITYP(JC) = ITYP(JC)*100
+ ELSE
+ JC = JC - 1
+ IF ( ITYPRM .NE. 0 ) WRITE(*,*)
+ * 'CXVAPOR : ILLEGAL PARTICLE ITYPRM =',ITYPRM
+ ENDIF
+
+ 100 CONTINUE
+ JFIN = JC
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) 'CXVAPOR : NO ITYP PFR'
+#endif
+ IF ( ifragm .EQ. 2 ) THEN
+C EVAPORATION WITH PT AFTER PARAMETRIZED JACEE DATA
+ DO MF = 1, JFIN
+ PFR(MF) = RANNOR(0.088D0,0.044D0)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) MF,ITYP(MF),SNGL(PFR(MF))
+#endif
+ ENDDO
+ ELSEIF ( ifragm .EQ. 3 ) THEN
+C EVAPORATION WITH PT AFTER GOLDHABER''S MODEL (PHYS.LETT.53B(1974)306)
+ DO MF = 1, JFIN
+ K = MAX( 1, ITYP(MF)/100 )
+ BGLH = K * (MAPROJ - K) / DBLE(MAPROJ-1)
+C THE VALUE 0.103 [GEV] IS SIGMA(0)=P(FERMI)/SQRT(5.)
+* AGLH = 0.103D0 * SQRT( BGLH )
+C THE VALUE 0.090 [GEV] IS EXPERIMENTALLY DETERMINED SIGMA(0)
+ AGLH = 0.090D0 * SQRT( BGLH )
+ PFR(MF) = RANNOR(0.D0,AGLH)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) MF,ITYP(MF),SNGL(PFR(MF))
+#endif
+ ENDDO
+ ELSE
+C EVAPORATION WITHOUT TRANSVERSE MOMENTUM
+ DO MF = 1, JFIN
+ PFR(MF) = 0.D0
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) MF,ITYP(MF),SNGL(PFR(MF))
+#endif
+ ENDDO
+ ENDIF
+C CALCULATE RESIDUAL TRANSVERSE MOMENTUM
+ SPFRX = 0.D0
+ SPFRY = 0.D0
+ CALL RMMARD( RD,JFIN,lseq )
+ DO MF = 1, JFIN
+ PHIFR = PI * RD(MF)
+ PFRX(MF) = PFR(MF) * COS( PHIFR )
+ PFRY(MF) = PFR(MF) * SIN( PHIFR )
+ SPFRY = SPFRY + PFRY(MF)
+ SPFRX = SPFRX + PFRX(MF)
+ ENDDO
+C CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION
+ SPFRX = SPFRX / JFIN
+ SPFRY = SPFRY / JFIN
+ DO MF = 1, JFIN
+ PFRX(MF) = PFRX(MF) - SPFRX
+ PFRY(MF) = PFRY(MF) - SPFRY
+ ENDDO
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.7 ) WRITE(ifck,*) 'CXVAPOR : NINTA,JFIN=',NINTA,JFIN
+#endif
+
+ RETURN
+ END
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE CXHI2FUN(x,y,Ibin,x1,y1,Iout)
+C-----------------------------------------------------------------------
+C
+C convert histogram table to function table and
+C add 1 point on each side
+C (RE 02/01)
+C
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+
+ double precision x,y,x1,y1
+ integer Ibin,Iout
+ dimension x(0:Ibin),y(Ibin),x1(Ibin+2),y1(Ibin+2)
+
+C local variables
+ double precision width
+ integer i!,k,Niter
+
+
+ width = x(1)-x(0)
+ Iout = Ibin+2
+
+C copy to output field (x define the right edge of the bin)
+c first bin is half size so first half is 0 (lowest energy bin)
+ x1(1) = x(1)
+ y1(1) = 0d0
+c last bin is half size (highest energy bin)
+c x1(Ibin+1) = x(Ibin) !additonnal bin
+c y1(Ibin+1) = y(Ibin) !additonnal bin
+c above maximum energy : 0
+ x1(Iout) = x(Ibin)+width/2d0
+ y1(Iout) = 0.D0
+ do i=1,Ibin !no additional bin
+c do i=1,Ibin-1 !additonnal bin
+ x1(i+1) = x(i)+width/2.D0
+ y1(i+1) = y(i)
+ enddo
+
+cC solve linear equation system iteratively
+c
+c Niter = 5
+c do k=1,Niter
+c
+cC boundaries
+c y1(2) = (8.D0*y(1)-y1(3))/5.D0
+c y1(Iout-1) = (8.D0*y(Ibin)-y1(Iout-2))/5.D0
+c
+cC inner bins
+c do i=2,Ibin-1
+c y1(i+1) = (8.D0*y(i)-y1(i)-y1(i+2))/6.D0
+c enddo
+c
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+c write(ifck,'(1x,a,i3)') 'CXHI2FUN: iteration ',k
+ write(ifck,'(1x,a)') 'CXHI2FUN: x,y'
+ write(ifck,'(25x,1p,4e12.4)') x1(1),y1(1)
+ do i=1,Iout-2
+ write(ifck,'(1x,1p,4e12.4)') x(i),y(i),x1(i+1),y1(i+1)
+ enddo
+ write(ifck,'(25x,1p,4e12.4)') x1(Iout),y1(Iout)
+ endif
+#endif
+c
+c enddo
+
+ END
+
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE CXSAMP1D(Imode,X_inp,F_inp,F_int,N_dim,X_out)
+C-----------------------------------------------------------------------
+C
+C Monte Carlo sampling from arbitrary 1d distribution
+C (linear interpolation to improve reproduction of initial function)
+C
+C input: Imode -1 initialization
+C 0 sampling (after initialization) without cut
+C 1 sampling (after initialization) with cut
+C X_inp(N_dim) array with x values
+C F_inp(N_dim) array with function values
+C F_int(N_dim) array with integral
+C
+C output: X_out sampled value (Imode=1)
+C
+C (R.E. 10/99)
+C
+C-----------------------------------------------------------------------
+ implicit none
+ save
+
+ integer Imode,N_dim
+ double precision X_inp,F_inp,F_int,X_out
+ dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
+
+C local variables
+ integer i
+ double precision dum,xi,width
+
+C external functions
+ double precision drangen
+ external drangen
+
+
+ if(Imode.eq.-1) then
+
+C initialization
+
+ F_int(1) = 0.D0
+ do i=2,N_dim
+ F_int(i) = F_int(i-1)+F_inp(i)*(X_inp(i)-X_inp(i-1))
+ enddo
+
+ else if(Imode.ge.0) then
+
+C sample from previously calculated integral
+
+ width = (X_inp(3)-X_inp(2))*0.5d0
+ dum=dble(N_dim)
+ 100 xi = drangen(dum)*F_int(N_dim)
+
+
+ do i=2,N_dim
+ if(xi.lt.F_int(i)) then
+ X_out = X_inp(i-1)+(xi-F_int(i-1))*(X_inp(i)-X_inp(i-1))
+ & /(F_int(i)-F_int(i-1))
+ if(Imode.eq.1.and.X_out.ge.X_inp(N_dim)-width)goto 100
+ return
+ endif
+ enddo
+ X_out = X_inp(N_dim)-width
+
+ else
+
+C invalid option Imode
+
+ X_out = 0.D0
+
+ endif
+
+ END
+
+#if __MC3D__ || __CXLATCE__
+
+c----------------------------------------------------
+ double precision function fptadd(np,i,pt2)
+c----------------------------------------------------
+c Correction function for pt2 composition at energy ei
+c based on the fit of sin2 distributions
+c i energy bin
+c np particle type
+c pt2 pt square of source particle
+c----------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision pt2,p2,am
+ integer i,np
+
+c transition from small angle approximation to large angle
+ fptadd=0.d0
+ if(np.eq.9)then
+ am=pmass(np)
+ if(i.eq.5)am=0d0
+ p2=eeha(i)*(eeha(i)+am)
+ fptadd=max(0.d0,0.4d0*pt2-pt2**2/p2) !*(1d0-1d0/cosh(min(10d0,0.02d0*sqrt(p2))))
+ endif
+ end
+
+c----------------------------------------------------
+ double precision function fsin2th(x,a,b,c)
+c----------------------------------------------------
+c Moyal distribution (best fit) for x with a and b being
+c the mean and variance of the distribution f(log10(x))
+c----------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x,a,b,c,sig2,mu,mu1,sig21,frac
+
+ fsin2th=0d0
+ if(a.le.0d0.or.b.le.0d0)return
+
+ frac=0.5d0 !adjust tail of sin2 distribution
+ sig21=log10(1d0+b/a**2)*(2d0-c)
+ sig2=sig21*c*0.5d0
+ mu=log10(a)-0.5d0*sig2
+ mu1=(-x+mu)/sqrt(sig2)
+ fsin2th=(1d0-frac)*exp(-0.5d0*(mu1+exp(-mu1)))/sqrt(sig2*2d0*pi)
+ & +frac*exp(-0.5d0*(x-mu)**2/sig21)/sqrt(sig21*2d0*pi)
+
+
+ end
+
+c----------------------------------------------------
+ double precision function rsin2th(a,b,c)
+c----------------------------------------------------
+c generate random number from Moyal distribution
+c with a and b being the mean and variance of the
+c distribution F(x) where x=log10(sin2(theta))
+c return sin2(theta)=10**x
+c----------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x,z,a,b,c,sig,mu,h,y,drangen,hz,xnorm
+ &,sig21,frac,x0,t
+ integer ntry
+
+ rsin2th=0d0
+ if(a.le.0d0.or.b.le.0d0)return
+
+ frac=0.5d0
+ sig21=log10(1d0+b/a**2)*(2.d0-c)
+ sig=sqrt(sig21*c*0.5d0)
+ mu=log10(a)-0.5d0*sig*sig
+ xnorm=1d0/sqrt(2d0*pi)
+ ntry=0
+ 10 ntry=ntry+1
+ y=pi*(drangen(b)-0.5d0)
+ h=drangen(y)*0.912d0
+ z=min(50d0,max(-50d0,tan(y)))
+ hz=xnorm*exp(-0.5d0*(z+exp(-z)))/cos(y)**2
+
+ if(h.le.hz)then
+c accept random number
+ x=-z*sig+mu
+ t=sqrt(-2d0*log(drangen(a)))*cos(2d0*pi*drangen(b))
+ x0=mu+sqrt(sig21)*t
+ if(drangen(t).lt.frac)x=x0
+ rsin2th=10d0**x
+c print *,z,sig,mu,x
+ if(rsin2th.le.1d0)return
+ endif
+
+ if(ntry.lt.1000)then
+ goto 10
+ else
+ rsin2th=1d0
+ return
+ endif
+
+
+ end
+
+c----------------------------------------------------
+ double precision function fsin2thold(x,a,b)
+c----------------------------------------------------
+c Normal distribution for x with a and b being
+c the mean and variance of the distribution f(log10(x))
+c----------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x,a,b,sig2,mu!,sig21,mu1,ratio1,ratio
+
+ fsin2thold=0d0
+ if(a.le.0d0.or.b.le.0d0)return
+
+
+ sig2=log10(1d0+b/a**2)
+ mu=log10(a)-0.5d0*sig2
+ fsin2thold=exp(-0.5d0*(x-mu)**2/sig2)/sqrt(sig2*2d0*pi)
+
+c sig21=log10(1d0+sqrt(b)/a**2)
+c mu1=log10(a)-0.5d0*sig21
+c ratio=sig2/sig21
+c ratio1=1d0-ratio
+c fsin2th=ratio1*exp(-0.5d0*(x-mu)**2/sig2)/sqrt(sig2*2d0*pi)
+c & +ratio*exp(-0.5d0*(x-mu1)**2/sig21)/sqrt(sig21*2d0*pi)
+
+ end
+
+c----------------------------------------------------
+ double precision function rsin2thold(a,b)
+c----------------------------------------------------
+c generate random number from normal distribution
+c with a and b being the mean and variance of the
+c distribution F(x) where x=log10(sin2(theta))
+c return sin2(theta)=10**x
+c----------------------------------------------------
+ implicit none
+#include "conex.h"
+ double precision x,x0,a,b,sig2,mu,t,drangen!,ratio,x1,mu1,sig21
+ integer ntry
+
+ rsin2thold=0d0
+ if(a.le.0d0.or.b.le.0d0)return
+
+ sig2=log10(1d0+b/a**2)
+ mu=log10(a)-0.5d0*sig2
+c sig21=log10(1d0+sqrt(b)/a**2)
+c mu1=log10(a)-0.5d0*sig21
+c ratio=sig2/sig21
+ ntry=0
+ 10 ntry=ntry+1
+ t=sqrt(-2d0*log(drangen(a)))*cos(2d0*pi*drangen(b))
+ x0=mu+sqrt(sig2)*t
+c t=sqrt(-2d0*log(drangen(t)))*cos(2d0*pi*drangen(x0))
+c x1=mu1+sqrt(sig21)*t
+
+c if(drangen(x1).ge.ratio)then
+c x=x0
+c else
+c x=x1
+c endif
+
+ x=x0
+
+ rsin2thold=10**x
+
+ if(rsin2thold.le.1d0)return
+ if(ntry.lt.1000)then
+ goto 10
+ else
+ rsin2thold=1d0
+ return
+ endif
+
+
+ end
+
+#endif
+
+C=======================================================================
+
+ SUBROUTINE CXMMPINI
+
+C-----------------------------------------------------------------------
+C C(ONE)X M(AGNETIC) M(ONOPOLE) P(ARAMETER) INI(TIALIZATION)
+C
+C ESTABLISHES TABLES FOR CROSS-SECTIONS OF BEMSSTRAHLUNG,
+C PAIR PRODUCTION AND NUCLEAR INTERACTION.
+C ESTABLISHES TABLES FOR MONOPOLE ENERGY LOSS FOR BEMSSTRAHLUNG,
+C PAIR PRODUCTION, AND NUCLEAR INTERACTION.
+C THIS SUBROUTINE IS CALLED FROM InitializeOnce.
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION YE,OB3,TB3!,cdeca
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (TB3 = 0.6666666666666d0)
+ DOUBLE PRECISION DEDXBR,DEDXNI,DEDXPR,bcuti,bcutn
+ INTEGER J,JE,JJMAT
+ DOUBLE PRECISION DBRELMM,DBRSGMM,DNIELMM,DNUSGMM,DPRELMM,DPRSGMM
+ EXTERNAL DBRELMM,DBRSGMM,DNIELMM,DNUSGMM,DPRELMM,DPRSGMM
+#ifdef __CXDEBUG__
+ DOUBLE PRECISION DEDXMUB(151,3),DEDXMNI(151,3),DEDXMUP(151,3),
+ * DEDXMB(151),DEDXMN(151),DEDXMP(151)
+ DOUBLE PRECISION CXBRSGMM,CXNUSGMM,CXPRSGMM,BREMS,NUCLE,PAIR
+ EXTERNAL CXBRSGMM,CXNUSGMM,CXPRSGMM
+#endif
+C-----------------------------------------------------------------------
+
+#ifdef __CXDEBUG__
+ call utisx1('CXMMPINI ',8)
+#endif
+ if(enymax.gt.1d15)
+ &stop'Extend definition of Monopole cross section tables'
+
+ PMASSMM = 1d5
+C SET CONSTANTS FOR MONOPOLE BREMSSTRAHLUNG
+ CMUON(7) = airz(1)**OB3
+ CMUON(8) = airz(2)**OB3
+ CMUON(9) = airz(3)**OB3
+ CMUON(1) = LOG( 189.D0 * PMASSMM / (CMUON(7)*pmass(10)) )
+ * + LOG( TB3/CMUON(7) )
+ CMUON(2) = LOG( 189.D0 * PMASSMM / (CMUON(8)*pmass(10)) )
+ * + LOG( TB3/CMUON(8) )
+ CMUON(3) = LOG( 189.D0 * PMASSMM / (CMUON(9)*pmass(10)) )
+ * + LOG( TB3/CMUON(9) )
+ SE = SQRT(EXP(1.D0))
+ CMUON(4) = 189.D0 * SE*PMASSMM**2/(2.D0*pmass(10)*CMUON(7))
+ CMUON(5) = 189.D0 * SE*PMASSMM**2/(2.D0*pmass(10)*CMUON(8))
+ CMUON(6) = 189.D0 * SE*PMASSMM**2/(2.D0*pmass(10)*CMUON(9))
+ CMUON(10) = 0.75D0 * PMASSMM * SE
+ CMUON(7) = CMUON(7) * CMUON(10)
+ CMUON(8) = CMUON(8) * CMUON(10)
+ CMUON(9) = CMUON(9) * CMUON(10)
+ CMUON(11) = LOG( MIN( emin, PITHR*1.D-3 )/PMASSMM )
+C MASS RATIO ELECTRON BY MUON
+ EBYMU = pmass(10)/PMASSMM
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ if(mode.ne.0)then
+C CALCULATE ENERGY LOSS TABLES INTEGRATED FROM THE MINIMUM TO THE
+C MAXIMUM ENERGY FOR CASCADE EQUATIONS WHERE INTERACTIONS ARE NOT EXPLICIT.
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+C ENERGY LOOP (1 GEV AT J=1; 100000 EEV AT J=151)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,109)
+ 109 FORMAT(' FULL MUON ENERGY LOSS (GEV G**-1 CM**2) FOR AIR'/
+ * ' BIN',1X,'ENERGY (GEV)',5X,'DEDXMB',8X,
+ * 'DEDXMP',8X,'DEDXMN',8X,' SUM')
+#endif
+c$$$C CALCULATE ENERGY LOSS IN AIR
+c$$$ cdeca=10.d0**(1d0/decade)
+c$$$ DO J = 1,maximEd
+c$$$C CALCULATE TOTAL ENERGY EE (IN GEV)
+c$$$ EE = dble(exmin) * cdeca**(J-1) + PMASSMM
+c$$$C SET BCUT AT EE
+c$$$ BCUT=EE
+c$$$C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+c$$$C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+c$$$C ENERGY LOSS IN MATERIAL COMPONENTS
+c$$$ DEDXBR = 0.d0
+c$$$ DEDXPR = 0.d0
+c$$$ DEDXNI = 0.d0
+c$$$ DO JJMAT = 1, 3
+c$$$ ZATOM = AIRZ(JJMAT)
+c$$$ AATOM = AIRA(JJMAT)
+c$$$ CONSTKINE = CMUON(JJMAT+6)
+c$$$ DEDXBR = DEDXBR + airw(JJMAT) * DBRELMM(JJMAT)
+c$$$ DEDXPR = DEDXPR + airw(JJMAT) * DPRELMM(JJMAT)
+c$$$ DEDXNI = DEDXNI + airw(JJMAT) * DNIELMM(JJMAT)
+c$$$ ENDDO
+c$$$ dedxion(4,J)=DEDXBR+DEDXPR+DEDXNI
+c$$$#ifdef __CXDEBUG__
+c$$$ IF (isx.ge.8 ) WRITE(ifck,106)
+c$$$ * J,EE,DEDXBR,DEDXPR,DEDXNI,dedxion(4,J)
+c$$$#endif
+c$$$ ENDDO
+c$$$ endif
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C SET BCUT BELOW THE PI THRESHOLD
+ BCUT = MIN( emin, PITHR*1.D-3 )
+ bcuti=bcut
+ bcutn=enymin+pmass(5) !for nuclear int, minimum correspond to minimum hadron energy
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,*) 'BCUT MC =',BCUT,' GEV'
+#endif
+
+C CALCULATE CROSS SECTION TABLES
+C MAXIMUM PRIMARY ENERGY DETERMINES MAXIMUM OF TABLE VALUES NEEDED
+C AND WE NEED 2 ADDITIONAL POINTS FOR QUADRATIC INTERPOLATION
+ JE = int (10 * LOG10(eprima-PMASSMM) ) + 21 + 2
+ JE = MIN(JE,151)
+
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+ DO JJMAT = 1, 3
+ ZATOM = AIRZ(JJMAT)
+ AATOM = AIRA(JJMAT)
+ CONSTKINE = CMUON(JJMAT+6)
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,101) JJMAT
+ 101 FORMAT(' MUON CROSS SECTIONS (MBARN) FOR MATERIAL ',
+ * 'INDEX = ',I3,/,' BIN',1X,
+ * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL')
+#endif
+
+C ENERGY LOOP (1 GEV AT J=1; 1000000 EEV AT J=151)
+ DO J = 1, JE
+ YE = DBLE(J - 1)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE+PMASSMM
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C CALCULATE CROSS SECTIONS (MILLIBARN)
+ BCUT=bcuti
+ BREMSTAB(J,JJMAT) = DBRSGMM(JJMAT)
+ BCUT=25d0*PMASSMM
+ PAIRTAB(J,JJMAT) = DPRSGMM(JJMAT)
+ BCUT=bcutn
+ NUCTAB(J,JJMAT) = DNUSGMM(JJMAT)
+ IF ( isx.ge.8 ) WRITE(ifck,102) J,EE,BREMSTAB(J,JJMAT),
+ * PAIRTAB(J,JJMAT),NUCTAB(J,JJMAT)
+ 102 FORMAT(' ',I3,1P,1X,E12.5,3(1X,E13.6))
+ BREMSTAB(J,JJMAT) = LOG(MAX( BREMSTAB(J,JJMAT), 1.D-30 ) )
+ NUCTAB(J,JJMAT) = LOG(MAX( NUCTAB(J,JJMAT), 1.D-30 ) )
+ PAIRTAB(J,JJMAT) = LOG(MAX( PAIRTAB(J,JJMAT), 1.D-30 ) )
+ ENDDO
+ ENDDO
+
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) THEN
+ WRITE(ifck,103)
+ 103 FORMAT(' MUON CROSS SECTIONS (MBARN) FOR AIR'/' BIN',1X,
+ * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL')
+ DO J = 1, JE
+ YE = DBLE(J - 1)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE+PMASSMM
+C CALCULATE THE CROSS SECTIONS FOR AIR
+ BREMS = airw(1) * CXBRSGMM( EE,1 )
+ BREMS = BREMS + airw(2) * CXBRSGMM( EE,2 )
+ BREMS = BREMS + airw(3) * CXBRSGMM( EE,3 )
+ PAIR = airw(1) * CXPRSGMM( EE,1 )
+ PAIR = PAIR + airw(2) * CXPRSGMM( EE,2 )
+ PAIR = PAIR + airw(3) * CXPRSGMM( EE,3 )
+ NUCLE = airw(1) * CXNUSGMM( EE,1 )
+ NUCLE = NUCLE + airw(2) * CXNUSGMM( EE,2 )
+ NUCLE = NUCLE + airw(3) * CXNUSGMM( EE,3 )
+ WRITE(ifck,104) J,EE,BREMS,PAIR,NUCLE
+ 104 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6))
+ ENDDO
+ ENDIF
+#endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C CALCULATE ENERGY LOSS TABLES. AS WE REGARD CUT VALUES ONLY BELOW 152 MEV
+C WE MAY NEGLECT NUCLEAR INTERACTIONS FOR THE ENERGY LOSS TABLES.
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C MATERIAL LOOP (JJMAT=1:14N; JJMAT=2: 16O; JJMAT=3: 40AR)
+ DO JJMAT = 1, 3
+ ZATOM = AIRZ(JJMAT)
+ AATOM = AIRA(JJMAT)
+ CONSTKINE = CMUON(JJMAT+6)
+C ENERGY LOOP (1 GEV AT J=1; 1000000 EEV AT J=151)
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,105) JJMAT
+ 105 FORMAT(' MUON ENERGY LOSS (GEV G**-1 CM**2) FOR ',
+ * 'MATERIAL INDEX = ',I3/' BIN',1X,
+ * 'ENERGY (GEV)',3X,'DEDXBREM',6X,'DEDXPAIR',6X,
+ * 'NUCLEAR',8X,'SUM')
+#endif
+ DO J = 1, JE
+ YE = DBLE(J - 1)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+ EE = 10.D0**YE+PMASSMM
+C TOTAL ENERGY (EE), ATOMIC NUMBER (ZATOM), NUCLEON NUMBER (AATOM)
+C ARE TRANSMITTED TO THE FUNCTIONS VIA COMMON MUPART
+C ENERGY LOSS IN MATERIAL COMPONENTS
+ BCUT=bcuti
+ DEDXBR = DBRELMM(JJMAT)
+ BCUT=25d0*PMASSMM
+ DEDXPR = DPRELMM(JJMAT)
+ BCUT=bcutn
+ DEDXNI = DNIELMM(JJMAT)
+ DEDXMU(J,JJMAT) = DEDXBR + DEDXPR + DEDXNI
+#ifdef __CXDEBUG__
+ DEDXMUB(J,JJMAT) = DEDXBR
+ DEDXMUP(J,JJMAT) = DEDXPR
+ DEDXMNI(J,JJMAT) = DEDXNI
+ IF (isx.ge.8 ) WRITE(ifck,106)
+ * J,EE,DEDXBR,DEDXPR,DEDXNI,DEDXMU(J,JJMAT)
+ 106 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6))
+#endif
+ ENDDO
+ ENDDO
+
+C CALCULATE ENERGY LOSS IN AIR
+#ifdef __CXDEBUG__
+ IF ( isx.ge.8 ) WRITE(ifck,107)
+ 107 FORMAT(' MONOPOLE ENERGY LOSS (GEV G**-1 CM**2) FOR AIR'/
+ * ' BIN',1X,'ENERGY (GEV)',5X,'DEDXMB',8X,
+ * 'DEDXMP',8X,'DEDXMN',8X,' SUM')
+#endif
+ DO J = 1, JE
+ YE = DBLE(J - 1)/10.D0
+C CALCULATE TOTAL ENERGY EE (IN GEV)
+C CALCULATE ENERGY LOSS IN AIR
+ EE = 10.D0**YE
+ DEDXM(J) = airw(1) * DEDXMU(J,1)
+ * +airw(2) * DEDXMU(J,2)
+ * +airw(3) * DEDXMU(J,3)
+#ifdef __CXDEBUG__
+ DEDXMB(J) = airw(1) * DEDXMUB(J,1)
+ * +airw(2) * DEDXMUB(J,2)
+ * +airw(3) * DEDXMUB(J,3)
+ DEDXMP(J) = airw(1) * DEDXMUP(J,1)
+ * +airw(2) * DEDXMUP(J,2)
+ * +airw(3) * DEDXMUP(J,3)
+ DEDXMN(J) = airw(1) * DEDXMNI(J,1)
+ * +airw(2) * DEDXMNI(J,2)
+ * +airw(3) * DEDXMNI(J,3)
+ IF ( isx.ge.8 ) WRITE(ifck,108)
+ * J,EE,DEDXMB(J),DEDXMP(J),DEDXMN(J),DEDXM(J)
+ 108 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6))
+#endif
+ ENDDO
+
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ endif
+ RETURN
+ END
+
+C-----------------------------------------------------------------------
+ SUBROUTINE MMSIGMA(Elab,SIGINEL)
+C-----------------------------------------------------------------------
+C Monopole cross sections
+C
+C Elab Monopole total energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+c
+c subroutine called by rlam
+c
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+*KEEP,SIGMM.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+ common/cxmmbrint/cxMmBRPair,cxMmBRBrem
+ double precision Elab,SIGINEL,cxMmBRPair,cxMmBRBrem
+ DOUBLE PRECISION CXBRSGMM,CXNUSGMM,CXPRSGMM
+ EXTERNAL CXBRSGMM,CXNUSGMM,CXPRSGMM
+
+
+C CALCULATE MUON BREMSSTRAHLUNG CROSS-SECTION FOR AIR (MILLIBARN)
+ FRABTN = airw(1) * CXBRSGMM( ELAB,1 )
+ FRBTNO = FRABTN + airw(2) * CXBRSGMM( ELAB,2 )
+ SIGBRM = FRBTNO + airw(3) * CXBRSGMM( ELAB,3 )
+
+C CALCULATE MUON PAIR PRODUCTION CROSS-SECTION FOR AIR (MILLIBARN)
+ FRAPTN = airw(1) * CXPRSGMM( ELAB,1 )
+ FRPTNO = FRAPTN + airw(2) * CXPRSGMM( ELAB,2 )
+ SIGPRM = FRPTNO + airw(3) * CXPRSGMM( ELAB,3 )
+
+C CALCULATE MUON NUCLEAR INTERACTION CROSS-SECTION FOR AIR (MILLIBARN)
+ FRANTN = airw(1) * CXNUSGMM( ELAB,1 )
+ FRNTNO = FRANTN + airw(2) * CXNUSGMM( ELAB,2 )
+ SIGNUC = FRNTNO + airw(3) * CXNUSGMM( ELAB,3 )
+
+ cxMmBRPair=SIGPRM
+ cxMmBRBrem=SIGBRM+SIGPRM
+ SIGINEL=cxMmBRBrem+SIGNUC
+ if(SIGINEL.gt.0.d0)then
+ cxMmBRPair=cxMmBRPair/SIGINEL
+ cxMmBRBrem=cxMmBRBrem/SIGINEL
+ endif
+
+
+ END
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE QBALLSIGMA(SIGINEL)
+C-----------------------------------------------------------------------
+C QBall Cross Section
+c
+c Elab total qball energy (GeV)
+c
+c Output: SIGINEL cross section for qball-induced proton decay
+c
+c Added by David Schuster <dschuste@mines.edu> Jan. 11, 2010
+C-----------------------------------------------------------------------
+
+ implicit none
+#include "conex.h"
+
+ COMMON /sigQBALL/ sigQBALL
+
+ double precision SIGINEL, sigQBALL
+
+ sigQBALL=5.0d5 !1
+ SIGINEL =sigQBALL !static cross section based on
+ !choice of SUSY breaking parameter
+ END !at 1 GeV, setting qball mass to
+ !10^9 GeV and cross section thus
+ !see Arafune et. al. Phys. Rev. D, 2000
+
+
+C-----------------------------------------------------------------------
+ SUBROUTINE STRANGELETSIGMA(np,SIGINEL)
+C-----------------------------------------------------------------------
+C Strangelet Cross Section
+c
+c Output: SIGINEL cross section for strangelet interaction
+c
+c Added by David Schuster <dschuste@mines.edu> Jan. 11, 2010
+C-----------------------------------------------------------------------
+
+ implicit none
+#include "conex.h"
+
+ COMMON /sigSTRANGELET/ sigSTRANGELET
+
+ double precision SIGINEL, sigSTRANGELET, r0, rad, a, b
+ integer np
+
+ r0 = 8.8d-6
+ a = abs(np)/10
+ b = a*1.115683d0*1.783d-24
+ rad = r0*b**(0.33333d0)
+ sigSTRANGELET = pi*rad**2
+ sigSTRANGELET = sigSTRANGELET * 1.0d27
+ SIGINEL = sigSTRANGELET !Geometric cross-section for
+ !Strangelet interaction
+ END !see Bakari et. al. hep-ex/0004019
+
+C-----------------------------------------------------------------------
+ SUBROUTINE QBallInteraction(epq)
+C-----------------------------------------------------------------------
+C Q-Ball Interaction Calculation
+c
+c subroutine called by cnexus
+c
+c by David Schuster <dschuste@mines.edu> Jan 13, 2010
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+#if __COAST__
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+c definition of the COAST crs::CInteraction class
+ COMMON/coastInteraction/coastX, coastY, coastZ,
+ & coastE, coastCX, coastEl, coastProjId, coastTargId
+ double precision coastX, coastY, coastZ
+ double precision coastE, coastCX, coastEl
+ integer coastProjId, coastTargId
+ double precision rdist,radh
+ integer idtrafocx
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+#endif
+ double precision s0xs,c0xs,s0s,c0s,ep(3)
+ common/cossins/s0xs,c0xs,s0s,c0s
+ double precision epq(5),epp(5)
+ integer i,id,iret,nptl0,iptl
+ external drangen
+ double precision drangen,dummy,efrac
+
+c Initialize temporary stack
+ do i=1,5
+ epp(i)=0.d0
+ istptlxs(i)=1
+ xsptl(1,i)=0.d0 !px
+ xsptl(2,i)=0.d0 !py
+ xsptl(3,i)=0.d0 !pz
+ xsptl(4,i)=0.d0 !E
+ xsptl(5,i)=0.d0 !m
+ ityptlxs(i)=0
+ iorptlxs(i)=1
+ jorptlxs(i)=1
+ ifrptlxs(1,i)=0
+ ifrptlxs(2,i)=0
+ xsorptl(1,i)=0.d0 !x
+ xsorptl(2,i)=0.d0 !y
+ xsorptl(3,i)=0.d0 !z
+ xsorptl(4,i)=0.d0 !t
+ xstivptl(1,i)=0.d0
+ xstivptl(2,i)=0.d0
+ idptlxs(i)=0 !id
+ enddo
+
+ nptlxs=0 !number of secondaries
+
+
+c Define energy given to the proton = energy loss of QBall
+ efrac = 0.d0!1d0 * drangen(dummy)
+ epp(4)=pmass(1)!efrac*(epq(4)-epq(5))
+ epp(5)=pmass(1) !mass
+ epp(3)=(epp(4)+epp(5))*(epp(4)-epp(5))
+ if(epp(3).ge.0.d0)then
+ epp(3)=sqrt(epp(3))
+ else
+c write(*,*) 'QBall : not enough energy for proton'
+ call d2a
+ return
+ endif
+
+c put back QBall remnant in stack
+ if(epq(4)-epp(4).gt.epq(5))then
+ dptl(4)=epq(4)-(epp(4)-pmass(1))
+ dptl(3)=(dptl(4)+dptl(5))*(dptl(4)-dptl(5))
+ if(dptl(3).ge.0.d0)then
+ dptl(1)=0.d0
+ dptl(2)=0.d0
+ dptl(3)=sqrt(dptl(3))
+ if(i1DMC.ne.2)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+ call d2a
+ else
+ write(*,*) 'QBall : Should not happen !!!'
+ write(*,*) dptl(3),dptl(4),dptl(5)
+ stop
+ endif
+ else
+ write(*,*) 'QBall : not enough energy for QBall'
+ call d2a
+ return
+ endif
+#if __COAST__
+ if(mod(idprojxs,100).ne.0)then !not a nucleus
+ coastProjId=-idtrafocx("nxs","cor",idprojxs)
+ else !nucleus
+ coastProjId=-idprojxs-int(dble(idprojxs/100)/2.15d0+0.7d0)
+ endif
+
+ coastTargId = matargxs
+#ifdef __CXCORSIKA__
+ coastX = dptl(7)*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ coastY = -dptl(6)*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+#else
+ coastX = dptl(6)*100d0 !(distance in cm in COAST)
+ coastY = dptl(7)*100d0 !(distance in cm in COAST)
+#endif
+ rdist=sqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7))
+ radh=dptl(8)+radearth
+ if(radh.gt.rdist)then
+ coastZ = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ coastZ = (coastZ-radearth)*100d0
+ else
+ coastZ = dptl(8)*100d0 !(distance in cm in COAST)
+ endif
+ coastE = dptl(4)
+ coastCX = Siginemb
+ coastEl = 1d0
+ call interaction(coastX)
+#endif
+
+ id=1120
+ nptlxs=nptlxs+1
+ nptl0=nptlxs
+ do i=1,5
+ xsptl(i,nptlxs)=epp(i)
+ enddo
+ idptlxs(nptlxs)=id
+ istptlxs(nptlxs)=0
+ iptl=nptlxs
+ do i=iptl,iptl+10
+ istptlxs(i)=0
+ enddo
+ call cxhdecay(iptl,iret)
+ if(iret.ne.0)nptlxs=0 !do nothing, particle is lost
+ istptlxs(nptl0)=1
+#ifdef __CXDEBUG__
+ if(isx.ge.4)write(ifck,*)'decay ',id,' --> ',nptlxs-nptl0,' ptls'
+ if(isx.ge.6)call cxalist('QBallInt&',1,nptlxs,2)
+#endif
+
+ END
+
+C-----------------------------------------------------------------------
+ SUBROUTINE MonopoleInteraction(id,ep)
+C-----------------------------------------------------------------------
+C Monopole Interaction Calculation
+c
+c subroutine called by cnexus
+c
+c by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ common/cxmmbrint/cxMmBRPair,cxMmBRBrem
+ double precision cxMmBRPair,cxMmBRBrem,dummy,rdmBR,ep(5),rd1
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+ integer i,LT,id
+ double precision drangen
+ external drangen
+
+c Initialize temporary stack
+ do i=1,5
+ istptlxs(i)=1
+ xsptl(1,i)=0.d0 !px
+ xsptl(2,i)=0.d0 !py
+ xsptl(3,i)=0.d0 !pz
+ xsptl(4,i)=0.d0 !E
+ xsptl(5,i)=0.d0 !m
+ ityptlxs(i)=0
+ iorptlxs(i)=1
+ jorptlxs(i)=1
+ ifrptlxs(1,i)=0
+ ifrptlxs(2,i)=0
+ xsorptl(1,i)=0.d0 !x
+ xsorptl(2,i)=0.d0 !y
+ xsorptl(3,i)=0.d0 !z
+ xsorptl(4,i)=0.d0 !t
+ xstivptl(1,i)=0.d0
+ xstivptl(2,i)=0.d0
+ idptlxs(i)=0 !id
+ enddo
+
+ nptlxs=0 !number of secondaries
+
+c ep(4)=dptl(4) !total E
+c ep(5)=dptl(5) !mass
+c ep(3)=(ep(4)+ep(5))*(ep(4)-ep(5))
+c if(ep(3).ge.0.d0)then
+c ep(3)=sqrt(ep(3))
+c else
+c#ifdef __CXDEBUG__
+c write(ifck,*) 'Should not happen !!! Cont. without Mon Inter.'
+c#endif
+c write(*,*) 'Should not happen !!! Cont. without Mon Inter.'
+c write(*,*) ep(3),ep(4),ep(5)
+c nptlxs=1
+c xsptl(5,nptlxs)=ep(5)
+c if(ep(3).ge.0.d0)then
+c xsptl(4,nptlxs)=ep(4)
+c xsptl(3,nptlxs)=sqrt(ep(3))
+c else
+c xsptl(4,nptlxs)=ep(5)
+c xsptl(3,nptlxs)=0.d0
+c endif
+c istptlxs(nptlxs)=0
+c idptlxs(nptlxs)=id
+c return
+c endif
+c
+
+ rdmBR=drangen(dummy)
+ rd1=drangen(dummy)
+ if(rdmBR.le.cxMmBRPair)then !Pair production
+C TARGET IS CHOSEN AT RANDOM FOR MONOPOLE PAIR PRODUCTION
+ IF ( RD1*SIGPRM .LE. FRAPTN ) THEN
+C PAIR PRODUCTION WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGPRM .LE. FRPTNO ) THEN
+C PAIR PRODUCTION WITH OXYGEN
+ LT = 2
+ ELSE
+C PAIR PRODUCTION WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MonopoleInteraction : Pair',LT
+#endif
+ call CXMMPRPR(id,ep,LT)
+
+ elseif(rdmBR.le.cxMmBRBrem)then !Bremstrahlung
+ IF ( RD1*SIGBRM .LE. FRABTN ) THEN
+C BREMSSTRAHLUNG WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGBRM .LE. FRBTNO ) THEN
+C BREMSSTRAHLUNG WITH OXYGEN
+ LT = 2
+ ELSE
+C BREMSSTRAHLUNG WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MonopoleInteraction : Brems',LT
+#endif
+ call CXMMBREM(id,ep,LT)
+
+ else !Nucl. Int
+ IF ( RD1*SIGNUC .LE. FRANTN ) THEN
+C NUCLEAR INTERACTION WITH NITROGEN
+ LT = 1
+ ELSEIF ( RD1*SIGNUC .LE. FRNTNO ) THEN
+C NUCLEAR INTERACTION WITH OXYGEN
+ LT = 2
+ ELSE
+C NUCLEAR INTERACTION WITH ARGON
+ LT = 3
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isx.ge.4) WRITE(ifck,*) 'MonopoleInteraction : Nuc. Int.',LT
+#endif
+ call CXMMNUCL(id,ep,LT)
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)call cxalist('MonopoleIntera&',1,nptlxs,2)
+#endif
+
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMMBREM(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X M(AGNETIC) M(ONOPOLE) BREM(SSTRAHLUNG)
+C
+C TREATES MUON BREMSSTRAHLUNG (WITHOUT POLARISATION EFFECTS)
+C IN ANALOGY WITH SUBROUT. GBREMM FROM GEANT WRITTEN BY L. URBAN
+C EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013
+C THIS SUBROUTINE IS CALLED FROM MuInteraction.
+c input : id = monopole id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+#if __COAST__
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+c definition of the COAST crs::CInteraction class
+ COMMON/coastInteraction/coastX, coastY, coastZ,
+ & coastE, coastCX, coastEl, coastProjId, coastTargId
+ double precision coastX, coastY, coastZ
+ double precision coastE, coastCX, coastEl
+ integer coastProjId, coastTargId
+ double precision rdist,radh
+ integer idtrafocx
+ common/cxmmbrint/cxMmBRPair,cxMmBRBrem
+ double precision cxMmBRPair,cxMmBRBrem
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+#endif
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision s0xs,c0xs,s0s,c0s,ep(3)
+ common/cossins/s0xs,c0xs,s0s,c0s
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ common /cxexoticdz/dXotic
+ double precision dXotic
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION ALFA1,BETA1,COSTH3,D,EKIN,PHI3,signew,sigold,
+ * SINTH3,THETA3,U,UMAX,V,W1,Z,SINPHI3,COSPHI3,V1
+c * ,CREJ,SCREJ,VC,VM,F1
+ INTEGER I,JCOUNT,LT,id
+ DOUBLE PRECISION CXBRSGMM,drangen,DBRELMM
+ EXTERNAL CXBRSGMM,drangen,DBRELMM
+ DATA ALFA1/0.625D0/
+ SAVE ALFA1
+ double precision epi(5),epf(5),RD(3),PT
+C-----------------------------------------------------------------------
+
+
+C TOTAL AND KINETIC ENERGY OF MONOPOLE
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ BCUT = MIN( emin, PITHR*1.D-3 )
+
+C MONOPOLE ENERGY IS TOO LOW TO PRODUCE BREMSSTRAHLUNG
+ IF ( EKIN .LE. BCUT )GOTO 900
+
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+C RESTORE OLD CROSS SECTION
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRABTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRBTNO - FRABTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGBRM - FRBTNO) / airw(3)
+ ELSE
+ WRITE(ifck,*) 'CXMMBREM: WRONG TARGET LT =',LT,' STOP'
+ STOP
+ ENDIF
+
+C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO
+C TARGET INDEX LT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2
+ Z = airz(LT)
+ ZATOM = Z
+ AATOM = aira(LT)
+
+C GET NEW CROSS-SECTION
+ SIGNEW = CXBRSGMM( EE,LT )
+ RD(1)=drangen(dble(LT))
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW )GOTO 900
+
+C ENERGY FRACTION FROM INTEGRATED ENERGY LOSS
+ V = DBRELMM( LT ) * dXotic
+ V = min( V, EKIN ) / EE
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*) 'CXMMBREM: V=',V,EKIN,dXotic,LT
+#endif
+
+
+c VC = BCUT/EE
+c VM = 1.D0 - CMUON(6+LT)/EE
+cC MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG
+c IF ( VM .LE. 0.D0 ) GOTO 900
+c CREJ = CMUON(3+LT)/EE
+c
+c JCOUNT = 0
+c 50 CONTINUE
+c JCOUNT = JCOUNT + 1
+c IF ( JCOUNT .GT. 1000 ) GOTO 900
+c RD(1)=drangen(dble(JCOUNT))
+c RD(2)=drangen(dble(JCOUNT))
+c V = VC*(VM/VC)**RD(1)
+ V1 = 1.D0 - V
+cC COMPUTE REJECTION FUNCTION
+c F1 = CMUON(LT) - LOG(1.D0 + CREJ*V/V1)
+c SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LT)
+c IF ( RD(2) .GT. SCREJ ) GOTO 50
+
+C GAMMA ENERGY
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = EE * V
+ xsptl(5,nptlxs) = 0.d0
+ idptlxs(nptlxs) = 10
+ istptlxs(nptlxs) = 0
+
+
+C GENERATE EMITTED GAMMA ANGLES WITH RESPECT TO MONOPOLE DIRECTION
+C PHI IS GENERATED ISOTROPICALLY AND THETA IS ASSIGNED A UNIVERSAL
+C ANGULAR DISTRIBUTION WITH D=D(Z,E,V)
+C THIS FUNCTION APPROXIMATES THE REAL DISTRIBUTION FUNCTION WHICH CAN
+C BE FOUND IN: YUNG-SU TSAI, REV. MOD. PHYS. 46(1974)815
+C +ERRATUM: REV. MOD. PHYS. 49(1977)421
+ D = 0.13D0 *(0.8D0 + 1.3D0/Z) * (100.D0 + 1.D0/EE) * (1.D0 + V)
+ W1 = 9.D0 / (9.D0 + D)
+ UMAX = EE * PI / PMASSMM
+ 10 CONTINUE
+ RD(1)=drangen(D)
+ RD(2)=drangen(W1)
+ RD(3)=drangen(UMAX)
+ IF ( RD(1) .LE. W1 ) THEN
+ BETA1 = ALFA1
+ ELSE
+ BETA1 = 3.D0 * ALFA1
+ ENDIF
+ U = (- LOG( RD(2) * RD(3) ) / BETA1)
+C CUT: THETA SHOULD BE .LE. PI !
+C THIS CONDITION DEPENDS ON E IN THE CASE OF D=CONST TOO!
+ IF ( U .GE. UMAX ) GOTO 10
+
+ THETA3 = U * PMASSMM / EE
+ COSTH3 = COS( THETA3 )
+ if(abs(COSTH3).ge.1.d0)COSTH3=sign(1.d0,COSTH3)
+ xsptl(3,nptlxs) = xsptl(4,nptlxs) * COSTH3
+ SINTH3 = sqrt((1.d0-COSTH3)*(1.d0+COSTH3))
+ PT = xsptl(4,nptlxs) * SINTH3
+ RD(1)=drangen(COSTH3)
+ PHI3 = 2.d0 * PI * RD(1)
+ COSPHI3 = COS( PHI3 )
+ if(abs(COSPHI3).ge.1.d0)COSPHI3=sign(1.d0,COSPHI3)
+ SINPHI3 = sqrt((1.d0-COSPHI3)*(1.d0+COSPHI3))
+ xsptl(1,nptlxs) = PT * COSPHI3
+ xsptl(2,nptlxs) = PT * SINPHI3
+
+
+
+C REDUCE ENERGY OF MONOPOLE
+ epf(1)= -xsptl(1,nptlxs)
+ epf(2)= -xsptl(2,nptlxs)
+ epf(4)= EE * V1
+ PT=sqrt(PT*PT+epf(5)*epf(5))
+ epf(3)=(epf(4)+PT)*(epf(4)-PT)
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ if(isx.ge.1)then
+ write(*,*) 'Negative Energy in CXMMBREM !!!'
+ write(ifck,*) 'Negative Energy in CXMMBREM !!!'
+ write(ifck,*) jcount,id,epf,V1,ekin,ekin
+ write(ifck,*) 'skip ...'
+ endif
+#endif
+ nptlxs=0
+ goto 900
+ endif
+
+ dptl(10)=dble(id)
+ do i=1,5
+ dptl(i)=epf(i)
+ enddo
+ if(i1DMC.ne.2)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+ 900 CONTINUE
+ call d2a
+#if __COAST__
+ if(mod(idprojxs,100).ne.0)then !not a nucleus
+ coastProjId=-idtrafocx("nxs","cor",idprojxs)
+ else !nucleus
+ coastProjId=-idprojxs-int(dble(idprojxs/100)/2.15d0+0.7d0)
+ endif
+
+ coastTargId = matargxs
+#ifdef __CXCORSIKA__
+ coastX = dptl(7)*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ coastY = -dptl(6)*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+#else
+ coastX = dptl(6)*100d0 !(distance in cm in COAST)
+ coastY = dptl(7)*100d0 !(distance in cm in COAST)
+#endif
+ rdist=sqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7))
+ radh=dptl(8)+radearth
+ if(radh.gt.rdist)then
+ coastZ = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ coastZ = (coastZ-radearth)*100d0
+ else
+ coastZ = dptl(8)*100d0 !(distance in cm in COAST)
+ endif
+ coastE = dptl(4)
+ coastCX = Siginemb*cxMmBRBrem
+ coastEl = 1d0
+ call interaction(coastX)
+#endif
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMMNUCL(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X M(AGNETIC) M(ONOPOLE) NUCL(EAR INTERATION)
+C
+C TREATES MONOPOLE NUCLEAR INTERACTION
+C IN ANALOGY WITH SUBR. GMUNU OF BOTTAI & PERRONE.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C L.B. BEZRUKOV AND E.V. BUGAEV, Yad. Fiz. 33 (1981) 1195
+C THIS SUBROUTINE IS CALLED FROM MuInteraction.
+c input : id = monopole id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+#if __COAST__
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+c definition of the COAST crs::CInteraction class
+ COMMON/coastInteraction/coastX, coastY, coastZ,
+ & coastE, coastCX, coastEl, coastProjId, coastTargId
+ double precision coastX, coastY, coastZ
+ double precision coastE, coastCX, coastEl
+ integer coastProjId, coastTargId
+ double precision rdist,radh
+ integer idtrafocx
+ common/cxmmbrint/cxMmBRPair,cxMmBRBrem
+ double precision cxMmBRPair,cxMmBRBrem
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+#endif
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ double precision PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ double precision XM,YM,ZM,DM,TM
+ double precision s0xs,c0xs,s0s,c0s,ep(3)
+ common/cossins/s0xs,c0xs,s0s,c0s
+*EGS4 Stack
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ double precision E,X,Y,Z,U,V,W,DNEAR,WT
+ integer IQ,IR,LATCH,LATCHI,NP
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ common /cxexoticdz/dXotic
+ double precision dXotic
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI,OB3!,ELE1,ELE2
+ PARAMETER (OB3 = 0.3333333333333d0)
+ PARAMETER (ALPHFA = 7.297353D-3)
+C BEZRUKOV'S M1**2 AND M2**2
+ PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+ PARAMETER (APH = 0.00282D0)
+C BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+ PARAMETER (CSI = 0.25D0)
+c PARAMETER (ELE1 = 0.0808D0)
+c PARAMETER (ELE2 = -0.4525D0)
+
+ DOUBLE PRECISION EKIN,signew,sigold,SNI,E1
+c * TTT,VPH,VPH1,VPH2,ZZZ
+c * ,SNIMIN1,SNIMIN2,SS,SIGN,SNIMAX,SNIMIN,
+c * ,ARGO,AUXIL1,BPH,COEF,COEF1,CPH
+c * ,DPH,EPH,FACTO,FPH,GG,GMAX,GMIN,HHH,
+ INTEGER I,id,LT!,JCOUNT
+#if __MC3D__ || __CXLATCE__
+ double precision rtr1,pinv,sintheP,sinphiP,costheP
+ * ,cosphiP
+#endif
+ DOUBLE PRECISION CXNUSGMM,drangen,epi(5),epf(5),RD(2),EGAM,DNIELMM
+ EXTERNAL CXNUSGMM,drangen,DNIELMM
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ integer ifckegs,isxegs
+C-----------------------------------------------------------------------
+
+
+
+C SET MATERIAL CONSTANTS ACCORDING TO TARGET INDEX LT (1=N, 2=O, 3=AR)
+C WHICH HAS BEEN SET IN BOX2, AND RESTORE OLD CROSS-SECTIONS
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRANTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRNTNO - FRANTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGNUC - FRNTNO) / airw(3)
+ ELSE
+ WRITE(*,*) 'MUNUCL: WRONG TARGET LT=',LT,' STOP'
+ STOP
+ ENDIF
+ BCUT=enymin+pmass(5) !for nuclear int, minimum correspond to minimum hadron energy
+ AATOM=aira(LT)
+
+C TOTAL AND KINETIC ENERGY OF MONOPOLE
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ IF ( EKIN .LE. BCUT ) GOTO 900
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+ SIGNEW = CXNUSGMM( EE,LT )
+ RD(1)=drangen(dble(LT))
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW ) GOTO 900
+
+C ENERGY FRACTION FROM INTEGRATED ENERGY LOSS
+ SNI = DNIELMM( LT ) * dXotic
+ SNI = min( SNI, EKIN ) / EE
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*) 'CXMMNUCL: SNI=',SNI,EKIN,dXotic,LT
+#endif
+
+c$$$C SAMPLE THE ENERGY FRACTION SNI OF VIRTUAL GAMMA
+c$$$C LIMITS FOR VIRTUAL GAMMA'S ENERGY ARE SNIMIN AND SNIMAX
+c$$$ SNIMIN1 = ( pmass(2) + 0.5D0*pmass(2)**2/pmass(7) )/EE
+c$$$ SNIMIN2 = ( enymin + pmass(5) )/EE
+c$$$ SNIMIN = MAX( SNIMIN1, SNIMIN2, 1.D-15)
+c$$$ SNIMAX = 1.D0 - ( pmass(7) + PMASSMM**2/pmass(7) ) * 0.5D0/EE
+c$$$ IF ( SNIMIN .GE. SNIMAX ) GOTO 900
+c$$$
+c$$$ IF ( EE .LE. 1.D6 ) THEN
+c$$$ COEF = 0.073D0 * LOG10(EE) - 1.565D0
+c$$$ FACTO = 1.D10 / (10.D0**(8.8D0-0.1D0*(.2D0+LOG10(EE)**2/6.D0)))
+c$$$ * * AATOM/22.D0
+c$$$ ELSEIF ( EE .GT. 1.D6 ) THEN
+c$$$ COEF = 0.063D0 * LOG10(EE) - 1.55326D0
+c$$$ FACTO = 1.D10 / (10.D0**(8.8D0-0.1D0*LOG10(EE)))
+c$$$ * * AATOM/22.D0
+c$$$ ENDIF
+c$$$ COEF1 = COEF + 1.D0
+c$$$ GMIN = FACTO/COEF1 * SNIMIN**COEF1
+c$$$ GMAX = FACTO/COEF1 * SNIMAX**COEF1
+c$$$
+c$$$ JCOUNT = 0
+c$$$ 1 CONTINUE
+c$$$ JCOUNT = JCOUNT + 1
+c$$$C WRITE MONOPOLE UNCHANGED TO STACK
+c$$$ IF ( JCOUNT .GT. 1000 ) GOTO 900
+c$$$ RD(1)=drangen(dble(JCOUNT))
+c$$$ RD(2)=drangen(dble(JCOUNT))
+c$$$ ARGO = GMIN + RD(1)*(GMAX-GMIN)
+c$$$ SNI = (COEF1*ARGO/FACTO)**(1.D0/COEF1)
+c$$$ AUXIL1 = RD(2) * FACTO * SNI**COEF
+c$$$
+c$$$
+c$$$ IF ( SNI .GE. 1.D0 ) THEN
+c$$$ VPH = 0.D0
+c$$$ GOTO 99
+c$$$ ENDIF
+c$$$C CALCULATE BEZRUKOV'S T
+c$$$ TTT = PMASSMM**2 * SNI**2 / (1.D0 - SNI)
+c$$$C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUON
+c$$$ SS = 2.D0 * pmass(7) * SNI * EE
+c$$$C CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+c$$$C SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+c$$$* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+c$$$C SEE: PARTICLE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+c$$$ SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+c$$$C SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+c$$$ ZZZ = SIGN * APH * AATOM**OB3
+c$$$C CALCULATE BOTTAI'S H(V)
+c$$$ HHH = 1.D0 - 2.D0/SNI + 2.D0/SNI**2
+c$$$C CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+c$$$ GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+c$$$C FACTOR BEFORE LARGE BRACKET
+c$$$ BPH = AATOM * SNI * SIGN * (ALPHFA/(8.D0*PI))
+c$$$C AUXILIARY QUANTITIES
+c$$$ CPH = 1.D0 + AM21/TTT
+c$$$ DPH = 1.D0 + AM22/TTT
+c$$$ EPH = 2.D0 * PMASSMM**2 / TTT
+c$$$ FPH = AM21 / (AM21 + TTT)
+c$$$C FIRST PART WITHIN LARGE BRACKET
+c$$$ VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+c$$$C SECOND PART WITHIN LARGE BRACKET
+c$$$ VPH2 = (2.D0 * CSI * PMASSMM**2/TTT)
+c$$$ * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + TTT/AM22 ) )
+c$$$C FINAL CROSS-SECTION
+c$$$ VPH = MAX( 0.D0, BPH * (VPH1+VPH2) )
+c$$$ 99 CONTINUE
+c$$$C USE REJECTION METHOD FOR SAMPLING OF SNI
+c$$$ IF ( AUXIL1 .GE. VPH ) GOTO 1
+
+C SNI FINALLY IS ENERGY FRACTION OF VIRTUAL GAMMA
+C ENERGY OF RESIDUAL MONOPOLE
+ E1 = EE * (1.D0 - SNI)
+C COSTH3 IS SET TO 1 (FORWARD MOVEMENT WITHOUT TRANSVERSE MOMENTUM)
+C MONOPOLE NOT DESTROYED, JUST LESS ENERGY AND BACK TO STACK
+ epf(4) = E1
+ epf(3)=(epf(4)+epf(5))*(epf(4)-epf(5))
+ epf(2)=0.d0
+ epf(1)=0.d0
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*) 'Negative Energy in CXMMNUCL !!!'
+#endif
+ write(*,*) 'Negative Energy in CXMMNUCL !!!'
+ write(*,*) id,epf,SNI
+ write(*,*) 'Skip ...'
+ nptlxs=0
+ goto 900
+ endif
+
+C NOW TREAT THE VIRTUAL GAMMA AS REAL GAMMA
+ EGAM = SNI * EE
+C CHECK: ENERGY OF VIRTUAL GAMMA IS SUFFICIENT FOR PION PRODUCTION ?
+ IF ( EGAM .LE. MAX( enymin, PITHR*1.D-3 ) ) THEN
+C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
+ if(iwrt.ge.2)call Profana(dptl(13)-0.0000001d0*dzHa,zshmax
+ & ,EGAM,EGAM,dptl(11),999,1)
+
+ ELSE
+ isxegs=isx
+C STORE VIRTUAL GAMMA INTO EGS STACK AND CALL SUBR. PIGEN
+C FILL IN STARTING COORDINATES
+ NP = 1
+c Particle initialization
+ XM(NP)=dptl(6) !x
+ YM(NP)=dptl(7) !y
+ ZM(NP)=dptl(8) !h
+ Z(NP)=dptl(13) !slant depth along shower axis
+ DM(NP)=dptl(16) !slant distance along shower axis to impact point, m
+ X(NP)=dptl(14) !x to shower axis
+ Y(NP)=dptl(15) !y to shower axis
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.eq.0)then !in case of 3D
+ rtr1=sqrt(XM(NP)*XM(NP)+YM(NP)*YM(NP))
+ if(rtr1.gt.1.d-20)then
+ sinphiP=YM(NP)/rtr1
+ cosphiP=XM(NP)/rtr1
+ sintheP=rtr1/(ZM(NP)+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ pinv=1.d0/sqrt(dptl(1)**2+dptl(2)**2+dptl(3)**2)
+ ep(1)=dptl(1)*pinv
+ ep(2)=dptl(2)*pinv
+ ep(3)=dptl(3)*pinv
+ call ToObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in obs. frame
+ call FromObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P in shower frame
+ U(NP)=ep(2) !in EGS4, left-handed frame y->u
+ V(NP)=ep(1) !in EGS4, left-handed frame x->v
+ W(NP)=ep(3)
+ else !1D all particle along shower axis
+#endif
+ U(NP)=0.d0
+ V(NP)=0.d0
+ W(NP)=1.d0 !direction towards the shower axis
+#if __MC3D__ || __CXLATCE__
+ endif !end 3D or 1D
+#endif
+ WT(NP)=dptl(11)
+ TM(NP)=dptl(9)
+C CONVERSION GEV --> MEV
+ E(NP) = EGAM * 1000.D0
+ IQ(NP) = 0
+C TREAT THE PHOTONUCLEAR INTERACTION WITH EGS BY PIGEN
+ CALL CXPIGEN
+C ALL SECONDARIES ARE WRITTEN TO STACK VIA AUSGAB
+ do while (NP.gt.0)
+ call AUSGABCX(100)
+ enddo
+ ENDIF
+
+ nptlxs=0
+ dptl(10)=dble(id)
+ do i=1,5
+ dptl(i)=epf(i)
+ enddo
+ if(i1DMC.ne.2)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+ 900 CONTINUE
+#if __COAST__
+ if(mod(idprojxs,100).ne.0)then !not a nucleus
+ coastProjId=-idtrafocx("nxs","cor",idprojxs)
+ else !nucleus
+ coastProjId=-idprojxs-int(dble(idprojxs/100)/2.15d0+0.7d0)
+ endif
+
+ coastTargId = matargxs
+#ifdef __CXCORSIKA__
+ coastX = dptl(7)*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ coastY = -dptl(6)*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+#else
+ coastX = dptl(6)*100d0 !(distance in cm in COAST)
+ coastY = dptl(7)*100d0 !(distance in cm in COAST)
+#endif
+ rdist=sqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7))
+ radh=dptl(8)+radearth
+ if(radh.gt.rdist)then
+ coastZ = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ coastZ = (coastZ-radearth)*100d0
+ else
+ coastZ = dptl(8)*100d0 !(distance in cm in COAST)
+ endif
+ coastE = dptl(4)
+ coastCX = Siginemb*(1d0-cxMmBRBrem-cxMmBRPair)
+ coastEl = 1d0
+ call interaction(coastX)
+#endif
+ call d2a
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXMMPRPR(id,epi,LT)
+
+C-----------------------------------------------------------------------
+C C(ONE)X M(AGNETIC) M(ONOPOLE) P(AI)R PR(ODUCTION)
+C
+C TREATES MAGNETIC MONOPOLE PAIR PRODUCTION (WITHOUT POLARISATION EFFECTS)
+C IN ANALOGY WITH SUBR. GPAIRM OF BOTTAI & PERRONE.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THIS SUBROUTINE IS CALLED FROM MonopoleInteraction.
+c input : id = monopole id (+/- 14)
+c epi = initial Momentum, Energy and Mass
+c LT = Material (1=Nitrogen, 2=Oxygen, 3=Argon)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+#include "conex.incnex"
+#if __COAST__
+ common/cxcurxs/Siginemb
+ double precision Siginemb
+c definition of the COAST crs::CInteraction class
+ COMMON/coastInteraction/coastX, coastY, coastZ,
+ & coastE, coastCX, coastEl, coastProjId, coastTargId
+ double precision coastX, coastY, coastZ
+ double precision coastE, coastCX, coastEl
+ integer coastProjId, coastTargId
+ double precision rdist,radh
+ integer idtrafocx
+ common/cxmmbrint/cxMmBRPair,cxMmBRBrem
+ double precision cxMmBRPair,cxMmBRBrem
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+#endif
+ double precision s0xs,c0xs,s0s,c0s,ep(3)
+ common/cossins/s0xs,c0xs,s0s,c0s
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ common /cxexoticdz/dXotic
+ double precision dXotic
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+*KEND.
+
+ DOUBLE PRECISION COSTH3,EKIN,ENEG,EPOS,EPP,
+ * PHI3,RO,SIGNEW,SIGOLD,
+ * OB3,SINPHI3,COSPHI3,SINTH3
+c * ,SINT1,SINT2,SK,SK1,SK2,SMAX,SMX1,SMX2,SNINT
+c * ,GX,RAT12,ROMAX,ROMIN,TRUR,TRUV,VC
+ PARAMETER (OB3 = 0.3333333333333d0)
+ INTEGER I,id,LT!,JCOUNT
+c DOUBLE PRECISION DKOKOIMM,PPCSMM
+c EXTERNAL DKOKOIMM,PPCSMM
+ double precision CXPRSGMM,drangen,DPRELMM
+ external CXPRSGMM,drangen,DPRELMM
+ double precision epi(5),epf(5),RD(3),PT,Ptot!,EELOG
+C-----------------------------------------------------------------------
+
+
+
+C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO TARGET INDEX LT
+C (1=N, 2=O, 3=AR) WHICH WAS SET IN BOX2; RESTORE OLD CROSS-SECTION
+ IF ( LT .EQ. 1 ) THEN
+ SIGOLD = FRAPTN / airw(1)
+ ELSEIF ( LT .EQ. 2 ) THEN
+ SIGOLD = (FRPTNO - FRAPTN) / airw(2)
+ ELSEIF ( LT .EQ. 3 ) THEN
+ SIGOLD = (SIGPRM - FRPTNO) / airw(3)
+ ELSE
+ WRITE(*,*) 'CXMUPRPR: WRONG TARGET LT =',LT,' STOP'
+ STOP
+ ENDIF
+ ZATOM = airz(LT)
+ AATOM = aira(LT)
+ BCUT = 25d0*PMASSMM
+
+C TOTAL AND KINETIC ENERGY OF MUON
+ EE = epi(4)
+ EKIN = epi(4) - epi(5)
+ do i=1,5
+ epf(i)=epi(i)
+ enddo
+ IF ( EKIN .LE. BCUT ) GOTO 900
+C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY
+C GET NEW CROSS-SECTION
+ SIGNEW = CXPRSGMM( EE,LT )
+ RD(1)=drangen(dble(LT))
+
+
+C SKIP INTERACTION IF RANDOM NUMBER SMALLER THAN CROSS-SECTION RATIO
+ IF ( RD(1)*SIGOLD .GT. SIGNEW ) GOTO 900
+C
+
+C ENERGY FRACTION FROM INTEGRATED ENERGY LOSS
+ VFRAC = DPRELMM( LT ) * dXotic
+ VFRAC = min( VFRAC, EKIN ) / EE
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*) 'CXMMPRPR: SNI=',VFRAC,EE,dXotic,LT
+#endif
+
+c VMIN = 4.D0 * pmass(10) / EE
+c VC = BCUT / EE
+c VMIN = MAX( VMIN, VC )
+c VMAX = 1.D0 - CMUON(10) * ZATOM**OB3 / EE
+c IF ( VMAX .LE. VMIN ) GOTO 900
+c
+c ROMIN = 0.D0
+cC CALCULATE AUXILIARY VARIABLES (NEW VERSION R.P.K./A.G.B. MARCH 2007
+c EELOG = LOG10 (EE)
+c SK = ZATOM * (ZATOM + 1.D0)
+c IF ( EELOG .LE. 4.D0 ) THEN
+c SK1 = SK*(EELOG+0.8D0)**2 * 0.868D-29
+c SK2 = SK*(EELOG+0.8D0) * 1.000D-33
+c ELSE
+c SK1 = SK*(EELOG-1.6D0) * 8.33D-29
+c SK2 = SK * 4.80D-33
+c ENDIF
+c SNINT = SQRT( SK2/SK1 )
+c SINT1 = SK1 * LOG( SNINT/VMIN )
+c SINT1 = MAX( 0.D0, SINT1 )
+c SINT2 = -0.5D0 * SK2 * ( 1.D0/VMAX**2 - 1.D0/SNINT**2 )
+c SINT2 = MAX( 0.D0, SINT2 )
+c RAT12 = SINT1 / (SINT1+SINT2)
+c
+cC SAMPLE THE ENERGY FRACTION VFRAC TRANSFERRED TO THE PAIR
+c JCOUNT = 0
+c 321 CONTINUE
+c JCOUNT = JCOUNT + 1
+c IF ( JCOUNT .GT. 1000 )GOTO 900
+c RD(1)=drangen(SK)
+c RD(2)=drangen(SK1)
+c RD(3)=drangen(SK2)
+c IF ( RD(1) .LT. RAT12 ) THEN
+c VFRAC = EXP( LOG( VMIN) + RD(2) * SINT1/SK1 )
+c ELSE
+c VFRAC = SQRT( 1.D0 / ( 1.D0/SNINT**2 - 2.D0*RD(2)*SINT2/SK2 ) )
+c ENDIF
+c IF ( VFRAC .LT. SNINT ) THEN
+c GX = SK1/VFRAC
+c ELSE
+c GX = SK2/(VFRAC**3)
+c ENDIF
+cC NORMALIZATION TO MBARN IS MADE IN DKOKOI
+c TRUV = DKOKOIMM()
+c IF ( RD(3)*GX .GT. TRUV ) GOTO 321
+c
+c IF ( VFRAC .GE. VMAX ) VFRAC = VMAX
+c IF ( VFRAC .LE. VMIN ) VFRAC = VMIN
+
+C WE HAVE VFRAC, NOW SAMPLE THE ENERGY ASYMMETRY RO OF THE PAIR
+ RO=0d0 !simplest case : symmetric distribution
+
+c ROMAX = ( 1.D0 - 6.D0*PMASSMM**2/( (1.D0-VFRAC)*EE**2 ) )
+c * * SQRT( 1.D0 - VMIN / VFRAC )
+c ROMIN = -ROMAX
+c SMX1 = PPCSMM(0.D0)
+c SMX2 = PPCSMM(ROMIN)
+c SMAX = 2.D0 * MAX( SMX1, SMX2 )
+c 456 CONTINUE
+c RD(1)=drangen(ROMIN)
+c RD(2)=drangen(ROMAX)
+c RO = ROMAX * ( 2.D0*RD(1) - 1.D0 )
+cC HERE WE NEED NO NORMALIZATION OF PPCS
+c TRUR = PPCSMM(RO)
+c IF ( SMAX*RD(2) .GT. TRUR ) GOTO 456
+
+C CALCULATE THE ENERGIES
+ EPP = VFRAC * EE
+ EPOS = max(pmass(10),0.5D0 * EPP * (1.D0 + RO))
+ ENEG = EPP - EPOS
+C CALCULATE THE ANGLES
+ COSTH3 = COS( PMASSMM/EE )
+ if(abs(COSTH3).ge.1.d0)COSTH3=sign(1.d0,COSTH3)
+ RD(1)=drangen(COSTH3)
+ PHI3 = 2.d0 * PI * RD(1)
+
+C TREAT THE POSITRON
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = EPOS
+ xsptl(5,nptlxs) = pmass(10)
+ idptlxs(nptlxs) = -12
+ istptlxs(nptlxs) = 0
+ if(xsptl(4,nptlxs).lt.xsptl(5,nptlxs))then
+ write(*,*)'Negative Energy for positron in CXMMPRPR !!!'
+ write(*,*)'should not happen ... skip !!!'
+ nptlxs=0
+ GOTO 900
+ endif
+ Ptot = sqrt((xsptl(4,nptlxs)+xsptl(5,nptlxs))
+ & *(xsptl(4,nptlxs)-xsptl(5,nptlxs)))
+ xsptl(3,nptlxs) = Ptot * COSTH3
+ SINTH3 = sqrt((1.d0-COSTH3)*(1.d0+COSTH3))
+ PT = Ptot * SINTH3
+ COSPHI3 = COS( PHI3 )
+ if(abs(COSPHI3).ge.1.d0)COSPHI3=sign(1.d0,COSPHI3)
+ SINPHI3 = sqrt((1.d0-COSPHI3)*(1.d0+COSPHI3))
+ xsptl(1,nptlxs) = PT * COSPHI3
+ xsptl(2,nptlxs) = PT * SINPHI3
+
+
+C TREAT THE ELECTRON
+
+ nptlxs=nptlxs+1
+ xsptl(4,nptlxs) = ENEG
+ xsptl(5,nptlxs) = pmass(10)
+ idptlxs(nptlxs) = 12
+ istptlxs(nptlxs) = 0
+ xsptl(1,nptlxs) = -PT * COSPHI3
+ xsptl(2,nptlxs) = -PT * SINPHI3
+ PT=PT*PT+xsptl(5,nptlxs)*xsptl(5,nptlxs)
+ xsptl(3,nptlxs) = (xsptl(4,nptlxs)+PT)*(xsptl(4,nptlxs)-PT)
+ if(xsptl(3,nptlxs).ge.0.d0)then
+ xsptl(3,nptlxs)=sqrt(xsptl(3,nptlxs))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*)'Negative Energy for electron in CXMMPRPR !!!'
+#endif
+ write(*,*)'Negative Energy for electro in CXMMPRPR !!!'
+ write(*,*) (xsptl(i,nptlxs-1),i=1,5),(xsptl(i,nptlxs),i=1,5)
+ write(*,*) 'Skip ...'
+ istptlxs(nptlxs)=1
+ istptlxs(nptlxs-1)=1
+ nptlxs=0
+ goto 900
+ endif
+
+C REDUCE ENERGY OF MONOPOLE
+ epf(4)= EE - EPP
+ epf(3)=(epf(4)+epf(5))*(epf(4)-epf(5))
+ epf(2)=0.d0
+ epf(1)=0.d0
+ if(epf(3).ge.0.d0)then
+ epf(3)=sqrt(epf(3))
+ else
+#ifdef __CXDEBUG__
+ write(ifck,*)'Negative Energy for MM in CXMMPRPR !!!'
+#endif
+ write(*,*)'Negative Energy for MM in CXMMPRPR !!!'
+ write(*,*) id,epf,EE,EPP
+ write(*,*) 'Skip ...'
+ istptlxs(nptlxs)=1
+ istptlxs(nptlxs-1)=1
+ nptlxs=0
+ goto 900
+ endif
+
+C THE CHANGEMENT OF THE MUON ANGLE IS NEGLECTED
+
+ dptl(10)=dble(id)
+ do i=1,5
+ dptl(i)=epf(i)
+ enddo
+ if(i1DMC.ne.2)then
+ ep(1)=dptl(1)
+ ep(2)=dptl(2)
+ ep(3)=dptl(3)
+ call cxrotat(ep,s0xs,c0xs,s0s,c0s)
+ dptl(1)=ep(1)
+ dptl(2)=ep(2)
+ dptl(3)=ep(3)
+ endif
+ 900 CONTINUE
+#if __COAST__
+ if(mod(idprojxs,100).ne.0)then !not a nucleus
+ coastProjId=-idtrafocx("nxs","cor",idprojxs)
+ else !nucleus
+ coastProjId=-idprojxs-int(dble(idprojxs/100)/2.15d0+0.7d0)
+ endif
+
+ coastTargId = matargxs
+#ifdef __CXCORSIKA__
+ coastX = dptl(7)*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ coastY = -dptl(6)*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+#else
+ coastX = dptl(6)*100d0 !(distance in cm in COAST)
+ coastY = dptl(7)*100d0 !(distance in cm in COAST)
+#endif
+ rdist=sqrt(dptl(6)*dptl(6)+dptl(7)*dptl(7))
+ radh=dptl(8)+radearth
+ if(radh.gt.rdist)then
+ coastZ = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ coastZ = (coastZ-radearth)*100d0
+ else
+ coastZ = dptl(8)*100d0 !(distance in cm in COAST)
+ endif
+ coastE = dptl(4)
+ coastCX = Siginemb*(1d0-cxMmBRBrem-cxMmBRPair)
+ coastEl = 1d0
+ call interaction(coastX)
+#endif
+ call d2a
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXBRSGMM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X BR(EMSSTRAHLUNG) S(I)G(MA FOR) M(AGNETIC) M(ONOPOLES)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MUON BREMSSTRAHLUNG. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. CXMUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM MMSIGMA
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MONOPOLE
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ CXBRSGMM=0d0
+ if (ELAB.LE.PMASSMM)return
+ YE = 10.D0 * LOG10(ELAB-PMASSMM) + 1.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXBRSGMM = 0.D0
+ DO I = 1, 3
+ CXBRSGMM = CXBRSGMM + BREMSTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXBRSGMM = EXP(CXBRSGMM)
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXNUSGMM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X NU(CLEAR INTERACTION) S(I)G(MA FOR) M(AGNETIC) M(ONOPOLES)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MONOPOLE NUCLEAR INTERACTION. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. MUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM BOX2.
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MONOPOLE
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ CXNUSGMM=0d0
+ if (ELAB.LE.PMASSMM)return
+ YE = 10.D0 * LOG10(ELAB-PMASSMM) + 1.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXNUSGMM = 0.D0
+ DO I = 1, 3
+ CXNUSGMM = CXNUSGMM + NUCTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXNUSGMM = EXP(CXNUSGMM)
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXPRSGMM( ELAB,MAT )
+
+C-----------------------------------------------------------------------
+C C(ONE)X P(AI)R (PRODUCTION) S(I)G(MA FOR) M(AGNETIC) M(ONOPOLES)
+C
+C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD)
+C MONOPOLE PAIR PRODUCTION. (SIGMA IN BARN/ATOM)
+C THIS FUNCTION USES TABLES ESTABLISHED WITH THE SUBR. MUPINI
+C ACCORDING THE ROUTINES OF:
+C S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C THESE TABLES ARE GIVEN AS LOG OF THE CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM BOX2.
+C ARGUMENTS:
+C ELAB = TOTAL ENERGY OF MONOPOLE
+C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+*KEEP,SIGMU.
+ COMMON /CRSIGMM/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
+ * FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
+ * SIGBRM,SIGNUC,SIGPRM
+
+ DOUBLE PRECISION BREMSTAB(151,3),NUCTAB(151,3),PAIRTAB(151,3),
+ * DEDXMU(151,3),DEDXM(151),FRABTN,FRANTN,FRAPTN,
+ * FRBTNO,FRNTNO,FRPTNO,SIGBRM,SIGNUC,SIGPRM
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ DOUBLE PRECISION DELTAE,ELAB,WK(3),YE
+ INTEGER I,JE,MAT
+C-----------------------------------------------------------------------
+
+C DETERMINE ENERGY INTERVAL FOR INTERPOLATION
+C WE HAVE 10 POINTS/DECADE AND 2 DECADES BELOW 1 GEV
+ CXPRSGMM=0d0
+ if (ELAB.LE.PMASSMM)return
+ YE = 10.D0 * LOG10(ELAB-PMASSMM) + 1.D0
+ IF ( YE .LT. 1.D0 ) YE = 1.D0
+ JE = INT(YE)
+ IF ( JE .GT. 139 ) JE = 139
+ DELTAE = YE - DBLE(JE)
+ WK(3) = DELTAE * (DELTAE-1.D0) * .5D0
+ WK(1) = 1.D0 - DELTAE + WK(3)
+ WK(2) = DELTAE - 2.D0 * WK(3)
+
+C NOW MAKE QUADRATIC INTERPOLATION OF THE LOG OF CROSS-SECTIONS
+ CXPRSGMM = 0.D0
+ DO I = 1, 3
+ CXPRSGMM = CXPRSGMM + PAIRTAB(JE+I-1,MAT)*WK(I)
+ ENDDO
+ CXPRSGMM = EXP(CXPRSGMM)
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DBRELMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) BR(EMSSTRAHLUNG) E(NERGY) L(OSS) M(agnetic) M(onopoles)
+C
+C FUNCTION TO CALCULATE THE MUON BREMSSTRAHLUNG ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER JJMAT,jdum!,IFAIL,NFNEVL
+c DOUBLE PRECISION VBSEMM
+c EXTERNAL VBSEMM
+ DOUBLE PRECISION gam0,q1,q2
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DBRELMM = 0.D0
+ jdum=jjmat
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+c ECMIN = 0.D0
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c ECMAX = EE - CONSTKINE
+c XLOW = XLOW0
+c XUPP = BCUT/EE
+c IF ( ECMIN .GE. BCUT ) RETURN
+c IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+c IF ( XUPP .LE. XLOW ) RETURN
+c
+cC DADMUL INTEGRATION
+c AA(1) = 0.D0
+c AA(2) = XLOW
+c B(1) = 1.D0
+c B(2) = XUPP
+c CALL DADMUL( VBSEMM,N,AA,B,MINPTS,MAXPTS
+c * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+c IF ( IFAIL .NE. 0 ) THEN
+c WRITE(ifck,*) 'DBRELMM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c STOP
+c ENDIF
+cC NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2
+c DBRELMM = 34.d0 * AVOG * RESULT * 1.D27 * EE / AATOM
+
+ gam0 = (EE/PMASSMM)
+ q1 = (16.d0/3.0d0)
+ q2 = (34.d0**2/fialpha*ZATOM**2*AVOG*gam0*log(gam0))
+C ENERGY LOSS IN GEV * G**-1 * CM**2
+ DBRELMM = q1 * q2 / (AATOM*PMASSMM)
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DBRSGMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) BR(EMSSTRAHLUNG) S(I)GM(A FOR)(M)onopoles
+C
+C FUNCTION TO CALCULATE THE MONOPOLE BREMSSTRAHLUNG CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM CXMMPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ double precision DBRELMM
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER JJMAT!,IFAIL,NFNEVL
+c DOUBLE PRECISION VBSSMM
+c EXTERNAL VBSSMM
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DBRSGMM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+c$$$
+c$$$ ECMIN = 0.D0
+c$$$ ECMAX = EE - CONSTKINE
+c$$$ XLOW = BCUT / EE
+c$$$ XUPP = ECMAX / EE
+c$$$ IF ( ECMAX .LT. BCUT ) RETURN
+c$$$ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN/EE
+c$$$ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+c$$$ IF ( XUPP .LE. XLOW ) RETURN
+c$$$
+c$$$C DADMUL INTEGRATION
+c$$$ AA(1) = 0.D0
+c$$$ AA(2) = XLOW
+c$$$ B(1) = 1.D0
+c$$$ B(2) = XUPP
+c$$$ CALL DADMUL( VBSSMM,N,AA,B,MINPTS,MAXPTS
+c$$$ * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+c$$$ IF ( IFAIL .NE. 0 ) THEN
+c$$$ WRITE(ifck,*) 'DBRSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c$$$ STOP
+c$$$ ENDIF
+
+C CONVERT FROM GeV / CM**2 TO MILLIBARN
+
+ DBRSGMM = AATOM * DBRELMM( JJMAT ) / AVOG / EE * 1d6
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DNIELMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) N(UCL.) I(NTER.) E(NERGY) L(OSS) M(agnetic) M(onopoles)
+C
+C FUNCTION TO CALCULATE THE MONOPOLE NUCLEAR INTERACTION ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER JJMAT,jdum!,IFAIL,NFNEVL
+c DOUBLE PRECISION VPHLMM
+c EXTERNAL VPHLMM
+ DOUBLE PRECISION gam0
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DNIELMM = 0.D0
+ jdum=jjmat
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c ECMIN = pmass(2) + 0.5D0 * pmass(2)**2 / pmass(7)
+c ECMAX = EE - 0.5D0 * pmass(7) * ( 1.D0 + (PMASSMM/pmass(7))**2 )
+c XLOW = ECMIN / EE
+c XUPP = BCUT / EE
+c IF ( ECMIN .GE. BCUT ) RETURN
+c IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+c IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+c IF ( XUPP .LE. XLOW ) RETURN
+c
+cC DADMUL INTEGRATION
+c AA(1) = 0.D0
+c AA(2) = XLOW
+c B(1) = 1.D0
+c B(2) = XUPP
+c CALL DADMUL(VPHLMM,N,AA,B,MINPTS,MAXPTS
+c * ,EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL)
+c IF ( IFAIL .NE. 0 ) THEN
+c WRITE(ifck,*) 'DNIELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c STOP
+c ENDIF
+c DNIELMM = 34.d0 * RESULT * 1.D27 * EE * AVOG / AATOM
+
+ gam0 = (EE/PMASSMM)
+C ENERGY LOSS IN GEV * G**-1 * CM**2
+ DNIELMM = gam0**1.28 * AVOG / AATOM
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DNUSGMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) NU(CLEAR INTERACTION) S(I)GM(A FOR) M(ONOPOLES)
+C
+C FUNCTION TO CALCULATE THE MONOPOLE NUCLEAR INTERACTION CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM CXMMPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+ double precision DBRELMM
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION EPSBS
+ PARAMETER (EPSBS = 1.D-6)
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+
+ INTEGER JJMAT!,IFAIL,NFNEVL
+c DOUBLE PRECISION gam0,VPHMM
+c EXTERNAL VPHMM
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DNUSGMM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+c$$$ ECMIN = pmass(2) + 0.5D0 * pmass(2)**2 / pmass(7)
+C EE IS THE TOTAL ENERGY OF INCOMING MUON
+c$$$ ECMAX = EE - 0.5D0 * pmass(7) * ( 1.D0 + (PMASSMM/pmass(7))**2 )
+c$$$ XLOW = BCUT / EE
+c$$$ XUPP = ECMAX / EE
+c$$$ IF ( ECMAX .LT. BCUT ) RETURN
+c$$$ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN/EE
+c$$$ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+c$$$ IF ( XUPP .LE. XLOW ) RETURN
+c$$$
+c$$$C DADMUL INTEGRATION
+c$$$ AA(1) = 0.D0
+c$$$ AA(2) = XLOW
+c$$$ B(1) = 1.D0
+c$$$ B(2) = XUPP
+c$$$ CALL DADMUL( VPHMM,N,AA,B,MINPTS,MAXPTS,
+c$$$ + EPSBS,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+c$$$
+c$$$ IF ( IFAIL .NE. 0 ) THEN
+c$$$ WRITE(ifck,*) 'DNUSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c$$$ STOP
+c$$$ ENDIF
+
+C CONVERT FROM GeV / CM**2 TO MILLIBARN
+
+ DNUSGMM = AATOM * DBRELMM( JJMAT ) / AVOG / EE * 1d6
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DPRELMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) P(AI)R (PRODUCTION) E(NERGY) L(OSS) M(agnetic) M(onopoles)
+C
+C FUNCTION TO CALCULATE THE MUON BREMSSTRAHLUNG ENERGY LOSS.
+C SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+C BILOKON ET AL., NUCL. INSTR. METH. A303 (1991) 381
+C LOHMANN, KOPP, VOSS, YELLOW REPORT FROM CERN 85-03
+C THIS FUNCTION IS CALLED FROM MUPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+c orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+c Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION ALPHFA,EPSPP,RE,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (EPSPP = 1.D-3)
+ PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER JJMAT,jdum!,IFAIL,NFNEVL
+c DOUBLE PRECISION DKOKOEMM
+c EXTERNAL DKOKOEMM
+ DOUBLE PRECISION gam0, b1, b2!, b3
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DPRELMM = 0.D0
+ jdum=jjmat
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c ECMIN = 4.D0 * pmass(10)
+c ECMAX = EE - CONSTKINE
+c XLOW = ECMIN / EE
+c XUPP = BCUT / EE
+c
+c IF ( ECMAX .LT. BCUT ) XUPP = ECMAX/EE
+c IF ( ECMIN .GT. BCUT ) RETURN
+c IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+c IF ( XUPP .LT. XLOW + (ECMIN+0.001D0)/EE ) RETURN
+c VMIN = 4.D0 * pmass(10) / EE
+c VMAX = 1.D0 - CONSTKINE / EE
+c
+cC DADMUL INTEGRATION
+c AA(1) = 0.D0
+c AA(2) = LOG10(XLOW)
+c B(1) = 1.D0
+c B(2) = LOG10(XUPP)
+c CALL DADMUL( DKOKOEMM,N,AA,B,MINPTS,MAXPTS,
+c + EPSPP,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+c IF ( IFAIL .NE. 0 ) THEN
+c WRITE(ifck,*) 'DPRELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c STOP
+c ENDIF
+cC NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2
+c DPRELMM=34.d0 * AVOG * RESULT * 2.D27 * EE * ALPHFA**4 * (TB3/PI)
+c * * ZATOM * (ZATOM+1.D0) * RE**2 / AATOM
+
+ gam0 = (EE/PMASSMM)
+ b1 = 48.d0/(19.d0*pi**2) * EBYMU * log(EBYMU)**2
+ b2 = 11.d0/6.0d0 + 16.d0/(19.d0*pi**2) * EBYMU * log(EBYMU)**3
+c b3 = 1.d0/38.0d0 - 16.d0/(19.d0*pi**2) * EBYMU * log(EBYMU)**3
+
+ DPRELMM = (19.d0*pi)/9d0 * (34.d0*ZATOM**2*AVOG) * gam0
+ * /(fialpha**3*EBYMU*PMASSMM*AATOM)
+C ENERGY LOSS IN GEV * G**-1 * CM**2
+ DPRELMM = DPRELMM * ((1-b1)*log(0.25d0*gam0)-b2)
+c DPRELMM = DPRELMM * ((1-b1)*log(189d0/CONSTKINE)+log(2d0)-b3)
+
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION DPRSGMM( JJMAT )
+
+C-----------------------------------------------------------------------
+C D(OUBLE PRECISION) P(AI)R (PRODUCTION) S(I)GM(A FOR) M(onopoles)
+C
+C FUNCTION TO CALCULATE THE MONOPOLE PAIR PRODUCTION CROSS-SECTIONS.
+C THIS FUNCTION IS CALLED FROM CXMMPINI.
+C ARGUMENT:
+C JJMAT = MATERIAL INDEX (1 = 14N, 2 = 16O, 3 = 40AR)
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+#include "conex.h"
+*KEEP,MUPART.
+ COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+ * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+ DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+ * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+ LOGICAL FMUBRM,FMUNUC,FMUORG
+ common /CRMMMASS/pmassmm
+ double precision pmassmm
+*KEND.
+
+ INTEGER IWK,MAXPTS,MINPTS,N
+ PARAMETER (IWK = 1000000)
+ PARAMETER (MAXPTS = 100000)
+ PARAMETER (MINPTS = 10)
+ PARAMETER (N = 2)
+ DOUBLE PRECISION ALPHFA,EPSPP,RE,TB3
+ PARAMETER (ALPHFA = 7.297353D-3)
+ PARAMETER (EPSPP = 1.D-3)
+ PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+ PARAMETER (TB3 = 0.6666666666666d0)
+
+c DOUBLE PRECISION AA(2),B(2),WK(IWK)
+c DOUBLE PRECISION ECMIN,ECMAX,RELERR,RESULT,XLOW,XLOW0,XUPP
+ INTEGER JJMAT!,IFAIL,NFNEVL
+c DOUBLE PRECISION DKOKOSMM
+c EXTERNAL DKOKOSMM
+ double precision DPRELMM
+c DATA XLOW0 / 1.D-15 /
+c SAVE XLOW0
+C-----------------------------------------------------------------------
+
+ DPRSGMM = 0.D0
+C EE IS THE TOTAL ENERGY OF INCOMING MONOPOLE
+ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+c$$$C EE IS THE TOTAL ENERGY OF INCOMING MUON
+c$$$ IF ( EE-PMASSMM .LT. BCUT ) RETURN
+c$$$
+c$$$ ECMIN = 4.D0 * pmass(10)
+c$$$ ECMAX = EE - CONSTKINE
+c$$$ XLOW = BCUT / EE
+c$$$ XUPP = ECMAX / EE
+c$$$ IF ( ECMAX .LT. BCUT ) RETURN
+c$$$ IF ( ECMIN .GT. BCUT ) XLOW = ECMIN / EE
+c$$$ IF ( XLOW .LE. XLOW0 ) XLOW = XLOW0
+c$$$ IF ( XUPP .LE. XLOW ) RETURN
+c$$$ VMIN = 4.D0 * pmass(10) / EE
+c$$$ VMAX = 1.D0 - CONSTKINE / EE
+c$$$
+c$$$C DADMUL INTEGRATION
+c$$$ AA(1) = 0.D0
+c$$$ AA(2) = LOG10(XLOW)
+c$$$ B(1) = 1.D0
+c$$$ B(2) = LOG10(XUPP)
+c$$$ CALL DADMUL( DKOKOSMM,N,AA,B,MINPTS,MAXPTS,
+c$$$ + EPSPP,WK,IWK,RESULT,RELERR,NFNEVL,IFAIL )
+c$$$ IF ( IFAIL .NE. 0 ) THEN
+c$$$ WRITE(ifck,*) 'DPRSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT
+c$$$ STOP
+c$$$ ENDIF
+c$$$C CONVERT FROM CM**2 TO MILLIBARN
+
+C CONVERT FROM GeV / CM**2 TO MILLIBARN
+
+ DPRSGMM = AATOM * DPRELMM ( JJMAT ) / AVOG / EE * 1d6
+
+ RETURN
+ END
+
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION DKOKOEMM( Y )
+c
+cC-----------------------------------------------------------------------
+cC D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) E(NERGY LOSS)
+cC
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+cC TO BE USED FOR ENERGY LOSS CALCULATION OF MONOPOLE PAIR PRODUCTION.
+cC THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRELM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION Y(2)
+c DOUBLE PRECISION ROMAX,ROMIN
+c INTEGER NPNTS
+c DOUBLE PRECISION DGQUAD,PPCEMM
+c EXTERNAL DGQUAD,PPCEMM
+c SAVE ROMIN,NPNTS
+c DATA ROMIN /0.D0/, NPNTS / 64 /
+cC-----------------------------------------------------------------------
+c
+c VFRAC = 10.D0**Y(2)
+cC INITIALISATION FOR GAUSS INTEGRATION
+c ROMAX = SQRT( 1.D0 - 4.D0*pmass(10)/(EE*VFRAC) )
+c * * ( 1.D0 - 6.D0*PMASSMM**2/( (1.D0-VFRAC)*EE**2 ) )
+cC INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+c DKOKOEMM = LOG(10.D0) * VFRAC * DGQUAD( PPCEMM,ROMIN,ROMAX,NPNTS )
+cC NORMALIZATION IS MADE IN DPRELM
+c IF ( DKOKOEMM .LT. 0.D0 ) DKOKOEMM = 0.D0
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION DKOKOIMM()
+c
+cC-----------------------------------------------------------------------
+cC D(OUBLE PRECISION) KOKO(ULIN) INTEGRATION)
+cC
+cC FUNCTION FOR INTEGRATION OF PAIR PRODUCTION CROSS SECTION WITH
+cC RESPECT TO ENERGY ASYMMETRY PARAMETER RO.
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+cC TO BE USED FOR SAMPLING OF MUON PAIR PRODUCTION.
+cC THIS FUNCTION IS CALLED FROM MUPRPR.
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION ALPHFA,RE,TB3
+c PARAMETER (ALPHFA = 7.297353D-3)
+c PARAMETER (RE = 3.8615932335D-11) !ELECTRON Wave Lenght (CM)
+c PARAMETER (TB3 = 0.666666666666D0)
+c
+c DOUBLE PRECISION A1,A2,A3,TMAX,TMIN
+c INTEGER NPNTS
+c DOUBLE PRECISION DGQUAD,PPCSLMM
+c EXTERNAL DGQUAD,PPCSLMM
+c SAVE
+c DATA TMAX /0.D0/, NPNTS / 8 /
+cC-----------------------------------------------------------------------
+c
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c
+cC INITIALISATION FOR GAUSS INTEGRATION
+c A1 = 4.D0*pmass(10)/(EE*VFRAC)
+c IF ( A1 .GE. 1.D0 ) THEN
+c DKOKOIMM = 0.D0
+c RETURN
+c ENDIF
+c A2 = SQRT(1.D0 - A1)
+c A3 = 6.D0*pmass(9)**2/( (1.D0-VFRAC) * EE**2 )
+c TMIN = LOG( A1/(1.D0+A2) + A3*A2 )
+cC INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+c DKOKOIMM = 2.D0 * DGQUAD( PPCSLMM,TMIN,TMAX,NPNTS )
+cC NORMALIZATION
+c DKOKOIMM = DKOKOIMM * ALPHFA**4 * (TB3/PI)
+c * * ZATOM * (ZATOM+1.D0) * RE**2
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION DKOKOSMM( Y )
+c
+cC-----------------------------------------------------------------------
+cC D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) S(IGMA)
+cC
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
+cC TO BE USED FOR CROSS SECTION CALCULATION OF MUON PAIR PRODUCTION.
+cC THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRSGM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMUPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION Y(2)
+c DOUBLE PRECISION ROMAX,ROMIN
+c INTEGER NPNTS
+c DOUBLE PRECISION DGQUAD,PPCSMM
+c EXTERNAL DGQUAD,PPCSMM
+c SAVE ROMIN,NPNTS
+c DATA ROMIN /0.D0/, NPNTS / 64 /
+cC-----------------------------------------------------------------------
+c
+c VFRAC = 10.D0**Y(2)
+c
+cC INITIALISATION FOR GAUSS INTEGRATION
+c ROMAX = SQRT( 1.D0 - 4.D0*pmass(10)/(EE*VFRAC) )
+c * * ( 1.D0 - 6.D0*PMASSMM**2/( (1.D0-VFRAC)*EE**2 ) )
+cC INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
+c DKOKOSMM = LOG(10.D0) * VFRAC * DGQUAD( PPCSMM,ROMIN,ROMAX,NPNTS )
+cC NORMALIZATION IS MADE IN DPRSGM
+c IF ( DKOKOSMM .LT. 0.D0 ) DKOKOSMM = 0.D0
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION PPCEMM( R1 )
+c
+cC-----------------------------------------------------------------------
+cC P(AIR) P(RODUCTION) C(ROSS SECTION FOR GAUSS INTEGR.) E(NERGY LOSS)
+cC
+cC FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+cC PAIR PRODUCTION ENERGY LOSS.
+cC PARAMETERS TO BE GIVEN BY COMMON:
+cC EE = ENERGY OF INCOMING MUON
+cC VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+cC ZATOM = ATOMIC NUMBER OF TARGET ATOM
+cC THIS FUNCTION IS CALLED FROM DGQUAD (BY DKOKOE)
+cC ARGUMENT:
+cC R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION R,OB3,TB3
+c PARAMETER (R = 189.D0)
+c PARAMETER (OB3 = 0.3333333333333d0)
+c PARAMETER (TB3 = 0.6666666666666d0)
+c
+c DOUBLE PRECISION R1
+c DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+c * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+c * FIE,FIM,QFIE,QFIM,
+c * RO2,UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+c SAVE
+cC-----------------------------------------------------------------------
+c
+c RO2 = R1**2
+c AUXIL2 = R / ZATOM**OB3
+c BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+c CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+c UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+c DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+c * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+c YE = UPPYE/DOWNYE
+c UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+c DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+c * + 1.D0 - 1.5D0 * RO2
+c YM = UPPYM/DOWNYM
+c AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+c UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+c DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+c * * AUXIL2 ) * AUXIL
+c ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+c * * (1.D0+YE)
+c ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+c UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+c DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+c * * AUXIL2 ) * AUXIL
+c ALM = LOG(UPPLM/DOWNLM)
+c QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+c FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+c * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+c QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+c * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+c FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+c * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+cC NORMALIZATION IS MADE IN DPRELM AND IN DKOKOE
+c PPCEMM = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION PPCSMM( R1 )
+c
+cC-----------------------------------------------------------------------
+cC P(AIR) P(RODUCTION) C(ROSS) S(ECTION FOR GAUSS INTEGRATION)
+cC
+cC FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+cC PAIR PRODUCTION CROSS-SECTIONS.
+cC PARAMETERS TO BE GIVEN BY COMMON:
+cC EE = ENERGY OF INCOMING MUON
+cC VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+cC ZATOM = ATOMIC NUMBER OF TARGET ATOM
+cC THIS FUNCTION IS CALLED FROM DGQUAD (BY CXMUPRPR, DKOKOS, DKOKOS)
+cC AND CXMUPRPR.
+cC ARGUMENT:
+cC R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 16, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION R,OB3,TB3
+c PARAMETER (R = 189.D0)
+c PARAMETER (OB3 = 0.3333333333333d0)
+c PARAMETER (TB3 = 0.6666666666666d0)
+c
+c DOUBLE PRECISION R1
+c DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+c * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+c * FIE,FIM,QFIE,QFIM,
+c * RO2,UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+cC-----------------------------------------------------------------------
+c
+c RO2 = R1**2
+c AUXIL2 = R / ZATOM**OB3
+c BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+c CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+c UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+c DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+c * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+c YE = UPPYE/DOWNYE
+c UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+c DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+c * + 1.D0 - 1.5D0 * RO2
+c YM = UPPYM/DOWNYM
+c AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+c UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+c DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+c * * AUXIL2 ) * AUXIL
+c ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+c * * (1.D0+YE)
+c ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+c UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+c DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+c * * AUXIL2 ) * AUXIL
+c ALM = LOG(UPPLM/DOWNLM)
+c QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+c FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+c * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+c QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+c * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+c FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+c * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+cC NORMALIZATION IS MADE IN DPRSGM AND IN DKOKOI
+c PPCSMM = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION PPCSLMM( T )
+c
+cC-----------------------------------------------------------------------
+cC P(AIR) P(RODUCTION) C(ROSS) S(ECTION WITH) L(OGARITHMIC SUBSTITUTION)
+cC (FOR GAUSS INTEGRATION)
+cC
+cC FUNCTION TO BE CALLED BY DGQUAD FOR CALCULATION OF MUON
+cC PAIR PRODUCTION CROSS-SECTIONS.
+cC PARAMETERS TO BE GIVEN BY COMMON:
+cC EE = ENERGY OF INCOMING MUON
+cC VFRAC = (E+ + E-)/EE FRACTION OF MUON ENERGY TRANSMITTED TO PAIR
+cC ZATOM = ATOMIC NUMBER OF TARGET ATOM
+cC THIS FUNCTION IS CALLED FROM DGQUAD (BY MUPRPR) FOR NEW VERSION OF
+cC DKOKOI (MARCH 2007)
+cC
+cC ARGUMENT:
+cC T = LOG( 1 - R1) WITH
+cC R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-)
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION R,OB3,TB3
+c PARAMETER (R = 189.D0)
+c PARAMETER (OB3 = 0.3333333333333d0)
+c PARAMETER (TB3 = 0.6666666666666d0)
+c
+c DOUBLE PRECISION R1,T
+c DOUBLE PRECISION ALE,ALE2,ALM,AUXIL,AUXIL2,BETA1,CSI,
+c * DOWNLE,DOWNLM,DOWNYE,DOWNYM,
+c * FIE,FIM,QFIE,QFIM,RO2,R1MN1,
+c * UPPLE,UPPLM,UPPYE,UPPYM,YE,YM
+c SAVE
+cC-----------------------------------------------------------------------
+cC R1MN1 IS 1 - R1
+cC T IS ARGUMENT FROM DGQUAD CALLED BY NEW VERSION OF DKOKOI
+c
+c R1MN1 = EXP( T )
+c R1 = 1.D0 - R1MN1
+c RO2 = R1**2
+c AUXIL2 = R / ZATOM**OB3
+c BETA1 = 0.5D0 * VFRAC**2 / (1.D0 - VFRAC)
+c CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC)
+c UPPYE = 5.D0 - RO2 + 4.D0 * BETA1 * (1.D0+RO2)
+c DOWNYE = 2.D0 * (1.D0 + 3.D0 * BETA1) * LOG(3.D0+1.D0/CSI)
+c * - RO2 - 2.D0 * BETA1 * (2.D0-RO2)
+c YE = UPPYE/DOWNYE
+c UPPYM = 4.D0 + RO2 + 3.D0 * BETA1 * (1.D0+RO2)
+c DOWNYM = (1.D0+RO2) * (1.5D0 + 2.D0*BETA1) * LOG(3.D0+CSI)
+c * + 1.D0 - 1.5D0 * RO2
+c YM = UPPYM/DOWNYM
+c AUXIL = 1.D0 / ( EE*VFRAC*(1.D0-RO2))
+c UPPLE = SQRT( (1.D0+CSI)*(1.D0+YE) ) * AUXIL2
+c DOWNLE = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YE)
+c * * AUXIL2 ) * AUXIL
+c ALE2 = 1.D0 + ( (1.5D0 * EBYMU * ZATOM**OB3)**2 ) * (1.D0+CSI)
+c * * (1.D0+YE)
+c ALE = LOG(UPPLE/DOWNLE) - 0.5D0 * LOG(ALE2)
+c UPPLM = (TB3 / EBYMU) * R / ZATOM**TB3
+c DOWNLM = 1.D0 + ( 2.D0 * pmass(10) * SE * (1.D0+CSI) * (1.D0+YM)
+c * * AUXIL2 ) * AUXIL
+c ALM = LOG(UPPLM/DOWNLM)
+c QFIE = (2.D0+RO2) * (1.D0+BETA1) + CSI * (3.D0+RO2)
+c FIE = ( QFIE * LOG(1.D0+1.D0/CSI)
+c * + (1.D0-RO2-BETA1)/(1.D0+CSI) - (3.D0+RO2) ) * ALE
+c QFIM = (1.D0 + 1.5D0*BETA1) * (1.D0+RO2)
+c * - (1.D0 + 2.D0*BETA1) * (1.D0-RO2) / CSI
+c FIM = ( QFIM*LOG(1.D0+CSI) + CSI*(1.D0-RO2-BETA1)/(1.D0+CSI)
+c * + (1.D0 + 2.D0*BETA1) * (1.D0-RO2) ) * ALM
+cC NORMALIZATION IS MADE IN DPRSGM AND IN DKOKOI
+c PPCSLMM = R1MN1 * ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC
+c
+c RETURN
+c END
+c
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION VBSEMM( Y )
+c
+cC-----------------------------------------------------------------------
+cC
+cC FUNCTION TO BE USED FOR INTEGRATION OF MONOPOLE BREMSSTRAHLUNG
+cC ENERGY LOSS.
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+cC THIS FUNCTION IS CALLED FROM DADMUL (BY DBRELM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION ALPHFA,BBS,CBS,RE,OB3,TB3
+c PARAMETER (ALPHFA = 7.297353D-3)
+c PARAMETER (BBS = 184.15D0)
+c PARAMETER (CBS = 1194.0D0)
+c PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM
+c PARAMETER (OB3 = 0.3333333333333d0)
+c PARAMETER (TB3 = 0.6666666666666d0)
+c DOUBLE PRECISION Y(2)
+c DOUBLE PRECISION AA,AASQ,ABS,APAM,A1,A2,C1,C2,CC1,CC2,
+c * D1,D2,DBS,DELTA1,DELTA2,FI1,FI10,FI2,FI20,
+c * QMIN,RA,XX,X1,X1SQ,X2,X2SQ
+cC-----------------------------------------------------------------------
+c
+c XX = Y(2)
+c ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2
+c DBS = (1.D0 - XX)
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c QMIN = XX * PMASSMM**2 / (2.D0 * EE * DBS)
+c A1 = BBS / ( SE * pmass(10) * ZATOM**OB3 )
+c A2 = CBS / ( SE * pmass(10) * ZATOM**TB3 )
+c
+c X1 = A1 * QMIN
+c X1SQ = X1**2
+c X2 = A2 * QMIN
+c X2SQ = X2**2
+c RA = ZATOM**OB3 / 1.9D0
+cC ANDREEV EQ. 2.16B
+c AASQ = 1.D0 + 4.D0 * RA**2
+c AA = SQRT(AASQ)
+c APAM = LOG( (AA+1.D0) / (AA-1.D0) )
+cC ANDREEV EQ. 2.16A
+c DELTA1= LOG(RA) + 0.5D0 * AA * APAM
+c DELTA2= LOG(RA) + 0.25D0 * AA * APAM * (3.D0-AASQ) + 2.D0*RA**2
+c C1 = LOG( ( (PMASSMM*A1)**2 ) / (1.D0+X1SQ) )
+c C2 = LOG( ( (PMASSMM*A2)**2 ) / (1.D0+X2SQ) )
+c CC1 = ATAN(1.D0/X1)
+c CC2 = ATAN(1.D0/X2)
+cC ANDREEV EQ. 2.9A
+c FI10 = ( 0.5D0*(1.D0+C2) - X2*CC2 ) / ZATOM
+c * + 0.5D0*(1.D0+C1) - X1*CC1
+c FI1 = FI10 - DELTA1
+c
+c D1 = 0.75D0 * LOG( X1SQ / (1.D0+X1SQ) )
+c D2 = 0.75D0 * LOG( X2SQ / (1.D0+X2SQ) )
+cC ANDREEV EQ. 2.9B
+c FI20 = ( 0.5D0*(TB3+C2) + 2.D0*X2SQ * (1.D0-X2*CC2+D2) ) / ZATOM
+c * + 0.5D0*(TB3+C1) + 2.D0*X1SQ * (1.D0-X1*CC1+D1)
+cC ANDREEV EQ. 2.6
+c FI2 = FI20 - DELTA2
+cC FOR ENERGY LOSSES
+c VBSEMM = ALPHFA * ABS * ( (1.D0+DBS**2)*FI1 - TB3*DBS*FI2 )
+cc print *,'la',XX,RE,VBSEMM,ALPHFA,ABS,DBS,FI1,TB3,DBS,FI2
+c
+c IF ( VBSEMM .LE. 0.D0 ) VBSEMM = 0.D0
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION VBSSMM( Y )
+c
+cC-----------------------------------------------------------------------
+cC
+cC FUNCTION TO BE USED FOR INTEGRATION OF MONOPOLE BREMSSTRAHLUNG
+cC CROSS SECTION.
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+cC THIS FUNCTION IS CALLED FROM DADMUL (BY DBRSGM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION ALPHFA,BBS,CBS,RE,OB3,TB3
+c PARAMETER (ALPHFA = 7.297353D-3)
+c PARAMETER (BBS = 184.15D0)
+c PARAMETER (CBS = 1194.0D0)
+c PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM
+c PARAMETER (OB3 = 0.3333333333333d0)
+c PARAMETER (TB3 = 0.6666666666666d0)
+c DOUBLE PRECISION Y(2)
+c DOUBLE PRECISION AA,AASQ,ABS,APAM,A1,A2,C1,C2,CC1,CC2,
+c * D1,D2,DBS,DELTA1,DELTA2,FI1,FI10,FI2,FI20,
+c * QMIN,RA,XX,X1,X1SQ,X2,X2SQ
+cC-----------------------------------------------------------------------
+c
+c XX = Y(2)
+c ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2
+c DBS = (1.D0 - XX)
+cC EE IS THE TOTAL ENERGY OF INCOMING MUON
+c QMIN = XX * PMASSMM**2 / (2.D0 * EE * DBS)
+c A1 = BBS / ( SE * pmass(10) * ZATOM**OB3 )
+c A2 = CBS / ( SE * pmass(10) * ZATOM**TB3 )
+c
+c X1 = A1 * QMIN
+c X1SQ = X1**2
+c X2 = A2 * QMIN
+c X2SQ = X2**2
+c RA = ZATOM**OB3 / 1.9D0
+cC ANDREEV EQ. 2.16B
+c AASQ = 1.D0 + 4.D0 * RA**2
+c AA = SQRT(AASQ)
+c APAM = LOG( (AA+1.D0) / (AA-1.D0) )
+cC ANDREEV EQ. 2.16A
+c DELTA1= LOG(RA) + 0.5D0 * AA * APAM
+c DELTA2= LOG(RA) + 0.25D0 * AA * APAM * (3.D0-AASQ) + 2.D0*RA**2
+c C1 = LOG( ( (PMASSMM*A1)**2 ) / (1.D0+X1SQ) )
+c C2 = LOG( ( (PMASSMM*A2)**2 ) / (1.D0+X2SQ) )
+c CC1 = ATAN(1.D0/X1)
+c CC2 = ATAN(1.D0/X2)
+cC ANDREEV EQ. 2.9A
+c FI10 = ( 0.5D0*(1.D0+C2) - X2*CC2 ) / ZATOM
+c * + 0.5D0*(1.D0+C1) - X1*CC1
+c FI1 = FI10 - DELTA1
+c
+c D1 = 0.75D0 * LOG( X1SQ / (1.D0+X1SQ) )
+c D2 = 0.75D0 * LOG( X2SQ / (1.D0+X2SQ) )
+cC ANDREEV EQ. 2.9B
+c FI20 = ( 0.5D0*(TB3+C2) + 2.D0*X2SQ * (1.D0-X2*CC2+D2) ) / ZATOM
+c * + 0.5D0*(TB3+C1) + 2.D0*X1SQ * (1.D0-X1*CC1+D1)
+cC ANDREEV EQ. 2.6
+c FI2 = FI20 - DELTA2
+cC FOR ENERGY LOSSES
+c VBSSMM = ALPHFA * ABS * ( (1.D0+DBS**2)*FI1 - TB3*DBS*FI2 )
+cC FOR CROSS-SECTIONS
+c VBSSMM = VBSSMM / XX
+c
+c IF ( VBSSMM .LE. 0.D0 ) VBSSMM = 0.D0
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION VPHLMM(Y)
+c
+cC-----------------------------------------------------------------------
+cC
+cC FUNCTION TO BE USED FOR INTEGRATION OF MONOPOLE NUCLEAR INTERACTION
+cC ENERGY LOSS.
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC YU.M. ANDREEV AND E.V. BUGAEV, PHYS. REV. D55 (1997) 1233
+cC THIS FUNCTION IS CALLED FROM DADMUL (BY DNIELM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI!,ELE1,ELE2
+c PARAMETER (ALPHFA = 7.297353D-3)
+cC BEZRUKOV'S M1**2 AND M2**2
+c PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+c PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+c PARAMETER (APH = 0.00282D0)
+cC BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+c PARAMETER (CSI = 0.25D0)
+cc PARAMETER (ELE1 = 0.0808D0)
+cc PARAMETER (ELE2 = -0.4525D0)
+c DOUBLE PRECISION Y(2),OB3
+c PARAMETER (OB3 = 0.3333333333333d0)
+c DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH,
+c * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ
+cC-----------------------------------------------------------------------
+c
+c XX = Y(2)
+cC CALCULATE BEZRUKOV'S T
+c TTT = PMASSMM**2 * XX**2 / (1.D0 - XX)
+cC SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUO
+c SS = 2.D0 * pmass(7) * XX * EE
+cC CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+cC SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+c* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+cC SEE: PARTCIlE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+c SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+cC SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+c ZZZ = SIGN * APH * AATOM**OB3
+cC CALCULATE BOTTAI'S H(V)
+c HHH = 1.D0 - 2.D0/XX + 2.D0/XX**2
+cC CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+c GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+cC FACTOR BEFORE LARGE BRACKET
+c BPH = AATOM * XX**2 * SIGN * (ALPHFA/(8.D0*PI)) * 1.D-30
+cC AUXILIARY QUANTITIES
+c CPH = 1.D0 + AM21/TTT
+c DPH = 1.D0 + AM22/TTT
+c EPH = 2.D0 * pmass(9)**2 / TTT
+c FPH = AM21 / (AM21 + TTT)
+cC FIRST PART WITHIN LARGE BRACKET
+c VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+cC SECOND PART WITHIN LARGE BRACKET
+c VPH2 = (2.D0 * CSI * PMASSMM**2/TTT)
+c * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) )
+cC FOR ENERGY LOSSES
+c VPHLMM = BPH * (VPH1+VPH2)
+c
+c IF ( VPHLMM .LE. 0.D0 ) VPHLMM = 0.D0
+c
+c RETURN
+c END
+c
+cC=======================================================================
+c
+c DOUBLE PRECISION FUNCTION VPHMM( Y )
+c
+cC-----------------------------------------------------------------------
+cC
+cC FUNCTION TO BE USED FOR INTEGRATION OF MONOPOLE NUCLEAR INTERACTION
+cC CROSS SECTION.
+cC SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
+cC L.B. BEZRUKOV AND E.V. BUGAEV, SOV.J.NUCL.PHYS. 33 (1981) 635
+cC THIS FUNCTION IS CALLED FROM DADMUL (BY DNUSGM).
+cC ARGUMENTS: (TO BE USED BY DADMUL)
+cC N = DIMENSION
+cC Y = DUMMY ARRAY OF DIMENSION N
+cc orig : d. heck <heck@ik3.fzk.de> jun. 25, 2003
+cc Adaptation for Conex by T. Pierog <pierog@ik.fzk.de> mar. 15, 2005
+cC-----------------------------------------------------------------------
+c
+c IMPLICIT NONE
+c#include "conex.h"
+c*KEEP,MUPART.
+c COMMON /CRMMPART/AMUPAR,BCUT,CMUON,AATOM,CONSTKINE,EBYMU,EE,SE,
+c * VFRAC,VMAX,VMIN,ZATOM,FMUBRM,FMUNUC,FMUORG
+c DOUBLE PRECISION AMUPAR(0:16),BCUT,CMUON(11),AATOM,CONSTKINE,
+c * EBYMU,EE,SE,VFRAC,VMAX,VMIN,ZATOM
+c LOGICAL FMUBRM,FMUNUC,FMUORG
+c common /CRMMMASS/pmassmm
+c double precision pmassmm
+c*KEND.
+c
+c DOUBLE PRECISION ALPHFA,AM21,AM22,APH,CSI!,ELE1,ELE2
+c PARAMETER (ALPHFA = 7.297353D-3)
+cC BEZRUKOV'S M1**2 AND M2**2
+c PARAMETER (AM21 = 0.54D0) ! SQUARE MASS IN GEV**2
+c PARAMETER (AM22 = 1.80D0) ! SQUARE MASS IN GEV**2
+c PARAMETER (APH = 0.00282D0)
+cC BEZRUKOV'S XI (POLARISATION DEPENDENCE) = CSI
+c PARAMETER (CSI = 0.25D0)
+cc PARAMETER (ELE1 = 0.0808D0)
+cc PARAMETER (ELE2 = -0.4525D0)
+c DOUBLE PRECISION Y(2),OB3
+c PARAMETER (OB3 = 0.3333333333333d0)
+c DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH,
+c * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ
+cC-----------------------------------------------------------------------
+c
+c XX = Y(2)
+cC CALCULATE BEZRUKOV'S T
+c TTT = PMASSMM**2 * XX**2 / (1.D0 - XX)
+cC SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUO
+c SS = 2.D0 * pmass(7) * XX * EE
+cC CROSS-SECTION OF VIRTUAL GAMMA WITH NUCLEON (IN MICROBARNS)
+cC SEE: A. DONNACHIE + P.V. LANDSHOFF, PHYS.LETT. B296 (1992) 227
+c* SIGN = 67.7D0 * SS**ELE1 + 129.D0 * SS**ELE2
+cC SEE: PARTICLE DATA GROUP, EUROPHYS. J. C15 (2000) 231
+c SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0)
+cC SCALE THE CROSS-SECTION WITH ATOMIC NUMBER
+c ZZZ = SIGN * APH * AATOM**OB3
+cC CALCULATE BOTTAI'S H(V)
+c HHH = 1.D0 - 2.D0/XX + 2.D0/XX**2
+cC CALCULATE BEZRUKOV'S NUCLEAR SHADOWING G(X)
+c GG = ( 0.5D0 + ((1.D0+ZZZ)*EXP(-ZZZ)-1.D0)/ZZZ**2 ) * 9.D0/ZZZ
+cC FACTOR BEFORE LARGE BRACKET
+c BPH = AATOM * XX**2 * SIGN * (ALPHFA/(8.D0*PI)) * 1.D-30
+cC AUXILIARY QUANTITIES
+c CPH = 1.D0 + AM21/TTT
+c DPH = 1.D0 + AM22/TTT
+c EPH = 2.D0 * PMASSMM**2 / TTT
+c FPH = AM21 / (AM21 + TTT)
+cC FIRST PART WITHIN LARGE BRACKET
+c VPH1 = HHH * LOG(DPH) - EPH + GG * (HHH*LOG(CPH) - HHH*FPH - EPH)
+cC SECOND PART WITHIN LARGE BRACKET
+c VPH2 = (2.D0 * CSI * PMASSMM**2/TTT)
+c * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) )
+cC FINAL CROSS-SECTION
+c VPHMM = BPH * (VPH1+VPH2) / XX
+c IF ( VPHMM .LT. 0.D0 ) VPHMM = 0.D0
+c
+c RETURN
+c END
+c
+c Analysis and ploting routines
+c (created by K. Werner; updated by T. Pierog and V. Chernatkin)
+c Last modifications 28.06.2017 add DPMJETIII by T.Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c begin analysis part
+#ifdef __ANALYSIS__
+c-------------------------------------------------------------------------
+ subroutine xHadronCascade(k1,k2)
+c-------------------------------------------------------------------------
+c makes multi-column histograms for hadronic cascade
+c In hybrid mode, we add particles from Shower (but only for depth profile)
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ integer kkk(3)
+#if __MC3D__ || __CXLATCE__
+ integer ii(maxjr)
+ character*6 cr(maxjr)
+ character*3 nyx
+ character*11 tx(maxjr,maxjz),ty(maxjr,maxjz,maxin)
+#endif
+ character*4 ch(3)
+ character*11 ptyp(maxin)
+ dimension spart(maxin),spartr(3,maxin),spmc(3,maxin)
+ ptyp(1)=' nucleons '
+ ptyp(2)=' [p]^+/-! '
+ if(mode.lt.7)then !plot pi0 if no EM shower
+ ptyp(3)=' d[p]^0!/dZ'
+ else
+ ptyp(3)=' d[g]/dZ '
+ endif
+ ptyp(4)=' K^+/-! '
+ ptyp(5)=' K?l! '
+ ptyp(6)=' K?s! '
+ ptyp(7)=' [m]^+/-! '
+ c=c2bas*c2bas
+ dle=log10(c)
+ dlez=delzsh
+ nbin=max(1,musZ/numiZ)
+
+ imax=musE !limit in energy for spectra from CE
+ nmax=musE
+ if(mode.eq.5.or.mode.eq.8)then !Hybrid mode : plot shower particles too
+c normalization of spec is already done if leptons are present
+ call NormalizeTables(1.d0/dble(max(1,nshower)))
+ cMC=(eamax(2)/eamin(2))**(1.d0/dble(numie))
+ dleMC=log10(cMC)
+ dlezMC=delza
+ nmax=1+int(log10(ehcut*c2bas/exmin)*decade)
+ imax=int(log10(eprima/enymin*c2bas)*decade)+1
+ endif
+
+ write(ifho,'(a)')'!---------------yieldz ------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name hyi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod log'
+ write(ifho,*) 'xrange ',zamin,zamax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)') '- txt "xaxis depth Z (g/cm^2!)"'
+ write(ifho,'(a)') '+ txt "yaxis number of hadrons"'
+ do ip=k1,k2
+ write(ifho,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*) 'array ',-1-(k2-k1+1)-1
+ do kk=0,(musz-1)/nbin
+ k=1+kk*nbin
+ z=zshmin+dlez*dble(k-1)
+ stot=0d0
+ do j=k1,k2
+ spart(j)=0d0
+ do i=1,nmax
+ spart(j) = spart(j) + hadspec(j,i,k)
+ end do
+ if(enymin.gt.exmin)
+ & spart(j) = (spart(j) - 0.5d0*hadspec(j,1,k))!cut off of spectra below enymin
+ if(mode.eq.5.or.mode.eq.8)then
+ if(z.ge.zamax)then !interpolation between CE bins and MC bins
+ iz=numiZ-1
+ appp1=0.d0
+ appp2=1.d0
+ else
+ iz=1+int((z-zamin)/dlezMC*1.0000001d0) !to avoid numerical problems
+ zMC=zamin+dlezMC*dble(iz-1)
+ appp2=max(0.d0,(z-zMC)/dlezMC)
+ appp1=1.d0-appp2
+ endif
+ if(appp1.lt.0.d0)then
+ write(*,*)'xan had appp Z',z,iz,zMC,zMC+delza,appp1,appp2
+ appp1=max(0.d0,1.d0-appp2)
+ endif
+ ip=j+3
+ spart(j)=spart(j)+appp1*yieldz(ip,iz)+appp2*yieldz(ip,iz+1)
+ endif
+ if(j.ne.3.and.j.ne.7)stot=stot+spart(j)
+ end do
+ write(ifho,'(e13.5,90e11.3)')z,stot
+ & ,(spart(ip),ip=k1,k2)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,k2-k1+2
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot hyi+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot hyi+',ip
+ enddo
+ write(ifho,'(a)')' '
+ do ip=1,k2-k1+2
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot -ymod lin hyi+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot -ymod lin hyi+',ip
+ enddo
+ write(ifho,'(a)')' '
+
+c Try to get time distribution from CE : simple approximation :
+c all particle of type ip as the same beta=sqrt(1-mass/Eprima)
+
+ if(ctime.gt.1.d0)then
+
+ write(ifho,'(a)')'zone 1 3 1'
+ do ip=1,4
+ if(ip.eq.3)goto 100
+ if(ip.eq.1)then
+ beta=sqrt((1.d0-pmass(7)/Eprima)*(1.d0+pmass(7)/Eprima))*cxlight
+ else
+ beta=sqrt((1.d0-pmass(ip)/Eprima)*(1.d0+pmass(ip)/Eprima))*cxlight
+ endif
+ write(ifho,'(a)')'!-------------time yields ------------'
+ write(ifho,'(a,i1,a)') 'openhisto name ht',ip,'i'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,*) 'xrange ',-tamax,-tamin
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)') '- txt "xaxis time -t (ns)"'
+ write(ifho,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*) 'array ',-2
+ do kk=0,(musz-1)/nbin
+ k=1+kk*nbin
+ z=zshmin+dlez*(k-1)
+ t=-distz(k)/beta
+ if(t.ge.tamax)goto 10
+ spart(ip)=0d0
+ do i=1,nmax
+ spart(ip) = spart(ip) + hadspec(ip,i,k)
+ end do
+ if(enymin.gt.exmin)
+ & spart(ip) = (spart(j) - 0.5d0*hadspec(ip,1,k))!cut off of spectra below enymin
+ if(mode.eq.5.or.mode.eq.8)then
+ if(t.ge.tamax)then !interpolation between CE bins and MC bins
+ it=numiZ-1
+ appp1=0.d0
+ appp2=1.d0
+ else
+ it=1-int(log(t/tamin)/log(ctime)*1.0000001d0)
+ tMC=tamin*ctime**(1-it)
+ appp2=max(0.d0,(t-tMC)/(tMC*(1.d0/ctime-1.d0)))
+ appp1=1.d0-appp2
+ endif
+ if(appp1.lt.0.d0)then
+ write(*,*)'xan had appp t',t,it,tMC,tMC/ctime,appp1,appp2
+ appp1=max(0.d0,1.d0-appp2)
+ endif
+ j=ip+3
+ spart(ip)=spart(ip)+appp1*yiex(j,it)+appp2*yiex(j,it+1)
+ endif
+ write(ifho,'(e13.5,90e16.8)')-t,spart(ip)
+ 10 end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a,i1,a)') ' plot ht',ip,'i+1'
+ write(ifho,'(a)')' '
+
+ 100 enddo
+
+ endif
+
+ write(ifho,'(a)')'zone 3 3 1'
+ write(ifho,'(a)')'!--------------spectra----------------------'
+ do m=1,3
+ kkk(m)=min(kfirsth+(m-1)*modkh,maximZ)
+ z=zshmin+delzsh*(kkk(m)-1)
+ write(ch(m),'(i4)')nint(z)
+ enddo
+ em=enymin*c**(imax-1)
+ write(ifho,'(a)') 'openhisto name hsp'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',enymin,em
+ write(ifho,'(a)') 'yrange 1e-6 auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)"'
+ do ip=k1,k2
+ write(ifho,'(a)')'+ txt "yaxis '//ptyp(ip)//' (z='//ch(1)//')"'
+ write(ifho,'(a)')'+ txt "yaxis '//ptyp(ip)//' (z='//ch(2)//')"'
+ write(ifho,'(a)')'+ txt "yaxis '//ptyp(ip)//' (z='//ch(3)//')"'
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-3*(k2-k1+1)
+ do ip=k1,k2
+ do m=1,3
+ spartr(m,ip)=0d0
+ enddo
+ enddo
+ do i=1,imax
+ d=1.d0/dle
+ energy=enymin*c**(i-1)
+ if(abs(enymin-exmin).lt.0.001d0.and.i.eq.1)d=2.d0*d !first bin is half size because of the cutoff
+ if(mode.eq.5.or.mode.eq.8)then !MC part
+ if(energy.ge.eamax(2))then !interpolation between CE bins and MC bins
+ ie=numiE
+ appp1=0.d0
+ appp2=energy/eamax(2)
+ else
+ ie=max(1,min(int(log(energy/eamin(2))
+ & /log(cMC)+1.00001d0),numiE))
+ eMC=eamin(2)*cMC**(ie-1)
+ appp1=max(0.d0,(eMC*cMC-energy)/(eMC*cMC-eMC))
+ appp2=1.d0-appp1
+ endif
+ if(appp2.lt.-1.d-10)then
+ write(*,*)'xan had appp',energy,ie,eMC,eMC*cMC,appp1,appp2
+ appp2=max(0.d0,1.d0-appp1)
+ endif
+ d1=appp1/dleMC
+ d2=appp2/dleMC
+ if(ie.eq.1)d1=2.d0*d1 !first bin is half size because of the cutoff
+ do ip=k1,k2
+ d3=d
+ do m=1,3
+c spmc(m,ip)=hadspec(ip,i,kkk(m))*d3
+ if(i.le.nmax)then !CE only below ehcut
+ spmc(m,ip)=spec(0,ip+3,ie,m)*d1+spec(0,ip+3,ie+1,m)*d2
+ & +hadspec(ip,i,kkk(m))*d3
+ spartr(m,ip)=spartr(m,ip)+spec(0,ip+3,ie,m)*appp1
+ & +hadspec(ip,i,kkk(m))+spec(0,ip+3,ie+1,m)*appp2
+ else
+ spmc(m,ip)=spec(0,ip+3,ie,m)*d1+spec(0,ip+3,ie+1,m)*d2
+ spartr(m,ip)=spartr(m,ip)+spec(0,ip+3,ie,m)*appp1
+ & +spec(0,ip+3,ie+1,m)*appp2
+ endif
+ enddo
+ enddo
+ else !no MC
+ do ip=k1,k2
+ d3=d
+ do m=1,3
+ spmc(m,ip)=hadspec(ip,i,kkk(m))*d3
+ enddo
+ enddo
+ endif
+ write(ifho,'(90e11.3)')energy
+ &,((spmc(m,ip),m=1,3),ip=k1,k2)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,3*(k2-k1+1)
+ if(ip.le.9)write(ifho,'(a,i1)') ' plot hsp+',ip
+ if(ip.gt.9)write(ifho,'(a,i2)') ' plot hsp+',ip
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+
+ write(ifho,'(a)')'!--------------sin(theta)----------------------'
+
+ do jr=1,maxjr
+ ie=iefirst+(jr-1)*moden
+ eee= eamin(2)*(eamax(2)/eamin(2))**(dble(ie)/dble(numie))
+ ii(jr)=min(int(1.d0+log10(eee/enymin)*decade),iemax)
+ write(cr(jr),'(f6.1)')eee
+ enddo
+
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name ls2th'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod lin'
+ write(ifho,'(a,2e11.3)') 'xrange ',xamin(5),xamax(5)
+ write(ifho,'(a)') 'yrange 1e-5 auto '
+ write(ifho,'(a)')'- txt "xaxis log10(sin^2!([q]))"'
+ do j=k1,k2
+ do jj=1,3
+ do jr=1,maxjr
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(j)//' (E='//cr(jr)//',z='//ch(jj)//')"'
+ enddo
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-3*(k2-k1+1)*maxjr
+
+ frac1=1.d0
+ frac2=0.5d0
+ do ix=1,numix(5)
+
+ xx= xamin(5)+(xamax(5)-xamin(5))
+ & *((dble(ix)-0.5d0)/dble(numix(5)))
+
+ write(ifho,'(100e16.6)')xx
+ &,(((fsin2th(xx,ptspec(1,ip,ii(m),kkk(k))
+ & ,ptspec(2,ip,ii(m),kkk(k)),frac1)
+ & ,m=1,maxjr),k=1,3),ip=k1,min(6,k2))
+ if(k2.eq.7)write(ifho,'(100e16.6)')
+ &((fsin2th(xx,ptspec(1,7,ii(m),kkk(k))
+ &,ptspec(2,7,ii(m),kkk(k)),frac2),m=1,maxjr),k=1,3)
+ end do
+
+
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,3*(k2-k1+1)*maxjr
+ if(ip.le.9)then
+ write(ifho,'(a,i1,$)') ' plot ls2th+',ip
+ else
+ if(ip.le.99) then
+ write(ifho,'(a,i2,$)') ' plot ls2th+',ip
+ else
+ if(ip.le.999)then
+ write(ifho,'(a,i3,$)') ' plot ls2th+',ip
+ endif
+ endif
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+
+ if(mode.eq.5.or.mode.eq.8)then !Hybrid mode : plot LDF if low energy MC
+ anorm=dble(max(1,nshower))
+ a=1d-9
+ ptyp(4)=' nucleons '
+ ptyp(5)=' [p]^+/-! '
+ ptyp(6)=' d[p]^0!/dZ'
+ ptyp(7)=' K^+/-! '
+ ptyp(8)=' K?l! '
+ ptyp(9)=' K?s! '
+ ptyp(10)=' [m]^+/-! '
+ k1r=k1+3
+ k2r=k2+3
+ write(ifho,'(a)')'!--------------yieldr----------------------'
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ write(ch(jz),'(i4)')nint(zi)
+ enddo
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name xyr'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',ramin,ramax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis R (m) "'
+ do ip=k1r,k2r
+ do jj=1,3 !radial density normalized
+ write(ifho,'(a)')
+ *'++ txt "yaxis '//ptyp(ip)//'?norm! (z='//ch(jj)//')"'
+ enddo
+ enddo
+ do ip=k1r,k2r !radial density
+ do jj=1,3
+ write(ifho,'(a)')'++ txt "yaxis '//ptyp(ip)//' (z='//ch(jj)//')"'
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-12*(k2r-k1r+1)
+ do ir=1,numir
+ rr= ramin*(ramax/ramin)**((dble(ir)-0.5d0)/dble(numir))
+ ra= (ramin*(ramax/ramin)**((dble(ir)-1.d0)/dble(numir)))**2.d0
+ rb= (ramin*(ramax/ramin)**((dble(ir)-0.d0)/dble(numir)))**2.d0
+ d=(rb-ra)*pi
+ write(ifho,'(900e11.3)')rr
+ & ,((abs(yieldr(ip,jz,ir))/d/max(a,spartr(jz,ip-3))
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d/max(a,spartr(jz,ip-3))
+ & ,jz=1,3),ip=k1r,k2r),((abs(yieldr(ip,jz,ir))/d
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d,jz=1,3),ip=k1r,k2r)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,6*(k2r-k1r+1)
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot xyr+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot xyr+',ip
+ enddo
+ write(ifho,'(a)')' '
+
+c MC time and angular distributions
+
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ do jr=1,3
+ ir=irfirst+(jr-1)*modr
+ ri= ramin*(ramax/ramin)**(dble(ir)/dble(numir))
+ tx(jr,jz)(5:5)=','
+ write(tx(jr,jz)(1:4),'(i4)')nint(zi)
+ write(tx(jr,jz)(6:11),'(f6.1)')ri
+ ie=iefirst+(jr-1)*moden
+ k=2
+ do ip=k1r,k2r
+ ei=eamin(k)*(eamax(k)/eamin(k))**(dble(ie)/dble(numie))
+ ty(jr,jz,ip)(5:5)=','
+ write(ty(jr,jz,ip)(1:4),'(i4)')nint(zi)
+ write(ty(jr,jz,ip)(6:11),'(f6.1)')ei
+ enddo
+ enddo
+ enddo
+
+ do iyx=1,maxiex
+
+ write(nyx,'(a,i1)')'xh',iyx
+ write(ifho,'(3a)')'!-------------- ',nyx,' --------------------'
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name '//nyx
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',xamin(iyx),xamax(iyx)
+ write(ifho,'(a)') 'yrange auto auto '
+ if(iyx.eq.1)then
+ write(ifho,'(a)')'- txt "xaxis cos([f])"'
+ elseif(iyx.eq.2)then
+ write(ifho,'(a)')'- txt "xaxis sin^2!([q])"'
+ elseif(iyx.eq.3)then
+ write(ifho,'(a)')'- txt "xaxis t (ns)"'
+ elseif(iyx.eq.4)then
+ write(ifho,'(a)')'- txt "xaxis [D][f]"'
+ elseif(iyx.eq.5)then
+ write(ifho,'(a)')'- txt "xaxis log?10!(sin^2!([q])"'
+ endif
+ do ip=k1r,k2r
+ do jz=1,maxjz
+ do jr=1,maxjr
+ if(iyx.eq.5)then
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//ty(jr,jz,ip)//')"'
+ else
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//tx(jr,jz)//')"'
+ endif
+ enddo
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-maxjr*maxjz*(k2r-k1r+1)
+ d=(xamax(iyx)-xamin(iyx))/numix(iyx)
+ do ix=1,numix(iyx)
+ xx= xamin(iyx)+(xamax(iyx)-xamin(iyx))
+ & *((dble(ix)-0.5d0)/dble(numix(iyx)))
+ if(iyx.eq.5)then !log10(sin2(theta)) is normalized
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,je,ix)/d/max(1d-9,speca(ip,jz,je))
+ & ,je=1,maxjr),jz=1,maxjz),ip=k1r,k2r)
+ else
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,jr,ix)/d,jr=1,maxjr),jz=1,maxjz),ip=k1r,k2r)
+ endif
+ end do
+ write(ifho,'(a/a)')' endarray','closehisto'
+ do ip=1,maxjr*maxjz*(k2r-k1r+1)
+ if(ip.le.9)write(ifho,'(a,a3,a1,i1,$)') ' plot ',nyx,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,a3,a1,i2,$)')
+ & ' plot ',nyx,'+',ip
+ if(ip.gt.99)write(ifho,'(a,a3,a1,i3,$)') ' plot ',nyx,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.maxjr*maxjz*(k2r-k1r+1))
+ & write(ifho,*)' '
+ enddo
+
+ enddo
+
+ endif
+
+
+#endif
+
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine xElectronPhotonCascade
+c-------------------------------------------------------------------------
+c makes multi-column histograms for electron and photon numbers
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ parameter(ndep=3)
+ integer l(ndep)
+ character*4 ch(ndep)
+ dimension spmc(ndep,5),spartr(ndep,5)
+#if __MC3D__ || __CXLATCE__
+ character*11 ptyp(3)
+ integer ii(maxjr)
+ character*6 cr(maxjr)
+ character*3 nyx
+ character*11 tx(maxjr,maxjz),ty(maxjr,maxjz,maxin)
+#endif
+#ifdef __CXDEBUG__
+ dimension emoy(3),sum(3)
+#endif
+
+ dle=log10(Cem)
+ nbin=max(1,maxZ/numiZ)
+ imax=maxE !limit in energy for spectra from CE
+ if(mode.eq.3.or.mode.eq.8)then !Hybrid mode : plot shower particles too
+ if(mode.eq.3)call NormalizeTables(1.d0/dble(max(1,nshower)))
+ cMC=(eamax(1)/eamin(1))**(1.d0/dble(numie))
+ dleMC=log10(cMC)
+ dlezMC=delza
+c number of point per decade is fixed to 10 for em (see InitializeEphCas)
+ imax=int(log10(eprima/Eo*c2em)*emdecade)+1
+ endif
+
+
+ write(ifho,'(a)')'!---------------deth yields-----------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name yi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod lin'
+ write(ifho,*) 'xrange ',zamin,zamax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ write(ifho,'(a)') '+ txt "yaxis number of photons"'
+ write(ifho,'(a)') '+ txt "yaxis number of e^+/-!"'
+ write(ifho,'(a)') '+ txt "yaxis number of electrons"'
+ write(ifho,'(a)') '+ txt "yaxis number of positrons"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,'(a)') 'array -5'
+ do kk=0,(maxZ-1)/nbin
+ k=1+kk*nbin
+ sph=0d0
+ sel=0d0
+ spo=0d0
+ do i=minE,maxE
+ sph = sph + agm(0,i,k)
+ sel = sel + aem(0,i,k)
+ spo = spo + apm(0,i,k)
+ end do
+ if(mode.eq.3.or.mode.eq.8)then
+ z=zzEM(k)
+ if(z.ge.zamax)then !interpolation between CE bins and MC bins
+ iz=numiZ-1
+ appp1=0.d0
+ appp2=1.d0
+ else
+ iz=1+int((z-zamin)/dlezMC*1.0000001d0)
+ zMC=zamin+dlezMC*(iz-1)
+ appp2=max(0.d0,(z-zMC)/dlezMC)
+ appp1=1.d0-appp2
+ endif
+ if(appp1.lt.0.d0)then
+ write(*,*)'xan em appp Z',z,iz,zMC,zMC+delza,appp1,appp2
+ appp1=max(0.d0,1.d0-appp2)
+ endif
+ sph=sph+appp1*yieldz(1,iz)+appp2*yieldz(1,iz+1)
+ sel=sel+appp1*yieldz(2,iz)+appp2*yieldz(2,iz+1)
+ spo=spo+appp1*yieldz(3,iz)+appp2*yieldz(3,iz+1)
+ endif
+ if(minE.ne.1)then !if cut off not at minimum energy
+ sph=sph-agm(0,1,k)/2.d0 !count only half the first bin
+ sel=sel-aem(0,1,k)/2.d0
+ spo=spo-apm(0,1,k)/2.d0
+ else
+ sel=sel-aem(0,1,k)/2.d0
+ spo=spo-apm(0,1,k)/2.d0
+ endif
+ write(ifho,'(5e11.3)')zzEM(k),sph,sel+spo,sel,spo
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot yi+1'
+ write(ifho,'(a)') 'plot yi+2'
+ write(ifho,'(a)') 'plot yi+3'
+ write(ifho,'(a)') 'plot yi+4'
+
+
+c Try to get time distribution from CE : simple approximation :
+c all particle of type ip as the same beta=sqrt(1-mass/Eprima)
+ if(ctime.gt.1.d0)then
+
+ beta=sqrt((1.d0-amc2/Eprima)*(1.d0+amc2/Eprima))*cxlight
+ write(ifho,'(a)')'!---------------time yield gamma------------'
+ write(ifho,'(a)') 'zone 2 3 1 openhisto name tgi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,*) 'xrange ',-tamax,-tamin
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)') '- txt "xaxis -t (ns)"'
+ write(ifho,'(a)') '+ txt "yaxis number of photons"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,'(a)') 'array -2'
+ do kk=0,(maxZ-1)/nbin
+ k=1+kk*nbin
+ tg=-distzem(k)/cxlight
+ if(tg.ge.tamax)goto 5
+ sph=0d0
+ do i=minE,maxE
+ sph = sph + agm(0,i,k)
+ end do
+ if(mode.eq.3.or.mode.eq.8)then
+ if(tg.ge.tamax)then !interpolation between CE bins and MC bins
+ it=numiZ-1
+ appp1=0.d0
+ appp2=1.d0
+ else
+ it=1-int(log(tg/tamin)/log(ctime)*1.00000001d0)
+ tMC=tamin*ctime**(1-it)
+ appp2=max(0.d0,(tg-tMC)/(tMC*(1.d0/ctime-1.d0)))
+ appp1=1.d0-appp2
+ endif
+ if(appp1.lt.0.d0)then
+ write(*,*)'xan em appp tg',tg,it,tMC,tMC/ctime,appp1,appp2
+ appp1=max(0.d0,1.d0-appp2)
+ endif
+ sph=sph+appp1*yiex(1,it)+appp2*yiex(1,it+1)
+ endif
+ if(minE.ne.1)then !if cut off not at minimum energy
+ sph=sph-agm(0,1,k)/2.d0 !count only half the first bin
+ endif
+ write(ifho,'(3e16.8)')-tg,sph
+ 5 end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot tgi+1'
+
+ write(ifho,'(a)')'!-----------time yields electron------------'
+ write(ifho,'(a)') 'openhisto name tei'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,*) 'xrange ',-tamax,-tamin
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)') '- txt "xaxis -t (ns)"'
+ write(ifho,'(a)') '+ txt "yaxis number of e^+/-!"'
+ write(ifho,'(a)') '+ txt "yaxis number of electrons"'
+ write(ifho,'(a)') '+ txt "yaxis number of positrons"'
+ write(ifho,'(a)') '+ txt "yaxis charge"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,'(a)') 'array -5'
+ do kk=0,(maxZ-1)/nbin
+ k=1+kk*nbin
+ te=-distzem(k)/beta
+ if(te.ge.tamax)goto 10
+ sel=0d0
+ spo=0d0
+ sdq=0d0
+ do i=minE,maxE
+ sel = sel + aem(0,i,k)
+ spo = spo + apm(0,i,k)
+ sdq = sdq + apm(0,i,k) - aem(0,i,k)
+ end do
+ if(mode.eq.3.or.mode.eq.8)then
+ if(te.ge.tamax)then !interpolation between CE bins and MC bins
+ it=numiZ-1
+ appp1=0.d0
+ appp2=1.d0
+ else
+ it=1-int(log(te/tamin)/log(ctime)*1.00000001d0)
+ tMC=tamin*ctime**(1-it)
+ appp2=max(0.d0,(te-tMC)/(tMC*(1.d0/ctime-1.d0)))
+ appp1=1.d0-appp2
+ endif
+ if(appp1.lt.0.d0)then
+ write(*,*)'xan em appp te',te,it,tMC,tMC/ctime,appp1,appp2
+ appp1=max(0.d0,1.d0-appp2)
+ endif
+ sel=sel+appp1*yiex(2,it)+appp2*yiex(2,it+1)
+ spo=spo+appp1*yiex(3,it)+appp2*yiex(3,it+1)
+ sdq=sdq+appp1*yiex(10,it)+appp2*yiex(10,it+1)
+ endif
+c if(minE.ne.1)then !if cut off not at minimum energy
+ sel=sel-aem(0,1,k)/2.d0
+ spo=spo-apm(0,1,k)/2.d0
+ sdq=sdq-(apm(0,1,k)-aem(0,1,k))/2.d0
+c endif
+ write(ifho,'(5e16.8)')-te,sel+spo,sel,spo,sdq
+ 10 end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot tei+1'
+ write(ifho,'(a)') 'plot tei+2'
+ write(ifho,'(a)') 'plot tei+3'
+ write(ifho,'(a)') 'plot tei+4'
+
+ endif
+
+ continue
+ write(ifho,'(a)')'!--------------- energy yields-----------------'
+ do m=1,ndep
+ l(m)=min(maximumZ,kfirst+(m-1)*modk)
+ write(ch(m),'(i4)')nint(zzEM(l(m)))
+ enddo
+
+ write(ifho,'(a)') 'zone 2 4 1 openhisto name ei'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',eeEM(minE),eprima
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*1.d9,'"'
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)"'
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis Num of phot (z='//ch(jj)//')"'
+ write(ifho,'(a)')'+ txt "yaxis Num of lept (z='//ch(jj)//')"'
+ enddo
+ do jj=1,ndep
+ write(ifho,'(a)')'+ txt "yaxis Num of elec (z='//ch(jj)//')"'
+ write(ifho,'(a)')'+ txt "yaxis Num of posi (z='//ch(jj)//')"'
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,'(a,i4)')'array ',-1-4*ndep
+#ifdef __CXDEBUG__
+ do nem=1,3
+ emoy(nem)=0.d0
+ sum(nem)=0.d0
+ enddo
+#endif
+ do ip=1,3
+ do m=1,3
+ spartr(m,ip)=0d0
+ enddo
+ enddo
+ do i=minE,imax
+ energy=max(emin,Eo*Cem**(i-1))
+ d=1.d0/dle
+ if(i.eq.1)d=2.d0*d !first bin is half size because of the cutoff
+ if(mode.eq.3.or.mode.eq.8)then !MC part
+ if(energy.ge.eamax(1))then !interpolation between CE bins and MC bins
+ ie=numiE
+ appp1=0.d0
+ appp2=energy/eamax(1)
+ else
+ ie=min(max(1,int(log(energy/eamin(1))/log(cMC)
+ & +1.000001d0)),numiE)
+ eMC=eamin(1)*cMC**(ie-1)
+ appp1=max(0.d0,(eMC*cMC-energy)/(eMC*cMC-eMC))
+ appp2=1.d0-appp1
+ endif
+ if(appp2.lt.-1.d-10)then
+ write(*,*)'xan em appp',energy,ie,eMC,eMC*cMC,appp1,appp2
+ appp2=max(0.d0,1.d0-appp1)
+ endif
+ d1=appp1/dleMC
+ d2=appp2/dleMC
+ if(ie.eq.1)d1=2.d0*d1 !first bin is half size because of the cutoff
+c#ifdef __MC3D__
+c if(i.eq.lowE)then
+c d2=d1+d2
+c d1=0d0
+c endif
+c#endif
+ do m=1,3
+ if(i.le.maxE)then
+ spmc(m,1)=spec(0,1,ie,m)*d1+spec(0,1,ie+1,m)*d2
+ & +agm(0,i,l(m))*d
+ spmc(m,2)=spec(0,2,ie,m)*d1+spec(0,2,ie+1,m)*d2
+ & +aem(0,i,l(m))*d
+ spmc(m,3)=spec(0,3,ie,m)*d1+spec(0,3,ie+1,m)*d2
+ & +apm(0,i,l(m))*d
+ spartr(m,1)=spartr(m,1)+spec(0,1,ie,m)*appp1
+ & +agm(0,i,l(m))+spec(0,1,ie+1,m)*appp2
+ spartr(m,2)=spartr(m,2)+spec(0,2,ie,m)*appp1
+ & +aem(0,i,l(m))+spec(0,2,ie+1,m)*appp2
+ spartr(m,3)=spartr(m,3)+spec(0,3,ie,m)*appp1
+ & +apm(0,i,l(m))+spec(0,3,ie+1,m)*appp2
+ else
+ spmc(m,1)=spec(0,1,ie,m)*d1+spec(0,1,ie+1,m)*d2
+ spmc(m,2)=spec(0,2,ie,m)*d1+spec(0,2,ie+1,m)*d2
+ spmc(m,3)=spec(0,3,ie,m)*d1+spec(0,3,ie+1,m)*d2
+ spartr(m,1)=spartr(m,1)+spec(0,1,ie,m)*appp1
+ & +spec(0,1,ie+1,m)*appp2
+ spartr(m,2)=spartr(m,2)+spec(0,2,ie,m)*appp1
+ & +spec(0,2,ie+1,m)*appp2
+ spartr(m,3)=spartr(m,3)+spec(0,3,ie,m)*appp1
+ & +spec(0,3,ie+1,m)*appp2
+ endif
+ enddo
+ else !no MC
+ do m=1,3
+ spmc(m,1)=agm(0,i,l(m))*d
+ spmc(m,2)=aem(0,i,l(m))*d
+ spmc(m,3)=apm(0,i,l(m))*d
+ enddo
+ endif
+#ifdef __CXDEBUG__
+ do nem=1,3
+ emoy(nem)=emoy(nem)+energy*(spmc(nem,2)+spmc(nem,3))
+ sum(nem)=sum(nem)+spmc(nem,2)+spmc(nem,3)
+ enddo
+#endif
+ write(ifho,'(25e11.3)')energy
+ &,(spmc(m,1),spmc(m,2)+spmc(m,3),m=1,ndep)
+ &,(spmc(m,2),spmc(m,3),m=1,ndep)
+ end do
+ write(ifho,'(a)') ' endarray'
+#ifdef __CXDEBUG__
+ do nem=1,3
+ if(sum(nem).gt.0.d0)then
+ emoy(nem)=emoy(nem)/sum(nem)
+ else
+ emoy(nem)=0.d0
+ endif
+ enddo
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.9 "Eel1= ',emoy(1),' GeV"'
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.8 "Eel2= ',emoy(2),' GeV"'
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.7 "Eel3= ',emoy(3),' GeV"'
+#endif
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,4*ndep
+ if(ip.le.9)write(ifho,'(a,i1)') ' plot ei+',ip
+ if(ip.gt.9)write(ifho,'(a,i2)') ' plot ei+',ip
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+
+c----------- lateral
+
+ if(mode.eq.3.or.mode.eq.8)then !Hybrid mode : plot LDF if low energy MC
+ anorm=dble(max(1,nshower))
+ a=1d-9
+ ptyp(1)=' [g] '
+ ptyp(2)=' e^-! '
+ ptyp(3)=' e^+! '
+ k1r=1
+ k2r=3
+ write(ifho,'(a)')'!--------------yieldr----------------------'
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ write(ch(jz),'(i4)')nint(zi)
+ enddo
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name xzr'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',ramin,ramax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis R (m) "'
+ do ip=k1r,k2r
+ do jj=1,3 !radial density normalized
+ write(ifho,'(a)')
+ *'++ txt "yaxis '//ptyp(ip)//'?norm! (z='//ch(jj)//')"'
+ enddo
+ enddo
+ do ip=k1r,k2r !radial density
+ do jj=1,3
+ write(ifho,'(a)')'++ txt "yaxis '//ptyp(ip)//' (z='//ch(jj)//')"'
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-12*(k2r-k1r+1)
+ do ir=1,numir
+ rr= ramin*(ramax/ramin)**((dble(ir)-0.5d0)/dble(numir))
+ ra= (ramin*(ramax/ramin)**((dble(ir)-1.d0)/dble(numir)))**2.d0
+ rb= (ramin*(ramax/ramin)**((dble(ir)-0.d0)/dble(numir)))**2.d0
+ d=(rb-ra)*pi
+ write(ifho,'(900e11.3)')rr
+ & ,((abs(yieldr(ip,jz,ir))/d/max(a,spartr(jz,ip))
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d/max(a,spartr(jz,ip))
+ & ,jz=1,3),ip=k1r,k2r),((abs(yieldr(ip,jz,ir))/d
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d,jz=1,3),ip=k1r,k2r)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,6*(k2r-k1r+1)
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot xzr+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot xzr+',ip
+ enddo
+ write(ifho,'(a)')' '
+c MC time and angular distributions
+
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ do jr=1,3
+ ir=irfirst+(jr-1)*modr
+ ri= ramin*(ramax/ramin)**(dble(ir)/dble(numir))
+ tx(jr,jz)(5:5)=','
+ write(tx(jr,jz)(1:4),'(i4)')nint(zi)
+ write(tx(jr,jz)(6:11),'(f6.1)')ri
+ ie=iefirst+(jr-1)*moden
+ k=1
+ do ip=k1r,k2r
+ ei=eamin(k)*(eamax(k)/eamin(k))**(dble(ie)/dble(numie))
+ ty(jr,jz,ip)(5:5)=','
+ write(ty(jr,jz,ip)(1:4),'(i4)')nint(zi)
+ write(ty(jr,jz,ip)(6:11),'(f6.1)')ei
+ enddo
+ enddo
+ enddo
+
+ do iyx=1,maxiex
+
+ write(nyx,'(a,i1)')'xe',iyx
+ write(ifho,'(3a)')'!-------------- ',nyx,' --------------------'
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name '//nyx
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',xamin(iyx),xamax(iyx)
+ write(ifho,'(a)') 'yrange auto auto '
+ if(iyx.eq.1)then
+ write(ifho,'(a)')'- txt "xaxis cos([f])"'
+ elseif(iyx.eq.2)then
+ write(ifho,'(a)')'- txt "xaxis sin^2!([q])"'
+ elseif(iyx.eq.3)then
+ write(ifho,'(a)')'- txt "xaxis t (ns)"'
+ elseif(iyx.eq.4)then
+ write(ifho,'(a)')'- txt "xaxis [D][f]"'
+ elseif(iyx.eq.5)then
+ write(ifho,'(a)')'- txt "xaxis log?10!(sin^2!([q])"'
+ endif
+ do ip=k1r,k2r
+ do jz=1,maxjz
+ do jr=1,maxjr
+ if(iyx.eq.5)then
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//ty(jr,jz,ip)//')"'
+ else
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//tx(jr,jz)//')"'
+ endif
+ enddo
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-maxjr*maxjz*(k2r-k1r+1)
+ d=(xamax(iyx)-xamin(iyx))/numix(iyx)
+ do ix=1,numix(iyx)
+ xx= xamin(iyx)+(xamax(iyx)-xamin(iyx))
+ & *((dble(ix)-0.5d0)/dble(numix(iyx)))
+ if(iyx.eq.5)then !log10(sin2(theta)) is normalized
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,je,ix)/d/max(1d-9,speca(ip,jz,je))
+ & ,je=1,maxjr),jz=1,maxjz),ip=k1r,k2r)
+ else
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,jr,ix)/d,jr=1,maxjr),jz=1,maxjz),ip=k1r,k2r)
+ endif
+ end do
+ write(ifho,'(a/a)')' endarray','closehisto'
+ do ip=1,maxjr*maxjz*(k2r-k1r+1)
+ if(ip.le.9)write(ifho,'(a,a3,a1,i1,$)') ' plot ',nyx,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,a3,a1,i2,$)')
+ & ' plot ',nyx,'+',ip
+ if(ip.gt.99)write(ifho,'(a,a3,a1,i3,$)') ' plot ',nyx,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.maxjr*maxjz*(k2r-k1r+1))
+ & write(ifho,*)' '
+ enddo
+
+ enddo
+
+ endif
+
+
+
+ if(i1DMC.eq.0)then !moments only in 3D
+
+ do m=1,ndep
+ l(m)=min(maximumZ,kfirst+(m-1)*modk)
+ write(ch(m),'(i4)')nint(zzEM(l(m)))
+ enddo
+
+ write(ifho,'(a)')'!--------------spectra----------------------'
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name splt'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',eeEM(minE),eeEM(maxE)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)"'
+ do m=0,maximom
+ do k=1,ndep
+ write(ifho,'(a,i3,a)')'+ txt "yaxis M',m,' phot (z='//ch(k)//')"'
+ enddo
+ enddo
+ do m=0,maximom
+ do k=1,ndep
+ write(ifho,'(a,i3,a)')'+ txt "yaxis M',m,' elec (z='//ch(k)//')"'
+ enddo
+ enddo
+ do m=0,maximom
+ do k=1,ndep
+ write(ifho,'(a,i3,a)')'+ txt "yaxis M',m,' posi (z='//ch(k)//')"'
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-(maximom+1)*ndep*3
+ do i=minE,maxE
+ write(ifho,'(2500e11.3)')eeEM(i)
+ & ,(agm(0,i,l(k))/dle
+ & ,k=1,ndep)
+ & ,((agm(m,i,l(k))/max(1d-9,agm(0,i,l(k))),k=1,ndep),m=1,maximom)
+ & ,(aem(0,i,l(k))/dle
+ & ,k=1,ndep)
+ & ,((aem(m,i,l(k))/max(1d-9,aem(0,i,l(k))),k=1,ndep),m=1,maximom)
+ & ,(apm(0,i,l(k))/dle
+ & ,k=1,ndep)
+ & ,((apm(m,i,l(k))/max(1d-9,apm(0,i,l(k))),k=1,ndep),m=1,maximom)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,(maximom+1)*3*ndep
+ if(ip.le.9)then
+ write(ifho,'(a,i1,$)') ' plot splt+',ip
+ elseif(ip.le.99) then
+ write(ifho,'(a,i2,$)') ' plot splt+',ip
+ elseif(ip.le.999)then
+ write(ifho,'(a,i3,$)') ' plot splt+',ip
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+
+
+
+ write(ifho,'(a)')'!--------------sin(theta)----------------------'
+
+ do je=1,maxjr
+ ie=iefirst+(je-1)*moden
+ eee= eamin(1)*(eamax(1)/eamin(1))**(dble(ie)/dble(numie))
+ ii(je)=min(int(1.d0+log10(eee/Eo)*emdecade),maxE-1)
+ write(cr(je),'(f6.3)')eee
+ enddo
+
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name lsin2t'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod lin'
+ write(ifho,'(a,2e11.3)') 'xrange ',xamin(5),xamax(5)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis log10(sin^2!([q]))"'
+ do jj=1,ndep
+ do jr=1,maxjr
+ write(ifho,'(a,a)')'+ txt "yaxis phot '
+ & ,' (E='//cr(jr)//',z='//ch(jj)//')"'
+ enddo
+ enddo
+ do jj=1,ndep
+ do jr=1,maxjr
+ write(ifho,'(a,a)')'+ txt "yaxis elec '
+ & ,' (E='//cr(jr)//',z='//ch(jj)//')"'
+ enddo
+ enddo
+ do jj=1,ndep
+ do jr=1,maxjr
+ write(ifho,'(a,a)')'+ txt "yaxis posi '
+ & ,' (E='//cr(jr)//',z='//ch(jj)//')"'
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-3*ndep*maxjr
+
+ m1=maxoep+1
+ m2=maxoep+2
+ frac=1.d0
+
+ do ix=1,numix(5)
+
+ xx= xamin(5)+(xamax(5)-xamin(5))
+ & *((dble(ix)-0.5d0)/dble(numix(5)))
+
+ write(ifho,'(100e16.6)')xx
+ &,((fsin2th(xx,agm(m1,ii(m),l(k))
+ &/max(1d-9,agm(0,ii(m),l(k))),agm(m2,ii(m),l(k))
+ &/max(1d-9,agm(0,ii(m),l(k))),frac),m=1,maxjr),k=1,ndep)
+ &,((fsin2th(xx,aem(m1,ii(m),l(k))
+ &/max(1d-9,aem(0,ii(m),l(k))),aem(m2,ii(m),l(k))
+ &/max(1d-9,aem(0,ii(m),l(k))),frac),m=1,maxjr),k=1,ndep)
+ &,((fsin2th(xx,apm(m1,ii(m),l(k))
+ &/max(1d-9,apm(0,ii(m),l(k))),apm(m2,ii(m),l(k))
+ &/max(1d-9,apm(0,ii(m),l(k))),frac),m=1,maxjr),k=1,ndep)
+ end do
+
+
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,3*ndep*maxjr
+ if(ip.le.9)then
+ write(ifho,'(a,i1,$)') ' plot lsin2t+',ip
+ else
+ if(ip.le.99) then
+ write(ifho,'(a,i2,$)') ' plot lsin2t+',ip
+ else
+ if(ip.le.999)then
+ write(ifho,'(a,i3,$)') ' plot lsin2t+',ip
+ endif
+ endif
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+
+#ifdef __CXLATCE__
+ if (iLatCE.eq.1) call printlaterals(ch, ndep)
+#endif
+
+ endif
+#endif
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine xShower(k1,k2)
+c-------------------------------------------------------------------------
+c plot particle type k1 to k2
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ integer kmn(2),kmx(2)
+ character*4 c(maxjz)
+ character*11 ptyp(maxin)
+#if __MC3D__ || __CXLATCE__
+ character*3 nyx
+ character*11 tx(maxjr,maxjz),ty(maxjr,maxjz,maxin)
+#endif
+#ifdef __CXDEBUG__
+ dimension emoy(maxjz),sum(maxjz)
+#endif
+ if(k1.gt.k2)then
+ write(*,*)'error in xShower k1 < k2 !'
+ return
+ elseif(k2.le.3)then
+ kkk=1
+ kmin=2
+ kmax=3
+ nk3=0
+ elseif(k1.ge.4)then
+ kkk=2
+ kmin=4
+ kmax=9
+ nk3=0
+ else
+ kkk=3
+ kmin=4
+ kmax=9
+ nk3=1
+ endif
+ fev=1.d9
+ a=1d-9
+ ptyp(1)=' [g] '
+ ptyp(2)=' e^-! '
+ ptyp(3)=' e^+! '
+ ptyp(4)=' nucleons '
+ ptyp(5)=' [p]^+/-! '
+ if(mode.ne.0)then !plot pi0 if no EM shower
+ ptyp(6)=' d[p]^0!/dZ'
+ else
+ ptyp(6)=' d[g]/dZ '
+ endif
+ ptyp(7)=' K^+/-! '
+ ptyp(8)=' K?l! '
+ ptyp(9)=' K?s! '
+ ptyp(10)=' [m]^+/-! '
+ ptyp(11)=' [m]^+! '
+ ptyp(12)=' [m]^-! '
+
+ call NormalizeTables(1.d0/dble(max(1,nshower)))
+
+ write(ifho,'(a)')'!---------------yieldz------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name xyi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod lin'
+ write(ifho,*) 'xrange ',zamin,zamax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*fev,'"'
+ write(ifho,'(a)') '- txt "xaxis depth Z (g/cm^2!)"'
+ if(kkk.eq.1)then
+ write(ifho,'(a)') '+ txt "yaxis number of charged"'
+ else
+ write(ifho,'(a)') '+ txt "yaxis number of charged hadrons"'
+ endif
+ do ip=k1,k2
+ write(ifho,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ enddo
+ if(kkk.eq.3)then
+ write(ifho,'(a)') '+ txt "yaxis number of e^+/-!"'
+ endif
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*) 'array ',-1-(k2-k1+1)-1-nk3
+ do iz=1,numiz
+ zi=zamin+delza*dble(iz-1)
+ stot=0.d0
+ do ip=kmin,kmax
+ if(ip.ne.6.and.ip.ne.1)stot=stot+yieldz(ip,iz)
+ enddo
+ if(kkk.ne.3)then
+ write(ifho,'(e13.5,90e11.3)')zi,stot
+ & ,(yieldz(ip,iz),ip=k1,k2)
+ else
+ write(ifho,'(e13.5,90e11.3)')zi,stot
+ & ,(yieldz(ip,iz),ip=k1,k2),yieldz(2,iz)+yieldz(3,iz)
+ endif
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,k2-k1+2+nk3
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot xyi+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot xyi+',ip
+ enddo
+ write(ifho,'(a)')' '
+
+ if(ctime.gt.1.d0)then
+
+ k2m=min(k2,10)
+ write(ifho,'(a)')'!---------------yiex------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name xti'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,*) 'xrange ',-tamax,-tamin
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'text 0.1 0.9 "Prim. Engy (eV) ='
+ & ,eprima*fev,'"'
+ write(ifho,'(a)') '- txt "xaxis time -t (ns)"'
+ if(kkk.eq.1)then
+ write(ifho,'(a)') '+ txt "yaxis number of e+/e-"'
+ else
+ write(ifho,'(a)') '+ txt "yaxis number of hadrons"'
+ endif
+ do ip=k1,k2m
+ write(ifho,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ enddo
+ write(ifho,'(a)') '+ txt "yaxis charge"'
+ if(kkk.eq.3)then
+ write(ifho,'(a)') '+ txt "yaxis number of e^+/-!"'
+ endif
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*) 'array ',-1-(k2m-k1+1)-2-nk3
+ do it=1,numiz
+ ti=-tamin*ctime**dble(1-it)
+ stot=0.d0
+ do ip=kmin,kmax
+ if(ip.ne.6)stot=stot+yiex(ip,it)
+ enddo
+ if(kkk.ne.3)then
+ write(ifho,'(e13.5,90e16.8)')ti,stot
+ & ,(yiex(ip,it),ip=k1,k2m),yiex(11,it)
+ else
+ write(ifho,'(e13.5,90e16.8)')ti,stot
+ & ,(yiex(ip,it),ip=k1,k2m),yiex(11,it),yiex(2,it)+yiex(3,it)
+ endif
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,k2m-k1+3+nk3
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot xti+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot xti+',ip
+ enddo
+ write(ifho,'(a)')' '
+
+ endif
+
+#if __MC3D__ || __CXLATCE__
+ anorm=dble(max(1,nshower))
+ if(i1DMC.le.1)then
+ write(ifho,'(a)')'!--------------yieldr----------------------'
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ write(c(jz),'(i4)')nint(zi)
+ enddo
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name xyr'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',ramin,ramax
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis R (m) "'
+ do ip=k1,k2
+ do jj=1,3 !radial density normalized
+ write(ifho,'(a)')
+ *'++ txt "yaxis '//ptyp(ip)//'?norm! (z='//c(jj)//')"'
+ enddo
+ enddo
+ do ip=k1,k2 !radial density
+ do jj=1,3
+ write(ifho,'(a)')'++ txt "yaxis '//ptyp(ip)//' (z='//c(jj)//')"'
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-12*(k2-k1+1)
+ do ir=1,numir
+ rr= ramin*(ramax/ramin)**((dble(ir)-0.5d0)/dble(numir))
+ ra= (ramin*(ramax/ramin)**((dble(ir)-1.d0)/dble(numir)))**2.d0
+ rb= (ramin*(ramax/ramin)**((dble(ir)-0.d0)/dble(numir)))**2.d0
+ d=(rb-ra)*pi
+ write(ifho,'(900e11.3)')rr
+ & ,((abs(yieldr(ip,jz,ir))/d/max(a,yieldz(ip,izfirst+(jz-1)*modz))
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d/max(a,yieldz(ip,izfirst+(jz-1)*modz))
+ & ,jz=1,3),ip=k1,k2),((abs(yieldr(ip,jz,ir))/d
+ & ,sqrt(max(0.d0,yieldr2(ip,jz,ir)-yieldr(ip,jz,ir)**2)
+ & /max(anorm-1.d0,1.d0))/d,jz=1,3),ip=k1,k2)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,6*(k2-k1+1)
+ if(ip.le.9)write(ifho,'(a,i1,$)') ' plot xyr+',ip
+ if(ip.gt.9)write(ifho,'(a,i2,$)') ' plot xyr+',ip
+ enddo
+ write(ifho,'(a)')' '
+
+
+
+
+ endif
+#endif
+
+
+ write(ifho,'(a)')'!--------------spec----------------------'
+
+ do j=1,3 !three selected depthes
+ iz=izfirst+(j-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ write(c(j),'(i4)')nint(zi)
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.le.1)then
+ do jz=1,3
+ iz=izfirst+(jz-1)*modz
+ zi=zamin+delza*dble(iz-1)
+ do jr=1,3
+ ir=irfirst+(jr-1)*modr
+ ri= ramin*(ramax/ramin)**(dble(ir)/dble(numir))
+ tx(jr,jz)(5:5)=','
+ write(tx(jr,jz)(1:4),'(i4)')nint(zi)
+ write(tx(jr,jz)(6:11),'(f6.1)')ri
+ ie=iefirst+(jr-1)*moden
+ do ip=k1,k2
+ if(ip.le.3)then
+ k=1
+ else
+ k=2
+ endif
+ ei=eamin(k)*(eamax(k)/eamin(k))**(dble(ie)/dble(numie))
+ ty(jr,jz,ip)(5:5)=','
+ write(ty(jr,jz,ip)(1:4),'(i4)')nint(zi)
+ write(ty(jr,jz,ip)(6:11),'(f6.1)')ei
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+
+ if(kkk.ne.3)then
+ kk1=kkk
+ kk2=kkk
+ kmn(kkk)=k1
+ kmx(kkk)=k2
+ else
+ kk1=1
+ kk2=2
+ kmn(1)=k1
+ kmx(1)=3
+ kmn(2)=4
+ kmx(2)=k2
+ endif
+
+
+ do k=kk1,kk2 !loop particle type (EM, hadron or both)
+
+ if(eamin(k).lt.eamax(k))then
+ dle=log10(eamax(k)/eamin(k))/numie
+
+ write(ifho,'(a,i1)') 'zone 2 3 1 openhisto name xsp',k
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',eamin(k),eamax(k)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)" '
+ do 10 ip=kmn(k),kmx(k)
+ do 10 j=1,3
+ 10 write(ifho,'(a)')
+ & '+ txt "yaxis EdN/dE '//ptyp(ip)(1:11)//' (z='//c(j)//')"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-3*(kmx(k)-kmn(k)+1)
+#ifdef __CXDEBUG__
+ do nem=1,3
+ emoy(nem)=0.d0
+ sum(nem)=0.d0
+ enddo
+#endif
+ do i=1,numie+1
+ ee= eamin(k)*(eamax(k)/eamin(k))**(dble(i-1)/dble(numie))
+ d=dle
+ if(i.eq.1)d=0.5d0*dle !first bin is half size because of the cutoff
+#ifdef __CXDEBUG__
+ do nem=1,3
+ emoy(nem)=emoy(nem)+ee*(spec(0,2,i,nem)
+ & +spec(0,3,i,nem))/d !mean energy of e+/e-
+ sum(nem)=sum(nem)+(spec(0,2,i,nem)+spec(0,3,i,nem))/d
+ enddo
+#endif
+ write(ifho,'(300e11.3)')ee
+ & ,((spec(0,ip,i,j)/d,j=1,3),ip=kmn(k),kmx(k))
+ end do
+ write(ifho,'(a)')' endarray'
+#ifdef __CXDEBUG__
+ do nem=1,3
+ if(sum(nem).gt.0.d0)then
+ emoy(nem)=emoy(nem)/sum(nem)
+ else
+ emoy(nem)=0.d0
+ endif
+ enddo
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.9 "Eel1= ',emoy(1),' GeV"'
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.8 "Eel2= ',emoy(2),' GeV"'
+ write(ifho,'(a,1p,e11.4,a)')'text 0.5 0.7 "Eel3= ',emoy(3),' GeV"'
+#endif
+ write(ifho,'(a)')'closehisto'
+ do ip=1,3*(kmx(k)-kmn(k)+1)
+ if(ip.le.9)write(ifho,'(a,i1,a,i1,$)') ' plot xsp',k,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2,$)')
+ & ' plot xsp',k,'+',ip
+ if(ip.gt.99)write(ifho,'(a,i1,a,i3,$)') ' plot xsp',k,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.3*(kmx(k)-kmn(k)+1))write(ifho,*)' '
+ enddo
+
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.le.1)then
+
+ write(ifho,'(a)') 'resethisto'
+ write(ifho,'(a,i1)') 'openhisto name xmo',k
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',eamin(k),eamax(k)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)" '
+ do 1 ii=1,2
+ do 1 ip=kmn(k),kmx(k)
+ do 1 m=0,musmm
+ do 1 j=1,3
+ 1 write(ifho,'(a,i2,1x,a)')
+ & '+ txt "yaxis M',m,ptyp(ip)(1:11)//' (z='//c(j)//')"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-2*3*(musmm+1)*(kmx(k)-kmn(k)+1)
+ do i=1,numie+1
+ ee= eamin(k)*(eamax(k)/eamin(k))**(dble(i-1)/dble(numie))
+ d=dle
+ if(i.eq.1)d=0.5d0*dle !first bin is half size because of the cutoff
+ write(ifho,'(800e11.3)')ee
+ & ,((spec(0,ip,i,j)/d,j=1,3)
+ & ,((spec(m,ip,i,j)/max(a,spec(0,ip,i,j)),j=1,3),m=1,musmm)
+ & ,ip=kmn(k),kmx(k))
+ write(ifho,'(800e11.3)')
+ & ((1d0-max(a,spex(0,ip,i,j))/max(a,spec(0,ip,i,j)),j=1,3)
+ & ,((1d0-max(a,spex(m,ip,i,j))/max(a,spec(m,ip,i,j)),j=1,3),
+ & m=1,musmm)
+ & ,ip=kmn(k),kmx(k))
+ end do
+ write(ifho,'(a/a)')' endarray','closehisto'
+ do ip=1,(musmm+1)*3*(kmx(k)-kmn(k)+1)
+ if(ip.le.9)write(ifho,'(a,i1,a,i1,$)') ' plot xmo',k,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2,$)')
+ & ' plot xmo',k,'+',ip
+ if(ip.gt.99.and.ip.le.999)write(ifho,'(a,i1,a,i3,$)')
+ & ' plot xmo',k,'+',ip
+ if(ip.gt.999)write(ifho,'(a,i1,a,i4,$)') ' plot xmo',k,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.3*(kmx(k)-kmn(k)+1))write(ifho,*)' '
+ if(mod(ip,10).eq.0.or.ip.eq.12*(kmx(k)-kmn(k)+1))write(ifho,*)' '
+ enddo
+ do ip=(musmm+1)*3*(kmx(k)-kmn(k)+1)+1,
+ * (musmm+1)*6*(kmx(k)-kmn(k)+1)
+ if(ip.le.9)write(ifho,'(a,i1,a,i1,$)')' plot -ymod lin xmo',k,'+'
+ *,ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2,$)')
+ * ' plot -ymod lin xmo',k,'+',ip
+ if(ip.gt.99.and.ip.le.999)write(ifho,'(a,i1,a,i3,$)')
+ * ' plot -ymod lin xmo',k,'+',ip
+ if(ip.gt.999)write(ifho,'(a,i1,a,i4,$)')' plot -ymod lin xmo',
+ * k,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.24*(kmx(k)-kmn(k)+1))write(ifho,*)' '
+ enddo
+ write(ifho,'(a)')
+ write(ifho,'(a)') 'resethisto'
+
+
+ write(ifho,'(a)')'!--------------specr----------------------'
+ write(ifho,'(a,i1)') 'zone 3 6 1 openhisto name xsr',k
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',eamin(k),eamax(k)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)')'- txt "xaxis energy (GeV)"'
+ do 2 ip=kmn(k),kmx(k)
+ do 2 jz=1,3
+ do 2 jr=1,3
+ 2 write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//tx(jr,jz)//')"'
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-9*(kmx(k)-kmn(k)+1)
+ do ie=1,numie+1
+ ee= eamin(k)*(eamax(k)/eamin(k))**(dble(ie-1)/dble(numie))
+ d=dle
+ if(ie.eq.1)d=0.5d0*dle !first bin is half size because of the cutoff
+ write(ifho,'(900e11.3)')ee
+ & ,(((specr(ip,ie,jz,jr)/d,jr=1,3),jz=1,3),ip=kmn(k),kmx(k))
+ end do
+ write(ifho,'(a/a)')' endarray','closehisto'
+ do ip=1,9*(kmx(k)-kmn(k)+1)
+ if(ip.le.9)write(ifho,'(a,i1,a,i1,$)') ' plot xsr',k,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2,$)')
+ & ' plot xsr',k,'+',ip
+ if(ip.gt.99)write(ifho,'(a,i1,a,i3,$)') ' plot xsr',k,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.9*(kmx(k)-kmn(k)+1))write(ifho,*)' '
+ enddo
+ write(ifho,'(a)')
+ write(ifho,'(a)') 'resethisto'
+
+ endif
+#endif
+
+ endif
+
+ enddo !---> end loop k (EM and hadron)
+
+
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.le.1)then
+
+ do iyx=1,maxiex
+
+ write(nyx,'(a,i1)')'xx',iyx
+ write(ifho,'(3a)')'!-------------- ',nyx,' --------------------'
+ write(ifho,'(a)') 'zone 3 6 1 openhisto name '//nyx
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod log'
+ write(ifho,'(a,2e11.3)') 'xrange ',xamin(iyx),xamax(iyx)
+ write(ifho,'(a)') 'yrange auto auto '
+ if(iyx.eq.1)then
+ write(ifho,'(a)')'- txt "xaxis cos([f])"'
+ elseif(iyx.eq.2)then
+ write(ifho,'(a)')'- txt "xaxis sin^2!([q])"'
+ elseif(iyx.eq.3)then
+ write(ifho,'(a)')'- txt "xaxis t (ns)"'
+ elseif(iyx.eq.4)then
+ write(ifho,'(a)')'- txt "xaxis [D][f]"'
+ elseif(iyx.eq.5)then
+ write(ifho,'(a)')'- txt "xaxis log?10!(sin^2!([q])"'
+ endif
+ do ip=k1,k2
+ do jz=1,maxjz
+ do jr=1,maxjr
+ if(iyx.eq.5)then
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//ty(jr,jz,ip)//')"'
+ else
+ write(ifho,'(a)')
+ & '+ txt "yaxis '//ptyp(ip)//' ('//tx(jr,jz)//')"'
+ endif
+ enddo
+ enddo
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweight ',dble(nshower)
+ write(ifho,*)'array ',-1-maxjr*maxjz*(k2-k1+1)
+ d=(xamax(iyx)-xamin(iyx))/numix(iyx)
+ do ix=1,numix(iyx)
+ xx= xamin(iyx)+(xamax(iyx)-xamin(iyx))
+ & *((dble(ix)-0.5d0)/dble(numix(iyx)))
+ if(iyx.eq.5)then !log10(sin2(theta)) is normalized
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,je,ix)/d/max(1d-9,speca(ip,jz,je))
+ & ,je=1,maxjr),jz=1,maxjz),ip=k1,k2)
+ else
+ write(ifho,'(900e11.3)')xx
+ & ,(((yieldx(iyx,ip,jz,jr,ix)/d,jr=1,maxjr),jz=1,maxjz),ip=k1,k2)
+ endif
+ end do
+ write(ifho,'(a/a)')' endarray','closehisto'
+ do ip=1,maxjr*maxjz*(k2-k1+1)
+ if(ip.le.9)write(ifho,'(a,a3,a1,i1,$)') ' plot ',nyx,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,a3,a1,i2,$)')
+ & ' plot ',nyx,'+',ip
+ if(ip.gt.99)write(ifho,'(a,a3,a1,i3,$)') ' plot ',nyx,'+',ip
+ if(mod(ip,10).eq.0.or.ip.eq.maxjr*maxjz*(k2-k1+1))
+ & write(ifho,*)' '
+ enddo
+
+ enddo
+
+ endif
+#endif
+
+ end
+
+c----------------------------------------------------------------------
+ subroutine NormalizeTables(value)
+c----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ do in=1,maxin
+ do iz=1,numiz
+ yieldz(in,iz)=yieldz(in,iz)*value
+ enddo
+ do iz=1,numiz
+ yiex(in,iz)=yiex(in,iz)*value
+ enddo
+ do jz=1,maxjz
+#if __MC3D__ || __CXLATCE__
+ do ir=1,numir
+ yieldr(in,jz,ir)=yieldr(in,jz,ir)*value
+ yieldr1(in,jz,ir)=yieldr1(in,jz,ir)*value
+ yieldr2(in,jz,ir)=yieldr2(in,jz,ir)*value
+#ifdef __CXLATCE__
+ yieldrt(in,jz,ir)=yieldrt(in,jz,ir)*value
+ yieldrt1(in,jz,ir)=yieldrt1(in,jz,ir)*value
+ yieldrt2(in,jz,ir)=yieldrt2(in,jz,ir)*value
+#endif
+ enddo
+#endif
+ do ie=1,numie+1
+ do mm=0,maxmm
+ spec(mm,in,ie,jz)=spec(mm,in,ie,jz)*value
+#if __MC3D__ || __CXLATCE__
+ spex(mm,in,ie,jz)=spex(mm,in,ie,jz)*value
+ enddo
+ do jr=1,maxjr
+ specr(in,ie,jz,jr)=specr(in,ie,jz,jr)*value
+#endif
+ enddo
+ enddo
+#if __MC3D__ || __CXLATCE__
+ do i=1,maxiex
+ do ix=1,numix(i)
+ do jr=1,maxjr
+ yieldx(i,in,jz,jr,ix)=yieldx(i,in,jz,jr,ix)*value
+ enddo
+ enddo
+ enddo
+ do jr=1,maxjr
+ speca(in,jz,jr)=speca(in,jz,jr)*value
+ enddo
+#endif
+ enddo
+ enddo
+ end
+
+c end analysis part
+#endif
+
+c-------------------------------------------------------------------------
+ subroutine depthprofile(k1,k2,nsho)
+c-------------------------------------------------------------------------
+c write in ifout(can be histo or data), depth profiles for particle
+c type k1 to k2:
+c 0-all charged
+c 1-photon
+#if __CXCORSIKA__ || __CORSIKA8__
+c -1-e-
+c 2-e+
+#else
+c 2-e+/e-
+#endif
+c 3-mu+/mu-
+c 4-all hadrons
+c 5-nucleons
+c 6-charged pions
+c 7-charged kaons
+c 8-protons
+c 9-neutrons
+c 10-neutral kaons
+c nsho > 0 : profile for shower nsho
+c nsho = 0 : mean profile.
+c nsho = -1: Height (m) and L (m) as a function of X (g/cm^2)
+c T. Pierog, 24.09.2003 - last modification : 28.06.2004
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ data thetapro/1000d0/
+ save thetapro
+#if __CXCORSIKA__ || __CORSIKA8__
+ parameter (mnPxPro=-1)
+#else
+ parameter (mnPxPro=0)
+#endif
+ character*9 ptyp(mnPxPro:10),namodel,nalemodel
+ character*11 etyp(mxExpro,mnPxPro:mxPxpro+1)
+ & ,edeptyp(mnPxPro:mxPxpro+1)
+ character*3 color(mnPxPro:10)
+ character*6 mean
+
+ nbin=1 !max(1,(nmaxX-nminX)/numiZ) !use all bins for these plots
+ if(nsho.eq.-1)then
+ write(ifout,'(a,a)')'!************************'
+ & ,' Models ************************'
+ if(ilowegy.eq.1)then
+ if(MCleModel.eq.2)then
+ nalemodel='QGSJet'
+ elseif(MCleModel.eq.3)then
+ nalemodel='Gheisha'
+ elseif(MCleModel.eq.6)then
+ nalemodel='QGSJet-II'
+ elseif(MCleModel.eq.7)then
+ nalemodel='FLUKA'
+ elseif(MCleModel.eq.8)then
+ nalemodel='UrQMD'
+ elseif(MCmodel.eq.9)then
+ nalemodel='DPMJetIII'
+ else
+ nalemodel='neXus'
+ endif
+ write(ifout,'(a)')'! Low energy model : '//nalemodel
+ if(ifout.ne.ifda.and.ifda.gt.0)
+ & write(ifda,'(a)')'! Low energy model : '//nalemodel
+ endif
+
+ if(MCmodel.eq.2)then
+ namodel='QGSJet'
+ elseif(MCmodel.eq.4)then
+ namodel='EPOS'
+ elseif(MCmodel.eq.5)then
+ namodel='SIBYLL'
+ elseif(MCmodel.eq.6)then
+ namodel='QGSJet-II'
+ elseif(MCmodel.eq.9)then
+ namodel='DPMJetIII'
+ else
+ namodel='neXus'
+ endif
+ write(ifout,'(a)')'! High energy model : '//namodel
+ write(ifout,'(a,2f5.0)')
+ & '! Number of bin/Energy decade (e/m,had) : ',emdecade,decade
+ write(ifout,'(a,f5.0)')
+ & '! Calculation bin width (g/cm^2) : ',delzsh
+ if(ifout.ne.ifda.and.ifda.gt.0)then
+ write(ifda,'(a)')'! High energy model : '//namodel
+ write(ifda,'(a,2f5.0)')
+ & '! Number of bin/Energy decade (e/m,had) : ',emdecade,decade
+ write(ifda,'(a,f5.0)')
+ & '! Calculation bin width (g/cm^2) : ',delzsh
+ endif
+#ifdef __CXSUB__
+ if(ifout.eq.ifho)write(ifout,'(a)')'newpage set scalel 0.5'
+#endif
+
+ else
+
+ if(k1.gt.k2)then
+ write(*,*)'error in depthprofile k1 < k2 !'
+ return
+ endif
+ fev=1.d9
+#if __CXCORSIKA__ || __CORSIKA8__
+ color(-1)='blu' ! e^-!
+#endif
+ color(0)='bla' ! all or charged
+ color(1)='red' ! photons
+#if __CXCORSIKA__ || __CORSIKA8__
+ color(2)='blu' ! e^+!
+#else
+ color(2)='blu' ! e^-!+e^+!
+#endif
+ color(3)='gre' ! lost or muons
+ color(4)='red' ! hadrons
+ color(5)='blu' ! muons or nucleons
+ color(6)='gre' ! c pions
+ color(7)='ora' ! c kaons
+ color(8)='gra' ! protons
+ color(9)='lig' ! neutrons
+ color(10)='yel' ! n kaons
+ do ip=mnPxPro,mxPxpro
+ do ic=1,mxExpro
+ if(ip.le.2)write(etyp(ic,ip),'(1p,e8.1,a3)')EMCutP(ic)*1000.d0
+ & ,'MeV'
+ if(ip.gt.2)write(etyp(ic,ip),'(f8.0,a3)')HaCutP(ic),'GeV'
+ enddo
+ if(ip.le.2)write(edeptyp(ip),'(f7.1,a4)')emin/c2em*1000.d0,' MeV'
+ if(ip.gt.2)write(edeptyp(ip),'(f8.0,a3)')enymin/c2bas,'GeV'
+ enddo
+
+ if(nsho.ge.1)then !profile for individual shower
+ write(ifout,'(a,a,i9,a)')'!************************'
+ & ,' shower ',nsho,' ************************'
+ if(nsho.le.9)then
+ write(mean,'(i1)')nsho
+ ile=1
+ elseif(nsho.le.99)then
+ write(mean,'(i2)')nsho
+ ile=2
+ elseif(nsho.le.999)then
+ write(mean,'(i3)')nsho
+ ile=3
+ elseif(nsho.le.9999)then
+ write(mean,'(i4)')nsho
+ ile=4
+ elseif(nsho.le.99999)then
+ write(mean,'(i5)')nsho
+ ile=5
+ else
+ write(mean,'(i6)')nsho
+ ile=6
+ endif
+ ier=1
+
+ endif
+
+
+c Geometry Profile *****************************************************
+
+c If theta angle change, rewrite Height vs depth in file
+ if(thetapro.ne.thetas)then
+ thetapro=thetas
+
+ therad=pi*thetas/180.d0
+ phirad=pi*phisho/180.d0
+ radtr=(radearth+hground+altitude)*sin(therad) !impact radius
+ write(ifout,'(a,a)')'!************************'
+ & ,' Coordinates ************************'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'zone 1 1 1'
+ write(ifout,'(a)') 'openhisto name coord'
+ write(ifout,'(a)') 'htyp lin'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,f8.0,a,f8.0,a)')
+ & 'txt "title Hground =',hground,' Altitude =',altitude,'"'
+ write(ifout,'(a,f6.3,a,f6.3,a)')
+ & 'text 0.3 0.3 "Zenith (rad) =',therad
+ & ,' Azimuth (rad) =',phirad,'"'
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ write(ifout,'(a)') 'colo mix'
+ write(ifout,'(a)') '+ txt "yaxis Height (m)"'
+ write(ifout,'(2a)') 'txt "refer key 1 ''H (m)'' 1 L"'
+ write(ifout,'(a)') '+ txt "yaxis Distance (m)"'
+ write(ifout,'(2a)') 'txt "refer key 1 ''L (m)'' 1 L"'
+ write(ifout,'(a)') '+ txt "yaxis x?coord! (m)"'
+ write(ifout,'(2a)') 'txt "refer key 1 ''x (m)'' 1 L"'
+ write(ifout,'(a)') '+ txt "yaxis y?coord! (m)"'
+ write(ifout,'(2a)') 'txt "refer key 1 ''y (m)'' 1 L"'
+ else
+ write(ifout,'(a,f6.3)') '! Zenith (rad) : ',therad
+ write(ifout,'(a,f6.3)') '! Azimuth (rad) : ',phirad
+ endif
+c column names
+ write(ifout,'(a1,6x,a,5x,a1,3x,a,3x,a1,2x,a,2x,a1
+ & ,3x,a,2x,a1,3x,a,2x,a1)')
+ & '!','X','!','Height','!','Distance','!','x coord'
+ & ,'!','y coord','!'
+ write(ifout,'(a1,2x,a,4x,a,5x,a1,4(4x,a,5x,a1))')
+ & '!','(g/cm^2) !','(m)','!','(m)','!','(m)','!','(m)','!'
+c end column names
+ if(ifout.eq.ifho)write(ifout,*)'array ',-5
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ distL=distance0(zi) !slant distance to obs level
+ dl=distL-sign(DistAlt,zsaxis)
+ x=dl*xsaxis
+ y=dl*ysaxis
+ write(ifout,'(1p,e13.5,4e13.5)')zi,heightt(distL,radtr)
+ & ,abs(distL),x,y
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ write(ifout,'(a,i2)') ' plot coord+1- plot coord+2'
+ endif
+ endif !end geometry
+
+ if(nsho.eq.0)then !mean energy profile
+
+ write(ifout,'(a,a)')'!************************'
+ & ,' mean profiles ************************'
+
+ if(iXmax.eq.1)then
+ if(k2.le.2)then
+ call Xmax_fit(0,0,0) !fit Xmax_mean for all e+/e-
+ elseif(k1.ge.3)then
+ call Xmax_fit(3,4,0) !fit Xmax_mean for all hadrons and muons
+ else
+ call Xmax_fit(0,0,0) !fit Xmax_mean for all charged
+ call Xmax_fit(3,4,0) !fit Xmax_mean for all hadrons and muons
+ endif
+ elseif(iXmax.eq.2)then
+ call Xmax_fit(k1,k2,0) !fit Xmax_mean for all
+ endif
+ anorm=dble(max(1,nshower))
+
+c Energy balance Profile **********************************************
+
+ if(iwrt.ge.2)then !only for option all or engy
+ write(ifout,'(a,a)')'!***********************'
+ & ,' Energy balance ***********************'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)')'zone 1 1 1'
+ endif
+
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name Ebalan'
+ write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ write(ifout,'(a)') '++ txt "yaxis Energy (GeV)"'
+ write(ifout,'(a)')
+ & 'txt "refer key 20 ''[g], e^+! and e^-! (GeV)''"'
+ write(ifout,'(a)') '++ txt "yaxis Energy (GeV)"'
+ write(ifout,'(a)')
+ & 'txt "refer key 21 ''hadrons''"'
+ write(ifout,'(a)') '++ txt "yaxis Energy (GeV)"'
+ write(ifout,'(a)')
+ & 'txt "refer key 22 ''Deposed and lost energy''"'
+ write(ifout,'(a)') '++ txt "yaxis Energy (GeV)"'
+ write(ifout,'(a)')
+ & 'txt "refer key 29 ''Muons''"'
+ write(ifout,'(a)') '++ txt "yaxis Energy (GeV)"'
+ write(ifout,'(a)')
+ & 'txt "refer key 24 ''unknown''"'
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+c column names
+ write(ifout,'(a,$)')'! X (g/cm^2) ! Energy of e/m (GeV) '
+ write(ifout,'(a,$)') '! Energy of hadrons (GeV) '
+ write(ifout,'(a,$)') '! Energy Lost (GeV) '
+ write(ifout,'(a,$)') '! Energy of Muons (GeV) '
+ write(ifout,'(a)') '! Balance (GeV) !'
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array -11'
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ sum=anorm*Einit
+ & -(Ebalan1(iz,1)+Ebalan1(iz,2)+Ebalan1(iz,3)+Ebalan1(iz,4))
+ sum1=Ebalan1(iz,1)+Ebalan1(iz,2)
+ & +Ebalan1(iz,3)+Ebalan1(iz,4)
+ sum2=Ebalan2(iz,1)+Ebalan2(iz,2)
+ & +Ebalan2(iz,3)+Ebalan2(iz,4)
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,(Ebalan1(iz,ip)/anorm
+ & ,sqrt(max(0.d0,Ebalan2(iz,ip)-Ebalan1(iz,ip)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm)),ip=1,4)
+ & ,sum/anorm
+ & ,sqrt(max(0.d0,sum2-sum1**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm))
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ write(ifout,'(a,a)') ' plot Ebalan+1- plot Ebalan+2-'
+ & ,' plot Ebalan+3- plot Ebalan+4- plot Ebalan+5'
+ endif
+
+ endif !end energy balance
+
+#ifdef __ANALYSIS__
+c Generation Profile **********************************************
+ if(cntgen(0).gt.0d0)then
+ genmn=0d0
+ genmx=0d0
+ do i=1,ngenmx
+ cntgen(i)=cntgen(i)/ cntgen(0)
+ if(cntgen(i).le.0d0.and.genmx.le.0d0)genmn=dble(i)
+ if(cntgen(i).gt.0d0)genmx=dble(i)
+ enddo
+ write(ifout,'(a,a)')'!************************'
+ & ,' Generation profile ************************'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)')'zone 1 1 1'
+ endif
+
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name Generation'
+ write(ifout,'(a)') 'htyp hru'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',genmn,genmx
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ write(ifout,'(a)') 'txt "xaxis number of generation"'
+ write(ifout,'(a)') 'txt "yaxis Probability"'
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+c column names
+ write(ifout,'(a)')'! Gener nbr ! Probability '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array 2'
+ endif
+ do ix=1,ngenmx
+ write(ifout,'(i3,1p,e13.5)')ix,cntgen(ix)
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ write(ifout,'(a,a)') ' plot 0'
+ endif
+ endif
+#endif
+
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)')'zone 1 2 1'
+ write(ifout,'(a)')'set ipmci 1'
+ endif
+ mean='mean '
+ ile=4
+ ier=2
+
+
+ else !for individual profiles
+
+ if(ifout.eq.ifho.and.nsho.eq.1)then
+ write(ifout,'(a)')'zone 1 2 1'
+ write(ifout,'(a)')'set ihcol 1'
+ endif
+
+ endif
+
+ if(iwrt.ge.2)then !only for option all or engy
+c Energy deposit Profile ************************************
+
+ ptyp(0)=' all '
+ ptyp(1)=' [g] '
+ ptyp(2)='e^-!+e^+!'
+ ptyp(3)=' lost '
+ ptyp(4)=' hadrons '
+ ptyp(5)=' [m]^+/-!'
+ ptyp(6)=' [p]^+/-!'
+ ptyp(7)=' K^+/-! '
+ ptyp(8)=' protons '
+ ptyp(9)=' neutrons'
+ ptyp(10)=' K?l/s! '
+
+ ip=0
+ ic=1
+ write(ifout,'(a)')
+ &'!---- X profile for effective total energy deposit ----'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name EdepoEff'//mean
+ if(ier.eq.1)write(ifout,'(a)') 'htyp lin'
+ if(ier.eq.2)write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a)') 'txt "xaxis depth (g/cm^2!)"'
+ if(ier.eq.1)mrk=0
+ if(ier.eq.2)mrk=19
+ mrk=mrk+1
+ write(ifout,'(a)')
+ $'txt "yaxis Total Eff. dE?depo!/dX (GeV/g.cm^2!)"'
+ write(ifout,'(a)') ' colo '//color(ip)
+ if(ier.eq.1)then
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ else
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+ endif
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ if(ier.eq.1)write(ifout,'(2x,a9,1x,a1,$)')ptyp(ip),'!'
+ if(ier.eq.2)write(ifout,'(8x,a9,8x,a1,$)')ptyp(ip),'!'
+ write(ifout,'(a1)')' '
+ write(ifout,'(a1,2x,a,$)')'!','(g/cm^2) !'
+ if(ier.eq.1)write(ifout,'(a11,1x,a1,$)')etyp(ic,ip),' !'
+ if(ier.eq.2)write(ifout,'(7x,a11,7x,a1,$)')etyp(ic,ip),' !'
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',1+ier
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ if(ier.eq.1)then
+ if(iXmax.ne.0)then !only if Xmax is calculated
+ Edepoeff=AlpEdepo(zi,XmaxShow(1,0))*XProf(iz,1,0)
+ else
+ Edepoeff=0.d0
+ endif
+ write(ifout,'(1p,e13.5,90e13.5)')zi,Edepoeff
+ else
+ if(iXmax.ne.0)then !only if Xmax is calculated
+ alp=AlpEdepo(zi,XmaxMean(1,0))
+ Edepoeff=alp*XmeanP(iz,ic,ip)/anorm
+ Edepoerr=alp*sqrt(max(0.d0,XmeanP2(iz,ic,ip)
+ & -XmeanP(iz,ic,ip)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm))
+ else
+ Edepoeff=0.d0
+ Edepoerr=0.d0
+ endif
+ write(ifout,'(1p,e13.5,90e13.5)')zi,Edepoeff,Edepoerr
+ endif
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ endif
+
+
+
+ kmin=0
+ kmax=k2
+ write(ifout,'(a)')
+ &'!---- X profile for charged particle energy deposit ----'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name Edepo'//mean
+ if(ier.eq.1)write(ifout,'(a)') 'htyp lin'
+ if(ier.eq.2)write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ if(ier.eq.1)
+ &write(ifout,'(a,f6.2,a)')
+ & 'text 0.1 0.95 "theta =',thetas,'"'
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ do ip=kmin,kmax
+ if(ier.eq.1)mrk=0
+ if(ier.eq.2)mrk=19
+ mrk=mrk+1
+ if(ier.eq.1)then
+ write(ifout,'(a)')
+ $'+ txt "yaxis dE?depo!/dX of '//ptyp(ip)//' (GeV/g.cm^2!)"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//edeptyp(ip)//''' 1 L"'
+ if(ic.eq.1)write(ifout,'(a)') ' tline ful'
+ else
+ write(ifout,'(a)')
+ $'++ txt "yaxis E?depo!/dX of '//ptyp(ip)//' (GeV/g.cm^2!)"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//edeptyp(ip)//''' "'
+ if(ic.eq.1)write(ifout,'(a)') ' mark fci'
+ endif
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ if(ier.eq.1)then
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ else
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+ endif
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=kmin,kmax
+ if(ier.eq.1)write(ifout,'(2x,a9,1x,a1,$)')ptyp(ip),'!'
+ if(ier.eq.2)write(ifout,'(8x,a9,8x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a1,2x,a,$)')'!','(g/cm^2) !'
+ do ip=kmin,kmax
+ if(ier.eq.1)write(ifout,'(a11,1x,a1,$)')edeptyp(ip),' !'
+ if(ier.eq.2)write(ifout,'(7x,a11,7x,a1,$)')edeptyp(ip),' !'
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(dble(iz)-0.5d0)
+ if(ier.eq.1)then
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,(Edepo(iz,ip),ip=kmin,kmax)
+ else
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,(Edepo1(iz,ip)/anorm
+ & ,sqrt(max(0.d0,Edepo2(iz,ip)-Edepo1(iz,ip)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm)),ip=kmin,kmax)
+ endif
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ write(ifout,'(a)')' plot -htyp lru EdepoEff'
+ & //mean(1:ile)//'-'
+ do ip=1,(kmax-kmin+1)-1
+ if(ip.le.9)write(ifout,'(a,a1,i1,a,$)')' plot Edepo'//mean(1:ile)
+ & ,'+',ip,'-'
+ if(ip.gt.9)write(ifout,'(a,a1,i2,a,$)')' plot Edepo'//mean(1:ile)
+ & ,'+',ip,'-'
+ enddo
+ ip=(kmax-kmin+1)
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot Edepo'//mean(1:ile)//'+'
+ $ ,ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot Edepo'//mean(1:ile)//'+'
+ $ ,ip
+ endif
+ write(ifout,'(a)')' '
+
+ if(ier.eq.2)then
+ write(ifout,'(a)')
+ &'!---- alpha profile for effective total energy deposit ----'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name Alpha'
+ write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',0.05,1.3
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a)') '- txt "xaxis s ( shower age)"'
+ write(ifout,'(a)') '+ txt "yaxis [a](s)"'
+ write(ifout,'(a)') '+ txt "yaxis [a](s)"'
+ write(ifout,'(a,d22.14)') 'histoweight ',anorm
+ endif
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','s','!'
+ write(ifout,'(2x,a9,1x,a1,$)')"alpha eff",'!'
+ write(ifout,'(2x,a9,1x,a1)')"alpha tru",'!'
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-3
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ if(iXmax.ne.0)then !only if Xmax is calculated
+ si=3d0/(1d0+2d0*XmaxMean(1,0)/zi)
+ alpeff=AlpEdepo(zi,XmaxMean(1,0))
+ if(XmeanP(iz,1,0).gt.0)then
+ alp=Edepo1(iz,0)/XmeanP(iz,1,0)
+ else
+ alp=0.d0
+ endif
+ else
+ alpeff=0.d0
+ alp=0.d0
+ si=0.d0
+ endif
+ write(ifout,'(1p,e13.5,90e13.5)')si,alpeff,alp
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ write(ifout,'(a)') 'plot -htyp lru Alpha+1-'
+ write(ifout,'(a)') 'plot -htyp pfc Alpha+2'
+ endif
+
+ endif
+
+ endif
+
+c Longitudinal Profile ************************************************
+#if __CXCORSIKA__ || __CORSIKA8__
+ ptyp(-1)='e^-!'
+#endif
+ ptyp(0)=' charged '
+ ptyp(1)=' [g] '
+#if __CXCORSIKA__ || __CORSIKA8__
+ ptyp(2)='e^+!'
+#else
+ ptyp(2)='e^-!+e^+!'
+#endif
+ ptyp(3)=' [m]^+/-!'
+ ptyp(4)=' hadrons '
+ ptyp(5)=' nucleons'
+ ptyp(6)=' [p]^+/-!'
+ ptyp(7)=' K^+/-! '
+ ptyp(8)=' protons '
+ ptyp(9)=' neutrons'
+ ptyp(10)=' K?l/s! '
+
+ if(k2.le.2.or.(k1.le.2.and.k2.gt.2))then !begin EM plot
+ kmin=k1
+ kmax=min(k2,2)
+ write(ifout,'(a)')
+ &'!---- X profile for charged particle, gammas and electrons ----'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name xlept'//mean
+ if(ier.eq.1)write(ifout,'(a)') 'htyp lin'
+ if(ier.eq.2)write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ if(ier.eq.1)then
+ write(ifout,'(a,f6.2,a)')
+ & 'text 0.1 0.95 "theta =',thetas,'"'
+#ifndef __CXCORSIKA__
+ if(ier.eq.1)write(ifout,'(a,3(f8.2),a)')
+ & 'text 0.1 0.85 "S1000(VEM) : '
+ & ,(SD1000(k),k=0,2),'"'
+ if(ier.eq.2)write(ifout,'(a,3(f8.2),a)')
+ & 'text 0.1 0.85 "S1000(VEM) : '
+ & ,(SD1000m(k)/anorm,k=0,2),'"'
+#endif
+ endif
+ if(iXmax.ge.1)then
+ if(ier.eq.2)then
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.3 0.15 "Xmax (g/cm^2!) = ',XmaxMean(1,0),' +/-'
+ & ,XmaxMean(2,0),'"'
+ else
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.3 0.15 "Xmax (g/cm^2!) = ',XmaxShow(1,0),' +/-'
+ & ,XmaxShow(3,0),'"'
+ endif
+ endif
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ do ip=kmin,kmax
+ if(ier.eq.1)mrk=0
+ if(ier.eq.2)mrk=19
+ do ic=1,mxExpro
+ mrk=mrk+1
+ if(ier.eq.1)then
+ write(ifout,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' 1 L"'
+ if(ic.eq.1)write(ifout,'(a)') ' tline ful'
+ else
+ write(ifout,'(a)') '++ txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' "'
+ if(ic.eq.1)write(ifout,'(a)') ' mark fci'
+ endif
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ enddo
+ if(ier.eq.1)then
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ else
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+ endif
+c Xmax
+ if(iXmax.ge.1)then
+ if(ier.eq.1)write(ifout,'(a,f10.2,2(a,1p,e10.3))')'! Xmax : '
+ &,XmaxShow(1,0),' +/- ',XmaxShow(1,0)*XmaxShow(3,0),' ! chi2 '
+ &,XmaxShow(2,0)
+ if(ier.eq.2)write(ifout,'(a,f10.2,a,1p,e10.3,0p,2(a,f10.2))')
+ &'! Xmax : ',XmaxMean(1,0),' +/- ',XmaxMean(2,0)
+ &,' ! min : ',XmaxMean(4,0)
+ &, ' max : ',XmaxMean(5,0)
+ endif
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=kmin,kmax
+ if(ier.eq.1)write(ifout,'(15x,a9,14x,a1,$)')ptyp(ip),'!'
+ if(ier.eq.2)write(ifout,'(34x,a9,34x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a1,2x,a,$)')'!','(g/cm^2) !'
+ do ip=kmin,kmax
+ do ic=1,mxExpro
+ if(ier.eq.1)write(ifout,'(a11,1x,a1,$)')etyp(ic,ip),'!'
+ if(ier.eq.2)write(ifout,'(7x,a11,7x,a1,$)')etyp(ic,ip),'!'
+ enddo
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier*mxExpro*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ if(ier.eq.1)then
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,((XProf(iz,ie,ip),ie=1,mxExpro),ip=kmin,kmax)
+ else
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,((XmeanP(iz,ic,ip)/anorm
+ & ,sqrt(max(0.d0,XmeanP2(iz,ic,ip)-XmeanP(iz,ic,ip)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm)),ic=1,mxExpro),ip=kmin,kmax)
+ endif
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ do ip=1,mxExpro*(kmax-kmin+1)-1
+ if(ip.le.9)write(ifout,'(a,a1,i1,a,$)')' plot xlept'//mean(1:ile)
+ & ,'+',ip,'-'
+ if(ip.gt.9)write(ifout,'(a,a1,i2,a,$)')' plot xlept'//mean(1:ile)
+ & ,'+',ip,'-'
+ enddo
+ ip=mxExpro*(kmax-kmin+1)
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot xlept'//mean(1:ile)//'+'
+ $ ,ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot xlept'//mean(1:ile)//'+'
+ $ ,ip
+ write(ifout,'(a)')' '
+ endif
+
+c Xmax and fit
+ if(iXmax.ge.1)then
+ if(ier.eq.2)then !Xmax profile
+ if(iXmax.eq.1)then
+ kmin=0
+ kmax=0
+ endif
+ write(ifout,'(a)')
+ &'!-------------- Xmax distr. for charged particles -----------'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name xmlept'
+ write(ifout,'(a)') 'htyp his'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.1 0.95 "Charged Xmax (g/cm^2!) = ',XmaxMean(1,0),' +/-'
+ & ,XmaxMean(2,0),'"'
+ write(ifout,'(a)') '- txt "xaxis X?max! (g/cm^2!)"'
+ mrk=0
+ do ip=kmin,kmax
+ mrk=mrk+1
+ write(ifout,'(a)')'++ txt "yaxis dN/dX?max! of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' '' 1 L"'
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweightbin ',anorm
+ endif
+ write(ifout,'(a,f10.2,a,1p,e10.3,0p,2(a,f10.2))')
+ &'! Xmax : ',XmaxMean(1,0),' +/- ',XmaxMean(2,0)
+ &,' ! min : ',XmaxMean(4,0)
+ &, ' max : ',XmaxMean(5,0)
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=kmin,kmax
+ write(ifout,'(8x,a9,8x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a,$)')'!Av (g/cm^2) !'
+ do ip=kmin,kmax
+ write(ifout,'(3x,f8.2,a4,f7.2,3x,a1,$)')XmaxMean(1,ip)
+ & ,' +/-',XmaxMean(2,ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)
+ iz=nminX+ix
+ zi=zshmin+delzsh*(iz-1)
+ write(ifout,'(1p,e13.5,90e13.5)')zi,(XmaxProf(iz,ip)
+ & ,XmaxProf(iz,ip)/sqrt(max(1.d0,XmaxMean(3,ip))),ip=kmin,kmax)
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ do ip=1,kmax-kmin
+ if(ip.le.9)write(ifout,'(a,i1,a,$)')' plot xmlept+',ip,'-'
+ if(ip.gt.9)write(ifout,'(a,i2,a,$)')' plot xmlept+',ip,'-'
+ enddo
+ ip=kmax-kmin+1
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot xmlept+',ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot xmlept+',ip
+ write(ifout,'(a)')' '
+ endif
+
+ elseif(ifout.eq.ifho)then !begin fit plot
+
+ write(ifout,'(a)')
+ &'!- X profile for charged particle with Gaisser-Hillas fit -'
+ write(ifout,'(a)') 'openhisto name xfit'//mean
+ write(ifout,'(a)') 'htyp lru'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,f8.0,a)')
+ & 'text 0.3 0.2 "Xfirst (g/cm^2!) = ',Xfirst,'"'
+ distL=abs(distance0(Xfirst))
+ write(ifout,'(a,f8.0,a)')
+ & 'text 0.3 0.3 "H first int (m) = ',heightt(distL,radtr0),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.55 "N?max! = ',XmaxShow(4,1),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.5 "X?0! = ',XmaxShow(4,2),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.45 "X?max! = ',XmaxShow(4,3),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.4 "P?1! = ',XmaxShow(4,4),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.35 "P?2! = ',XmaxShow(4,5),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.3 "P?3! = ',XmaxShow(4,6),'"'
+ write(ifout,'(a,1p,e11.3,a)')
+ &'text 0.7 0.25 "[h]^2! = ',XmaxShow(2,0),'"'
+ write(ifout,'(a)') 'txt "xaxis depth (g/cm^2!)"'
+ mrk=1
+ ip=0
+ ic=1
+ write(ifout,'(a)') 'txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ write(ifout,*)'array 2'
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ y=1.d0
+ xlambda=XmaxShow(4,4)+XmaxShow(4,5)*zi+XmaxShow(4,6)*zi**2.d0
+ denom=XmaxShow(4,3)-XmaxShow(4,2)
+ xnum=max(0.d0,zi-XmaxShow(4,2))
+ if(abs(xlambda*denom*xnum).gt.0.d0)then
+ xdelta=max(-200.d0,min(200.d0,(XmaxShow(4,3)-zi)/xlambda))
+ y=XmaxShow(4,1)*EXP(xdelta)
+ & *(xnum/denom)**(denom/xlambda)
+ endif
+ write(ifout,'(1p,e13.5,90e13.5)')zi,y
+ end do
+ write(ifout,'(a)')' endarray'
+ write(ifout,'(a)')'closehisto'
+ write(ifout,'(a)')'plot xfit'//mean(1:ile)//'-'
+ write(ifout,'(a)')
+ &'plot -htyp pnt xlept'//mean(1:ile)//'+1'
+
+ endif !end fit plot
+ endif !end Xmax and fit
+
+ endif !end EM plot
+
+
+ if(k2.ge.3)then !begin Hadron plot
+ kmin=max(k1,3)
+ kmax=k2
+ write(ifout,'(a)')
+ &'!-------------------- X profile for hadrons --------------------'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name xhadr'//mean
+ if(ier.eq.1)write(ifout,'(a)') 'htyp lin'
+ if(ier.eq.2)write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod log'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ if(ier.eq.1)
+ &write(ifout,'(a,f6.2,a,1p,e10.3,a)')
+ & 'text 0.1 0.95 "theta =',thetas,'deg, Maximum Had. Energy'
+#ifndef __CXCORSIKA__
+ & ,EHaMax,' GeV"'
+ if(ier.eq.1)write(ifout,'(a,2(f8.2),a)')
+ & 'text 0.1 0.85 "S1000(VEM) : '
+ & ,(SD1000(k),k=3,4),'"'
+ if(ier.eq.2)write(ifout,'(a,2(f8.2),a)')
+ & 'text 0.1 0.85 "S1000(VEM) : '
+ & ,(SD1000m(k)/anorm,k=3,4),'"'
+#endif
+ if(iXmax.ge.1)then
+ if(ier.eq.2)then
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.3 0.15 "Xmax (g/cm^2!) = ',XmaxMean(1,4),' +/-'
+ & ,XmaxMean(2,4),'"'
+ else
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.3 0.15 "Xmax (g/cm^2!) = ',XmaxShow(1,4),' +/-'
+ & ,XmaxShow(3,4),'"'
+ endif
+ endif
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ do ip=kmin,kmax
+ if(ier.eq.1)mrk=0
+ if(ier.eq.2)mrk=19
+ do ic=1,mxExpro
+ mrk=mrk+1
+ if(ier.eq.1)then
+ write(ifout,'(a)') '+ txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' 1 L"'
+ if(ic.eq.1)write(ifout,'(a)') ' tline ful'
+ else
+ write(ifout,'(a)') '++ txt "yaxis number of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' "'
+ if(ic.eq.1)write(ifout,'(a)') ' mark fci'
+ endif
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ enddo
+ if(ier.eq.1)then
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ else
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+ endif
+c Xmax
+ if(iXmax.ge.1)then
+ if(ier.eq.1)write(ifout,'(a,f10.2,2(a,1p,e10.3))')'! Xmax : '
+ &,XmaxShow(1,4),' +/- ',XmaxShow(1,4)*XmaxShow(3,4),' ! chi2 '
+ &,XmaxShow(2,4)
+ if(ier.eq.2)write(ifout,'(a,f10.2,a,1p,e10.3,0p,2(a,f10.2))')
+ &'! Xmax : ',XmaxMean(1,4),' +/- ',XmaxMean(2,4)
+ &,' ! min : ',XmaxMean(4,4)
+ &, ' max : ',XmaxMean(5,4)
+ endif
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=kmin,kmax
+ if(ier.eq.1)write(ifout,'(15x,a9,14x,a1,$)')ptyp(ip),'!'
+ if(ier.eq.2)write(ifout,'(34x,a9,34x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a1,2x,a,$)')'!','(g/cm^2) !'
+ do ip=kmin,kmax
+ do ic=1,mxExpro
+ if(ier.eq.1)write(ifout,'(a11,1x,a1,$)')etyp(ic,ip),'!'
+ if(ier.eq.2)write(ifout,'(7x,a11,7x,a1,$)')etyp(ic,ip),'!'
+ enddo
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier*mxExpro*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ if(ier.eq.1)then
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,((XProf(iz,ic,ip),ic=1,mxExpro),ip=kmin,kmax)
+ else
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,((XmeanP(iz,ic,ip)/anorm
+ & ,sqrt(max(0.d0,XmeanP2(iz,ic,ip)-XmeanP(iz,ic,ip)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm)),ic=1,mxExpro),ip=kmin,kmax)
+ endif
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ do ip=1,mxExpro*(kmax-kmin+1)-1
+ if(ip.le.9)write(ifout,'(a,a1,i1,a,$)')' plot xhadr'//mean(1:ile)
+ & ,'+',ip,'-'
+ if(ip.gt.9)write(ifout,'(a,a1,i2,a,$)')' plot xhadr'//mean(1:ile)
+ & ,'+',ip,'-'
+ enddo
+ ip=mxExpro*(kmax-kmin+1)
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot xhadr'//mean(1:ile)//'+'
+ $ ,ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot xhadr'//mean(1:ile)//'+'
+ $ ,ip
+ endif
+c Xmax
+ if(iXmax.ge.1.and.ier.eq.2)then
+ if(iXmax.eq.1)then
+ kmin=4
+ kmax=4
+ endif
+ write(ifout,'(a)')
+ &'!-------------- Xmax distr. for hadrons --------------'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name xmhadr'
+ write(ifout,'(a)') 'htyp his'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.1 0.95 "Hadron Xmax (g/cm^2!) = ',XmaxMean(1,4),' +/-'
+ & ,XmaxMean(2,4),'"'
+ write(ifout,'(a)') '- txt "xaxis X?max! (g/cm^2!)"'
+ mrk=0
+ do ip=kmin,kmax
+ mrk=mrk+1
+ if(mod(mrk,6).eq.0)mrk=1
+ write(ifout,'(a)')'++ txt "yaxis dN/dX?max! of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' '' 1 L"'
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ write(ifho,'(a,d22.14)') 'histoweightbin ',anorm
+ endif
+ write(ifout,'(a,f10.2,a,1p,e10.3,0p,2(a,f10.2))')
+ &'! Xmax : ',XmaxMean(1,4),' +/- ',XmaxMean(2,4)
+ &,' ! min : ',XmaxMean(4,4)
+ &, ' max : ',XmaxMean(5,4)
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=kmin,kmax
+ write(ifout,'(8x,a9,8x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a,$)')'!Av (g/cm^2) !'
+ do ip=kmin,kmax
+ write(ifout,'(3x,f8.2,a4,f7.2,3x,a1,$)')XmaxMean(1,ip)
+ & ,' +/-',XmaxMean(2,ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)
+ iz=nminX+ix
+ zi=zshmin+delzsh*(iz-1)
+ write(ifout,'(1p,e13.5,90e13.5)')zi,(XmaxProf(iz,ip)
+ & ,XmaxProf(iz,ip)/sqrt(max(1.d0,XmaxMean(3,ip))),ip=kmin,kmax)
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+ do ip=1,kmax-kmin
+ if(ip.le.9)write(ifout,'(a,i1,a,$)')' plot xmhadr+',ip,'-'
+ if(ip.gt.9)write(ifout,'(a,i2,a,$)')' plot xmhadr+',ip,'-'
+ enddo
+ ip=kmax-kmin+1
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot xmhadr+',ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot xmhadr+',ip
+ write(ifout,'(a)')' '
+ endif
+ endif
+
+ write(ifout,'(a)') !muon production rate
+ &'!--------------- X profile for muon production ----------------'
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') 'openhisto name xdmu'//mean
+ if(ier.eq.1)write(ifout,'(a)') 'htyp lin'
+ if(ier.eq.2)write(ifout,'(a)') 'htyp pnt'
+ write(ifout,'(a)') 'xmod lin ymod lin'
+ write(ifout,*) 'xrange ',XminP,XmaxP
+ write(ifout,'(a)') 'yrange auto auto '
+ write(ifout,'(a,1p,e10.3,a)')
+ & 'txt "title Prim. Engy (eV) =',eprima*fev,'"'
+ write(ifout,'(a,f8.0,a,f8.2,a)')
+ & 'text 0.4 0.15 "dXMuMax (g/cm^2!) = ',XmaxMean(1,3),' +/-'
+ & ,XmaxMean(2,3),'"'
+ if(ier.eq.1)then
+ write(ifout,'(a,f6.2,a)')
+ & 'text 0.1 0.95 "theta =',thetas,'"'
+#ifndef __CXCORSIKA__
+ write(ifout,'(a,1p,3(e11.3),a)')
+ & 'text 0.1 0.85 "Truncated number of muons : '
+ & ,(MuTrunc(k),k=1,mxExpro),'"'
+#endif
+ endif
+ write(ifout,'(a)') '- txt "xaxis depth (g/cm^2!)"'
+ do ip=3,3
+ if(ier.eq.1)mrk=0
+ if(ier.eq.2)mrk=19
+ do ic=1,1
+ mrk=mrk+1
+ if(ier.eq.1)then
+ write(ifout,'(a)') '+ txt "yaxis produc. of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' 1 L"'
+ if(ic.eq.1)write(ifout,'(a)') ' tline ful'
+ else
+ write(ifout,'(a)') '++ txt "yaxis produc. of '//ptyp(ip)//'"'
+ write(ifout,'(a,i2,a)')' txt "refer key ',mrk
+ $ ,' '''//ptyp(ip)//' cutoff :'//etyp(ic,ip)//''' "'
+ if(ic.eq.1)write(ifout,'(a)') ' mark fci'
+ endif
+ write(ifout,'(a)') ' colo '//color(ip)
+ enddo
+ enddo
+ if(ier.eq.1)then
+ write(ifho,'(a,d22.14)') 'histoweight ',1.d0
+ else
+ write(ifho,'(a,d22.14)') 'histoweight ',anorm
+ endif
+ endif
+c Xmax
+c column names
+ write(ifout,'(a,6x,a,5x,a1,$)')'!','X','!'
+ do ip=3,3
+ if(ier.eq.1)write(ifout,'(15x,a9,14x,a1,$)')ptyp(ip),'!'
+ if(ier.eq.2)write(ifout,'(34x,a9,34x,a1,$)')ptyp(ip),'!'
+ enddo
+ write(ifout,'(a1)')' '
+ write(ifout,'(a1,2x,a,$)')'!','(g/cm^2) !'
+ do ip=3,3
+ do ic=1,1
+ if(ier.eq.1)write(ifout,'(a11,1x,a1,$)')etyp(ic,ip),'!'
+ if(ier.eq.2)write(ifout,'(7x,a11,7x,a1,$)')etyp(ic,ip),'!'
+ enddo
+ enddo
+ write(ifout,'(a1)')' '
+c end column names
+ if(ifout.eq.ifho)then
+ write(ifout,*)'array ',-1-ier!*mxExpro*(kmax-kmin+1)
+ endif
+ do ix=0,(nmaxX-nminX)/nbin
+ iz=nminX+ix*nbin
+ zi=zshmin+delzsh*(iz-1)
+ if(ier.eq.1)then
+ write(ifout,'(1p,e13.5,90e13.5)')zi,XdMu(iz)
+c & ,((XdMu(iz,ic,ip),ic=1,mxExpro),ip=kmin,kmax)
+ else
+ write(ifout,'(1p,e13.5,90e13.5)')zi
+ & ,((XdMuMean(iz)/anorm
+ & ,sqrt(max(0.d0,XdMuMean2(iz)-XdMuMean(iz)**2/anorm)
+ & /(max(anorm-1.d0,1.d0)*anorm)),ic=1,1),ip=3,3)
+ endif
+ end do
+ if(ifout.eq.ifho)then
+ write(ifout,'(a)') ' endarray'
+ write(ifout,'(a)') 'closehisto'
+c do ip=1,mxExpro*(kmax-kmin+1)-1
+c if(ip.le.9)write(ifout,'(a,a1,i1,a,$)')' plot xdmu'//mean(1:ile)
+c & ,'+',ip,'-'
+c if(ip.gt.9)write(ifout,'(a,a1,i2,a,$)')' plot xdmu'//mean(1:ile)
+c & ,'+',ip,'-'
+c enddo
+ ip=1 !mxExpro*(kmax-kmin+1)
+ if(ip.le.9)write(ifout,'(a,i1)') ' plot xdmu'//mean(1:ile)//'+'
+ $ ,ip
+ if(ip.gt.9)write(ifout,'(a,i2)') ' plot xdmu'//mean(1:ile)//'+'
+ $ ,ip
+ endif
+ endif !end hadron plot
+
+
+ if(ifout.eq.ifho)then
+ if(ier.eq.1)write(ifout,'(a)')'resethisto'
+ if(ier.eq.2)then
+ write(ifout,'(a)')'set ihcol 0'
+ write(ifout,'(a)')'set ipmci 0'
+ endif
+ endif
+ write(ifout,'(a)')' '
+
+ endif
+
+
+ end
+
+
+c----------------------------------------------------------------------
+ subroutine Profana(z1i,z2i,E1,E2,wt,id,iimode) !tp081003
+c-----------------------------------------------------------------------
+c analyzes a particle going from z1 to z2 (in CE mode, z1=z2=bin number)
+c for output profile.
+c id = nexus/isajet particle id (999 = lost energy)
+c z1,z2 = slant depth in g/cm^2
+c E1,E2 = kinetic energy in GeV,GeV/c^2
+c wt = weight
+c iimode = particle from CE (=0) or MC (=1,2,3,4,5)
+c (if 1 or 2 , count energy until max depth)
+c if id = 999, : 1 = E1 and E2 are the same
+c -1 = E1 is energy for energy balance
+c E2 is energy for energy deposit
+c 2 = energy is lost
+c 10 (MC) or -10 (CE) to count muon production rate
+c in case of abs(id)<=1 we have EGS4 which means:
+c 0 = photon
+c -1 = electron
+c 1 = positron
+c E is in MeV units
+c In MC mode, we can compare E with the cutoff to count or not the particle,
+c but in CE mode, since E has some fixed value, we have to count only the
+c particles which are above the cutoff in one bin of width c(=10**(1/decade).
+c (here we assume a 1/E distribution for the particles in a bin).
+c T. Pierog, 24.09.2003 - last modification : 28.06.2004
+c-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ logical go,up
+ dimension Ecut(mxExpro)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.10)write(ifck,*)'Profana',iimode,z1i,E1,z2i,E2,wt,id
+#endif
+
+c RU Sun Oct 16 21:37:51 CEST 2011
+c this is a construct useful for shower-disection, interaction-wise:
+c muons are only counted from MC (->decays)
+ if (particleListMode.eq.1) then
+ if (id.eq.14) then
+ if (iimode.le.0) then
+ return
+ endif
+c write(*,*)'rudebug Profana',iimode,z1i,E1,z2i,E2,wt,id
+ endif
+ endif
+c RU-end
+
+ z1=z1i
+ z2=z2i
+ ee1=E1
+ ee2=E2
+ ida=abs(id)
+ if(ida.le.13)then !electromagnetic particles
+ c2=c2em
+ E0=Eo
+ dndec=emdecade
+ if(ida.le.1.and.iimode.ne.0)then
+ ee1=ee1/1000.d0 ! means EGS4 which has MeV units
+ ee2=ee2/1000.d0 ! means EGS4 which has MeV units
+ endif
+ do ic=1,mxExpro
+ Ecut(ic)=EMCutP(ic)
+ enddo
+c sq=0d0 !energy distribution in EM CE : (1/E)**(sq+1)
+c csp=c2**sq
+c csm=c2**(-sq)
+c csmp=csm-csp
+ else
+ c2=c2bas
+ E0=exmin
+ dndec=decade
+ do ic=1,mxExpro
+ Ecut(ic)=HaCutP(ic)
+ enddo
+c sq=0d0 !energy distribution in hadronic CE : (1/E) (assumed)
+ endif
+
+ up=.false.
+ if(iimode.ne.0.and.iimode.ne.-10)then
+ iz1=int((z1-zshmin)/delzsh)+1
+ iz2=int((z2-zshmin)/delzsh)+1
+ dz=abs(z2-z1)
+ if(dz.le.1.d-20.and.iimode.ne.10)then
+ if(z1.gt.0.1d0.and.iz1.lt.musZ.and.iimode.ne.5)then
+#ifndef __MC3D__
+#ifndef __CXCORSIKA__
+ write(*,*)'In Profana for MC, z1=z2 !',iimode,z1i,E1,z2i,E2,id
+#else
+#ifdef __CXDEBUG__
+ write(ifck,*)'In Profana for MC, z1=z2 !',iimode,z1i,E1,z2i,E2,id
+#endif
+#endif
+#endif
+ endif
+ return
+ endif
+ if(ida.eq.999)dz=delzsh
+ if(iz2.lt.iz1)then
+ izt=iz1
+ iz1=max(0,iz2)
+ iz2=izt
+ zt=z1
+ z1=max(zshmin,z2)
+ z2=zt
+ up=.true. !upward gowing particle
+ endif
+ if(iz1.lt.0.and.iz2.ge.1)iz1=0
+ else
+ iz1=nint(z1)
+ iz2=nint(z2)
+ dz=delzsh
+ if(iz1.ne.iz2)write(*,*)'In Profana for CE, z1.ne.z2 !'
+ c=c2*c2
+ if(id.ge.-1)ie=1+int(log10(ee2*c2/E0)*dndec)
+ delc=1.d0/log(c)
+ iz1=iz1-1
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.11)write(ifck,*)'Profana bins',iz1,iz2,dz,up
+#endif
+
+ if(iz1+1.lt.1.or.iz1.ge.musZ)return
+ if(iz2.lt.1)then
+ return
+ else
+ iz2=min(iz2,musZ)
+ endif
+
+ if(abs(iimode).eq.10)then !count muon production rate
+ XdMu(iz2)=XdMu(iz2)+wt/delzsh
+ return
+ endif
+
+
+ in=0
+ ine=-1
+ ineb=0
+ ied=0
+ ebal=ee1
+ edep=0.d0
+ elast=0.d0
+ if(id.eq.0.or.id.eq.10)then
+ in=1 !photon
+ ine=2 !not charged
+ ineb=1!e/m particle
+ ied=in !depose energy
+ elast=ee2/delzsh
+ elseif(ida.eq.1)then
+ in=2 !electron+positron
+ ine=1 !charged
+ ineb=1!e/m particle
+ ied=in !depose energy
+c To solve the problem of rest mass of electr we don't count the mass of the e-
+c but we con't 2 times the mass of the e+
+ elast=ee2
+ if(lxfirst)then
+ if(id.gt.0)then
+ ebal=ebal+2.d0*pmass(10) !count double mass for positrons
+ elast=elast+2.d0*pmass(10)
+ endif
+ else
+ elast=elast+pmass(10)
+ ebal=ebal+pmass(10)
+ endif
+ edep=(ee1-ee2)/dz
+ elast=elast/delzsh
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(id.lt.0)in=-1 !electron
+#endif
+ elseif(ida.eq.12)then !electron and positron produced from hadrons
+ in=2 !electron+positron
+ ine=1 !charged
+ ied=in !depose energy
+ ineb=1!e/m particle
+c To solve the problem of rest mass of electr we don't count the mass of the e-
+c but we con't 2 times the mass of the e+
+ elast=ee2
+ ebal=ebal+pmass(10) !count mass for electrons or positrons from hadrons
+ if(id.lt.0)elast=elast+2.d0*pmass(10) !count double mass for positrons energy deposit
+ edep=(ee1-ee2)/dz
+ elast=elast/delzsh
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(id.gt.0)in=-1 !electron
+#endif
+ elseif(ida.eq.14)then
+ in=3 !muon
+ ine=1 !charged
+ ineb=4!muon
+ ebal=ebal+pmass(9) !count mass for muons
+ ied=5 !depose energy ---> warning, ied=3 is used for id=999
+ edep=(ee1-ee2)/dz
+ elast=(ee2+pmass(9))/delzsh/3.d0
+ elseif(ida.eq.120) then
+ in=6 !pi+ pi-
+ ine=1
+ ineb=2!hadron
+ ied=in !depose energy
+ ebal=ebal+pmass(2) !count mass for mesons
+ edep=(ee1-ee2)/dz
+ elast=(ee2+pmass(2))/delzsh/4.d0
+ elseif(ida.eq.130)then
+ in=7 !K+ K-
+ ine=1
+ ineb=2!hadron
+ ied=in !depose energy
+ ebal=ebal+pmass(3) !count mass for mesons
+ edep=(ee1-ee2)/dz
+ elast=(ee2+pmass(3))/delzsh/4.d0
+ elseif(ida.eq.1120) then
+ in=8 !proton
+ ine=1
+ ineb=2!hadron
+ ebal=ebal+pmass(1)
+ elast=ee2
+ if(lxfirst)then
+ if(id.lt.0)then
+ ebal=ebal+pmass(7) !count mass + mean nucleon mass for antiproton
+ elast=elast+pmass(1)+pmass(7) !annihilation
+ if(iimode.eq.0)in=0
+ else
+ ebal=ebal-pmass(7) !to count nucleon mass coming from nucleus
+ endif
+ else
+ elast=elast+pmass(1)
+ endif
+ ied=in !depose energy
+ edep=(ee1-ee2)/dz
+ elast=elast/delzsh
+ elseif(id.eq.-1170) then !anti nucleon from CE
+ ine=2
+ ineb=2!hadron
+ ebal=2.d0*pmass(7)
+ elseif(ida.eq.1220) then
+ in=9 !neutron
+ ine=2
+ ineb=2!hadron
+ ebal=ebal+pmass(6)
+ if(lxfirst)then
+ if(id.lt.0)then
+ ebal=ebal+pmass(7) !count mass + mean nucleon mass for antineutron
+ elast=ee2+pmass(6)+pmass(7)
+ if(iimode.eq.0)in=0
+ ied=in
+ else
+ ebal=ebal-pmass(7) !to count nucleon mass coming from nucleus in MC
+ endif
+ else
+ elast=elast+pmass(6)
+ endif
+ elast=elast/delzsh
+ elseif(ida.eq.20) then
+ in=10 !Kl Ks
+ ine=2
+ ineb=2 !hadron
+ ebal=ebal+pmass(4) !count mass for mesons
+ ied=in
+ elast=(ee2+pmass(4))/delzsh/2.d0
+ elseif(ida.eq.2130) then
+ in=mxPxpro+1 !lambda (counted into hadrons but not nucleons)
+ ine=2
+ ineb=2 !hadron
+ ied=in !depose energy
+ elast=ee2+pmass(8)
+ ebal=ebal+pmass(8)
+ if(lxfirst)then
+ if(id.lt.0)then
+ ebal=ebal+pmass(7) !count mass + mean nucleon mass for antilambda
+ elast=elast+pmass(7)
+ else
+ elast=elast-pmass(7) !at the end, only nucleon mass
+ ebal=ebal-pmass(7)
+ endif
+ endif
+ elast=elast/delzsh
+ elseif(id.ge.100.and.mod(id,100).eq.0) then !nuclei
+ ine=1
+ ied=100 !depose energy
+ ineb=2 !hadron
+ anumass=dptl(5)
+ ebal=ebal+anumass-dble(id/100)*pmass(7)
+ edep=(ee1-ee2)/dz
+ elast=(ee2+anumass)/delzsh
+ elseif(ida.eq.999) then
+ ine=3
+ ineb=3 !lost or deposed
+ if(iimode.eq.1)then
+ ied=3 !depose energy
+ elast=ee1/dz
+ elseif(iimode.eq.-1)then !electrons from hadronic interaction : depose kinetic energy but total energy for balance.
+ ied=3 !depose energy
+ elast=ee2/dz
+ endif
+ endif
+
+c Energy Balance
+
+ if(iwrt.ge.2.and.ineb.gt.0)then
+
+
+ ede=0.d0
+ edet=wt*ebal
+c ionization loss energy
+ if(ine.le.2.and.iz1.ne.musZ)
+ & ede=wt*(ee1-ee2)/dble(min(iz2,musZ-1)-iz1+1)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.11)write(ifck,*)'Bal',ineb,edet,ede,iz1,iz2
+#endif
+
+
+ do iz=iz1+1,iz2
+ edet=edet-ede
+ Ebalan(iz,ineb)=Ebalan(iz,ineb)+edet
+ enddo
+
+ if(ine.le.2)then !for real particle
+ edet=0.d0
+ go=.false.
+ if(abs(iimode).eq.1.or.iimode.eq.2.or.z2.ge.dphmaxi0)then
+ edef=wt*ebal !lost particles
+ go=.true.
+ endif
+ if(go.or.ede.gt.0.d0)then
+ edet=0.d0
+ do iz=min(iz1+1,musZ),musZ
+ if(iz.le.iz2+1)then !ionization loss
+ edet=edet+ede
+ if(iz.eq.iz2+1.and.go)edet=edef !lost particle
+ endif
+ Ebalan(iz,3)=Ebalan(iz,3)+edet
+ enddo
+ if(go)edet=edef
+ elseif(iz1.eq.musZ)then
+ edet=wt*(ee1-ee2)
+ endif
+ endif
+
+#ifdef __CXDEBUG__
+ etotlost=etotlost+edet !energy balance for debugging
+#endif
+
+c longitudinal energy deposit of particles
+
+ if(ied.ge.1.and.iimode.ne.0)then
+
+ izf=iz2
+ elastb=0.d0
+ ede=edep*wt
+ ifmode=abs(iimode)
+ if(ifmode.eq.1)then
+ elastb=elast*wt
+ izf=iz1 !energy is deposed in the previous bin
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.11)write(ifck,*)'Depo',ied,ede,elastb,iz1,izf
+#endif
+ if(ede.gt.0.d0)then
+
+ do iz=max(iz1,1),izf
+ if(izf.eq.iz1)then
+ dedz=ede*dz/delzsh
+ elseif(iz.eq.iz1)then
+ dedz=ede*(zha(iz1+1)-z1)/delzsh
+ elseif(iz.eq.izf)then
+ dedz=ede*(z2-zha(izf))/delzsh
+ else
+ dedz=ede
+ endif
+ Edepo(iz,0)=Edepo(iz,0)+dedz
+ if(ied.le.mxPxpro)Edepo(iz,ied)=Edepo(iz,ied)+dedz !particle
+ if(ied.ge.6.and.ied.lt.100)
+ & Edepo(iz,4)=Edepo(iz,4)+dedz !hadrons
+ enddo
+
+ endif
+
+c if particle disappear, put its energy into the current bin
+
+ if(ifmode.eq.1)then
+
+ izf=max(1,min(izf,musZ))
+ Edepo(izf,0)=Edepo(izf,0)+elastb
+ if(ied.le.mxPxpro)Edepo(izf,ied)=Edepo(izf,ied)+elastb !particles
+ if(ied.ge.6.and.ied.lt.100)
+ & Edepo(izf,4)=Edepo(izf,4)+elastb !hadrons
+ endif
+
+ endif
+
+ endif
+
+
+ if(in.eq.0)return !particle not ploted
+
+
+ if(iz1.eq.iz2)return !do not cross any depth plane
+
+c longitudinal profile of particles
+
+ do 10 ic=1,mxExpro !loop over the cutoff
+
+ izf=iz2
+
+ if(iimode.ne.0)then !for MC direct test
+ if(ee1.lt.Ecut(ic))then
+ goto 10
+ elseif(ee2.lt.Ecut(ic))then !when particle cross energy threshold
+ dedz=edep !during its propagation
+ ee=Ecut(ic)
+ z=z1+(ee-ee1)/dedz !maximum z above energy cut off
+ izf=min(int((z-zshmin)/delzsh)+1,musZ)
+ endif
+ anum=wt !add all only if above cutoff
+ else !for CE calculate part to add
+ ee=ee2
+ if(ee*c2.le.Ecut(ic))then
+ goto 10
+ elseif(ee/c2.le.Ecut(ic) !if Ecut above the min limit of the bin and below the maximum limit
+ & .and.Ecut(ic).lt.eprima !and lower than primary energy
+ & .and.(ie.ne.1.or.Ecut(ic).gt.E0))then !(for ie=1, minlim=E0)
+c number of particle, from Ecut to max bin limit, to add to the histogram
+c if(sq.eq.0.d0)then
+ anum=0.5d0+delc*log(ee/Ecut(ic))
+c else
+c anum=(csm-(ee/Ecut(ic))**sq)/csmp
+c endif
+ else !else we count all
+ anum=1.d0
+ endif
+ anum=anum*wt
+ endif
+
+c longitudinal profile
+
+ if(.not.up.and.iz1.lt.izf)then
+
+ do iz=iz1+1,izf
+ if(in.le.mxPxpro)XProf(iz,ic,in)=XProf(iz,ic,in)+anum !particle
+ if(ine.eq.1)XProf(iz,ic,0)=XProf(iz,ic,0)+anum !charged
+ if(in.ge.6)XProf(iz,ic,4)=XProf(iz,ic,4)+anum !hadrons
+ if(in.eq.8.or.in.eq.9)XProf(iz,ic,5)=XProf(iz,ic,5)+anum !nucleons
+ enddo
+
+ endif
+
+ 10 enddo
+
+
+ end
+
+c----------------------------------------------------------------------
+ subroutine cana2(h1,x01,y01,x1,y1,dist1,z1,t1,E1,h2,x02,y02,x2
+ $ ,y2,dist2,z2,t2,E2,px,py,pz,am,wt,gen,idi,iimode)
+c-----------------------------------------------------------------------
+c previous version with all moments
+c analyzes a particle going from (x1,y1,dist1,z1,t1) to (x2,y2,dist2,z2,t2)
+c
+c id = nexus/isajet particle id
+c x01,y01,dist1,x02,y02,dist2 = position in meter
+c (x0,y0 from shower axis and slant distance to the obs level)
+c (x,y in the obs frame)
+c h1,h2 = height (m)
+c z1,z2 = slant depth in g/cm^2
+c t1,t2 = time in meter
+c divide by 0.299792458 to get nano-seconds
+c E1,E2 = total energy in GeV,GeV/c^2
+c px,py,pz,am = momentum,mass in GeV,GeV/c^2 at the end in shower frame
+c wt = weight
+c gen = generation
+c iimode = particle below the cutoff (1) or reaches ground
+c (or leaves atmo) (2)
+c
+c in case of abs(id)<=1 we have EGS4 which means:
+c 0 = photon
+c -1 = electron
+c 1 = positron
+c px,py,pz are the directional vectors
+c (not necessarily normalized to 1, but almost)
+c E and am are in MeV units
+c
+c DO not use cana AND cana2 together
+c-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#ifdef __ANALYSIS__
+ logical lpi0
+#endif
+#ifdef __COAST__
+#if __CXCORSIKA__ || __CORSIKA8__
+ COMMON /CXCONVE/CXXCONV,CXYCONV,CXTCONV
+ DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV
+#endif
+ dimension ep(3)
+c definition of the COAST crs::CParticle class
+ common/coastTrackStart/pnt1x, pnt1y, pnt1z, pnt1d, pnt1t,
+ & pnt1e, pnt1w, pnt1id, pnt1gen
+ common/coastTrackEnd/pnt2x, pnt2y, pnt2z, pnt2d, pnt2t,
+ & pnt2e, pnt2w, pnt2id, pnt2gen
+ double precision pnt1x, pnt1y, pnt1z, pnt1d, pnt1t, pnt1e, pnt1w
+ integer pnt1id, pnt1gen
+ double precision pnt2x, pnt2y, pnt2z, pnt2d, pnt2t, pnt2e, pnt2w
+ integer pnt2id, pnt2gen
+#endif
+
+ id=idi
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,*)'cana2',iimode,z1,E1,z2,E2,wt,gen
+ & ,id,iimode,x1,y1,h1,x2,y2,h2
+#endif
+ if(iwrt.ne.0.and.id.ne.110.and.id.ne.-10)then
+ call Profana(z1,z2,E1-am,E2-am,wt,id,iimode)
+#ifndef __CXCORSIKA__
+ if(h2.lt.0.99d0*eatm(mxatm+1).and.iimode.eq.2)then
+ call AugerSignal(x02,y02,E2-am,wt,id)
+ if(abs(id).eq.14)then
+ call TruncatedMu(x2,y2,E2-am,wt)
+ elseif(abs(id).ge.100)then
+ call HadronEnergy(E2-am,wt)
+ endif
+ endif
+#endif
+ endif
+
+#ifdef __COAST__
+
+ P=sqrt(px**2+py**2+pz**2) !momentum
+ Pinv=1.d0/P !inverse momentum
+ ep(1)=px*Pinv
+ ep(2)=py*Pinv
+ ep(3)=pz*Pinv
+ call ToObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P in Obs. frame
+#ifdef __CXCORSIKA__
+ px0=ep(2) !(in CONEX Y=north, so X_cors= Y_conex)
+ py0=-ep(1) !(in CONEX X=east, so Y_cors=-X_conex)
+ pz0=-ep(3) !pz in OBS frame (z down in CORSIKA, up in CONEX)
+#else
+ px0=ep(1)
+ py0=ep(2)
+ pz0=ep(3)
+#endif
+C BEGINNING OF TRACKING STEP
+ if(abs(id).le.1)then
+ if(id.eq.0)then
+ idcoast=1 !photon
+ elseif(id.lt.0)then
+ idcoast=3 !electron
+ else
+ idcoast=2 !positron
+ endif
+ pnt1e = E1 * 0.001d0
+ pnt2e = E2 * 0.001d0
+ else
+ if(mod(id,100).ne.0)then !not a nucleus
+ idcoast=idtrafocx("nxs","cor",id)
+ else !nucleus
+ idcoast=id+int(dble(id/100)/2.15d0+0.7d0)
+ endif
+ pnt1e = E1
+ pnt2e = E2
+ endif
+ pnt1id = -idcoast
+#ifdef __CXCORSIKA__
+ pnt1x = y1*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ pnt1y = -x1*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+ pnt1t = t1/cxlight*1d-9 + CXTCONV !(time in sec in COAST)
+ pnt1d = z1 - XminP
+#else
+ pnt1x = x1*100d0 !(distance in cm in COAST)
+ pnt1y = y1*100d0 !(distance in cm in COAST)
+ pnt1t = t1/cxlight*1d-9 !(time in sec in COAST)
+ pnt1d = z1
+#endif
+ rdist=sqrt(x1*x1+y1*y1)
+ radh=h1+radearth
+ if(radh.gt.rdist)then
+ pnt1z = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ pnt1z = (pnt1z-radearth)*100d0
+ else
+ pnt1z = h1*100d0 !(distance in cm in COAST)
+ endif
+c pnt1ct = MIN( 1.D0, pz0 )
+c pnt1cx = px0
+c pnt1cy = py0
+ pnt1w = wt
+ pnt1gen = nint(gen)
+C END OF TRACKING STEP
+ pnt2id = -idcoast
+#ifdef __CXCORSIKA__
+ pnt2x = y2*100d0 + CXXCONV !(in CONEX Y=north, so X_cors= Y_conex)
+ pnt2y = -x2*100d0 + CXYCONV !(in CONEX X=east, so Y_cors=-X_conex)
+ pnt2t = t2/cxlight*1d-9 + CXTCONV !(time in sec in COAST)
+ pnt2d = z2 - XminP
+#else
+ pnt2x = x2*100d0
+ pnt2y = y2*100d0
+ pnt2t = t2/cxlight*1d-9
+ pnt2d = z2
+#endif
+ rdist=sqrt(x2*x2+y2*y2)
+ radh=h2+radearth
+ if(radh.gt.rdist)then
+ pnt2z = sqrt((radh-rdist)*(radh+rdist)) !h in obs frame
+ pnt2z = (pnt2z-radearth)*100d0
+ else
+ pnt2z = h2*100d0
+ endif
+c pnt2ct = MIN( 1.D0, pz0 )
+c pnt2cx = px0
+c pnt2cy = py0
+ pnt2w = wt
+ pnt2gen= nint(gen)
+#ifdef __CXDEBUG__
+ if(isx.ge.8)write(ifck,*)'track :'
+ & , idcoast,' : '
+ & , pnt1x,pnt1y,pnt1z, ' -> '
+ & , pnt2x,pnt2y,pnt2z
+#endif
+ call track(pnt1x, pnt2x)
+
+#endif
+
+#ifdef __ANALYSIS__
+
+ dz=delza
+ iz1=int((z1-zamin)/dz)+1 !so020703
+ iz1=min(iz1,numiz)
+ iz2=int((z2-zamin)/dz)+1 !so020703
+ iz2=min(iz2,numiz)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.10)write(ifck,*)'cana2 bins',iz1+1,zamin+dz*iz1,'->'
+ & ,zamin+dz*(iz2-1),iz2
+#endif
+
+ if(iz1.lt.0.and.iz2.eq.1)iz1=0
+ if(iz1.lt.0.or.iz2.le.0.or.iz1.gt.iz2)return
+
+
+
+c added----------vc300304---from cana
+ dt=log(ctime)
+ it1=1
+ it2=0
+ ci=1.d0/cxlight
+ if(t1*ci.lt.tamax.and.abs(dt).gt.0.d0)then
+ it1=-int(log(t1*ci/tamin)/dt)+1 !tp070304
+ it1=max(1,min(it1,numiz))
+ if(t2*ci.le.tamax)then
+ it2=-int(log(t2*ci/tamin)/dt)+1
+ it2=min(it2,numiz)
+ endif
+ endif
+
+ if(mode.ne.0.and.mode.ne.8)then
+ lpi0=.true.
+ else
+ lpi0=.false.
+ endif
+c added----------vc300304---from cana
+
+ ee=E1
+ ee0=E2
+ amm=am
+ ida=abs(id)
+ if(ida.le.1)then ! if (ida.le.1) means EGS4 which has MeV units
+ ee0=ee0*1.d-3
+ ee=ee*1.d-3
+ amm=am*1.d-3
+ k=1
+ else
+ k=2
+ endif
+ ee0=ee0-amm ! use kinetic energy !
+ ee=ee-amm ! use kinetic energy !
+
+ if(.not.lxfirst)then !before first interaction
+ if(id.eq.10)then
+ id=0
+ elseif(id.eq.12)then
+ id=-1
+ elseif(id.eq.-12)then
+ id=1
+ endif
+ endif
+
+
+c added----------vc300304---from cana
+ in=0
+ inti=0
+ if(id.eq.0)then
+ in=1 !photon
+c gami=0.d0
+ elseif(id.eq.-1)then
+ in=2 !electron
+ inti=-1
+c gami=pmass(10)/Eprima
+ elseif(id.eq. 1)then
+ in=3 !positron
+ inti=1
+c gami=pmass(10)/Eprima
+ elseif(ida.eq.1120) then
+ in=4 !nucleon
+ inti=sign(1,id)
+c gami=pmass(1)/Eprima
+ elseif(ida.eq.1220) then
+ in=4 !nucleon
+c gami=pmass(6)/Eprima
+ elseif(ida.eq.120) then
+ in=5 !pi+pi-
+ inti=sign(1,id)
+c gami=pmass(2)/Eprima
+ elseif(ida.eq.130) then
+ in=7 !K+K-
+ inti=sign(1,id)
+c gami=pmass(3)/Eprima
+ elseif(id.eq.-20) then
+ in=8 !Klong
+c gami=pmass(4)/Eprima
+ elseif(id.eq. 20) then
+ in=9 !Kshort
+c gami=pmass(4)/Eprima
+ elseif(ida.eq.14) then
+ inti=-sign(1,id)
+ if(inti.gt.0)then
+ in=11 !muon +
+ else
+ in=12 !muon -
+ endif
+c gami=pmass(9)/Eprima
+ elseif(id.eq.110.and.lpi0)then
+ in=6 !pi0
+ elseif(id.eq.-10.and..not.lpi0)then
+ in=6 !gamma from hadron
+c gami=0.d0
+ endif
+c added----------vc300304---from cana
+
+
+ if(in.eq.0)return
+ if(ee-eamin(k).lt.-1d-8.or.ee-eamax(k).gt.1d-8)return
+c eamin and eamax are the middle of the first and the last bin
+ cdec=(eamax(k)/eamin(k))**(1.d0/dble(numie))
+ dzi=0.d0
+ if(abs(z1-z2).gt.1d-8)dzi=1.d0/(z2-z1)
+ dedz=(ee0-ee)*dzi
+ if(ee0-eamin(k).lt.-1d-8.and.dedz.gt.0.d0)then !when particle cross energy threshold
+ ee0=eamin(k) !during its propagation
+ z=z1+(ee0-ee)/dedz !maximum z above energy cut off
+ iz2=min(numiz,int((z-zamin)/dz)+1)
+ dist=distance0(z) !slant distance to obs level
+ ratio=0.d0
+ dl=dist1-dist2
+ if(dl.gt.0.d0)ratio=(dist1-dist)/dl
+ t=t1+ratio*(t2-t1)
+ if(t*ci.le.tamax.and.abs(dt).gt.0.d0)
+ & it2=min(numiz,-int(log(t*ci/tamin)/dt)+1)
+ endif
+
+c longitudinal
+
+ if(iz1.lt.iz2.and.id.ne.110)then
+
+ do iz=iz1+1,iz2
+ yieldz(in,iz)=yieldz(in,iz)+wt
+ enddo
+ if(in.gt.10)then
+ do iz=iz1+1,iz2
+ yieldz(10,iz)=yieldz(10,iz)+wt
+ enddo
+ endif
+
+ elseif(id.eq.110.and.iz1.gt.0)then !pi0
+ yieldz(in,iz1)=yieldz(in,iz1)+wt/dz
+
+c spectra for selected depthes
+ if(mod(iz1-izfirst,modz).eq.0.and.iz1.ge.izfirst
+ & .and.1+(iz1-izfirst)/modz.le.maxjz)then
+ jz=1+(iz1-izfirst)/modz
+ ie=max(1,int(log(ee/eamin(k))/log(cdec)+1.5d0))
+ spec(0,in,ie,jz)=spec(0,in,ie,jz)+wt/dz
+ endif
+
+ endif
+
+c time
+
+ if(it1.lt.it2)then
+
+ if(in.ge.10)then
+ do it=it1+1,it2
+ yiex(10,it)=yiex(10,it)+wt
+ if(inti.ne.0)yiex(11,it)=yiex(11,it)+wt*inti !charge difference
+ enddo
+ else
+ do it=it1+1,it2
+ yiex(in,it)=yiex(in,it)+wt
+ if(inti.ne.0)yiex(11,it)=yiex(11,it)+wt*inti !charge difference
+ enddo
+ endif
+
+ endif
+
+c spectra for selected depthes
+
+ if(iz1.lt.iz2.and.id.ne.110)then
+
+#if __MC3D__ || __CXLATCE__
+ if(i1DMC.le.1.and.ida.ne.10)then
+
+ pt2=px**2+py**2
+ pp2=pt2+pz**2
+ sin2t=pt2/pp2
+ pp=sqrt(pp2)
+ cost=pz/pp
+ aa=px/pp
+ bb=py/pp
+ ddd=dist2-dist1
+
+c write(6,*) 'pp px py pz aa bb sin2t cost= ',
+c & pp, px, py, pz, aa, bb, sin2t, cost
+
+ do iz=iz1+1,iz2
+ if(mod(iz-izfirst,modz).eq.0.and.iz.ge.izfirst
+ & .and.1+(iz-izfirst)/modz.le.maxjz)then
+ jz=1+(iz-izfirst)/modz
+ zi=zamin+dz*dble(iz-1)
+ eef=ee+dedz*(zi-z1)
+ ie=max(1,int(log(eef/eamin(k))/log(cdec)+1.5d0))
+ dist=distance0(zi) !slant distance to obs level
+ dd=dist-dist1
+ t=0.d0
+ if(abs(ddd).gt.0.d0)t=dd/ddd
+
+ xx=x01+t*(x02-x01)
+ yy=y01+t*(y02-y01)
+ tt=t1+t*(t2-t1)
+ r2=xx**2+yy**2
+ r=sqrt(r2) !radial distance (m)
+ axby=aa*xx+bb*yy
+ h=heightt(dist,radtr0) !so240903
+c fct=rhoair(h)/radlth !so020703
+ rr1=sin2t
+ rr2=r2 !*fct*fct !radial distance squared (unit of radiation lenght squared)
+ rr3=axby !*fct
+
+ do ii=0,musmm
+
+ spec(ii,in,ie,jz)=spec(ii,in,ie,jz)
+ & +wt *rr1**i1mom(ii) *rr2**i2mom(ii) *rr3**i3mom(ii)
+
+
+c write(6,*) 'rr1, rr2, rr3 = ',
+c & rr1, rr2, rr3, ii, i1mom(ii), i2mom(ii),i3mom(ii)
+
+ spex(ii,in,ie,jz)=spex(ii,in,ie,jz)
+ & +wt*cost *rr1**i1mom(ii) *rr2**i2mom(ii) *rr3**i3mom(ii)
+ enddo !moments
+ if(in.gt.10)then
+ do ii=0,musmm
+ spec(ii,10,ie,jz)=spec(ii,10,ie,jz)
+ & +wt *rr1**i1mom(ii) *rr2**i2mom(ii) *rr3**i3mom(ii)
+ spex(ii,10,ie,jz)=spex(ii,10,ie,jz)
+ & +wt*cost *rr1**i1mom(ii) *rr2**i2mom(ii) *rr3**i3mom(ii)
+ enddo !moments
+ endif
+
+ if(r.gt.ramin.and.r.lt.ramax)then
+ ir=int(log(r/ramin)/log(ramax/ramin)*numir)+1
+ yieldr1(in,jz,ir)=yieldr1(in,jz,ir)+wt
+
+ if(in.gt.10)then
+ yieldr1(10,jz,ir)=yieldr1(10,jz,ir)+wt
+ endif
+
+
+ jr=1+(ir-irfirst)/modr
+ if(jr.ge.1.and.jr.le.maxjr)then
+ specr(in,ie,jz,jr)=specr(in,ie,jz,jr)+wt
+ if(in.gt.10)then
+ specr(10,ie,jz,jr)=specr(10,ie,jz,jr)+wt
+ endif
+ do i=1,4
+ xx=-1.d100
+ if(i.eq.1.and.pt2.gt.0.d0)then
+c cos(phi) distribution for a given depth and radius
+ xx=px/pt2
+ elseif(i.eq.2)then
+c sin^2(theta) distribution for a given depth and radius
+ xx=sin2t
+ elseif(i.eq.3)then
+c time distribution for a given depth and radius
+ beta=cxlight !*sqrt((1.d0-gam)*(1.d0+gam))! (minimum front time)
+ tfront=tamin+sqrt((-cxlight*tamin-dist)**2.d0
+ & +rr2)/beta
+ xx=tt*ci-tfront
+ elseif(i.eq.4)then
+c angle difference between particle position and particle direction
+ xx=atan2(yy,xx)-atan2(py,px)
+ endif
+ if(xx.gt.xamin(i).and.xx.lt.xamax(i))then
+ ix=int((xx-xamin(i))/(xamax(i)-xamin(i))*dble(numix(i)))+1
+ yieldx(i,in,jz,jr,ix)=yieldx(i,in,jz,jr,ix)+wt
+ if(in.gt.10)then
+ yieldx(i,10,jz,jr,ix)=yieldx(i,10,jz,jr,ix)+wt
+ endif
+ endif
+ enddo
+ endif
+ endif
+
+ if(mod(ie-iefirst,moden).eq.0.and.ie.ge.iefirst
+ & .and.1+(ie-iefirst)/moden.le.maxjr)then
+ je=1+(ie-iefirst)/moden
+ i=5
+c sin^2(theta) distribution for a given depth and energy
+ xx=log10(sin2t)
+ if(xx.gt.xamin(i).and.xx.lt.xamax(i))then
+ speca(in,jz,je)=speca(in,jz,je)+wt
+ if(in.gt.10)then
+ speca(10,jz,je)=speca(10,jz,je)+wt
+ endif
+ ix=int((xx-xamin(i))/(xamax(i)-xamin(i))*dble(numix(i)))+1
+ yieldx(i,in,jz,je,ix)=yieldx(i,in,jz,je,ix)+wt
+ if(in.gt.10)then
+ yieldx(i,10,jz,je,ix)=yieldx(i,10,jz,je,ix)+wt
+ endif
+ endif
+ endif
+ endif
+ enddo
+
+ else
+#else
+ if(id.ne.10)then
+#endif
+ do iz=iz1+1,iz2
+
+ if(mod(iz-izfirst,modz).eq.0.and.iz.ge.izfirst
+ & .and.1+(iz-izfirst)/modz.le.maxjz)then
+ jz=1+(iz-izfirst)/modz
+ z=zamin+dz*dble(iz-1)
+ eef=ee+dedz*dble(z-z1)
+ ie=max(1,int(log(eef/eamin(k))/log(cdec)+1.5d0))
+ spec(0,in,ie,jz)=spec(0,in,ie,jz)+wt
+ if(in.gt.10)then
+ spec(0,10,ie,jz)=spec(0,10,ie,jz)+wt
+ endif
+ endif
+
+ enddo
+
+ endif
+
+ endif
+
+#endif
+
+ end
+
+#ifndef __CXCORSIKA__
+c----------------------------------------------------------------------
+ subroutine AugerSignal(x1,x2,Eki,wt,id)
+c-----------------------------------------------------------------------
+c S1000 at ground for Auger (VEM)
+c T. Pierog, 04.11.2008 - last modification : 04.11.2008
+c-----------------------------------------------------------------------
+
+ implicit none
+#include "conex.h"
+#include "conexep.h"
+ double precision x1,x2,r,wt,Ek,S1000,EKi
+ integer id,k
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'AugerSignal',x1,x2,Eki,wt,id
+#endif
+
+ r=sqrt(x1*x1+x2*x2)
+
+
+ if(r.ge.970.and.r.le.1030)then
+ Ek=Eki
+ if(abs(id).le.1)Ek=Eki*0.001d0
+c add wt/(1020^2-980^2)/pi*11 for density (11m2 = tank surface, 240MeV=1VEM)
+ S1000=2.91784d-5*wt
+ if(Ek.gt.0.0015.and.id.eq.0)then
+ if(EK.lt.0.15d0)then
+ S1000=S1000*3.33333d0*(Ek-0.0015d0) !3.333=0.8/0.24 -> from fit
+ else
+c from fit of detector response to gamma and electron E->VEM
+ S1000=S1000*(2.08333d0*min(5d0,Ek)**0.75d0
+ & +sqrt(log10(max(5d0,Ek))-0.69897d0))
+ endif
+ SD1000(0)=SD1000(0)+S1000 !all
+ SD1000(1)=SD1000(1)+S1000 !gamma
+c print *,id,SD1000(1),S1000,Ek,wt,wt*min(Ek,0.24d0)/0.24d0
+ elseif(Ek.gt.0.0015.and.abs(id).eq.1)then
+ if(EK.lt.0.15d0)then
+ S1000=S1000*3.33333d0*(Ek-0.0015d0) !3.333=0.8/0.24 -> from fit
+ else
+c from fit of detector response to gamma and electron E->VEM
+ S1000=S1000*(2.08333d0*min(5d0,Ek)**0.75d0
+ & +sqrt(log10(max(5d0,Ek))-0.69897d0))
+ endif
+ SD1000(0)=SD1000(0)+S1000 !all
+ SD1000(2)=SD1000(2)+S1000 !electron
+c print *,id,SD1000(2),S1000,Ek,wt,wt*min(Ek,0.24d0)/0.24d0
+ elseif(abs(id).eq.14.and.EK.gt.0.055d0)then
+ S1000=S1000*min(Ek,0.24d0)/0.24d0
+ SD1000(0)=SD1000(0)+S1000 !all
+ SD1000(3)=SD1000(3)+S1000 !muon
+c print *,id,SD1000(3),S1000,Ek,wt,wt*min(Ek,0.24d0)/0.24d0
+ elseif((abs(id).eq.1120.and.EK.gt.0.5d0)
+ & .or.(abs(id).eq.120.and.EK.gt.0.08d0)
+ & .or.(abs(id).eq.130.and.EK.gt.0.25d0))then
+ S1000=S1000*min(Ek,0.24d0)/0.24d0
+ SD1000(0)=SD1000(0)+S1000 !all
+ SD1000(4)=SD1000(4)+S1000 !charged hadrons
+c print *,id,SD1000(4),S1000,Ek,wt,wt*min(Ek,0.24d0)/0.24d0
+ endif
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'S1000 (VEM)',(SD1000(k),k=0,4)
+#endif
+ end
+
+c----------------------------------------------------------------------
+ subroutine TruncatedMu(x1,x2,Ek,wt)
+c-----------------------------------------------------------------------
+c Count truncated number of muon (from 40 to 200 m) at ground
+c T. Pierog, 20.09.2007 - last modification : 12.10.2007
+c-----------------------------------------------------------------------
+
+ implicit none
+#include "conex.h"
+#include "conexep.h"
+ double precision x1,x2,r,wt,Ek
+ integer ic
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'MuTrunc',x1,x2,Ek,wt
+#endif
+
+ r=sqrt(x1*x1+x2*x2)
+
+ if(r.ge.40.and.r.le.200)then
+ do ic=1,mxExpro
+ if(Ek.ge.HaCutP(ic))then
+ MuTrunc(ic)=MuTrunc(ic)+wt
+ endif
+ enddo
+ endif
+c muon density at 600m for MIA detector
+ if(Ek.ge.0.85d0/max(0.5d0,costhet).and.
+ & r.ge.580.and.r.le.620)MuMia=MuMia+6.63d-6*wt !add wt/(620^2-580^2)/pi for density
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,*)'Mu',(MuTrunc(ic),ic=1,mxExpro),MuMia
+#endif
+
+ end
+
+c----------------------------------------------------------------------
+ subroutine HadronEnergy(Ek,wt)
+c-----------------------------------------------------------------------
+c Count hadron Energy at ground
+c T. Pierog, 12.10.2007 - last modification : 12.10.2007
+c-----------------------------------------------------------------------
+
+ implicit none
+#include "conex.h"
+#include "conexep.h"
+ double precision wt,Ek
+ integer ic
+#ifdef __CXDEBUG__
+
+ if(isx.ge.10)write(ifck,*)'HadronEnergy in',Ek,wt
+#endif
+
+ EHaMax=max(EHaMax,Ek)
+ do ic=1,mxExpro
+ if(Ek.ge.HaCutP(ic))then
+ EHaSum(ic)=EHaSum(ic)+wt*Ek
+ endif
+ enddo
+
+#ifdef __CXDEBUG__
+ if(isx.ge.10)write(ifck,*)'HadronEnergy out',EHaMax
+ & ,(EHaSum(ic),ic=1,mxExpro)
+#endif
+
+ end
+#endif
+
+#ifdef __ANALYSIS__
+
+c-------------------------------------------------------------------------
+ subroutine xgreisen
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ write(ifho,'(a)')'!---------------greisen---------------------'
+ en=Eo*cEM**(maxe-1)
+ y=log(en/0.081d0)
+ write(ifho,'(a)') 'openhisto name gr'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a)') 'xrange 0 1000'
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "xaxis depth (g/cm^2!)"'
+ write(ifho,'(a)') 'txt "yaxis number of electrons"'
+ write(ifho,'(a)') 'array 2'
+ do k=1,40
+ zk=1000d0*dble(k-1)/39.d0
+ t=max(0.00001d0,zk)/radlth
+ s=3*t/(t+2*y)
+ greisen=0.31d0/sqrt(y)*exp(t*(1.d0-1.5d0*log(s)))
+ write(ifho,'(2e11.3)')zk,greisen
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot gr'
+ end
+
+c----------------------------------------------------------------------------
+ subroutine xcross(word)
+c----------------------------------------------------------------------------
+c makes histograms for cross sections
+c----------------------------------------------------------------------------
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+#include "conex.h"
+#include "conex.incnex"
+#include "conexep.h"
+ character word*500
+ parameter (max=50)
+ data ifirst/0/
+ save ifirst
+
+ if(ifirst.eq.0)then
+ ifirst=1
+#ifdef __GHEISHA__
+ call IniGheisha
+#endif
+#ifdef __QGSJET__
+ call IniQGSJet
+#endif
+#ifdef __QGSJETII__
+ call IniQGSJetII
+#endif
+#ifdef __NEXUS__
+ if(MClemodel.ne.1.and.MCmodel.ne.1)call aaset(1)
+ call IniNexus
+#endif
+#ifdef __EPOS__
+ if(MClemodel.ne.4.and.MCmodel.ne.4)then
+ call aaset(1)
+ call LHCparameters
+ endif
+ call IniEpos
+#endif
+#ifdef __SIBYLL21__
+ call IniSibyll
+#endif
+#ifdef __FLUKA__
+ call IniFluka
+#endif
+#ifdef __URQMD__
+ call IniUrQMD
+#endif
+#ifdef __DPMJET__
+ call IniDPMJet
+#endif
+ endif
+ emn=Eo
+ emx=eprima
+
+ Cem=10.D0**(1.d0/emdecade) !size of the bin
+ c2em=sqrt(Cem)
+ d=Cem
+
+ if(word.eq.'annihi')then
+
+ write(ifho,'(a)') '!-------------annihi---------------'
+ write(ifho,'(a)') 'openhisto name annihi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.35 0.5 "annihi"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ if(ej.gt.2*amc2)write(ifho,'(2e11.3)')ej
+ & ,fann(0,0.d0,ej+2.d0*amc2,ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'heitler')then
+
+ write(ifho,'(a)') '!-------------heitler---------------'
+ write(ifho,'(a)') 'openhisto name heitler'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.1 0.35 "annhi heitler"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ if(ej.gt.2*amc2)write(ifho,'(2e11.3)')ej,sheitl(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'pairegf')then
+
+ write(ifho,'(a)') '!-------------pairegf---------------'
+ write(ifho,'(a)') 'openhisto name pairegf'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a)') 'text 0.01 0.2 "pair EGF"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ if(ej.gt.2*amc2)write(ifho,'(2e11.3)')ej,spair(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'pair')then
+
+ write(ifho,'(a)') '!-------------pair---------------'
+ write(ifho,'(a)') 'openhisto name pair'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a)') 'text 0.7 0.8 "pair"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ if(ej.gt.2*amc2)write(ifho,'(2e11.3)')ej,sigpar(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'eloss')then
+
+ hz=0.d0!1.d5
+ write(ifho,'(a)') '!------------ eloss ele ------------'
+ write(ifho,'(a)') 'openhisto name eloss'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-3 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis dE/dX"'
+ write(ifho,'(a,a)') 'text 0.1 0.90 "e-.loss"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ dedx=dedzEM(ej,hz,-1)
+ write(ifho,'(2e11.3)')ej,dedx
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'ploss')then
+
+ hz=0.d0!1.d5
+ write(ifho,'(a)') '!----------- eloss pos -------------'
+ write(ifho,'(a)') 'openhisto name elossp'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-3 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis dE/dX"'
+ write(ifho,'(a,a)') 'text 0.6 0.90 "e+.loss"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ dedx=dedzEM(ej,hz,1)
+ write(ifho,'(2e11.3)')ej,dedx
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'brems')then
+
+ write(ifho,'(a)') '!-------------brems---------------'
+ write(ifho,'(a)') 'openhisto name brems'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.7 0.6 "brems"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,fbrem(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'bremsegf')then
+
+ write(ifho,'(a)') '!-------------brems---------------'
+ write(ifho,'(a)') 'openhisto name bremsegf'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.1 0.75 "bremsEGF"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,sbrem(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'delta')then
+
+ write(ifho,'(a)') '!-------------delta---------------'
+ write(ifho,'(a)') 'openhisto name delta'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.7 0.90 "delta"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,fmoel(0,eo,ej-eo,ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'deltaegf')then
+
+ write(ifho,'(a)') '!-------------deltaegf---------------'
+ write(ifho,'(a)') 'openhisto name deltaegf'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.2 0.90 "delta EGF"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,smoel(0,eo,ej-eo,ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'bhabha')then
+
+ write(ifho,'(a)') '!-------------bhabha---------------'
+ write(ifho,'(a)') 'openhisto name bhabha'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.2 0.80 "bhabha"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,fbaba(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'bhabhaegf')then
+
+ write(ifho,'(a)') '!-------------bhabhaegf---------------'
+ write(ifho,'(a)') 'openhisto name bhabhaegf'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-4 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.7 0.80 "bhabha EGF"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,sbaba(0,eo,ej,ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'compton')then
+
+ write(ifho,'(a)') '!-------------compton---------------'
+ write(ifho,'(a)') 'openhisto name compton'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.1 0.9 "compton"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,fcompt(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+
+ elseif(word.eq.'comptonegf')then
+
+ write(ifho,'(a)') '!-------------comptonegf---------------'
+ write(ifho,'(a)') 'openhisto name comptonegf'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis cross section (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.4 0.6 "compton EGF"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,f1cx(ej/(2.d0*ej/amc2+1.d0),ej,ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'mupair')then
+
+ write(ifho,'(a)') '!-------------compton---------------'
+ write(ifho,'(a)') 'openhisto name mupair'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis muon pair prod (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.9 0.05 "muon pair"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,sigmupar(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+ elseif(word.eq.'photnuc')then
+
+ write(ifho,'(a)') '!-------------compton---------------'
+ write(ifho,'(a)') 'openhisto name photnuc'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1e-7 auto '
+ write(ifho,'(a)') 'text 0 0 "xaxis energy (gev)"'
+ write(ifho,'(a)') 'text 0 0 "yaxis photonucl eff (cm^2!/g)"'
+ write(ifho,'(a,a)') 'text 0.8 0.4 "photonuclear"'
+ write(ifho,'(a)') 'array 2'
+ do j=1,maxe
+ ej=emn*d**(j-1)
+ write(ifho,'(2e11.3)')ej,sigphonu(ej)
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+
+
+
+ elseif(word.eq.'nucleon')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+
+
+ write(ifho,'(a)') '!-------------nucleon---------------'
+ write(ifho,'(a)') 'openhisto name nuclxs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 200 auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "p/n + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer neXus"'
+ write(ifho,'(a)') '+ txt "refer QGSJet"'
+ write(ifho,'(a)') '+ txt "refer GHEISHA"'
+ write(ifho,'(a)') '+ txt "refer EPOS"'
+ write(ifho,'(a)') '+ txt "refer SIBYLL"'
+ write(ifho,'(a)') '+ txt "refer QGSJet II"'
+ write(ifho,'(a)') '+ txt "refer FLUKA"'
+ write(ifho,'(a)') '+ txt "refer URQMD"'
+ write(ifho,'(a)') '+ txt "refer DPMJET"'
+ write(ifho,'(a)') 'array -10'
+ iclproxs=2
+ do i=1,max
+ ei=emn*d**(i-1)
+#ifdef __NEXUS__
+ call NXSSIGMA(1,ei,signxs)
+#else
+ signxs=0.d0
+#endif
+#ifdef __EPOS__
+ call EPOSIGMA(1,ei,sigepo)
+#else
+ sigepo=0.d0
+#endif
+#ifdef __QGSJET__
+ call QGSSIGMA(1,ei+pmass(1),sigqgs)
+#else
+ sigqgs=0.d0
+#endif
+#ifdef __QGSJETII__
+ call QGSSIGMAII(1,ei+pmass(1),sigqgsII)
+#else
+ sigqgsII=0.d0
+#endif
+#ifdef __GHEISHA__
+ call GHESIGMA(1,ei,sigghe,dum)
+#else
+ sigghe=0.d0
+#endif
+#ifdef __SIBYLL21__
+ call SIBSIGMA(1,ei+pmass(1),sigsib)
+#else
+ sigsib=0.d0
+#endif
+#ifdef __FLUKA__
+ p0=sqrt((ei+2d0*pmass(1))*ei)
+ call FLUSIGMA(1,ei+pmass(1),p0,sigflu)
+#else
+ sigflu=0.d0
+#endif
+#ifdef __URQMD__
+ call URQSIGMA(1,ei,sigurq)
+#else
+ sigurq=0.d0
+#endif
+#ifdef __DPMJET__
+ call DPMSIGMA(1,ei+pmass(1),sigdpm)
+#else
+ sigdpm=0.d0
+#endif
+ write(ifho,'(10e11.3)')ei,signxs,sigqgs,sigghe,sigepo,sigsib
+ *,sigqgsII,sigflu,sigurq,sigdpm
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot nuclxs+1- plot nuclxs+2- plot nuclxs+3-'
+ write(ifho,'(a)') 'plot nuclxs+4- plot nuclxs+5- plot nuclxs+6-'
+ write(ifho,'(a)') 'plot nuclxs+7- plot nuclxs+8- plot nuclxs+9'
+
+ elseif(word.eq.'pion')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+
+
+ write(ifho,'(a)') '!-------------pion---------------'
+ write(ifho,'(a)') 'openhisto name pionxs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "[p] + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer neXus"'
+ write(ifho,'(a)') '+ txt "refer QGSJet"'
+ write(ifho,'(a)') '+ txt "refer GHEISHA"'
+ write(ifho,'(a)') '+ txt "refer EPOS"'
+ write(ifho,'(a)') '+ txt "refer SIBYLL"'
+ write(ifho,'(a)') '+ txt "refer QGSJet II"'
+ write(ifho,'(a)') '+ txt "refer FLUKA"'
+ write(ifho,'(a)') '+ txt "refer URQMD"'
+ write(ifho,'(a)') '+ txt "refer DPMJET"'
+ write(ifho,'(a)') 'array -10'
+ iclproxs=1
+ do i=1,max
+ ei=emn*d**(i-1)
+#ifdef __NEXUS__
+ call NXSSIGMA(2,ei,signxs)
+#else
+ signxs=0.d0
+#endif
+#ifdef __EPOS__
+ call EPOSIGMA(2,ei,sigepo)
+#else
+ sigepo=0.d0
+#endif
+#ifdef __QGSJET__
+ call QGSSIGMA(2,ei+pmass(2),sigqgs)
+#else
+ sigqgs=0.d0
+#endif
+#ifdef __QGSJETII__
+ call QGSSIGMAII(2,ei+pmass(2),sigqgsII)
+#else
+ sigqgsII=0.d0
+#endif
+#ifdef __GHEISHA__
+ call GHESIGMA(2,ei,sigghe,dum)
+#else
+ sigghe=0.d0
+#endif
+#ifdef __SIBYLL21__
+ call SIBSIGMA(2,ei+pmass(2),sigsib)
+#else
+ sigsib=0.d0
+#endif
+#ifdef __FLUKA__
+ p0=sqrt((ei+2d0*pmass(2))*ei)
+ call FLUSIGMA(2,ei+pmass(2),p0,sigflu)
+#else
+ sigflu=0.d0
+#endif
+#ifdef __URQMD__
+ call URQSIGMA(2,ei,sigurq)
+#else
+ sigurq=0.d0
+#endif
+#ifdef __DPMJET__
+ call DPMSIGMA(2,ei+pmass(2),sigdpm)
+#else
+ sigdpm=0.d0
+#endif
+ write(ifho,'(10e11.3)')ei,signxs,sigqgs,sigghe,sigepo,sigsib
+ *,sigqgsII,sigflu,sigurq,sigdpm
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot pionxs+1- plot pionxs+2- plot pionxs+3-'
+ write(ifho,'(a)') 'plot pionxs+4- plot pionxs+5- plot pionxs+6-'
+ write(ifho,'(a)') 'plot pionxs+7- plot pionxs+8- plot pionxs+9'
+
+ elseif(word.eq.'kaon')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+
+
+ write(ifho,'(a)') '!-------------kaon---------------'
+ write(ifho,'(a)') 'openhisto name kaonxs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "K + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer neXus"'
+ write(ifho,'(a)') '+ txt "refer QGSJet"'
+ write(ifho,'(a)') '+ txt "refer GHEISHA (K?ch!)"'
+ write(ifho,'(a)') '+ txt "refer GHEISHA (K?l!)"'
+ write(ifho,'(a)') '+ txt "refer GHEISHA (K?s!)"'
+ write(ifho,'(a)') '+ txt "refer EPOS"'
+ write(ifho,'(a)') '+ txt "refer SIBYLL"'
+ write(ifho,'(a)') '+ txt "refer QGSJet II"'
+ write(ifho,'(a)') '+ txt "refer FLUKA (K?ch!)"'
+ write(ifho,'(a)') '+ txt "refer FLUKA (K?l!)"'
+ write(ifho,'(a)') '+ txt "refer FLUKA (K?s!)"'
+ write(ifho,'(a)') '+ txt "refer URQMD (K?ch!)"'
+ write(ifho,'(a)') '+ txt "refer URQMD (K?l!)"'
+ write(ifho,'(a)') '+ txt "refer DPMJET"'
+ write(ifho,'(a)') 'array -15'
+ iclproxs=3
+ do i=1,max
+ ei=emn*d**(i-1)
+#ifdef __NEXUS__
+ call NXSSIGMA(3,ei,signxs)
+#else
+ signxs=0.d0
+#endif
+#ifdef __EPOS__
+ call EPOSIGMA(3,ei,sigepo)
+#else
+ sigepo=0.d0
+#endif
+#ifdef __QGSJET__
+ call QGSSIGMA(3,ei+pmass(3),sigqgs)
+#else
+ sigqgs=0.d0
+#endif
+#ifdef __QGSJETII__
+ call QGSSIGMAII(3,ei+pmass(3),sigqgsII)
+#else
+ sigqgsII=0.d0
+#endif
+#ifdef __GHEISHA__
+ call GHESIGMA(3,ei,sigghe,dum)
+ call GHESIGMA(4,ei,sigghe4,dum)
+ call GHESIGMA(5,ei,sigghe5,dum)
+#else
+ sigghe=0.d0
+ sigghe4=0.d0
+ sigghe5=0.d0
+#endif
+#ifdef __SIBYLL21__
+ call SIBSIGMA(3,ei+pmass(3),sigsib)
+#else
+ sigsib=0.d0
+#endif
+#ifdef __FLUKA__
+ p0=sqrt((ei+2d0*pmass(3))*ei)
+ call FLUSIGMA(3,ei+pmass(3),p0,sigflu3)
+ p0=sqrt((ei+2d0*pmass(4))*ei)
+ call FLUSIGMA(4,ei+pmass(4),p0,sigflu4)
+ p0=sqrt((ei+2d0*pmass(5))*ei)
+ call FLUSIGMA(5,ei+pmass(5),p0,sigflu5)
+#else
+ sigflu3=0.d0
+ sigflu4=0.d0
+ sigflu5=0.d0
+#endif
+#ifdef __URQMD__
+ call URQSIGMA(3,ei,sigurq3)
+ call URQSIGMA(4,ei,sigurq4)
+#else
+ sigurq3=0.d0
+ sigurq4=0.d0
+#endif
+#ifdef __DPMJET__
+ call DPMSIGMA(3,ei+pmass(3),sigdpm)
+#else
+ sigdpm=0.d0
+#endif
+ write(ifho,'(15e11.3)')ei,signxs,sigqgs,sigghe,sigghe4,sigghe5
+ & ,sigepo,sigsib,sigqgsII,sigflu3,sigflu4,sigflu5,sigurq3,sigurq4
+ & ,sigdpm
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot kaonxs+1- plot kaonxs+2- plot kaonxs+3- '
+ & ,'plot kaonxs+4- plot kaonxs+5- plot kaonxs+6- '
+ & ,'plot kaonxs+7- plot kaonxs+8- plot kaonxs+9- plot kaonxs+10-'
+ & ,'plot kaonxs+11- plot kaonxs+12- plot kaonxs+13- plot kaonxs+14'
+
+ elseif(word.eq.'helium')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+ call cxidmass(400,amass)
+
+
+ write(ifho,'(a)') '!-------------helium---------------'
+ write(ifho,'(a)') 'openhisto name heliumxs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange auto auto '
+c write(ifho,'(a)') 'yrange 1500 auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "Fe + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer neXus"'
+ write(ifho,'(a)') '+ txt "refer QGSJet"'
+ write(ifho,'(a)') '+ txt "refer EPOS"'
+ write(ifho,'(a)') '+ txt "refer SIBYLL"'
+ write(ifho,'(a)') '+ txt "refer QGSJet II"'
+ write(ifho,'(a)') '+ txt "refer DPMJET"'
+ write(ifho,'(a)') 'array -7'
+ iclproxs=2
+ do i=1,max
+ ei=emn*d**(i-1)/4d0
+#ifdef __NEXUS__
+ call NXSSIGMA(40,ei,signxs)
+#else
+ signxs=0.d0
+#endif
+#ifdef __EPOS__
+ call EPOSIGMA(40,ei,sigepo)
+#else
+ sigepo=0.d0
+#endif
+#ifdef __QGSJET__
+ call QGSSIGMA(40,ei+amass,sigqgs)
+#else
+ sigqgs=0.d0
+#endif
+#ifdef __QGSJETII__
+ call QGSSIGMAII(40,ei+amass,sigqgsII)
+#else
+ sigqgsII=0.d0
+#endif
+#ifdef __SIBYLL21__
+ call SIBSIGMA(40,ei+amass,sigsib)
+#else
+ sigsib=0.d0
+#endif
+#ifdef __DPMJET__
+ call DPMSIGMA(40,ei+amass,sigdpm)
+#else
+ sigdpm=0.d0
+#endif
+ write(ifho,'(7e11.3)')ei*4d0,signxs,sigqgs
+ & ,sigepo,sigsib,sigqgsII,sigdpm
+c write(ifho,'(6e11.3)')ei,signxs,sigqgs2/sigqgs
+c & ,sigepo2/sigepo,sigsib2/sigsib,sigqgsII
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot heliumxs+1- plot heliumxs+2- '
+ write(ifho,'(a)') 'plot heliumxs+3- plot heliumxs+4- '
+ write(ifho,'(a)') 'plot heliumxs+5- plot heliumxs+6'
+
+ elseif(word.eq.'iron')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+ call cxidmass(5600,amass)
+
+
+ write(ifho,'(a)') '!-------------iron---------------'
+ write(ifho,'(a)') 'openhisto name ironxs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange auto auto '
+c write(ifho,'(a)') 'yrange 1500 auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "Fe + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer neXus"'
+ write(ifho,'(a)') '+ txt "refer QGSJet"'
+ write(ifho,'(a)') '+ txt "refer EPOS"'
+ write(ifho,'(a)') '+ txt "refer SIBYLL"'
+ write(ifho,'(a)') '+ txt "refer QGSJet II"'
+ write(ifho,'(a)') '+ txt "refer DPMJET"'
+ write(ifho,'(a)') 'array -7'
+ iclproxs=2
+ do i=1,max
+ ei=emn*d**(i-1)/56d0
+#ifdef __NEXUS__
+ call NXSSIGMA(560,ei,signxs)
+#else
+ signxs=0.d0
+#endif
+#ifdef __EPOS__
+ call EPOSIGMA(560,ei,sigepo)
+#else
+ sigepo=0.d0
+#endif
+#ifdef __QGSJET__
+ call QGSSIGMA(560,ei+amass,sigqgs)
+#else
+ sigqgs=0.d0
+#endif
+#ifdef __QGSJETII__
+ call QGSSIGMAII(560,ei+amass,sigqgsII)
+#else
+ sigqgsII=0.d0
+#endif
+#ifdef __SIBYLL21__
+ call SIBSIGMA(560,ei+amass,sigsib)
+#else
+ sigsib=0.d0
+#endif
+#ifdef __DPMJET__
+ call DPMSIGMA(560,ei+amass,sigdpm)
+#else
+ sigdpm=0.d0
+#endif
+ write(ifho,'(7e11.3)')ei*56d0,signxs,sigqgs
+ & ,sigepo,sigsib,sigqgsII,sigdpm
+c write(ifho,'(6e11.3)')ei,signxs,sigqgs2/sigqgs
+c & ,sigepo2/sigepo,sigsib2/sigsib,sigqgsII
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot ironxs+1- plot ironxs+2- plot ironxs+3-'
+ write(ifho,'(a)') 'plot ironxs+4- plot ironxs+5- plot ironxs+6'
+
+ elseif(word.eq.'strange')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+ call cxidmass(50000,amass)
+
+
+ write(ifho,'(a)') '!-------------strange---------------'
+ write(ifho,'(a)') 'openhisto name strangexs'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod lin'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange auto auto '
+c write(ifho,'(a)') 'yrange 1500 auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis xsection (mb)"'
+ write(ifho,'(a)') 'text 0.2 0.95 "Heavy + Air"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer lead"'
+ write(ifho,'(a)') '+ txt "refer strangelet"'
+ write(ifho,'(a)') 'array -3'
+ iclproxs=2
+ do i=1,max
+ ei=emn*d**(i-1)
+#ifdef __EPOS__
+ call EPOSIGMA(2800,ei/280d0,sigepo)
+#else
+ sigepo=0.d0
+#endif
+ call STRANGELETSIGMA(-5000,Siginemb)
+ write(ifho,'(7e11.3)')ei,sigepo,Siginemb
+c write(ifho,'(6e11.3)')ei,signxs,sigqgs2/sigqgs
+c & ,sigepo2/sigepo,sigsib2/sigsib,sigqgsII
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') 'plot strangexs+1- plot strangexs+2'
+
+ elseif(word.eq.'rlam')then
+
+ emn=enymin
+ emx=eprima
+ d=(emx/emn)**(1.d0/dble(max-1))
+
+ write(ifho,'(a)') '!-------------rlam---------------'
+ write(ifho,'(a)') 'openhisto name rlam'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e11.3)')'xrange ',emn,emx
+ write(ifho,'(a)') 'yrange 1. 500. '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') 'txt "yaxis int length"'
+ write(ifho,'(a)') '- txt "xaxis Kinetic energy (GeV)"'
+ write(ifho,'(a)') '+ txt "refer He+Air"'
+ write(ifho,'(a)') '+ txt "refer Be+Air"'
+ write(ifho,'(a)') '+ txt "refer O+Air"'
+ write(ifho,'(a)') '+ txt "refer S+Air"'
+ write(ifho,'(a)') '+ txt "refer Fe+Air"'
+ write(ifho,'(a)') '+ txt "refer p/n+Air"'
+ write(ifho,'(a)') '+ txt "refer [p]+Air"'
+ write(ifho,'(a)') '+ txt "refer K+Air"'
+ write(ifho,'(a)') '+ txt "refer K?l!+Air"'
+ write(ifho,'(a)') '+ txt "refer K?s!+Air"'
+ write(ifho,'(a)') '+ txt "refer [m]+Air"'
+ write(ifho,'(a)') 'array -12'
+ do i=1,max
+ ei=emn*d**(i-1)
+ rlammu=0d0
+ if(imuint.ne.0)rlammu=rlam(9,ei,pmass(9))
+ write(ifho,'(12e11.3)')ei
+ * ,(rlam(min(560,2**(1+j)*10),ei,0.d0),j=1,5)
+ * ,(rlam(j,ei,pmass(j)),j=1,5)
+ * ,rlammu
+ enddo
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,9
+ write(ifho,'(a,i1,a,$)') ' plot rlam+',ip,'-'
+ enddo
+ write(ifho,'(a)') ' plot rlam+10- plot rlam+11'
+
+ endif
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine xTableCascade(k1,k2,word)
+c-------------------------------------------------------------------------
+c makes multi-column histograms for input table of hadronic cascade
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexwei.h"
+#include "conex.incnex"
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ character*9 ptyp1(maxin),ptyp(maxin)
+ character word*500
+ logical go
+
+ if(word.eq.'interaction')then
+
+ ptyp1(1)=' protons '
+ ptyp1(2)=' [p]^+/-!'
+ ptyp1(3)=' K^+/-! '
+ ptyp1(4)=' K?l! '
+ ptyp1(5)=' K?s! '
+ ptyp1(6)=' [p]^0! '
+ ptyp1(7)=' neutrons'
+ ptyp(1)=' protons '
+ ptyp(2)=' [p]^+/-!'
+ ptyp(3)=' K^+/-! '
+ ptyp(4)=' K?l! '
+ ptyp(5)=' K?s! '
+ ptyp(6)=' [p]^0! '
+ ptyp(7)=' neutrons'
+ ptyp(8)=' [g] '
+ ptyp(9)=' [m]^-! '
+ ptyp(10)=' [m]^+! '
+ ptyp(11)=' e^-! '
+ ptyp(12)=' e^+! '
+
+
+ dE=log10(eeha(iemax)/eeha(iemax-1))
+
+ dnbe=5.d0 !total number of spectra
+ nbin=max(1,int(log10(eprima)*dnHa/dnbe))
+ nbmax=(iemax-iemin)/nbin+1
+ write(*,*)'xTable',iemin,iemax,nbin,nbmax
+ if(iemin.lt.iemax)then
+
+ write(ifho,'(a)') 'resethisto'
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name ednde'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',eeha(1),eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ do i1=1,7
+ do i2=k1,k2
+ do ie=iemax,iemin,-nbin
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of '//ptyp(i2)//' from '
+ & //ptyp1(i1)//'"'
+ enddo
+ enddo
+ enddo
+ write(ifho,*) 'array ',-1-7*nbmax*(k2-k1+1)
+ j=1
+ write(ifho,'(8888e13.6)')eeha(j),(((wwHa(i,j,i1,i2)*2.d0/dE
+ &*rlam(i1,eeha(i),pmass(i1)),i=iemax,iemin,-nbin),i2=k1,k2),i1=1,4)
+ write(ifho,'(8888e13.6)')(((wwHa(i,j,i1,i2)*2.d0
+ &*rlam(i1,eeha(i),pmass(i1-1)),i=iemax,iemin,-nbin),i2=k1,k2)
+ &,i1=5,7)
+ do j=2,iemax-1
+ write(ifho,'(8888e13.6)')eeha(j),(((wwHa(i,j,i1,i2)/dE
+ &*rlam(i1,eeha(i),pmass(i1)),i=iemax,iemin,-nbin),i2=k1,k2),i1=1,4)
+ write(ifho,'(8888e13.6)')(((wwHa(i,j,i1,i2)
+ &*rlam(i1,eeha(i),pmass(i1-1)),i=iemax,iemin,-nbin),i2=k1,k2)
+ &,i1=5,7)
+ end do
+ j=iemax
+ write(ifho,'(8888e13.6)')eeha(j),(((wwHa(i,j,i1,i2)*2.d0/dE
+ &*rlam(i1,eeha(i),pmass(i1)),i=iemax,iemin,-nbin),i2=k1,k2),i1=1,4)
+ write(ifho,'(8888e13.6)')(((wwHa(i,j,i1,i2)*2.d0
+ &*rlam(i1,eeha(i),pmass(i1-1)),i=iemax,iemin,-nbin),i2=k1,k2)
+ &,i1=5,7)
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ ip=0
+ do i1=1,7
+ do i2=k1,k2
+ do ie=iemax,iemin+nbin,-nbin
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1,a,$)') ' plot ednde+',ip,'-'
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i2,a,$)') ' plot ednde+'
+ &,ip,'-'
+ if(ip.gt.99.and.ip.le.999)write(ifho,'(a,i3,a,$)')' plot ednde+'
+ &,ip,'-'
+ if(ip.gt.999)write(ifho,'(a,i4,a,$)') ' plot ednde+',ip,'-'
+ enddo
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1)') ' plot ednde+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i2,a)') ' plot ednde+',ip
+ if(ip.gt.99.and.ip.le.999)write(ifho,'(a,i3,a)')' plot ednde+',ip
+ if(ip.gt.999)write(ifho,'(a,i4)') ' plot ednde+',ip
+ enddo
+ enddo
+ write(ifho,'(a)') 'resethisto'
+ endif
+
+ elseif(word.eq.'pt2d')then
+
+ ptyp1(1)=' [p]^+/-!'
+ ptyp1(2)=' K^+/-! '
+ ptyp1(3)=' K?l! '
+ ptyp1(4)=' K?s! '
+ ptyp(1)=' [p]^+/-!'
+ ptyp(2)=' [p]^0! '
+ ptyp(3)=' [g] '
+ ptyp(4)=' [m]^+/-!'
+ ptyp(5)=' e^+/-! '
+ ptyp(6)=' [n] '
+
+
+ dnbe=10.d0 !total number of spectra
+ nbin=max(1,int(log10(eprima)*dnHa/dnbe))
+ nbmax=(iemax-iemin)/nbin+1
+ write(*,*)'xTable',iemin,iemax,nbin,nbmax
+ if(iemin.lt.iemax)then
+
+ write(ifho,'(a)') 'resethisto'
+ write(ifho,'(a)')'!--------------- pt2d ------------'
+ write(ifho,'(a)') 'zone 2 2 1 openhisto name pt2d'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',eeha(1),eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ do i1=1,4
+ do i2=1,6
+ do ie=iemax,iemin,-nbin
+ write(ifho,'(a)') '+ txt "yaxis pt^2! of '//ptyp(i2)//' from '
+ & //ptyp1(i1)//'"'
+ enddo
+ enddo
+ enddo
+ write(ifho,*) 'array ',-1-4*nbmax*6 !6=range of i2
+ j=1
+ write(ifho,'(999e13.6)')eeha(j),(((ppj(j,i,i2,i1)
+ & ,i=iemax,iemin,-nbin),i2=1,6),i1=1,4)
+ do j=2,iemax-1
+ write(ifho,'(999e13.6)')eeha(j),(((ppj(j,i,i2,i1)
+ & ,i=iemax,iemin,-nbin),i2=1,6),i1=1,4)
+ end do
+ j=iemax
+ write(ifho,'(999e13.6)')eeha(j),(((ppj(j,i,i2,i1)
+ & ,i=iemax,iemin,-nbin),i2=1,6),i1=1,4)
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ ip=0
+ do i1=1,4
+ do i2=1,6
+ do ie=iemax,iemin+nbin,-nbin
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1,a,$)') ' plot pt2d+',ip,'-'
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i2,a,$)') ' plot pt2d+'
+ &,ip,'-'
+ if(ip.gt.99)write(ifho,'(a,i3,a,$)') ' plot pt2d+',ip,'-'
+ enddo
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1)') ' plot pt2d+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i2,a)') ' plot pt2d+',ip
+ if(ip.gt.99)write(ifho,'(a,i3)') ' plot pt2d+',ip
+ enddo
+ enddo
+ endif
+
+#if __MC3D__ || __CXLATCE__
+c *************************************************************************
+
+ elseif(word.eq.'pt2')then
+
+ ptyp1(1)=' protons '
+ ptyp1(2)=' [p]^+/-!'
+ ptyp1(3)=' K^+/-! '
+ ptyp1(4)=' K?l/s! '
+ ptyp1(5)=' neutrons'
+ ptyp(1)=' protons '
+ ptyp(2)=' [p]^+/-!'
+ ptyp(3)=' K^+/-! '
+ ptyp(4)=' K?l/s! '
+ ptyp(5)=' [p]^0! '
+ ptyp(6)=' neutrons'
+ ptyp(7)=' [g] '
+ ptyp(8)=' [m]^-! '
+ ptyp(9)=' [m]^+! '
+ ptyp(10)=' e^-! '
+ ptyp(11)=' e^+! '
+
+
+ dnbe=10.d0 !total number of spectra
+ nbin=max(1,int(log10(eprima)*dnHa/dnbe))
+ nbmax=(iemax-iemin)/nbin+1
+ write(*,*)'xTable',iemin,iemax,nbin,nbmax
+ if(iemin.lt.iemax)then
+
+ do i1=1,5
+ write(ifho,'(a)') 'resethisto'
+ write(ifho,'(a)')'!--------------- pt2 ------------'
+ write(ifho,'(a,i1)') 'zone 2 2 1 openhisto name pt2-',i1
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',eeha(1),eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ do i2=k1,k2
+ do ie=iemax,iemin,-nbin
+ write(ifho,'(a)') '+ txt "yaxis pt^2! of '//ptyp(i2)//' from '
+ & //ptyp1(i1)//'"'
+ enddo
+ enddo
+ write(ifho,*) 'array ',-1-nbmax*(k2-k1+1)
+ j=1
+ write(ifho,'(999e13.6)')eeha(j),((pt2w(i,j,i1,i2)
+ & ,i=iemax,iemin,-nbin),i2=k1,k2)
+ do j=2,iemax-1
+ write(ifho,'(999e13.6)')eeha(j),((pt2w(i,j,i1,i2)
+ & ,i=iemax,iemin,-nbin),i2=k1,k2)
+ end do
+ j=iemax
+ write(ifho,'(999e13.6)')eeha(j),((pt2w(i,j,i1,i2)
+ & ,i=iemax,iemin,-nbin),i2=k1,k2)
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ ip=0
+ do i2=k1,k2
+ do ie=iemax,iemin+nbin,-nbin
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1,a,i1,a,$)') ' plot pt2-',i1,'+'
+ &,ip,'-'
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2,a,$)')' plot pt2-'
+ &,i1,'+',ip,'-'
+ if(ip.gt.99)write(ifho,'(a,i1,a,i3,a,$)') ' plot pt2-',i1,'+'
+ &,ip,'-'
+ enddo
+ ip=ip+1
+ if(ip.le.9)write(ifho,'(a,i1,a,i1)') ' plot pt2-',i1,'+',ip
+ if(ip.gt.9.and.ip.le.99)write(ifho,'(a,i1,a,i2)') ' plot pt2-'
+ &,i1,'+',ip
+ if(ip.gt.99)write(ifho,'(a,i1,a,i3)') ' plot pt2-',i1,'+',ip
+ enddo
+ enddo
+ endif
+
+
+ ptyp1(1)=' [p]^+/-!'
+ ptyp1(2)=' K^+/-! '
+ ptyp1(3)=' K?l! '
+ ptyp1(4)=' K?s! '
+ ptyp(1)=' [p]^+/-!'
+ ptyp(2)=' [p]^0! '
+ ptyp(3)=' [g] '
+ ptyp(4)=' [m]^+/-!'
+ ptyp(5)=' e^+/-! '
+ ptyp(6)=' [n] '
+
+
+#endif
+c *************************************************************************
+
+ elseif(word.eq.'ionloss')then
+
+ ptyp1(1)=' protons '
+ ptyp1(2)=' [p]^+/-!'
+ ptyp1(3)=' K^+/-! '
+ ptyp1(4)='[m]^+/-! '
+c Ionization loss distribution
+ write(ifho,'(a)')'!--------------- dE/dX ------------'
+ write(ifho,'(a)') 'zone 1 1 1 openhisto name dedxMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',eeha(1),eeha(iemax)
+ write(ifho,'(a)') 'yrange 1e-3 auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis dE/dX"'
+ do i1=1,4
+ write(ifho,'(a)') '+ txt "refer '//ptyp1(i1)//'"'
+ write(ifho,'(a)') 'txt "yaxis dE/dX"'
+ enddo
+ write(ifho,*) 'array ',-5
+ rho=rhoair(hground)
+ do j=1,iemax
+ EK=eeha(j)
+ write(ifho,*)EK,dedxionMC(1,EK,rho),dedxionMC(2,EK,rho)
+ & ,dedxionMC(3,EK,rho),dedxionMC(9,EK,rho)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot dedxMC+1- plot dedxMC+2- '
+ if(ionloss.eq.1)then
+ write(ifho,'(a)') ' plot dedxMC+3- plot dedxMC+4-'
+
+ write(ifho,'(a)')'!--------------- dE/dX ------------'
+ write(ifho,'(a)') 'zone 1 1 1 openhisto name dedx'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',eeha(1),eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'colo mix'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis dE/dX"'
+ do i1=1,5
+ write(ifho,'(a)') '+ txt "yaxis dE/dX"'
+ enddo
+ write(ifho,*) 'array ',-6
+ do j=1,iemax
+ write(ifho,*)eeha(j),(dedxion(i1,j),i1=1,3)
+ & ,dedxionmu(j,mzHa)-dedxion(4,j),dedxion(4,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot dedx+1- plot dedx+2- plot dedx+3-'
+ write(ifho,'(a)') ' plot dedx+4- plot dedx+5'
+ else
+ write(ifho,'(a)') ' plot dedxMC+3- plot dedxMC+4'
+ endif
+
+c *************************************************************************
+
+ elseif(word.eq.'decay')then
+
+ ptyp1(1)='[p]^+/-! '
+ ptyp1(2)=' K^+/-! '
+ ptyp1(3)=' K?L! '
+ ptyp1(4)=' K?S! '
+
+ ptyp(1)='[p]^+/-! '
+ ptyp(2)=' [p]^0! '
+ ptyp(3)=' [g] '
+ ptyp(4)='[m]^+/-! '
+ ptyp(5)=' e^+/-! '
+ ptyp(6)=' [n] '
+ ifw=25
+c Monte-Carlo hadron decay production
+ inquire(file='/home/pierog/conex/conex.svn/conex.wdec20',exist=go)
+ if(go)then
+ write(6,'(a)')'read Decay table'
+ open(ifw,file='/home/pierog/conex/conex.svn/conex.wdec20'
+ $,status='old')
+ read(ifw,*) ppjver,exmin,ieminl,iemaxl,n1maxl,n2maxl,nde
+ if(nde.eq.nint(decade))then
+ read(ifw,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=ieminl,iemaxl)
+ $ ,i2=1,n2maxl)
+ $ ,i1=1,n1maxl)
+ else
+ go=.false.
+ write(6,'(a)')'Decay table not found',ppjver
+ endif
+ close(ifw)
+ endif
+ imx=iemax
+
+c Energy distribution of gammas from pi0 decay
+
+
+c Pi0 from Charge Kaon or Kaon Long
+ if(ifdkz.gt.0)then
+ open(ifdkz,file=fndkz(1:nfndkz),status='old')
+ read(ifdkz,*) akz,akz0
+ close(ifdkz)
+ else
+ write(6,*)'Table dkz is not defined for hadron cascade !'
+ endif
+ if(ifdkl.gt.0)then
+ open(ifdkl,file=fndkl(1:nfndkl),status='old')
+ read(ifdkl,*) akl,akl0
+ close(ifdkl)
+ else
+ write(6,*)'Table dkl is not defined for hadron cascade !'
+ endif
+ if(ifdks.gt.0)then
+ open(ifdks,file=fndks(1:nfndks),status='old')
+ read(ifdks,*) aks,aks0
+ close(ifdks)
+ else
+ write(6,*)'Table dks is not defined for hadron cascade !'
+ endif
+ write(ifho,'(a)') 'zone 1 2 1'
+ write(ifho,'(a)')'!------------- dekay table ----------'
+ write(ifho,'(a)') 'openhisto name pi0'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*5.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,'(a)') ' txt "refer from k^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,'(a)') ' txt "refer from k?l!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,'(a)') ' txt "refer from k?s!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,iemax
+ write(ifho,*)eeha(j),akz0(iemax,j),akl0(iemax,j),aks0(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot pi0+1- plot pi0+2- plot pi0+3-'
+
+ write(ifho,'(a)') 'openhisto name pi0MC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*5.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^0!"'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeha(j),ppj(j,imx,2,2),ppj(j,imx,2,3)
+ & ,ppj(j,imx,2,4)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot pi0MC+1- plot pi0MC+2- plot pi0MC+3'
+ else
+ write(ifho,'(a)') ' plot pi0+1- plot pi0+2- plot pi0+3'
+ endif
+
+c Pi+/- from Charge Kaon or neutral Kaon
+ write(ifho,'(a)') 'openhisto name pi'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*5.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,'(a)') ' txt "refer from k^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,'(a)') ' txt "refer from k?l!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,'(a)') ' txt "refer from k?s!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,iemax
+ write(ifho,*)eeha(j),akz(iemax,j),akl(iemax,j),aks(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot pi+1- plot pi+2- plot pi+3-'
+
+ write(ifho,'(a)') 'openhisto name piMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*5.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,'(a)') '+ txt "yaxis EdN/dE of [p]^+/-!"'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeha(j),ppj(j,imx,1,2),ppj(j,imx,1,3)
+ & ,ppj(j,imx,1,4)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot piMC+1- plot piMC+2- plot piMC+3'
+ else
+ write(ifho,'(a)') ' plot pi+1- plot pi+2- plot pi+3'
+ endif
+
+c Electrons from Charge Kaon or Kaon Long
+ if(ifdke.gt.0)then
+ open(ifdke,file=fndke(1:nfndke),status='old')
+ read(ifdke,*) akze,akle,ap0g,ap0e,amue
+ close(ifdke)
+ else
+ write(6,*)'Table dke is not defined for hadron cascade !'
+ endif
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name elec'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & 'K^+/-!"'
+ write(ifho,'(a)') ' txt "refer e from K^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & 'K?L!"'
+ write(ifho,'(a)') ' txt "refer e from K?L!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -3'
+ do j=1,imx
+ write(ifho,*)eeHa(j),akze(iemax,j),akle(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot elec+1- plot elec+2-'
+
+ write(ifho,'(a)') 'openhisto name elecMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & 'K?+/-!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & 'K?L!"'
+ write(ifho,*) 'array -3'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,5,2),ppj(j,imx,5,3)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot elecMC+1- plot elecMC+2'
+ else
+ write(ifho,'(a)') ' plot elec+1- plot elec+2'
+ endif
+
+c Muons from Charge Kaon or Kaon Long or charged pion
+ if(ifdkm.gt.0)then
+ open(ifdkm,file=fndkm(1:nfndkm),status='old')
+ read(ifdkm,*) akzm,aklm,apim
+ close(ifdkm)
+ else
+ write(6,*)'Table dkm is not defined for hadron cascade !'
+ endif
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name muon'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & '[p]^+/-!"'
+ write(ifho,'(a)') ' txt "refer [m] from [p]^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & 'K^+/-!"'
+ write(ifho,'(a)') ' txt "refer [m] from K^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & 'K?L!"'
+ write(ifho,'(a)') ' txt "refer [m] from K?L!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeHa(j),apim(iemax,j),akzm(iemax,j),aklm(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot muon+1- plot muon+2- plot muon+3-'
+
+ write(ifho,'(a)') 'openhisto name muonMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-2)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & '[p]?+/-!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & 'K?+/-!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & 'K?L!"'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,4,1),ppj(j,imx,4,2),ppj(j,imx,4,3)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot muonMC+1- plot muonMC+2- plot muonMC+3'
+ else
+ write(ifho,'(a)') ' plot muon+1- plot muon+2- plot muon+3'
+ endif
+
+c Neutrinos from Charge Kaon or Kaon Long or charged pion
+ if(ifdkn.gt.0)then
+ open(ifdkn,file=fndkn(1:nfndkn),status='old')
+ read(ifdkn,*) akzn,akln,apin,amun
+ close(ifdkn)
+ else
+ write(6,*)'Table dkn is not defined for hadron cascade !'
+ endif
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name neutr'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & '[p]^+/-!"'
+ write(ifho,'(a)') ' txt "refer [n] from [p]^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & 'K^+/-!"'
+ write(ifho,'(a)') ' txt "refer [n] from K^+/-!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & 'K?L!"'
+ write(ifho,'(a)') ' txt "refer [n] from K?L!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeHa(j),apin(iemax,j),10d0*akzn(iemax,j)
+ & ,2d0*akln(iemax,j) !problem in spectra
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot neutr+1- plot neutr+2- plot neutr+3-'
+
+ write(ifho,'(a)') 'openhisto name neutrMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & '[p]?+/-!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & 'K?+/-!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [n] from ',
+ & 'K?L!"'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,6,1),ppj(j,imx,6,2),ppj(j,imx,6,3)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)')' plot neutrMC+1- plot neutrMC+2- plot neutrMC+3'
+ else
+ write(ifho,'(a)') ' plot neutr+1- plot neutr+2- plot neutr+3'
+ endif
+
+c --------------------------------------------------------------------------
+
+ ptyp1(1)=' [p]^o! '
+ ptyp1(2)='[m]^+/-! '
+
+ ptyp(1)=' [g] '
+ ptyp(2)=' e^+/-! '
+ ptyp(3)=' [n] '
+ ifw=25
+c Monte-Carlo pion0 and muon decay production
+ go=.false.
+ inquire(file='/home/pierog/conex/conex.svn/conex.wlep20',exist=go)
+ if(go)then
+ write(6,'(a)')'read lepton Decay table'
+ open(ifw,file='/home/pierog/conex/conex.svn/conex.wlep20'
+ $,status='old')
+ read(ifw,*) ppjver,exmin,ieminl,iemaxl,n1maxl,n2maxl,nde
+ if(nde.eq.nint(decade))then
+ read(ifw,*)
+ $ ((((ppj(j,i,i2,i1)
+ $ ,j=1,i)
+ $ ,i=ieminl,iemaxl)
+ $ ,i2=1,n2maxl)
+ $ ,i1=1,n1maxl)
+ else
+ go=.false.
+ write(6,'(a)')'Lepton Decay table not found',ppjver
+ endif
+ close(ifw)
+ endif
+ imx=iemax
+
+c Energy distribution of gammas from pi0 decay
+
+
+ write(ifho,'(a)') 'zone 1 2 1'
+ write(ifho,'(a)')'!------------- dekay table ----------'
+ write(ifho,'(a)') 'openhisto name gam'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') 'txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis EdN/dE of [g]"'
+ write(ifho,'(a)') 'txt "refer from [p]^o!"'
+ write(ifho,*) 'array 2'
+ do j=1,iemax
+ write(ifho,*)eeha(j),ap0g(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot gam- '
+
+ write(ifho,'(a)') 'openhisto name gamMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis EdN/dE of [g]"'
+ write(ifho,*) 'array 2'
+ do j=1,imx
+ write(ifho,*)eeha(j),ppj(j,imx,1,1)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot gamMC'
+ else
+ write(ifho,'(a)') ' plot gam'
+ endif
+
+
+c Electrons from pion 0 and muons
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name elec2'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & '[p]^o!"'
+ write(ifho,'(a)') ' txt "refer e from [p]^o!"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & '[m]"'
+ write(ifho,'(a)') ' txt "refer e from [m]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -3'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ap0e(iemax,j),amue(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot elec2+1- plot elec2+2-'
+
+ write(ifho,'(a)') 'openhisto name elec2MC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & '[p]?o!"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of e from ',
+ & '[m]"'
+ write(ifho,*) 'array -3'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,2,1),ppj(j,imx,2,2)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot elec2MC+1- plot elec2MC+2'
+ else
+ write(ifho,'(a)') ' plot elec2+1- plot elec2+2'
+ endif
+
+
+c Neutrinos from muons
+ write(ifho,'(a)') 'zone 1 2 1'
+ write(ifho,'(a)')'!------------- dekay table ----------'
+ write(ifho,'(a)') 'openhisto name neutr2'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') 'txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis EdN/dE of [n]"'
+ write(ifho,'(a)') 'txt "refer from [m]"'
+ write(ifho,*) 'array 2'
+ do j=1,iemax
+ write(ifho,*)eeha(j),amun(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot neutr2- '
+
+ write(ifho,'(a)') 'openhisto name neutr2MC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "xaxis E (GeV)"'
+ write(ifho,'(a)') 'txt "yaxis EdN/dE of [n]"'
+ write(ifho,*) 'array 2'
+ do j=1,imx
+ write(ifho,*)eeha(j),ppj(j,imx,3,2)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot neutr2MC'
+ else
+ write(ifho,'(a)') ' plot neutr2'
+ endif
+
+c *************************************************************************
+
+ elseif(word.eq.'photonu')then
+
+ ptyp1(1)=' [g] '
+
+ ptyp(1)=' proton '
+ ptyp(2)=' neutron '
+ ptyp(3)=' [r] '
+ ptyp(4)=' [m] '
+ ifw=25
+c rho, proton and neutron from gamma by photonuclear effect
+ if(ifdkg.gt.0)then
+ open(ifdkg,file=fndkg(1:nfndkg),status='old')
+ read(ifdkg,*) agpr,agne,agpi,agmu
+ close(ifdkg)
+ else
+ write(6,*)'Table dkg is not defined for hadron cascade !'
+ endif
+ imx=iemax
+ go=.true.
+ do i=1,imx
+ do j=1,imx
+ ppj(j,i,1,1)=0.
+ ppj(j,i,1,2)=0.
+ ppj(j,i,1,3)=0.
+ ppj(j,i,1,4)=0.
+ enddo
+ enddo
+
+c Muon Pair Production
+ write(ifho,'(a)')'!--------Muon Pair Production-----------'
+
+ MEDIUM=1
+ i=imx
+ ei=eeha(i)
+ ntry=100000
+ xnorm=1.d0/dble(ntry)
+ write(*,*)'Run cxmupair for E=',ei,i
+ ams=pmass(9)
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call cxmupair
+ enpe=max(1.d-10,E(NP)*1.d-3-ams)
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,4)=ppj(j,i,1,4)+real(xnorm*appp1)
+ ppj(j+1,i,1,4)=ppj(j+1,i,1,4)+real(xnorm*appp2)
+
+ enpe=max(1.d-10,E(NP-1)*1.d-3-ams)
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,4)=ppj(j,i,1,4)+real(xnorm*appp1)
+ ppj(j+1,i,1,4)=ppj(j+1,i,1,4)+real(xnorm*appp2)
+ enddo
+
+c muon pair production
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name mup'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer [m] from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -2'
+ do j=1,imx
+ write(ifho,*)eeHa(j),agmu(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot mup+1-'
+
+ write(ifho,'(a)') 'openhisto name mupMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [m] from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer[m] from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -2'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,1,4)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot mupMC+1'
+ else
+ write(ifho,'(a)') ' plot mup+1'
+ endif
+
+ if(eeha(iemax).gt.2.d0)then
+
+c Photonuclear effect
+ write(ifho,'(a)')'!--------Photonuclear effect-----------'
+
+ MEDIUM=1
+ i=imx
+ ei=eeha(i)
+ ntry=100000
+ xnorm=1.d0/dble(ntry)
+ write(*,*)'Run cxrhogen for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call cxrhogen
+c produced rho
+ if(iq(np-1).eq.111)then
+ id=111
+ call cxidmass(id,ams)
+c enpe=max(1.d-10,E(NP-1)*1.d-3-ams)
+c j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+c ej0=eeha(j)
+c ej01=eeha(j+1)
+c appp1=(ej01-enpe)/(ej01-ej0)
+c appp2=1.d0-appp1
+c xnorm1=xnorm*appp1
+c nptlxs=1
+c idptlxs(nptlxs)=id
+c xsptl(5,nptlxs)=ams
+c xsptl(4,nptlxs)=ej0+ams
+c xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+c & *(xsptl(4,nptlxs)+ams))
+c xsptl(2,nptlxs)=0.d0
+c xsptl(1,nptlxs)=0.d0
+c call cxhdecay(1,iret)
+c if(iret.eq.1)goto 10
+c do iii=2,nptlxs
+c if(abs(idptlxs(iii)).eq.120)then
+c enpe=max(1.d-10,xsptl(4,iii)-pmass(2))
+c j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+c ej=eeha(j)
+c ej1=eeha(j+1)
+c appp1=(ej1-enpe)/(ej1-ej)
+c appp2=1.d0-appp1
+c ppj(j,i,1,1)=ppj(j,i,1,1)+xnorm1*appp1
+c ppj(j+1,i,1,1)=ppj(j+1,i,1,1)+xnorm1*appp2
+c endif
+c enddo
+c xnorm2=xnorm*appp2
+c nptlxs=1
+c idptlxs(nptlxs)=id
+c xsptl(5,nptlxs)=ams
+c xsptl(4,nptlxs)=ej01+ams
+c xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+c & *(xsptl(4,nptlxs)+ams))
+c xsptl(2,nptlxs)=0.d0
+c xsptl(1,nptlxs)=0.d0
+ nptlxs=1
+ xnorm2=xnorm
+ idptlxs(nptlxs)=id
+ xsptl(5,nptlxs)=ams
+ xsptl(4,nptlxs)=E(NP-1)*1.d-3
+ xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+ & *(xsptl(4,nptlxs)+ams))
+ xsptl(2,nptlxs)=0.d0
+ xsptl(1,nptlxs)=0.d0
+ call cxhdecay(1,iret)
+ if(iret.eq.1)goto 10
+ do iii=2,nptlxs
+ if(abs(idptlxs(iii)).eq.120)then
+ enpe=max(1.d-10,xsptl(4,iii)-pmass(2))
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,1)=ppj(j,i,1,1)+real(xnorm2*appp1)
+ ppj(j+1,i,1,1)=ppj(j+1,i,1,1)+real(xnorm2*appp2)
+ endif
+ enddo
+ else
+ id=221
+ call cxidmass(id,ams)
+c enpe=max(1.d-10,E(NP-1)*1.d-3-ams)
+c j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+c ej0=eeha(j)
+c ej01=eeha(j+1)
+c appp1=(ej01-enpe)/(ej01-ej0)
+c appp2=1.d0-appp1
+c xnorm1=xnorm*appp1
+c nptlxs=1
+c idptlxs(nptlxs)=id
+c xsptl(5,nptlxs)=ams
+c xsptl(4,nptlxs)=ej0+ams
+c xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+c & *(xsptl(4,nptlxs)+ams))
+c xsptl(2,nptlxs)=0.d0
+c xsptl(1,nptlxs)=0.d0
+c call cxhdecay(1,iret)
+c if(iret.eq.1)goto 10
+c do iii=2,nptlxs
+c if(abs(idptlxs(iii)).eq.120)then
+c enpe=max(1.d-10,xsptl(4,iii)-pmass(2))
+c j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+c ej=eeha(j)
+c ej1=eeha(j+1)
+c appp1=(ej1-enpe)/(ej1-ej)
+c appp2=1.d0-appp1
+c ppj(j,i,1,1)=ppj(j,i,1,1)+real(xnorm1*appp1)
+c ppj(j+1,i,1,1)=ppj(j+1,i,1,1)+real(xnorm1*appp2)
+c endif
+c enddo
+c xnorm2=xnorm*appp2
+c nptlxs=1
+c idptlxs(nptlxs)=id
+c xsptl(5,nptlxs)=ams
+c xsptl(4,nptlxs)=ej01+ams
+c xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+c & *(xsptl(4,nptlxs)+ams))
+c xsptl(2,nptlxs)=0.d0
+c xsptl(1,nptlxs)=0.d0
+ nptlxs=1
+ xnorm2=xnorm
+ idptlxs(nptlxs)=id
+ xsptl(5,nptlxs)=ams
+ xsptl(4,nptlxs)=E(NP-1)*1.d-3
+ xsptl(3,nptlxs)=sqrt((xsptl(4,nptlxs)-ams)
+ & *(xsptl(4,nptlxs)+ams))
+ xsptl(2,nptlxs)=0.d0
+ xsptl(1,nptlxs)=0.d0
+ call cxhdecay(1,iret)
+ if(iret.eq.1)goto 10
+ do iii=2,nptlxs
+ if(abs(idptlxs(iii)).eq.120)then
+ enpe=max(1.d-10,xsptl(4,iii)-pmass(2))
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,1)=ppj(j,i,1,1)+real(xnorm2*appp1)
+ ppj(j+1,i,1,1)=ppj(j+1,i,1,1)+real(xnorm2*appp2)
+ endif
+ enddo
+ endif
+c produced proton/neutron
+ if(iq(np).eq.1120)then
+ ams=pmass(1)
+ enpe=max(1.d-10,E(NP)*1.d-3-ams)
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,2)=ppj(j,i,1,2)+real(xnorm*appp1)
+ ppj(j+1,i,1,2)=ppj(j+1,i,1,2)+real(xnorm*appp2)
+ elseif(iq(np).eq.1220)then
+ ams=pmass(6)
+ enpe=max(1.d-10,E(NP)*1.d-3-ams)
+ j=max(1,min(int(1.d0+log10(enpe/exmin)*decade),maximE))
+ ej=eeha(j)
+ ej1=eeha(j+1)
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ ppj(j,i,1,3)=ppj(j,i,1,3)+real(xnorm*appp1)
+ ppj(j+1,i,1,3)=ppj(j+1,i,1,3)+real(xnorm*appp2)
+ endif
+ 10 enddo
+
+c rho, proton, neutron from gamma by photonuclear effect
+ write(ifho,'(a)')'!---------------yield ------------'
+ write(ifho,'(a)') 'openhisto name pho'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a,1p,e10.3,a)') 'txt "title EngyMax (GeV) ='
+ & ,eeha(iemax),'"'
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [p] from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer[p] from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of proton from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer proton from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of neutron from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer neutron from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ if(agpi(iemax,j).lt.1.d-8)agpi(iemax,j)=0.d0
+ if(agpr(iemax,j).lt.1.d-8)agpr(iemax,j)=0.d0
+ if(agne(iemax,j).lt.1.d-8)agne(iemax,j)=0.d0
+ write(ifho,*)eeHa(j),agpi(iemax,j),agpr(iemax,j)
+ & ,agne(iemax,j)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ if(go)then
+ write(ifho,'(a)') ' plot pho+1- plot pho+2- plot pho+3-'
+
+ write(ifho,'(a)') 'openhisto name phoMC'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,'(a,2e15.3)') 'xrange ',max(eeha(1),eeha(iemax)*1.d-7)
+ & ,eeha(iemax)
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis E (GeV)"'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of [p] from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer[p] from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of proton from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer proton from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(2a)') '+ txt "yaxis EdN/dE of neutron from ',
+ & '[g]"'
+ write(ifho,'(a)') ' txt "refer neutron from [g]"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,*) 'array -4'
+ do j=1,imx
+ write(ifho,*)eeHa(j),ppj(j,imx,1,1),ppj(j,imx,1,2),ppj(j,imx,1,3)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ write(ifho,'(a)') ' plot phoMC+1- plot phoMC+2- plot phoMC+3'
+ else
+ write(ifho,'(a)') ' plot pho+1- plot pho+2- plot pho+3'
+ endif
+ endif
+
+ else
+
+ write(*,*)'command :',word
+ write(*,*)'not known in "table"'
+
+ endif
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine xEGScomp
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ write(ifho,'(a)')'!---------------EGS compton-----------------'
+ en=Eo*cEM**(maxe-1)
+ ntry=1000000
+ nbin=1
+ ni=(maxe-1)/nbin
+ xnorm=1.d0/dble(ntry)
+
+ goto 100
+
+c Compton
+ write(ifho,'(a)')'!------EGS Compton--------------'
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsCompt for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call comptcx
+c produced gamma
+ if(iq(np).eq.0)then
+ enpg=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpg=max(1.d-10,E(NP-1)*1.d-3)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.5d0+log(enpg/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+c produced electron
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ sww(i,j)=sww(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*f1cx(ej/c2em,C2em*ej,ei)
+ & /f1cx(ei/(2.d0*ei/amc2+1.d0),ei,ei)
+ svw(i,j)=ej*f1cx(ei-ej*C2em,ei-ej/c2em,ei)
+ & /f1cx(ei/(2.d0*ei/amc2+1.d0),ei,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGScompt'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Compton spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGScompt+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGScompt+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFcompt'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFcompt+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFcompt+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFcompt+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFcompt+',ip
+ endif
+
+
+c Bremstrahlung
+ write(ifho,'(a)')'!------EGS Bremstrahlung--------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsBrem for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=-1
+ call bremscx
+c produced gamma
+ if(iq(np).eq.0)then
+ enpg=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpg=max(1.d-10,E(NP-1)*1.d-3)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.5d0+log(enpg/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+c produced electron
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ sww(i,j)=sww(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wbremg(ei,ej,cem)
+ & /sbrem(ei)
+ svw(i,j)=ej*wbreme(ei,ej,cem)
+ & /sbrem(ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSbrem'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Bremstrahlung spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e from e of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSbrem+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSbrem+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFbrem'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFbrem+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFbrem+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFbrem+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFbrem+',ip
+ endif
+
+
+c Pair Production
+ write(ifho,'(a)')'!----------EGS pair-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsPair for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call paircx
+c produced gamma
+ if(iq(np).eq.1)then
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpp=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.5d0+log(enpp/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+c produced electron
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ sww(i,j)=sww(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ sp=spair(ei)
+ if(j.le.i.and.sp.gt.0.d0)then
+ svu(i,j)=ej*wpaire(ei,ej,cem)
+ & /sp
+ svw(i,j)=ej*wpaire(ei,ej,cem)
+ & /sp
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSpair'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Pair Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^+! from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSpair+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSpair+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFpair'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFpair+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFpair+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFpair+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFpair+',ip
+ endif
+
+
+c Moller
+ write(ifho,'(a)')'!----------EGS Moller-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ svu(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsMoller for E=',ei,i
+ do k=1,ntry
+c initial electron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=-1
+ call mollercx
+c produced electrons
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ j=max(1,min(int(1.5d0+log(enpp/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wdelta(ei,ej,cem)
+ & /smoel(0,eo,ei-eo,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSmoller'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Moller Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from e^-! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSmoller+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSmoller+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFmoller'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark ost'
+ enddo
+ write(ifho,*) 'array ',-1-nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFmoller+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFmoller+',ip,'- '
+ endif
+ enddo
+ ip=nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFmoller+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFmoller+',ip
+ endif
+
+c bhabha
+ write(ifho,'(a)')'!----------EGS Bhabha-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsBhaBha for E=',ei,i
+ do k=1,ntry
+c initial positron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=1
+ call bhabhacx
+ if(IQ(NP).eq.1)then
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpp=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+c produced positron
+ j=max(1,min(int(1.5d0+log(enpp/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+c produced electron
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ sww(i,j)=sww(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wbhap(ei,ej,cem)
+ & /sbaba(0,eo,ei,ei)
+ svw(i,j)=ej*wbhae(ei,ej,cem)
+ & /sbaba(0,eo,ei,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSbha'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Bhabha Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^+! from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSbha+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSbha+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFbha'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark ost'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFbha+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFbha+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFbha+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFbha+',ip
+ endif
+
+
+c Annihilation
+ write(ifho,'(a)')'!----------EGS Annihilation-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsAnni for E=',ei,i
+ do k=1,ntry
+c initial positron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=1
+ call annihcx
+c produced gammas
+ if(drangen(dummy).gt.0.5d0)then
+ enpp=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3)
+ else
+ enpe=max(1.d-10,E(NP)*1.d-3)
+ enpp=max(1.d-10,E(NP-1)*1.d-3)
+ endif
+ j=max(1,min(int(1.5d0+log(enpp/Eo)/log(Cem)),maxE))
+ suu(i,j)=suu(i,j)+1.d0
+ j=max(1,min(int(1.5d0+log(enpe/Eo)/log(Cem)),maxE))
+ sww(i,j)=sww(i,j)+1.d0
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ sp=fann(0,0.d0,ei+2.d0*amc2,ei)
+ if(j.le.i.and.sp.gt.0.d0)then
+ svu(i,j)=ej*wanng(ei,ej,cem)
+ & /sp
+ svw(i,j)=ej*wanng(ei,ej,cem)
+ & /sp
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSanni'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Annihilation spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSanni+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSanni+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFanni'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFanni+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFanni+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFanni+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFanni+',ip
+ endif
+
+ return
+
+
+c The same with energy sharing -------------------------------------------------
+
+ 100 continue
+
+c Compton
+ write(ifho,'(a)')'!------EGS Compton--------------'
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsCompt for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call comptcx
+c produced gamma
+ if(iq(np).eq.0)then
+ enpg=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpg=max(1.d-10,E(NP-1)*1.d-3)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.d0+log(enpg/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpg)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+c produced electron
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ sww(i,j)=sww(i,j)+appp1
+ sww(i,j+1)=sww(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wcompg(ei,ej,cem)
+ & /f1cx(ei/(2.d0*ei/amc2+1.d0),ei,ei)
+ svw(i,j)=ej*wcompe(ei,ej,cem)
+ & /f1cx(ei/(2.d0*ei/amc2+1.d0),ei,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGScompt'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Compton spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGScompt+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGScompt+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFcompt'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFcompt+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFcompt+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFcompt+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFcompt+',ip
+ endif
+
+c Bremstrahlung
+ write(ifho,'(a)')'!------EGS Bremstrahlung--------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsBrem for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=-1
+ call bremscx
+c produced gamma
+ if(iq(np).eq.0)then
+ enpg=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpg=max(1.d-10,E(NP-1)*1.d-3)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.d0+log(enpg/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpg)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+c produced electron
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ sww(i,j)=sww(i,j)+appp1
+ sww(i,j+1)=sww(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wbremg(ei,ej,cem)
+ & /sbrem(ei)
+ svw(i,j)=ej*wbreme(ei,ej,cem)
+ & /sbrem(ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSbrem'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Bremstrahlung spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e from e of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSbrem+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSbrem+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFbrem'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFbrem+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFbrem+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFbrem+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFbrem+',ip
+ endif
+
+
+c Pair Production
+ write(ifho,'(a)')'!----------EGS pair-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsPair for E=',ei,i
+ do k=1,ntry
+c initial gamma
+ NP=1
+ E(NP)=ei*1000.d0
+ IQ(NP)=0
+ call paircx
+c produced gamma
+ if(iq(np).eq.1)then
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpp=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+ j=max(1,min(int(1.d0+log(enpp/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpp)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+c produced electron
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ sww(i,j)=sww(i,j)+appp1
+ sww(i,j+1)=sww(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ sp=spair(ei)
+ if(j.le.i.and.sp.gt.0.d0)then
+ svu(i,j)=ej*wpaire(ei,ej,cem)
+ & /sp
+ svw(i,j)=ej*wpaire(ei,ej,cem)
+ & /sp
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSpair'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Pair Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^+! from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from [g] of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSpair+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSpair+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFpair'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFpair+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFpair+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFpair+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFpair+',ip
+ endif
+
+
+c Moller
+ write(ifho,'(a)')'!----------EGS Moller-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ svu(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsMoller for E=',ei,i
+ do k=1,ntry
+c initial electron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=-1
+ call mollercx
+c produced electrons
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ j=max(1,min(int(1.d0+log(enpp/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpp)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wdelta(ei,ej,cem)
+ & /smoel(0,eo,ei-eo,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSmoller'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Moller Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from e^-! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSmoller+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSmoller+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFmoller'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark ost'
+ enddo
+ write(ifho,*) 'array ',-1-nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFmoller+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFmoller+',ip,'- '
+ endif
+ enddo
+ ip=nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFmoller+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFmoller+',ip
+ endif
+
+c bhabha
+ write(ifho,'(a)')'!----------EGS Bhabha-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsBhaBha for E=',ei,i
+ do k=1,ntry
+c initial positron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=1
+ call bhabhacx
+ if(IQ(NP).eq.1)then
+ enpp=max(1.d-10,E(NP)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ else
+ enpp=max(1.d-10,E(NP-1)*1.d-3-amc2)
+ enpe=max(1.d-10,E(NP)*1.d-3-amc2)
+ endif
+c produced positron
+ j=max(1,min(int(1.d0+log(enpp/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpp)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+c produced electron
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ sww(i,j)=sww(i,j)+appp1
+ sww(i,j+1)=sww(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ if(j.le.i)then
+ svu(i,j)=ej*wbhap(ei,ej,cem)
+ & /sbaba(0,eo,ei,ei)
+ svw(i,j)=ej*wbhae(ei,ej,cem)
+ & /sbaba(0,eo,ei,ei)
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSbha'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Bhabha Production spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^+! from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer e^-! from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSbha+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSbha+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFbha'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'colo bla'
+ write(ifho,'(a)') 'mark ost'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFbha+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFbha+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFbha+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFbha+',ip
+ endif
+
+
+c Annihilation
+ write(ifho,'(a)')'!----------EGS Annihilation-------------'
+
+ do j=1,maxe
+ do i=mine,maxe
+ suu(i,j)=0.d0
+ sww(i,j)=0.d0
+ svu(i,j)=0.d0
+ svw(i,j)=0.d0
+ enddo
+ enddo
+ MEDIUM=1
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EgsAnni for E=',ei,i
+ do k=1,ntry
+c initial positron
+ NP=1
+ E(NP)=(ei+amc2)*1000.d0
+ IQ(NP)=1
+ call annihcx
+c produced gammas
+ if(drangen(dummy).gt.0.5d0)then
+ enpp=max(1.d-10,E(NP)*1.d-3)
+ enpe=max(1.d-10,E(NP-1)*1.d-3)
+ else
+ enpe=max(1.d-10,E(NP)*1.d-3)
+ enpp=max(1.d-10,E(NP-1)*1.d-3)
+ endif
+ j=max(1,min(int(1.d0+log(enpp/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpp)/(ej1-ej)
+ appp2=1.d0-appp1
+ suu(i,j)=suu(i,j)+appp1
+ suu(i,j+1)=suu(i,j+1)+appp2
+ j=max(1,min(int(1.d0+log(enpe/Eo)/log(Cem)),maxE-1))
+ ej=Eo*cEM**(j-1)
+ ej1=Eo*cEM**j
+ appp1=(ej1-enpe)/(ej1-ej)
+ appp2=1.d0-appp1
+ sww(i,j)=sww(i,j)+appp1
+ sww(i,j+1)=sww(i,j+1)+appp2
+ enddo
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ suu(i,j)=ej*suu(i,j)*xnorm
+ sww(i,j)=ej*sww(i,j)*xnorm
+ sp=fann(0,0.d0,ei+2.d0*amc2,ei)
+ if(j.le.i.and.sp.gt.0.d0)then
+ svu(i,j)=ej*wanng(ei,ej,cem)
+ & /sp
+ svw(i,j)=ej*wanng(ei,ej,cem)
+ & /sp
+ endif
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSanni'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Annihilation spectra"'
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer [g] from e^+! of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(suu(i,j),sww(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSanni+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSanni+',ip,'- '
+ endif
+ enddo
+ write(ifho,'(a)') ' '
+ write(ifho,'(a)') 'openhisto name EGFanni'
+ write(ifho,'(a)') 'htyp pnt'
+ write(ifho,'(a)') 'xmod log ymod log'
+ write(ifho,*) 'xrange ',Eo,en
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') '- txt "xaxis Energy (GeV)"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark osq'
+ write(ifho,'(a)') ' colo bla'
+ write(ifho,'(a)') '+ txt "yaxis dN/dln(E)"'
+ write(ifho,'(a)') 'mark ost'
+ write(ifho,'(a)') ' colo bla'
+ enddo
+ write(ifho,*) 'array ',-1-2*nbin
+ do j=1,maxe
+ ej=Eo*cEM**(j-1)
+ write(ifho,'(999e11.3)')ej,(svu(i,j),svw(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,2*nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGFanni+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGFanni+',ip,'- '
+ endif
+ enddo
+ ip=2*nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGFanni+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGFanni+',ip
+ endif
+
+
+
+ end
+
+c-------------------------------------------------------------------------
+ subroutine xEGSangle
+c-------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHIe,COSPHIe,PIe,TWOPI,PI5D2
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ dimension thetaEGS(maximumE,101)
+
+ write(ifho,'(a)')'!---------------EGS mscat-----------------'
+
+ ntry=1000000
+ nbin=4
+ ni=(maxe-1)/nbin
+ xnorm=1.d0/dble(ntry)
+ MEDIUM=1
+ RMSQ=amc2*amc2
+
+ do j=1,101
+ do i=mine,maxe
+ thetaEGS(i,j)=0.d0
+ enddo
+ enddo
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(*,*)'Run EGSangle for E=',ei,i
+ do k=1,ntry
+c initial electron
+ EOLD=ei*1000.d0
+ EIE=ei*1000.d0
+ BETA2=MAX(1.d-8,1.d0-RMSQ/EIE**2)
+ TVSTEP=5.d0!1d-3*RLDU(MEDIUM)*(EIE*BETA2*0.094315d0)**2/RHOF
+ call mscatcx
+ if(abs(sinthe).lt.1.d0)then
+ thet=asin(SINTHE)
+ else
+ thet=pi/2.d0
+c write(*,*)'EGS angle ???',sinthe,costhe
+ endif
+ j=min(1+int(100d0*thet/pi*2.d0),101)
+ thetaEGS(i,j)=thetaEGS(i,j)+1.d0
+ enddo
+ do j=1,101
+ thetaEGS(i,j)=thetaEGS(i,j)*xnorm
+ enddo
+ enddo
+ write(ifho,'(a)') 'openhisto name EGSangle'
+ write(ifho,'(a)') 'htyp lin'
+ write(ifho,'(a)') 'xmod lin ymod log'
+ write(ifho,*) 'xrange ',0,90.
+ write(ifho,'(a)') 'yrange auto auto '
+ write(ifho,'(a)') 'txt "title Multiple scattering"'
+ write(ifho,'(a)') '- txt "xaxis [q]"'
+ do i=maxe,ni,-ni
+ ei=Eo*cEM**(i-1)
+ write(ifho,'(a)') '+ txt "yaxis dN/d[q]"'
+ write(ifho,'(a,1p,e11.4,a)')
+ & 'txt "refer electron of',ei,' GeV"'
+ write(ifho,'(a)') ' colo mix'
+ enddo
+ write(ifho,*) 'array ',-1-nbin
+ do j=1,101
+ th=(j-1)*90.d0/100.d0
+ write(ifho,'(999e11.3)')th,(thetaEGS(i,j),i=maxe,ni,-ni)
+ end do
+ write(ifho,'(a)') ' endarray'
+ write(ifho,'(a)') 'closehisto'
+ do ip=1,nbin-1
+ if(ip.le.9)then
+ write(ifho,'(a,i1,a,$)') 'plot EGSangle+',ip,'- '
+ else
+ write(ifho,'(a,i2,a,$)') 'plot EGSangle+',ip,'- '
+ endif
+ enddo
+ ip=nbin
+ if(ip.le.9)then
+ write(ifho,'(a,i1)') 'plot EGSangle+',ip
+ else
+ write(ifho,'(a,i2)') 'plot EGSangle+',ip
+ endif
+
+ end
+
+#endif
+c 03.11.09 Correct (new) bug in thinning due to modification to avoid having
+c weight > wmax
+c 18.01.07 Change all function, subroutine and common name to avoid conflict with CORSIKA
+c 05.09.05 change Xfirst common
+c 17.02.05 Add DM(NP) in common xyzat
+c 15.11.04 Put AUSGAB, and additionnal subroutines (not originally in EGS4)
+c in egs4_conex.fpp
+c 12.11.04 Add muon pair production and photonuclear effect by T.Pierog
+c (from Corsika by D. Heck).
+c 28.06.04 Correction of the call of Profana for energy deposit.
+c 15.04.04 Switch to no multiple scattering with imscat flag and no ionizationloss with ionloss flag by T.Pierog to compare with Conex CE.
+c 01.03.04 Switch to 1D with i1DEM flag by T.Pierog to compare with Conex CE.
+c 13.01.04 Switch to double precision by T.Pierog for using into CONEX
+
+Copyright Stanford Mortran3.1 (FORTRAN 77 11JUN85)
+CINDENT EACH MORTRAN NESTING LEVEL BY 4
+CINDENT EACH FORTRAN NESTING LEVEL BY 2
+CThis line is 80 characters long, use it to set up the screen width
+C23456789|123456789|123456789|123456789|123456789|123456789|123456789|123456789
+C*********************************************************************
+C
+C **************
+C * *
+C * TUTOR1.MOR *
+C * *
+C **************
+C
+C An EGS4 user code. It lists the particles escaping from the back
+C of a 1 mm Ta plate when a pencil beam of 20 MeV electrons
+C is incident on it normally.
+C
+C For SLAC-265: A simple example which 'scores' by listing particles
+C D.W.O.R. JAN 1985
+C
+C The following units are used: unit 6 for (terminal) output
+C unit 8 to echo PEGS input data
+C unit 12 is PEGS cross-section file
+C unit 12 is PEGS cross-section file
+C Removed definition of RANDOM/RANDOMSET - BLIF 96/12/16
+C*********************************************************************
+C---------------------------------------------------------------------
+CSTEP 1: USER-OVERRIDE-OF-EGS4-MACROS
+C---------------------------------------------------------------------
+Conly 1 medium in the problem(default 10)
+Conly 3 geometric regions (default 2000)
+Cless than x particles on stack at once
+C REPLACE {$RANDOMSET#;} WITH {{P1}=rangen();}
+CDEFINE A COMMON TO PASS INFORMATION TO THE GEOMETRY ROUTINE HOWFAR
+C this changes the dunit=-2 into g/cm^2 instead of radiation length
+
+C********************************************************************
+C
+c SUBROUTINE AUSGABCX(IARG) ---> see egs4_conex.fpp
+C
+C IN GENERAL, AUSGAB IS A ROUTINE WHICH IS CALLED UNDER A SERIES
+C OF WELL DEFINED CONDITIONS SPECIFIED BY THE VALUE OF IARG (SEE THE
+C EGS4 MANUAL FOR THE LIST). THIS IS A PARTICULARILY SIMPLE AUSGAB.
+C WHENEVER THIS ROUTINE IS CALLED WITH IARG=3 , A PARTICLE HAS
+C BEEN DISCARDED BY THE USER IN HOWFAR
+C WE GET AUSGAB TO PRINT THE REQUIRED INFORMATION AT THAT POINT
+C
+C********************************************************************
+C*********************************************************************
+ SUBROUTINE HOWFARCX
+C
+C
+C THE FOLLOWING IS A GENERAL SPECIFICATION OF HOWFARCX
+C GIVEN A PARTICLE AT (X,Y,Z) IN REGION IR AND GOING IN DIRECTION
+C (U,V,W), THIS ROUTINE ANSWERS THE QUESTION, CAN THE PARTICLE GO
+C A DISTANCE USTEP WITHOUT CROSSING A BOUNDARY
+C IF YES, IT MERELY RETURNS
+C IF NO, IT SETS USTEP=DISTANCE TO BOUNDARY IN THE CURRENT
+C DIRECTION AND SETS IRNEW TO THE REGION NUMBER ON THE
+C FAR SIDE OF THE BOUNDARY (THIS CAN BE MESSY IN GENERAL!)
+C
+C THE USER CAN TERMINATE A HISTORY BY SETTING IDISC>0. HERE WE
+C TERMINATE ALL HISTORIES WHICH ENTER REGION 3 OR ARE GOING
+C BACKWARDS IN REGION 1
+C
+C | |
+C REGION 1 | REGION 2 | REGION 3
+C | |
+C e- =========> | | e- or photon ====>
+C | |
+C vacuum | Air | vacuum
+C
+C*********************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+C COMMON STACK CONTAINS X,Y,Z,U,V,W,IR AND NP(STACK POINTER)
+C COMMON EPCONT CONTAINS IRNEW, USTEP AND IDISC
+C COMMON CGEOM CONTAINS ZBOUND
+ COMMON/CGEOM/ZBOUND
+ IF ((IR(NP).EQ.3)) THEN
+ IDISC=1
+ RETURN
+C TERMINATE THIS HISTORY: IT IS PAST THE PLATE
+C WE ARE IN THE Ta PLATE - CHECK THE GEOMETRY
+ ELSE IF((IR(NP).EQ.2)) THEN
+ IF ((W(NP).GT.0.0)) THEN
+C GOING FORWARD - CONSIDER FIRST SINCE MOST FREQUENT
+C TVAL IS DIST TO BOUNDARY
+C IN THIS DIRECTION
+ TVAL=(ZBOUND-Z(NP))/W(NP)
+ IF ((TVAL.GT.USTEP)) THEN
+ RETURN
+C CAN TAKE CURRENTLY REQUESTED STEP
+ ELSE
+ USTEP=TVAL
+c in case of precision problem when particle reach ground (TP081104)
+ if(ustep.lt.0d0.and.abs(ZBOUND-Z(NP)).lt.1.d0)USTEP=0D0
+ IRNEW=3
+ RETURN
+ END IF
+C END OF W(NP)>0 CASE
+C GOING BACK TOWARDS ORIGIN
+ ELSE IF((W(NP).LT.0.0)) THEN
+C DISTANCE TO PLANE AT ORIGIN
+ TVAL=-Z(NP)/W(NP)
+ IF ((TVAL.GT.USTEP)) THEN
+ RETURN
+C CAN TAKE CURRENTLY REQUESTED STEP
+ ELSE
+ USTEP=TVAL
+c in case of precision problem when particle leave atmosphere (TP081104)
+ if(ustep.lt.0d0.and.Z(NP).lt.0.d0)USTEP=0D0
+ IRNEW=1
+ RETURN
+ END IF
+C END W(NP)<0 CASE
+C CANNOT HIT BOUNDARY
+ ELSE IF((W(NP).EQ.0.0)) THEN
+ RETURN
+ END IF
+C END OF REGION 2 CASE
+C IN REGON WITH SOURCE
+C THIS MUST BE A SOURCE PARTICLE ON Z=0 BOUNDARY
+ ELSE IF((IR(NP).EQ.1)) THEN
+ IF ((W(NP).GT.0.0)) THEN
+ USTEP=0.d0
+ IRNEW=2
+ RETURN
+ ELSE
+C IT MUST BE A REFLECTED PARTICLE-DISCARD IT
+ IDISC=1
+ RETURN
+ END IF
+C END REGION 1 CASE
+ END IF
+ END
+CEND OF SUBROUTINE HOWFARCX
+
+C******************************************************************
+ SUBROUTINE SHOW(IQI,EI,XMI,YMI,ZMI,DMI,XI,YI,ZI,TMI,UI,VI,WI,
+ * IRI,WTI,LATCHIN)
+C
+C EI in MeV
+C XMI in meter
+C YMI in meter
+C ZMI in meter
+C XI in meter
+C YI in meter
+C ZI in g/cm^2
+C LATCHIN : generation
+C
+C
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E,PZERO,PRM,PRMT2
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,STACK,UPHIOT,RANDOM/;
+ common /cxthin/ thin,ethin,wtmax,rthmax,iothin
+ COMMON/CXEGSDEB/ifckegs,isxegs
+
+ NP=1
+ DNEARI=0.d0
+ IQ(1)=IQI
+ E(1)=EI
+ U(1)=UI
+ V(1)=VI
+ W(1)=WI
+ X(1)=XI
+ Y(1)=YI
+ Z(1)=ZI
+ IR(1)=IRI
+ XM(1)=XMI
+ YM(1)=YMI
+ ZM(1)=ZMI
+ DM(1)=DMI
+ TM(1)=TMI
+ WT(1)=WTI
+ DNEAR(1)=DNEARI
+ LATCH(1)=LATCHIN
+ do while (NP.gt.0)
+
+ if(isxegs.ge.6)then
+ write(ifckegs,*)'egs step ---------------------------------'
+ do iii=1,np
+ write(ifckegs,*)'np,IQ,E,Z,H,Wt :',iii,IQ(iii),E(iii),Z(iii)
+ & ,ZM(iii),wt(iii)
+ enddo
+ endif
+C DECIDE WHAT IS ON TOP OF STACK
+ NPOLD=NP
+C OUTPUT NP,IQ(NP),E(NP),U(NP),V(NP),W(NP);
+C (' ',2i4,15g13.6);
+ IF (IQ(NP).EQ.0) THEN
+ CALL PHOTONCX(IRCODE)
+ ELSEIF (ABS(IQ(NP)).EQ.1) THEN
+ CALL ELECTRCX(IRCODE)
+ ELSE !if production of muons or hadrons
+ IARG=100
+ CALL AUSGABCX(IARG)
+ END IF
+
+
+C Here some thinning can be done (only for gamma and electrons)
+ if(iothin.ne.0.and.NP.gt.NPOLD)then
+ if(ABS(IQ(NP)).LE.1)then
+ IF (E(NP).lt.ETHIN.and.WT(NP).lt.0.99d0*wtmax) THEN
+1101 IF(.NOT.(E(NPOLD).ge.ETHIN.or.WT(NPOLD).ge.0.99d0*wtmax))
+ & GO TO 1102
+ NPOLD=NPOLD+1
+ GO TO 1101
+1102 CONTINUE
+ ETOT=0.d0
+ do i=NPOLD,NP
+ ETOT=ETOT+E(i)
+ enddo
+ IF (iothin.eq.1) THEN
+ R=DRANEGS(dummy)
+ ERAN=ETOT*R
+ i=NPOLD
+ E2=E(i)
+ do while (E2.lt.ERAN)
+ i=i+1
+ E2=E2+E(i)
+ enddo
+C OUTPUT EIN,ETOT,R,ERAN,weight,NPOLD,NP,i;
+C (5g13.6,3i5);
+ weight=ETOT/E(i)
+ IF (i.gt.NP) THEN
+ write(*,*)'Problem in thinning in EGS4 !',NPOLD,NP,ETOT
+ & ,ERAN,E2,iq(i),i,E(np),E(npold),E(i)
+ stop'i.gt.NP'
+ END IF
+ WT(i)=WT(i)*weight
+ IF (i.gt.NPOLD) THEN
+ IQ(NPOLD)=IQ(i)
+ E(NPOLD)=E(i)
+ U(NPOLD)=U(i)
+ V(NPOLD)=V(i)
+ W(NPOLD)=W(i)
+ X(NPOLD)=X(i)
+ Y(NPOLD)=Y(i)
+ Z(NPOLD)=Z(i)
+ IR(NPOLD)=IR(i)
+ XM(NPOLD)=XM(i)
+ YM(NPOLD)=YM(i)
+ ZM(NPOLD)=ZM(i)
+ DM(NPOLD)=DM(i)
+ TM(NPOLD)=TM(i)
+ WT(NPOLD)=WT(i)
+ DNEAR(NPOLD)=DNEAR(i)
+ LATCH(NPOLD)=LATCH(i)
+ END IF
+ NP=NPOLD
+ ELSE IF(iothin.eq.2) THEN
+ i=np
+ do while (i.ge.npold)
+ R=DRANEGS(dble(i))
+ pb=(e(i)/etot)
+ if(wt(i)/pb.gt.wtmax)pb=1.d0
+ IF ((pb.lt.R)) THEN
+ IF (i.lt.NP) THEN
+ IQ(i)=IQ(NP)
+ E(i)=E(NP)
+ U(i)=U(NP)
+ V(i)=V(NP)
+ W(i)=W(NP)
+ X(i)=X(NP)
+ Y(i)=Y(NP)
+ Z(i)=Z(NP)
+ IR(i)=IR(NP)
+ XM(i)=XM(NP)
+ YM(i)=YM(NP)
+ ZM(i)=ZM(NP)
+ DM(i)=DM(NP)
+ TM(i)=TM(NP)
+ WT(i)=WT(NP)
+ DNEAR(i)=DNEAR(NP)
+ LATCH(i)=LATCH(NP)
+ END IF
+ NP=NP-1
+ ELSE
+ wt(i)=wt(i)/pb
+ END IF
+ i=i-1
+ enddo
+cc$$$ ELSE IF(iothin.eq.3) THEN
+cc$$$ xx=XM(NP)
+cc$$$ yy=YM(NP)
+cc$$$ hh=ZM(NP)-hgrnd
+cc$$$ call toaxis(xx,yy,hh)
+cc$$$ i=np
+cc$$$ if (xx*xx+yy*yy.gt.rthmax*rthmax) i=npold-1
+cc$$$ do while (i.ge.npold)
+cc$$$ R=DRANEGS(dble(i))
+cc$$$ pb=(e(i)/etot)
+cc$$$ if(wt(i)/pb.gt.wtmax)pb=1.
+cc$$$ IF ((pb.lt.R)) THEN
+cc$$$ IF (i.lt.NP) THEN
+cc$$$ IQ(i)=IQ(NP)
+cc$$$ E(i)=E(NP)
+cc$$$ U(i)=U(NP)
+cc$$$ V(i)=V(NP)
+cc$$$ W(i)=W(NP)
+cc$$$ X(i)=X(NP)
+cc$$$ Y(i)=Y(NP)
+cc$$$ Z(i)=Z(NP)
+cc$$$ IR(i)=IR(NP)
+cc$$$ XM(i)=XM(NP)
+cc$$$ YM(i)=YM(NP)
+cc$$$ ZM(i)=ZM(NP)
+cc$$$ DM(i)=DM(NP)
+cc$$$ TM(i)=TM(NP)
+cc$$$ WT(i)=WT(NP)
+cc$$$ DNEAR(i)=DNEAR(NP)
+cc$$$ LATCH(i)=LATCH(NP)
+cc$$$ END IF
+cc$$$ NP=NP-1
+cc$$$ ELSE
+cc$$$ wt(i)=wt(i)/pb
+cc$$$ END IF
+cc$$$ i=i-1
+cc$$$ enddo
+ END IF
+ END IF
+ endif
+ endif
+ enddo
+ RETURN
+CEND OF SUBROUTINE SHOW
+ END
+
+Cegs4blok.mortran (SID 1.2 last edited 23 Nov 1996)
+C 1.1 based on old version
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ BLOCK DATA
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C Copyright (C) 1985 by the Board of Trustees of the Leland
+C Stanford Junior University. All Rights Reserved.
+C******************************************************************
+C
+C AUTHORS: WALTER R. NELSON
+C Radiation Physics Group
+C Stanford Linear Accelerator Center
+C Stanford, CA 94305
+C U.S.A.
+C
+C HIDEO HIRAYAMA
+C National Laboratory for High Energy Physics (KEK)
+C Oho-machi, Tsukuba-gun, Ibaraki,
+C JAPAN
+C
+C DAVID W. O. ROGERS
+C Division of Physics
+C National Research Council of Canada
+C Ottawa K1A 0R6
+C CANADA
+C
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/BREMPR/ DL1(6,1),DL2(6,1),DL3(6,1),DL4(6,1),DL5(6,1),DL6(6,
+ *1), ALPHI(2,1),BPAR(2,1),DELPOS(2,1), ASYM(1,50,2), WA(1,50),PZ(1,
+ *50),ZELEM(1,50),RHOZ(1,50), PWR2I(100), DELCM(1),ZBRANG(1),FBRSPL,
+ * NNE(1),IBRDST,IPRDST,IBRSPL,NBRSPL
+ CHARACTER*4 ASYM
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/MULTS/ B0G21,B1G21,G210(7),G211(7),G212(7), B0G22,B1G22,G22
+ *0(8),G221(8),G222(8), B0G31,B1G31,G310(11),G311(11),G312(11), B0G3
+ *2,B1G32,G320(25),G321(25),G322(25), B0BGB,B1BGB,BGB0(8),BGB1(8),BG
+ *B2(8), NG21,NG22,NG31,NG32,NBGB
+ COMMON/PATHCM/B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6),NPTH
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIIN/SINC0,SINC1,SIN0(1002),SIN1(1002)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/BOUNDS,BREMPR,ELECIN,EPCONT,MEDIA,MISC,MULTS,PATHCM,PHOTIN,
+C STACK,THRESH,UPHIIN,UPHIOT,USEFUL/;
+CNOW A FUDGE FOR NRC ADDITIONS
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+C==========
+C========================
+ COMMON/EDGE/EKALPH(1),EKBETA(1),BKR1(1),BKR2(1),IEDGFL(3)
+C=============================
+ COMMON/USERSC/ SMAX,SMAXIR(3),ESTEPE,ESTEPR(3),ESAVE(3), NOMSCT(3)
+ *,NOPLC(3)
+C===============
+ COMMON/USERVR/ CEXPTR,GWAIT,IFORCE,NFMIN,NFMAX,NFTIME,ISOURC,IFPB,
+ *IQINC,MONOEN
+ COMMON/USERXT/IPHTER(3)
+ CHARACTER*4 MEDIA1(24)
+ EQUIVALENCE(MEDIA1(1),MEDIA(1,1))
+CDATA INITIALIZATION FOR THE ABOVE COMMON BLOCKS
+CBOUNDS
+ DATA ECUT/3*0./,PCUT/3*0./,VACDST/1.E8/
+CELECIN
+ DATA EKELIM/0./,ICOMP/1/
+CEPCONT
+ DATA IAUSFL/5*1,25*0/,RHOF/1.0/
+CMEDIA
+ DATA NMED /1/, MEDIA1/'N','A','I',' ',' ',' ',' ',' ',' ',' ',' ',
+ *' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '/
+ DATA IRAYLM/1*0/
+CMISC
+ DATA KMPI/12/,KMPO/8/,DUNIT/1./,NOSCAT/0/
+CNote, if you change KMPI, must change OPEN(UNIT=KMPI,file=fort.12..)
+Cstmt in egs4.mortran- this is a fudge for HP port DR
+ DATA MED/3*1/,RHOR/3*0./,IRAYLR/3*0/
+CMULTS
+ DATA NG21/ 7/,B0G21/ 2.0000E+00/,B1G21/ 5.0000E+00/
+ DATA G210( 1),G211( 1),G212( 1)/-9.9140E-04, 2.7672E+00,-1.1544E+0
+ *0/
+ DATA G210( 2),G211( 2),G212( 2)/-9.9140E-04, 2.7672E+00,-1.1544E+0
+ *0/
+ DATA G210( 3),G211( 3),G212( 3)/-7.1017E-02, 3.4941E+00,-3.0773E+0
+ *0/
+ DATA G210( 4),G211( 4),G212( 4)/-7.3556E-02, 3.5487E+00,-3.1989E+0
+ *0/
+ DATA G210( 5),G211( 5),G212( 5)/ 3.6658E-01, 2.1162E+00,-2.0311E+0
+ *0/
+ DATA G210( 6),G211( 6),G212( 6)/ 1.4498E+00,-5.9717E-01,-3.2951E-0
+ *1/
+ DATA G210( 7),G211( 7),G212( 7)/ 1.4498E+00,-5.9717E-01,-3.2951E-0
+ *1/
+ DATA NG22/ 8/,B0G22/ 2.0000E+00/,B1G22/ 6.0000E+00/
+ DATA G220( 1),G221( 1),G222( 1)/-5.2593E-04, 1.4285E+00,-1.2670E+0
+ *0/
+ DATA G220( 2),G221( 2),G222( 2)/-5.2593E-04, 1.4285E+00,-1.2670E+0
+ *0/
+ DATA G220( 3),G221( 3),G222( 3)/-6.4819E-02, 2.2033E+00,-3.6399E+0
+ *0/
+ DATA G220( 4),G221( 4),G222( 4)/ 3.7427E-02, 1.6630E+00,-2.9362E+0
+ *0/
+ DATA G220( 5),G221( 5),G222( 5)/ 6.1955E-01,-6.2713E-01,-6.7859E-0
+ *1/
+ DATA G220( 6),G221( 6),G222( 6)/ 1.7584E+00,-4.0390E+00, 1.8810E+0
+ *0/
+ DATA G220( 7),G221( 7),G222( 7)/ 2.5694E+00,-6.0484E+00, 3.1256E+0
+ *0/
+ DATA G220( 8),G221( 8),G222( 8)/ 2.5694E+00,-6.0484E+00, 3.1256E+0
+ *0/
+ DATA NG31/ 11/,B0G31/ 2.0000E+00/,B1G31/ 9.0000E+00/
+ DATA G310( 1),G311( 1),G312( 1)/ 4.9437E-01, 1.9124E-02, 1.8375E+0
+ *0/
+ DATA G310( 2),G311( 2),G312( 2)/ 4.9437E-01, 1.9124E-02, 1.8375E+0
+ *0/
+ DATA G310( 3),G311( 3),G312( 3)/ 5.3251E-01,-6.1555E-01, 4.5595E+0
+ *0/
+ DATA G310( 4),G311( 4),G312( 4)/ 6.6810E-01,-2.2056E+00, 8.9293E+0
+ *0/
+ DATA G310( 5),G311( 5),G312( 5)/-3.8262E+00, 2.5528E+01,-3.3862E+0
+ *1/
+ DATA G310( 6),G311( 6),G312( 6)/ 4.2335E+00,-1.0604E+01, 6.6702E+0
+ *0/
+ DATA G310( 7),G311( 7),G312( 7)/ 5.0694E+00,-1.4208E+01, 1.0456E+0
+ *1/
+ DATA G310( 8),G311( 8),G312( 8)/ 1.4563E+00,-3.3275E+00, 2.2601E+0
+ *0/
+ DATA G310( 9),G311( 9),G312( 9)/-3.2852E-01, 1.2938E+00,-7.3254E-0
+ *1/
+ DATA G310(10),G311(10),G312(10)/-2.2489E-01, 1.0713E+00,-6.1358E-0
+ *1/
+ DATA G310(11),G311(11),G312(11)/-2.2489E-01, 1.0713E+00,-6.1358E-0
+ *1/
+ DATA NG32/ 25/,B0G32/ 2.0000E+00/,B1G32/ 2.3000E+01/
+ DATA G320( 1),G321( 1),G322( 1)/ 2.9907E-05, 4.7318E-01, 6.5921E-0
+ *1/
+ DATA G320( 2),G321( 2),G322( 2)/ 2.9907E-05, 4.7318E-01, 6.5921E-0
+ *1/
+ DATA G320( 3),G321( 3),G322( 3)/ 2.5820E-03, 3.5853E-01, 1.9776E+0
+ *0/
+ DATA G320( 4),G321( 4),G322( 4)/-5.3270E-03, 4.9418E-01, 1.4528E+0
+ *0/
+ DATA G320( 5),G321( 5),G322( 5)/-6.6341E-02, 1.4422E+00,-2.2407E+0
+ *0/
+ DATA G320( 6),G321( 6),G322( 6)/-3.6027E-01, 4.7190E+00,-1.1380E+0
+ *1/
+ DATA G320( 7),G321( 7),G322( 7)/-2.7953E+00, 2.6694E+01,-6.0986E+0
+ *1/
+ DATA G320( 8),G321( 8),G322( 8)/-3.6091E+00, 3.4125E+01,-7.7512E+0
+ *1/
+ DATA G320( 9),G321( 9),G322( 9)/ 1.2491E+01,-7.1103E+01, 9.4496E+0
+ *1/
+ DATA G320(10),G321(10),G322(10)/ 1.9637E+01,-1.1371E+02, 1.5794E+0
+ *2/
+ DATA G320(11),G321(11),G322(11)/ 2.1692E+00,-2.5019E+01, 4.5340E+0
+ *1/
+ DATA G320(12),G321(12),G322(12)/-1.6682E+01, 6.2067E+01,-5.5257E+0
+ *1/
+ DATA G320(13),G321(13),G322(13)/-2.1539E+01, 8.2651E+01,-7.7065E+0
+ *1/
+ DATA G320(14),G321(14),G322(14)/-1.4344E+01, 5.5193E+01,-5.0867E+0
+ *1/
+ DATA G320(15),G321(15),G322(15)/-5.4990E+00, 2.3874E+01,-2.3140E+0
+ *1/
+ DATA G320(16),G321(16),G322(16)/ 3.1029E+00,-4.4708E+00, 2.1318E-0
+ *1/
+ DATA G320(17),G321(17),G322(17)/ 6.0961E+00,-1.3670E+01, 7.2823E+0
+ *0/
+ DATA G320(18),G321(18),G322(18)/ 8.6179E+00,-2.0950E+01, 1.2536E+0
+ *1/
+ DATA G320(19),G321(19),G322(19)/ 7.5064E+00,-1.7956E+01, 1.0520E+0
+ *1/
+ DATA G320(20),G321(20),G322(20)/ 5.9838E+00,-1.4065E+01, 8.0342E+0
+ *0/
+ DATA G320(21),G321(21),G322(21)/ 4.4959E+00,-1.0456E+01, 5.8462E+0
+ *0/
+ DATA G320(22),G321(22),G322(22)/ 3.2847E+00,-7.6709E+00, 4.2445E+0
+ *0/
+ DATA G320(23),G321(23),G322(23)/ 1.9514E+00,-4.7505E+00, 2.6452E+0
+ *0/
+ DATA G320(24),G321(24),G322(24)/ 4.8808E-01,-1.6910E+00, 1.0459E+0
+ *0/
+ DATA G320(25),G321(25),G322(25)/ 4.8808E-01,-1.6910E+00, 1.0459E+0
+ *0/
+ DATA NBGB/ 8/,B0BGB/ 1.5714E+00/,B1BGB/ 2.1429E-01/
+ DATA BGB0( 1),BGB1( 1),BGB2( 1)/-1.0724E+00, 2.8203E+00,-3.5669E-0
+ *1/
+ DATA BGB0( 2),BGB1( 2),BGB2( 2)/ 3.7136E-01, 1.4560E+00,-2.8072E-0
+ *2/
+ DATA BGB0( 3),BGB1( 3),BGB2( 3)/ 1.1396E+00, 1.1910E+00,-5.2070E-0
+ *3/
+ DATA BGB0( 4),BGB1( 4),BGB2( 4)/ 1.4908E+00, 1.1267E+00,-2.2565E-0
+ *3/
+ DATA BGB0( 5),BGB1( 5),BGB2( 5)/ 1.7342E+00, 1.0958E+00,-1.2705E-0
+ *3/
+ DATA BGB0( 6),BGB1( 6),BGB2( 6)/ 1.9233E+00, 1.0773E+00,-8.1806E-0
+ *4/
+ DATA BGB0( 7),BGB1( 7),BGB2( 7)/ 2.0791E+00, 1.0649E+00,-5.7197E-0
+ *4/
+ DATA BGB0( 8),BGB1( 8),BGB2( 8)/ 2.0791E+00, 1.0649E+00,-5.7197E-0
+ *4/
+ DATA NPTH/ 6/,B0PTH/ 2.0000E+00/,B1PTH/ 1.8182E+01/
+ DATA PTH0( 1),PTH1( 1),PTH2( 1)/ 1.0000E+00, 9.8875E-01, 2.5026E+0
+ *0/
+ DATA PTH0( 2),PTH1( 2),PTH2( 2)/ 1.0000E+00, 9.8875E-01, 2.5026E+0
+ *0/
+ DATA PTH0( 3),PTH1( 3),PTH2( 3)/ 1.0060E+00, 7.8657E-01, 4.2387E+0
+ *0/
+ DATA PTH0( 4),PTH1( 4),PTH2( 4)/ 1.0657E+00,-2.5051E-01, 8.7681E+0
+ *0/
+ DATA PTH0( 5),PTH1( 5),PTH2( 5)/ 1.6971E+00,-7.5600E+00, 2.9946E+0
+ *1/
+ DATA PTH0( 6),PTH1( 6),PTH2( 6)/ 1.6971E+00,-7.5600E+00, 2.9946E+0
+ *1/
+CTHRESH
+ DATA RMT2/1.02200/,RMSQ/.2611199/
+CUPHIOT
+ DATA PI/3.141593/,TWOPI/6.283185/,PI5D2/7.853982/
+CUSEFUL
+C******************************************************************
+C********************* END OF EGS4 BLOCK DATA *********************
+C******************************************************************
+CNOW SOME FUDGES FOR NRC ADDITIONS
+CRANDOM
+CSHUT OFF TO ALLOW MORE GENERAL INITIALIZATION IN MAIN AFB 90/01/09
+C$RNG-INITIALIZATION; NRCC EXTENSION AFB 87/12/31
+CUSER
+ DATA IPHTER /3*0/
+CEDGE
+ DATA IEDGFL/3*0/, BKR1/1*0/,BKR2/1*0/, EKALPH/1*0/,EKBETA/1*0/
+ END
+CEND OF BLOCK DATA
+Cegs4.mortran (SID 1.8 last edited 27 Nov 1996)
+C EGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C This version contains the correction to the error in the Moller
+C sampling routine which had a small effect on electron transport
+C To recover the previous version, rename the file
+C egs4_mollerbug.mortran to egs4.mortran (after saving of course)
+C Alternativel, just change the configuration file to pick
+C up $HEN_HOUSE/egs4_mollerbug.mortran instead of egs4.mortran
+C DWOR Oct 3, 1996
+C******************************************************************
+C
+C NRCC CHANGES
+C
+C******************************************************************
+CCHANGE MADE IN ANNIH, JULY 24, 1986 TO PREVENT COSTHE>1.00 IN HIGH
+CENERGY APPLICATIONS - D.W.O.R.
+CMADE CHANGES IN PHOTO, 86/9/12 TO SELECT PHOTOELECTRON ANGLE - AFB
+CCHANGE IN ELECTR
+CMODIFIED USER DIRECTED POSITRON DISCARD TO ALLOW FOR THE CREATION
+COF THE ANNIHILATION GAMMAS. THIS WOULD BE USED FOR EXAMPLE WHEN
+CRANGE REJECTING POSITRONS SINCE THE PHOTONS CAN PENETRATE BEYOND
+CTHE RANGE OF THE POSITRON. THIS IS SIGNALED BY IDISC=+/-99 SET BY
+CTHE USER CODE. SEE FURTHER COMMENTS NEAR :USER-ELECTRON-DISCARD:
+C AFB 86/9/12
+CCHANGE IN ELECTR
+CPUT IN AN EXTRA TEMPLATE $USER_CONTROLS_TSTEP_RECURSION IN ORDER
+CTO RE-EVALUATE THE ELECTRON CROSS SECTIONS AFTER A BOUNDARY
+CCROSSING.
+C AFB 87/12/08
+CCHANGE IN HATCH
+CNOW READ IN THE ELEMENTAL COMPOSITION OF EACH MEDIUM AND STORE
+CTHEM IN VARIABLES HOUSED IN COMMON BREMPR. THIS INFORMATION WAS
+CNEEDED FOR SAMPLING THE BREMSSTRAHLUNG ANGULAR DISTRIBUTION BUT
+CMAY BE NEEDED FOR OTHER PURPOSES LATER ON.
+C AFB 88/05/31
+CCHANGED PHOTO so PHOTOELECTRIC angle selected (as per AFB) and
+Cimplement K-shell fluorescence x-rays (i.e. new PHOTO and placed
+Croutine EDGSET in EGS4
+CCorresponding changes in BLOCK DATA to zero all arrays needed
+C
+CCHANGE IN HATCH
+C NOW READS IN IUNRST, EPSTFL AND IAPRIM AND STORED IN ELECIN
+C DWOR 89/12/19
+C
+Cbuffer flush
+CCHANGE IN HATCH
+CInserted new macro template $INITIALIZE-PAIR-ANGLE for
+Cinitializing elemental data.
+C
+CCHANGE IN PAIR
+CFixed bug whereby a negative energy positron or electron could be
+Ccreated.
+C AFB 91/05/29
+C
+CCHANGE TO ALL ROUTINES
+CAdded !LABELS 1000; at the start of each routine.
+CThis allows the 'x' mode of compilation in the UNIX distribution
+Cto work more efficiently
+C AFB 92/04/03
+C
+CINFINITE LOOP IN BREMS
+CInfinite loop problem in BREMSCX spotted by H Hirayama fixed using
+CHideo's patch. Here is the letter sent regarding the patch:
+C
+CInfinitive loop in SUBROUTINE BREMSCX EBR1 and PBR1 are set to 0
+Cbelow AP+RM in PEGS4. This means that EBR1 or PBR1 drops to 0 at
+Cthis point. It is very difficult to fit these tendency.
+CTherefore, the calculated EBR1 or PBR1 in EGS4 has some value
+Cbelow AP+RM. The value is very small. But once bremsstrahlung
+Cis selected in this situation, particle cannot escape from the
+Cloop of energy determination in BREMSCX. (Photon energy must be
+Clarger than AP and electron or positron energy must be larger than
+CRM.) For example, one of the user met this infinitive loop under
+Cthe following situation.
+C
+C AE=0.516, AP=0.01 and loop ocuures at EI=0.52099 MeV. at this
+C energy EBR1=0.63255E-05. (at EI=0.530 EBR1 becomes 0.12E-02)
+C
+CTo avoide this infinitive loop, EBR1 and PBR1 must be set 0 below
+CAP+RM as follows.
+C
+CIn SUBROUTINE ELECTRA
+C
+C $EVALUATE EBR1 USING EBR1(ELKE);
+C IF(EKE.LE.AP(MED(IRL))) EBR1=0.0;
+C
+C $EVALUATE PBR1 USING PBR1(ELKE);
+C IF(EKE.LE.AP(MED(IRL))) PBR1=0.0;
+C
+C $RANDOMSET RNNO24;
+C IF(RNNO24.LT.EBR1) [
+C GO TO :EBREMS:;]
+C
+CNote that there was a change RNNO24.LE.EBR1 to RNNO24.LT.EBR1
+Cin the above coding.
+C
+CDo a search for 'HH' to find these patches.
+C
+C AFB 92/07/24
+Cbuffer flush
+C
+CLOW PROBABILITY FLOATING ERROR IN BHABHACX
+CDavid Jaffrey (London Regional Cancer Centre reports that
+Cthe following statement in SUBROUTINE BHABHACX can cause a problem:
+C
+CH1=(PEIP+PRM)/PEKIN;
+CDCOSTH=H1*(PESE1-PRM)/(PESE1+PRM);
+CSINTHE=DSQRT(1.D0-DCOSTH);
+C
+Csince DCOSTH can be > 1 (extremely low probability).
+C
+CI have hard-wired the following change:
+C
+CDCOSTH=MIN(1.0D0,H1*(PESE1-PRM)/(PESE1+PRM));
+CSINTHE=DSQRT(1.D0-DCOSTH);
+C
+C AFB 92/10/28
+C
+Cbuffer flush
+CFAILURE TO CALL AUSGAB WITH IARG=5 on BOUNDARY
+C
+CIn ELECTR and PHOTON, if the particle crosses a boundary,
+Cthe call to AUSGAB after the particle has been transported
+Cis done after a check against ECUT and PCUT. If it is
+Cdiscarded for being below ECUT or PCUT, then the call to
+CAUSGAB is not made.
+C
+CThus, if a USER code makes no use of the call to AUSGAB
+Cafter the particle transport (i.e. with IARG =5, which
+Crequires setting IAUSFL(6)=1), or if PCUT and ECUT are
+Cconstant throughout all geometric regions, then this bug
+Cwill have no effect on previous calculations. However, if
+Cboth of these conditions are met, there could be serious
+Cproblems in the simulation.
+C
+C
+CThe PATCHES are very simple, requiring the changing of
+Corder of two statements, and in the photon case, slightly
+Crearranging one block.
+C
+CError found by C Ma and corrected by DWOR 31 Oct 1994
+C
+Cbuffer flush
+CSAMPLING ERROR IN MOLLER/BHABHACX ROUTINES
+C==================================================================
+C
+C
+CThe rejection functions employed in the energy distribution
+C
+Csampling of both the Moller and Bhabhacx routines have been fixed.
+C
+CBasically, the error caused the sampling to be pure 1/E**2 which
+C
+Cis not completely correct and results in too few high energy
+C
+Cknock-ons being created. The was first pointed out by L Urban as
+C
+Cpart of the GEANT collaboration in 1986 and pointed out again by
+C
+CAlfredo Ferrari of INFN in 1996. To see the patches, look for
+C
+CBLIF 96/2/1.
+C
+C BLIF 96/2/1
+C
+C
+C
+CCONSISTENT ELECTRON VACUUM ECUT DISCARDS AND DEFERRED DISCARDS
+C
+C==================================================================
+C
+CPaul Magnuson of Imatron Inc. provided the following patch:
+C
+CIn SUBROUTINE ELECTR, change:
+C
+CIF(EIE.LE.ECUT(IRL)) [GO TO :ECUT-DISCARD:;]
+C
+CIF(USTEP.NE.0.0) [$AUSCALL($TRANAUSA);]
+C
+CNEXT :TSTEP: ;]
+C
+Cto:
+C
+CIF(USTEP.NE.0.0) [$AUSCALL($TRANAUSA);]
+C
+CIF(EIE.LE.ECUT(IRL)) [GO TO :ECUT-DISCARD:;]
+C
+CIF(USTEP.NE.0.AND.IDISC.LT.0) [GO TO :USER-ELECTRON-DISCARD:;]
+C
+CNEXT :TSTEP: ;]
+C
+CThis makes the ECUT discard for electrons consistent with the
+C
+Cnon-vacuum transport suggest by Charlie Ma and implimented
+C
+C94/10/31 by Dave Rogers. Also, the deferred user discard is
+C
+Cprovided here as well.
+C
+C BLIF 96/11/27
+C
+C******************************************************************
+C
+C END OF NRCC CHANGES
+C
+C******************************************************************
+C******************************************************************
+C*************************** STANFORD LINEAR ACCELERATOR CENTER
+C********* E G S 4 *********
+C*************************** VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C Copyright (C) 1985 by the Board of Trustees of the Leland
+C Stanford Junior University. All Rights Reserved.
+C******************************************************************
+C
+C AUTHORS: WALTER R. NELSON
+C Radiation Physics Group
+C Stanford Linear Accelerator Center
+C Stanford, CA 94305
+C U.S.A.
+C
+C HIDEO HIRAYAMA
+C National Laboratory for High Energy Physics (KEK)
+C Oho-machi, Tsukuba-gun, Ibaraki,
+C JAPAN
+C
+C DAVID W. O. ROGERS
+C Division of Physics
+C National Research Council of Canada
+C Ottawa K1A 0R6
+C CANADA
+C
+C******************************************************************
+C
+C DESCRIPTION: EGS ('Electron-Gamma Shower') is a program
+C that simulates electron-photon transport by
+C the Monte Carlo method. Version 4 of the EGS
+C Code System consists of:
+C
+C EGS4: The MAIN simulation program itself.
+C
+C EGS4 MACROS: A separate file of macros, usually
+C identified on tape as EGS4MAC, that
+C must be used with EGS4.
+C
+C EGS4 BLOCK: A separate file, usually identified
+C on tape as EGS4BLOK, that contains
+C the Block Data necessary for EGS4.
+C
+C PEGS4: A self-contained Preprocessor code
+C that, when run separately, creates
+C media data to be read by subroutine
+C HATCH of EGS4.
+C
+C******************************************************************
+C
+C ACKNOWLEDGEMENT
+C
+C The authors acknowledge Dr. Richard L. Ford for his part in
+C developing the previous version of the EGS Code System
+C (EGS3 and PEGS3) including the documentation thereof.
+C
+C******************************************************************
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C
+C The EGS4 Code System and associated documents, and the material
+C and data contained therein, were developed under the sponsorship
+C of the U.S. Government. Neither the U.S. nor the U.S.D.O.E.,
+C nor the Leland Stanford Junior University, nor their employees,
+C nor their respective contractors, subcontractors, or their
+C employees, makes any warranty, express or implied, or assumes
+C any liability or responsibility for accuracy, completeness or
+C usefulness of any information, apparatus, product or process
+C disclosed, or represents that its use will not infringe
+C privately-owned rights. Mention of any product, its manu-
+C facturer, or suppliers shall not, nor is it intended to, imply
+C approval, disapproval, or fitness for any particular use. A
+C royalty-free, non-exclusive right to use and disseminate same
+C for any purpose whatsoever is expressly reserved to the U.S.
+C and the University. [The EGS4 Code System includes the files
+C commonly known as EGS4MAC, EGS4, EGS4BLOK, and PEGS4].
+C
+C******************************************************************
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE ANNIHCX
+C VERSION 4.00 -- 24 JUL 1986/1400
+C******************************************************************
+C GAMMA SPECTRUM FOR TWO GAMMA IN-FLIGHT POSITRON ANNIHILATION.
+C USING SCHEME BASED ON HEITLER'S P269-27O FORMULAE
+C THIS ROUTINE SHOULD GIVE THE CORRECT DISTRIBUTION, BUT MORE
+C THOUGHT COULD BE PUT INTO DEVISING A FASTER SCHEME. HOWEVER,
+C SINCE POSITRON ANNIHILATION IN FLIGHT IS RELATIVELY INFREQUENT
+C THIS MAY NOT BE WORTHWHILE.
+C Correction by T. Pierog, 09.01.04, to avoid precision problem at
+C Very high energy, use double precision !
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PAVIP,PESG1,PESG2,ESG1,AVIP,A,AI,G,T,P,POT,EP0,EP
+ double precision dranegs,RNNO01,RNNO02,dummy,REJF
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,STACK,UPHIOT,USEFUL,RANDOM/;
+ PAVIP=E(NP)+PRM
+CPRECISE AVAILABLE ENERGY OF INCIDENT POSITRON
+ AVIP=PAVIP
+CAVAILABLE ENERGY OF INCIDENT POSITRON
+ A=AVIP/RM
+ AI=1.d0/A
+ G=A-1.d0
+ T=G-1.d0
+ P=SQRT(A*T)
+ POT=P/T
+C SAMPLE 1/EP FROM EP=EP0 TO 1.0-EP0
+ EP0=1.d0/(A+P)
+1011 CONTINUE
+ RNNO01=DRANEGS(dummy)
+ EP=EP0*EXP(RNNO01*LOG((1.d0-EP0)/EP0))
+C NOW DECIDE WHETHER TO ACCEPT
+ RNNO02=DRANEGS(dummy)
+ REJF=1.d0-EP+AI*AI*(2.d0*G-1.d0/EP)
+ IF((RNNO02.LE.REJF))GO TO1012
+ GO TO 1011
+1012 CONTINUE
+C THIS COMPLETES SAMPLING OF A DISTRIBUTION WHICH IS ASYMMETRIC
+C ABOUT EP=1/2, BUT WHICH WHEN SYMMETRIZED IS THE SYMMETRIC
+C ANNIHILATION DISTRIBUTION. PICK EP IN (1/2,1-EP0).
+ EP=MAX(EP,1.d0-EP)
+ IF(EP.ge.1.d0)goto 1011
+C SET UP ENERGIES
+ ESG1=AVIP*EP
+CENERGY OF SECONDARY GAMMA 1
+ PESG1=ESG1
+CPRECISE ENERGY OF SECONDARY GAMMA 1
+ E(NP)=PESG1
+ PESG2=PAVIP-PESG1
+ E(NP+1)=PESG2
+ ESG2=PESG2
+ IQ(NP)=0
+ if(i1dem.eq.0)then
+C SET UP COORD FOR HIGHER ENERGY GAMMA
+ COSTHE=MIN(1.d0,(ESG1-RM)*POT/ESG1)
+CMIN IS A PATCH JULY 24 1986
+ SINTHE=SQRT(MAX(0.d0,1.d0-COSTHE*COSTHE))
+ CALL UPHICX(2,1)
+C SET UP LOWER ENERGY GAMMA
+ NP=NP+1
+ IQ(NP)=0
+ COSTHE=MIN(1.d0,(ESG2-RM)*POT/ESG2)
+CMIN IS A PATCH, JULY 24,1986 D.R.
+ SINTHE=-SQRT(MAX(0.d0,1.d0-COSTHE*COSTHE))
+ CALL UPHICX(3,2)
+ else
+ costhe=1.d0
+ sinthe=0.d0
+ CALL UPHICX(2,1)
+ NP=NP+1
+ IQ(NP)=0
+ CALL UPHICX(3,2)
+ endif
+ RETURN
+CEND OF SUBROUTINE ANNIH
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE BHABHACX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C DISCRETE BHABHA SCATTERING (A CALL TO THIS ROUTINE) HAS BEEN
+C ARBITRARILY DEFINED AND CALCULATED TO MEAN BHABHA SCATTERINGS
+C WHICH IMPART TO THE SECONDARY ELECTRON SUFFICIENT ENERGY THAT
+C IT BE TRANSPORTED DISCRETELY, I.E. E=AE OR T=TE. IT IS NOT
+C GUARANTEED THAT THE FINAL POSITRON WILL HAVE THIS MUCH ENERGY
+C HOWEVER. THE EXACT BHABHA DIFFERENTIAL CROSS SECTION IS USED.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIP,PEKSE2,PESE1,PESE2
+ DOUBLE PRECISION PEKIN,H1,DCOSTH
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ PEIP=E(NP)
+CPRECISE ENERGY OF INCIDENT POSITRON
+c EIP=PEIP
+CENERGY OF INCIDENT POSITRON
+ PEKIN=PEIP-PRM
+CPRECISE K.E. OF INCIDENT POSITRON
+ EKIN=PEKIN
+ T0=EKIN/RM
+ E0=T0+1.d0
+ YY=1.d0/(T0+2.d0)
+ E02=E0*E0
+CBETAI2=E02/(E02-1.);
+CBLIF 96/2/1 -- not needed for Bhabha fix-up
+ BETA2=(E02-1.d0)/E02
+CBLIF 96/2/1 -- needed for Bhabha fix-up
+ EP0=TE(MEDIUM)/EKIN
+ EP0C=1.d0-EP0
+ Y2=YY*YY
+ YP=1.d0-2.d0*YY
+ YP2=YP*YP
+ B4=YP2*YP
+ B3=B4+YP2
+ B2=YP*(3.d0+Y2)
+C SAMPLE BR FROM MINIMUM(EP0) TO 1.
+ B1=2.d0-Y2
+1011 CONTINUE
+ RNNO03=DRANEGS(dummy)
+ BR=EP0/(1.d0-EP0C*RNNO03)
+C APPLY REJECTION FUNCTION
+ RNNO04=DRANEGS(dummy)
+C REJF2=EP0C*(BETAI2-BR*(B1-BR*(B2-BR*(B3-BR*B4))));BLIF 96/2/1 -- Bhab
+C ha fix-up
+ REJF2=(1.d0-BETA2*BR*(B1-BR*(B2-BR*(B3-BR*B4))))
+C BLIF 96/2/1 -- Bhabha fix-up
+ IF((RNNO04.LE.REJF2))GO TO1012
+ GO TO 1011
+1012 CONTINUE
+C IF E- GOT MORE THAN E+, MOVE THE E+ POINTER AND REFLECT B
+ IF ((BR.LT.0.5d0)) THEN
+ IQ(NP+1)=-1
+ ELSE
+ IQ(NP)=-1
+ IQ(NP+1)=1
+ BR=1.d0-BR
+ END IF
+CTHE ABOVE PUTS E+ ON TOP OF STACK IF IT HAS LESS ENERGY
+C DIVIDE UP THE ENERGY
+ BR=MAX(BR,0.d0)
+CAVOIDS POSSIBLE NEGATIVE NUMBER DUE TO ROUND-OFF
+ PEKSE2=BR*PEKIN
+CPRECISE KINETIC ENERGY OF SECONDARY 'ELECTRON' 2
+ PESE1=PEIP-PEKSE2
+CPRECISE ENERGY OF SECONDARY 'ELECTRON' 1
+ PESE2=PEKSE2+PRM
+CPRECISE ENERGY OF SECONDARY 'ELECTRON' 2
+ ESE1=PESE1
+ ESE2=PESE2
+ E(NP)=ESE1
+ E(NP+1)=ESE2
+ if(i1DEM.eq.0)then
+C BHABHA ANGLES ARE UNIQUELY DETERMINED BY KINEMATICS
+ H1=(PEIP+PRM)/PEKIN
+C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON
+CAFB modified the following statement 92/10/28 to avoid
+Cnumerical difficulties
+CDCOSTH=H1*(PESE1-PRM)/(PESE1+PRM);
+ DCOSTH=MIN(1.0D0,H1*(PESE1-PRM)/(PESE1+PRM))
+ SINTHE=DSQRT(1.D0-DCOSTH)
+ COSTHE=DSQRT(DCOSTH)
+ CALL UPHICX(2,1)
+ NP=NP+1
+ DCOSTH=MIN(1D0,H1*(PESE2-PRM)/(PESE2+PRM))
+ SINTHE=-DSQRT(1.D0-DCOSTH)
+ COSTHE=DSQRT(DCOSTH)
+ CALL UPHICX(3,2)
+ else
+ sinthe=0.d0
+ costhe=1.d0
+ CALL UPHICX(2,1)
+ NP=NP+1
+ CALL UPHICX(3,2)
+ endif
+ RETURN
+CEND OF SUBROUTINE BHABHA
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE BREMSCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C FOR ELECTRON ENERGY GREATER THAN 5.0 MEV, THE BETHE-HEITLER
+C CROSS SECTION IS EMPLOYED.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIE,PESG,PESE
+ COMMON/BREMPR/ DL1(6,1),DL2(6,1),DL3(6,1),DL4(6,1),DL5(6,1),DL6(6,
+ *1), ALPHI(2,1),BPAR(2,1),DELPOS(2,1), ASYM(1,50,2), WA(1,50),PZ(1,
+ *50),ZELEM(1,50),RHOZ(1,50), PWR2I(100), DELCM(1),ZBRANG(1),FBRSPL,
+ * NNE(1),IBRDST,IPRDST,IBRSPL,NBRSPL
+ CHARACTER*4 ASYM
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BREMPR,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ DATA AI2LN2/0.7213475/
+C1./(2.*LOG(2.))
+ PEIE=E(NP)
+CPRECISE ENERGY OF INCIDENT 'ELECTRON'
+ EIE=PEIE
+CENERGY OF INCIDENT 'ELECTRON'
+C DECIDE WHICH DISTRIBUTION TO USE (B-H COULOMB CORRECTED IS
+C USED FROM 50 TO 20000 MEV, B-H IS USED 1.5 TO 50 MEV)
+ NP=NP+1
+ IF ((EIE.LT.50.0)) THEN
+ LVX=1
+ LVL0=0
+ ELSE
+ LVX=2
+ LVL0=3
+ END IF
+C THE METHOD OF BUTCHER AND MESSEL FOR SAMPLING A CLASS OF
+C FACTORIZABLE FREQUENCY DISTRIBUTIONS IS USED.
+C OUR 'BR' VARIABLE IS THE SAME AS THEIR 'EPSILON' VARIABLE.
+C SEE BUTCHER AND MESSEL,NUCL.PHYS.,VOL.20,PP23,24.
+C COMPUTE NUMBER OF SUBDISTRIBUTIONS NEEDED TO PRODUCE PHOTONS
+C OF MINIMUM DISCRETE TRANSPORT ENRGY AP, IN CASE THE (1-BR)/BR
+C PART OF THE DISTRIBUTION IS USED.
+C ILOG2(X) IS THAT INTEGER FUNCTION OF X SUCH THAT . . .
+C 2**(ILOG2(X)-1) .LE. X .LT. 2**(ILOG2(X))
+CVARIOUS REJECTIONS CAN CAUSE RESAMPLE
+ ABREMS=DBLE(INT(1.44269d0*LOG(EIE/AP(MEDIUM))))
+1011 CONTINUE
+C DECIDE WHETHER TO SAMPLE FROM THE (1-BR)/BR OR THE 2*BR PART
+C OF THE DISTRIBUTION.
+ RNNO06=DRANEGS(dummy)
+ IF ((0.5d0.LT.((ABREMS*ALPHI(LVX,MEDIUM)+0.5d0)*RNNO06))) THEN
+C USE THE (1-BR)/BR PART. WHICH SUBDISTRIBUTION?
+ RNNO07=DRANEGS(dummy)
+ IDISTR=ABREMS*RNNO07
+C THIS CHOOSES IDISTR AT RANDOM FROM THE SET
+C (0,1,2, . . . , NBREMS - 1 )
+ P=PWR2I(IDISTR+1)
+C SELECT SCREENING REJECTION FUNCTION
+C LVL=1 UNCOULOMB CORRECTED A(DELTA)
+C LVL=2 UNCOULOMB CORRECTED B(DELTA)
+C LVL=3 UNCOULOMB CORRECTED C(DELTA)
+C LVL=4 COULOMB CORRECTED A(DELTA)
+C LVL=5 COULOMB CORRECTED B(DELTA)
+C LVL=6 COULOMB CORRECTED C(DELTA)
+ LVL=LVL0+1
+C USE A(DELTA), EITHER BORN OR COULOMB CORRECTED, DEPENDING ON
+C WHETHER LVL HAS BEEN PREVIOUSLY SET TO 0 OR 3.
+C ALL SUBDISTRIBUTIONS ARE SAMPLED BY FIRST SAMPLING FROM
+C (1./LOG(2.))*(1.-BR)/BR IF 0.5 .LE. BR .LE. 1.
+C 1./LOG(2.) IF BR.LT. 0.5
+C AND THEN TAKING BR = BR*P
+C AI2LN2 IS ACTUALLY 1./(2.*LOG(2.)), WHICH IS THE PROBABILITY
+C THAT BR IS LESS THAN 0.5 IN THE ELEMENTARY DISTRIBUTION ABOVE.
+ RNNO08=DRANEGS(dummy)
+ IF ((RNNO08.GE.AI2LN2)) THEN
+1021 CONTINUE
+ RNNO09=DRANEGS(dummy)
+C IF REJECTED FOR SUBDISTRIBUTION
+ RNNO10=DRANEGS(dummy)
+ RNNO11=DRANEGS(dummy)
+ H=MAX(RNNO10,RNNO11)
+ BR=1.d0-0.5d0*H
+ IF((RNNO09.LE.0.5d0/BR))GO TO1022
+C REJECTION CONDITION
+ GO TO 1021
+1022 CONTINUE
+C END BR.GE.0.5 PART
+C SAMPLE BR.LT.0.5 PART
+ ELSE
+ RNNO12=DRANEGS(dummy)
+ BR=RNNO12*0.5d0
+ END IF
+C END OF BR.LT.0.5 PART
+C PRODUCT ENERGY FRACTION CHOSEN
+ BR=BR*P
+C END (1-BR)/BR PART
+ ELSE
+C USE THE 2*BR PART
+ RNNO13=DRANEGS(dummy)
+ RNNO14=DRANEGS(dummy)
+ BR=MAX(RNNO13,RNNO14)
+ LVL=LVL0+2
+C USE B(DELTA) FOR SCREENING FUNCTION
+ END IF
+C END OF 2*BR PART OF DISTRIBUTION
+C ENERGY OF NEW PHOTON
+C ENERGY OF SECONDARY GAMMA
+C AP=0.256 MEV --- RM=0.511 MEV
+C AP IS SELECTED IN THE ROUTINE PEGS.
+C MINIMUM HARDNESS REQUIREMENT, CORRESPONDING TO LOWER BOUND
+C CHOICE FOR TOTAL CROSS SECTION INTEGRAL
+C TRY
+ ESG=EIE*BR
+ IF((ESG.LT.AP(MEDIUM)))GO TO1011
+ PESG=ESG
+C PRECISE ENERGY OF SECONDARY GAMMA
+ PESE=PEIE-PESG
+C PRECISE ENERGY OF SECONDARY 'ELECTRON'
+C ENERGY OF SECONDARY 'ELECTRON'
+C THE ELECTRON MUST HAVE A MINIMUM ENERGY EQUAL TO 0.511 MEV
+C TRY
+
+ ESE=PESE
+ IF((ESE.LT.RM))GO TO1011
+C DELTA=136.0*EXP(ZG)*RM*EE/(E*(1.0-EE))
+C =DELCM*EE/(E*(1.0-EE))=DELCM*DEL
+C WHERE E=ELECTRON INCIDENT ENERGY(MEV), AND EE=(PHOTON ENERGY)/E
+C ZG IS DEFINED IN THE PROGRAM SHINP, AND IS A WEIGHTED AVERAGE
+C OF LOG(Z**(-1./3.)) OVER THE VARIOUS TYPES OF ATOMS IN THE
+C MOLECULE (BUTCHER AND MESSEL, OP.CIT., P.17-19,22-24).
+C A(DELTA) AND B(DELTA) MUST ALWAYS BE POSITIVE
+C TRY
+ DEL = BR/ESE
+ IF((DEL.GE.DELPOS(LVX,MEDIUM)))GO TO1011
+ DELTA = DELCM(MEDIUM)*DEL
+ IF ((DELTA.LT.1.0)) THEN
+ REJF=DL1(LVL,MEDIUM)+DELTA*(DL2(LVL,MEDIUM)+DELTA*DL3(LVL,MEDI
+ * UM))
+ ELSE
+ REJF=DL4(LVL,MEDIUM)+DL5(LVL,MEDIUM)*LOG(DELTA+DL6(LVL,MEDIUM
+ * ))
+ END IF
+ RNSCRN=DRANEGS(dummy)
+C GET RANDOM NUMBER FOR SCREENING REJECTION
+ IF((RNSCRN.LE.REJF))GO TO1012
+ GO TO 1011
+1012 CONTINUE
+CLOOP UNTIL VALUE ACCEPTED
+C SET UP THE NEW PHOTON
+ IF ((IBRDST.EQ.0)) THEN
+C DEFAULT EGS4 ANGLE SELECTION
+ THETA=RM/EIE
+ ELSE IF((IBRDST.EQ.1)) THEN
+C KOCH AND MOTZ (1959) EQUATION 2BS ANGLE SELECTION
+C ZBRANG=( (1/111)*Zeff**(1/3) )**2
+ ZTARG=ZBRANG(MEDIUM)
+C TTEIE = TOTAL INITIAL ELECTRON ENERGY IN ELECTRON REST MASS UNITS
+ TTEIE=EIE/RM
+C TTESE = TOTAL FINAL ELECTRON ENERGY IN ELECTRON REST MASS UNITS
+ TTESE=ESE/RM
+C THIS IS THE RATIO (r IN PIRS0203)
+ ESEDEI=TTESE/TTEIE
+C MAXIMUM VALUE OF (THETA*TTEIE)**2
+ Y2MAX=(PI*TTEIE)**2
+C THE FOLLOWING THREE STATEMENTS DEFINE QUANTITES REQUIRED
+C BY THE $SET-BREM-REJECTION-FUNCTION MACRO
+ RJARG1=(1.d0+ESEDEI**2)
+ RJARG2=3.d0*RJARG1-2.d0*ESEDEI
+ RJARG3=((1.d0-ESEDEI)/(2.d0*TTEIE*ESEDEI))**2
+ Y2TST1=(1.d0+0.d0)**2
+ REJMIN= (4.d0+LOG(RJARG3+ZTARG/Y2TST1))*(4.d0*ESEDEI*0.0d0
+ * /Y2TST1-RJARG1)+RJARG2
+ Y2TST1=(1.d0+1.0d0)**2
+ REJMID= (4.d0+LOG(RJARG3+ZTARG/Y2TST1))*(4.d0*ESEDEI*1.0d0
+ * /Y2TST1-RJARG1)+RJARG2
+ Y2TST1=(1.d0+Y2MAX)**2
+ REJMAX= (4.d0+LOG(RJARG3+ZTARG/Y2TST1))*(4.d0*ESEDEI*Y2MAX
+ * /Y2TST1-RJARG1)+RJARG2
+C ESTIMATE MAXIMUM OF THE REJECTION FUNCTION
+C FOR LATER USE BY THE REJECTION TECHNIQUE
+ REJTOP=MAX(REJMIN,REJMID,REJMAX)
+1031 CONTINUE
+C SAMPLE THE DIRECT PART, FUNCTION F(X) OF PIRS0203
+C PICK A CANDIDATE Y**2 (X IN PIRS0203)
+ Y2TST=DRANEGS(dummy)
+ Y2TST=Y2TST/(1.d0-Y2TST+1.d0/Y2MAX)
+C EVALUATE THE REJECTION FUNCTION AT Y2TST
+ Y2TST1=(1.d0+Y2TST)**2
+ REJTST= (4.d0+LOG(RJARG3+ZTARG/Y2TST1))*(4.d0*ESEDEI*Y2TST
+ * /Y2TST1-RJARG1)+RJARG2
+ RTEST=DRANEGS(dummy)
+C LOOP UNTIL REJECTION TECHNIQUE ACCEPTS Y2TST
+ IF(((RTEST.LE.(REJTST/REJTOP))))GO TO1032
+ GO TO 1031
+1032 CONTINUE
+C CONVERT THE SUCCESSFUL CANDIDATE Y2TST TO AN ANGLE IN RADIANS
+ THETA=SQRT(Y2TST)/TTEIE
+ END IF
+C DEFAULT FOR $SET-BREMS-ANGLE; IS THETA=RM/EIE;
+CNOW GET LOWEST ENERGY PARTICLE ON TOP OF STACK AND SET CHARGES
+ CALL UPHICX(1,3)
+
+ IF ((ESG.LE.ESE)) THEN
+ IQ(NP)=0
+C SET PHOTON CHARGE
+ E(NP)=PESG
+ E(NP-1)=PESE
+C PHOTON TOP,ELECTRON BOTTOM
+C MUST PUT ELECTRON ON TOP
+ ELSE
+ IQ(NP)=IQ(NP-1)
+C TRANSFER CHARGE FROM INCOMING 'ELECTRON'
+ IQ(NP-1)=0
+ E(NP)=PESE
+ E(NP-1)=PESG
+C ELECTRON TOP,PHOTON BOTTOM
+ T=U(NP)
+ U(NP)=U(NP-1)
+ U(NP-1)=T
+C SWAP U
+ T=V(NP)
+ V(NP)=V(NP-1)
+ V(NP-1)=T
+C SWAP V
+ T=W(NP)
+ W(NP)=W(NP-1)
+ W(NP-1)=T
+C SWAP W
+ END IF
+CEND OF SWAPPING
+ RETURN
+CEND OF SUBROUTINE BREMSCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE COMPTCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C BUTCHER AND MESSEL'S CROSS SECTION EXPRESSION IS USED
+C (BUTCHER AND MESSEL, OP.CIT., P. 17-19,25), BUT THE
+C 1/EPSILON PART IS NOT SAMPLED IN THE WAY THAT THEY DO.
+C THIS ROUTINE CALLS THEIR 'EPSILON' VARIABLE BY THE NAME 'BR'.
+C BR=FINAL PHOTON ENERGY /INITIAL PHOTON ENERGY.
+C BR0 = MINIMUM BR = 1./(1.+2.*(E(NP)/RM))
+C MAXIMUM BR IS 1.
+C BUTCHER AND MESSEL'S EXPRESSION FOR THE DIFFERENTIAL CROSS
+C SECTION IS PROPORTIONAL TO
+C (1./BR+BR)*(1.-BR*SINTHE**2/(1.+BR*BR))
+C WE SHALL SAMPLE FROM THE FIRST FACTOR FROM THE INTERVAL (BR0,1)
+C AND USE THE SECOND FACTOR AS A REJECTION FUNCTION.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIG,PESG,PESE
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ PEIG=E(NP)
+CPRECISE ENERGY OF INCIDENT GAMMA
+ EIG=PEIG
+CENERGY OF INCIDENT GAMMA
+ EGP=EIG/RM
+C BR0I IS THE INVERSE OF BR0
+ BR0I=1.d0+2.d0*EGP
+ ALPH1=LOG(BR0I)
+ ALPH2=EGP*(BR0I+1.d0)/(BR0I*BR0I)
+C DUE TO REJECTION, SOME EXPRESSIONS WHICH ONLY APPEAR ONCE IN
+C THE CODE BELOW, MAY ACTUALLY BE NEEDED MORE THAN ONCE.
+CRETRY IF REJECTED
+ SUMALP = ALPH1+ALPH2
+1011 CONTINUE
+C WHICH PART OF 1./BR + BR TO SAMPLE FROM ?
+ RNNO15=DRANEGS(dummy)
+ IF ((ALPH1.GE.SUMALP*RNNO15)) THEN
+C USE 1/BR PART OF DISTRIBUTION
+ RNNO16=DRANEGS(dummy)
+ BR=EXP(ALPH1*RNNO16)/BR0I
+C END OF 1/BR PART
+ ELSE
+C USE LINEAR ( BR ) PART OF DISTRIBUTION
+ BRP=DRANEGS(dummy)
+ RNNO18=DRANEGS(dummy)
+ IF ((EGP.GE.(EGP+1.d0)*RNNO18)) THEN
+ RNNO19=DRANEGS(dummy)
+ BRP=MAX(BRP,RNNO19)
+ END IF
+ BR=((BR0I-1.d0)*BRP+1.d0)/BR0I
+ END IF
+C END SAMPLING OF LINEAR PART
+C BR=FINAL PHOTON ENERGY FRACTION
+ ESG=BR*EIG
+C ENERGY OF SECONDARY GAMMA
+C THE COMPTON ANGLES FOR PHOTON AND RECOIL ELECTRON ARE UNIQUELY
+C DETERMINED BY THE CONSERVATION LAWS
+ A1MIBR = 1.d0-BR
+ TEMP=RM*A1MIBR/ESG
+C THE MAX IN THE FF. IS TO PREVENT SINTHE.LT.0 FROM TRUNC ERROR
+ SINTHE=MAX(0.d0,TEMP*(2.d0-TEMP))
+C COMPARE REJECTION FUNCTION WITH RANDOM NUMBER.
+ RNNO20=DRANEGS(dummy)
+ REJF3=1.d0-BR*SINTHE/(1.d0+BR*BR)
+ IF((RNNO20.LE.REJF3))GO TO1012
+ GO TO 1011
+1012 CONTINUE
+CLOOP UNTIL ACCEPTED
+ if(i1DEM.eq.0)then
+ SINTHE=SQRT(SINTHE)
+ COSTHE=1.d0-TEMP
+ else
+ SINTHE=0.d0
+ COSTHE=1.d0
+ endif
+C THE RECOIL ELECTRON IS ADDED TO THE SHOWER MEMORY. THE EXTRA
+C REST MASS ENERGY WILL BE DISCARDED WHEN THE
+C ELECTRON IS THROWN AWAY.
+ PESG=ESG
+CPRECISE ENERGY OF SECONDARY GAMMA
+ PESE=PEIG-PESG+PRM
+CPRECISE ENERGY OF SECONDARY ELECTRON
+ ESE=PESE
+CENERGY OF SECONDARY ELECTRON
+C DIRECTION COSINE CHANGE FOR OLD PHOTON
+ CALL UPHICX(2,1)
+C RELATED CHANGE AND (X,Y,Z) SETUP FOR NEW ELECTRON
+ NP=NP+1
+CWE NOW POINT AT ELECTRON
+C PSQ HERE IS THE MOMENTUM SQUARED.
+ PSQ=ESE**2-RMSQ
+ IF (i1DEM.eq.1) THEN
+ COSTHE=1.d0
+ SINTHE=0.d0
+ ELSEIF (PSQ.LE.0.d0) THEN
+C THE ABOVE IS TO AVOID DIVISION BY ZERO IN CASE TRUNCATION
+C ERRORS MAKE BR=1 AND HENCE E(NP)=RM, AND PSQ=0
+ COSTHE=0.d0
+ SINTHE=-1.d0
+C END PSQ.LE.0 CASE
+C OK TO DIVIDE, PSQ IS POSITIVE
+ ELSE
+ COSTHE=(ESE+ESG)*A1MIBR/SQRT(PSQ)
+ SINTHE=-SQRT(MAX(0.d0,1.d0-COSTHE*COSTHE))
+ END IF
+CEND OF PSQ.GT.0 CASE
+CNOW GET LOWEST ENERGY PARTICLE ON TOP OF STACK AND SET CHARGES
+ CALL UPHICX(3,2)
+ IF ((ESE.LE.ESG)) THEN
+ IQ(NP)=-1
+C ELECTRON IS ON TOP
+ E(NP)=PESE
+ E(NP-1)=PESG
+C SET ENERGIES
+C MUST PUT GAMMA ON TOP
+ ELSE
+ IQ(NP)=0
+ IQ(NP-1)=-1
+ E(NP)=PESG
+ E(NP-1)=PESE
+C SET ENERGIES
+ T=U(NP)
+ U(NP)=U(NP-1)
+ U(NP-1)=T
+C SWAP U
+ T=V(NP)
+ V(NP)=V(NP-1)
+ V(NP-1)=T
+C SWAP V
+ T=W(NP)
+ W(NP)=W(NP-1)
+ W(NP-1)=T
+C SWAP W
+ END IF
+CEND OF SWAPPING
+ RETURN
+CEND OF SUBROUTINE COMPTCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE ELECTRCX(IRCODE)
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIE
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/BREMPR/ DL1(6,1),DL2(6,1),DL3(6,1),DL4(6,1),DL5(6,1),DL6(6,
+ *1), ALPHI(2,1),BPAR(2,1),DELPOS(2,1), ASYM(1,50,2), WA(1,50),PZ(1,
+ *50),ZELEM(1,50),RHOZ(1,50), PWR2I(100), DELCM(1),ZBRANG(1),FBRSPL,
+ * NNE(1),IBRDST,IPRDST,IBRSPL,NBRSPL
+ CHARACTER*4 ASYM
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/PATHCM/B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6),NPTH
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIIN/SINC0,SINC1,SIN0(1002),SIN1(1002)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+C==========
+C========================
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+C=============================
+ COMMON/USERSC/ SMAX,SMAXIR(3),ESTEPE,ESTEPR(3),ESAVE(3), NOMSCT(3)
+ *,NOPLC(3)
+C===============
+ COMMON/USERVR/ CEXPTR,GWAIT,IFORCE,NFMIN,NFMAX,NFTIME,ISOURC,IFPB,
+ *IQINC,MONOEN
+ COMMON/USERXT/IPHTER(3)
+ common/cxstern/sterncor,istern
+ logical lxfirst,lXfirstIn
+ common/cxoutput4/Xfirst,XfirstIn,lxfirst,lxfirstIn !also in conex.h
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+C========================
+
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BOUNDS,BREMPR,ELECIN,EPCONT,MEDIA,MISC,PATHCM,
+C STACK,THRESH,UPHIIN,UPHIOT,USEFUL,USER,RANDOM/;
+ IRCODE=1
+ IERUST=0
+CSET UP NORMAL RETURN-WHICH MEANS THERE IS A PHOTON
+C WITH LESS AVAILABLE ENERGY THAN THE LOWEST ENERGY ELECTRON,
+C SO RETURN TO SHOWER SO IT CAN CALL PHOTON TO FOLLOW IT.
+ IROLD=IR(NP)
+CINITIALIZE PREVIOUS REGION
+ IRL=IR(NP)
+CREGION NUMBER IN LOCAL VARIABLE.
+CGET MEDIUM OF CURRENT PARTICLE
+CGO ONCE THROUGH THIS LOOP FOR EACH
+ MEDIUM=MED(IRL)
+1010 CONTINUE
+1011 CONTINUE
+C 'NEW' ELECTRON WHOSE CHARGE AND ENERGY HAS NOT BEEN CHECKED
+ LELEC=IQ(NP)
+C SAVE CHARGE IN LOCAL VARIABLE
+ PEIE=E(NP)
+C PRECISE ENERGY OF INCIDENT ELECTRON
+C ENERGY INCIDENT ELECTRON
+ EIE=PEIE
+ IF ((EIE.LE.ECUT(IRL))) THEN
+ GO TO 1020
+ END IF
+C GO THROUGH THIS LOOP EACH TIME WE RECOMPUTE
+ MEDIUM=MED(IRL)
+c1030 CONTINUE
+C DISTANCE TO AN INTERACTION.
+C NOT VACUUM. MUST SAMPLE TO SEE HOW FAR
+1031 CONTINUE
+ IF ((MEDIUM.NE.0)) THEN
+C TO NEXT INTERACTION
+ RNNE1=DRANEGS(dummy)
+ IF ((RNNE1.EQ.0.d0)) THEN
+ RNNE1=1.d-30
+ END IF
+ DEMFP=MAX(-LOG(RNNE1),1.d-6)
+C DEFAULT FOR $SELECT-ELECTRON-MFP; IS: $RANDOMSET RNNE1;
+C DEMFP=-LOG(RNNE1);
+ EKE=EIE-RM
+ ELKE=LOG(EKE)
+C PREPARE TO APPROXIMATE CROSS SECTION
+ LELKE=EKE1(MEDIUM)*ELKE+EKE0(MEDIUM)
+ IF ((LELEC.LT.0)) THEN
+ SIG0=ESIG1(LELKE,MEDIUM)*ELKE+ESIG0(LELKE,MEDIUM)
+C E+
+ ELSE
+ SIG0=PSIG1(LELKE,MEDIUM)*ELKE+PSIG0(LELKE,MEDIUM)
+ END IF
+ END IF
+C END NON-VACUUM TEST
+C HERE FOR EACH CHECK WITH USER GEOMETRY
+c1040 CONTINUE
+C COMPUTE SIZE OF MAXIMUM ACCEPTABLE STEP, WHICH IS LIMITED
+C BY MULTIPLE SCATTERING OR OTHER APPROXIMATIONS.
+C VACUUM
+1041 CONTINUE
+ IF ((MEDIUM.EQ.0)) THEN
+ TSTEP=VACDST
+ USTEP=TSTEP
+ TUSTEP=USTEP
+C NON-VACUUM
+ ELSE
+ RHOF=RHOR(IRL)/RHO(MEDIUM)
+C DENSITY RATIO SCALING TEMPLATE
+C THIS CAN HAPPEN IF THE THRESHOLD FOR BREMS,
+ SIG=SIG0*RHOF
+ IF ((SIG.LE.0.d0)) THEN
+C (AP+RM), IS GREATER THAN AE. MOLLER THRESHOLD IS 2*AE-RM.
+C IF SIG IS ZERO, WE ARE BELOW THE THRESHOLDS FOR BOTH
+C BREMSSTRAHLUNG AND MOLLER. IN THIS CASE WE WILL JUST LOSE
+C
+C ENERGY BY IONIZATION LOSS UNTIL WE GO BELOW CUT-OFF.
+C DO NOT ASSUME RANGE IS AVAILABLE, SO JUST ASK FOR STEP SAM
+C E AS
+C VACUUM. ELECTRON TRANSPORT WILL REDUCE INTO LITTLE STEPS.
+ TSTEP=VACDST
+ ELSE
+ TSTEP=DEMFP/SIG
+ END IF
+C END SIG IF-ELSE
+ TMXS=TMXS1(LELKE,MEDIUM)*ELKE+TMXS0(LELKE,MEDIUM)
+C ==============
+ TP=200.d0*TEFF0(MEDIUM)
+ IF ((ESTEPR(IRL).NE.0)) THEN
+ TMXS=TMXS*ESTEPR(IRL)
+ END IF
+ TMXS = MIN(TMXS,TP,SMAX,SMAXIR(IRL))
+ TMXS=TMXS/RHOF
+C COMPUTE THE RANGE TO ECUT(IRL)-$ENEPS. DO NOT GO MORE
+C THAN RANGE.
+C ELECTRON
+ TUSTEP=MIN(TSTEP,TMXS)
+ IF ((LELEC.LT.0)) THEN
+ DEDX0=EDEDX1(LELKE,MEDIUM)*ELKE+EDEDX0(LELKE,MEDIUM)
+C POSITRON
+ ELSE
+ DEDX0=PDEDX1(LELKE,MEDIUM)*ELKE+PDEDX0(LELKE,MEDIUM)
+ END IF
+C STERNHEIMER CORRECTION OF DENSITY DEPENDENT IONISATION ENERGY LOSS
+C DEDX. SATURATION VALUE OF DEDX AT HIGH ENERGIES IS PRESSURE DEPENDENT
+C AND SATURATES AT LOWER VALUES FOR HIGHER PRESSURE. THEREFORE THE
+C CROSS-SECTION FILE IS ESTABLISHED WITH GAS PRESSURE OF 1.E-6 ATM
+C (CORRESPONDING TO ABOUT 100 KM HIGHT IN ATMOSPHERE). THE CORRECTION
+C INTRODUCED GIVES VALUES ABOUT 3% TO HIGH IN TRANSITION REGION TO
+C SATURATION. THE PARAMETRISATION IS ONLY VALID FOR U.S. STANDARD ATMOS.
+C Formulas and parameters taken from Corsika 6.020 by Dieter Heck & Al
+C Correction by T. Pierog : Z(NP) (in cm) -> -ZM(NP) (in m)
+ IF (ISTERN.EQ.1.AND.PEIE.GE.3.D0) THEN
+ alt=ZM(NP) !sternheimer correction only at high altitude
+ if(alt.lt.0.d0)alt=0.d0
+ DEDX=RHOF*MIN(DEDX0,
+ * (86.65D0-STERNCOR+alt*8.D-4)/RLDU(MEDIUM))
+ ELSE
+C NO DENSITY DEPENDENT STERNHEIMER CORRECTION AT LOW ENERGIES
+ DEDX=RHOF*DEDX0
+ ENDIF
+ if(ionloss.eq.0)then
+ dedx=0.d0
+ range=1.d20
+ else
+ RANGE=(EIE-ECUT(IRL)+0.0001d0)/DEDX
+ endif
+ BETA2=MAX(1.d-8,1.d0-RMSQ/EIE**2)
+ TSCAT=RLDU(MEDIUM)*(EIE*BETA2*0.094315d0)**2
+C 0.094315=2/ESUBS
+ TSCAT=TSCAT/RHOF
+ TUSTEP=MIN(TUSTEP,0.3d0*TSCAT,RANGE)
+C TUSTEP RESTRICTION MACRO TEMPLATE
+ USTEP=TUSTEP*(1.d0-TUSTEP/TSCAT)
+C PATH LENGTH CORRECTION MACRO TEMPLATE
+ END IF
+C END NON-VACUUM TEST
+C ADDITIONAL TUSTEP RESTRICTION IN EM FIELD
+C DEFAULT FOR $SET-TUSTEP-EM-FIELD; IS ; (NULL)
+C ADDITIONAL USTEP RESTRICTION IN EM FIELD
+C DEFAULT FOR $SET-USTEP-EM-FIELD; IS ; (NULL)
+ IRNEW=IR(NP)
+C DEFAULT NEW REGION IS OLD REGION
+ IDISC=0
+C DEFAULT IS NO DISCARD
+ USTEP0=USTEP
+ IF (((USTEP.GT.DNEAR(NP) ))) THEN
+ CALL HOWFARCX
+ END IF
+C DEFAULT FOR $PRESTA-1; IS ; (NULL)
+C ====================
+ IF ((RANGE.LT.DNEAR(NP) .AND. E(NP).LE.ESAVE(IRL) .AND. MEDI
+ * UM.NE.0)) THEN
+ IF ((LELEC.EQ.-1)) THEN
+ IDISC=1
+ ELSE
+ IDISC=99
+ END IF
+ END IF
+C DEFAULT FOR $USER-RANGE-DISCARD; IS ; (NULL)
+C NOW SEE IF USER REQUESTED DISCARD
+C USER REQUESTED IMMEDIATE DISCARD
+ IF ((IDISC.GT.0)) THEN
+ GO TO 1050
+ END IF
+C NEGATIVE USTEP---PROBABLE TRUNCATION PROBLEM AT
+ IF ((USTEP.LE.0.d0)) THEN
+C A BOUNDARY, WHICH MEANS WE ARE NOT IN THE REGION WE THINK WE
+C ARE IN. THE DEFAULT MACRO ASSUMES THAT USER HAS SET IRNEW T
+C O
+C THE REGION WE ARE REALLY MOST LIKELY TO BE IN. A MESSAGE IS
+C WRITTEN OUT WHENEVER USTEP IS LESS THAN -1.E-4
+C ============================
+ IF ((USTEP.LT.-1.d-3)) THEN
+ IERUST=IERUST+1
+ WRITE(6,1060)IERUST,USTEP,IR(NP),IRNEW, IROLD,X(NP),Y(NP
+ * ),Z(NP),SQRT(X(NP)**2+Y(NP)**2)
+1060 FORMAT(I6,' NEGATIVE USTEP=',E13.6,' IR,IRNEW,IROLD=',3I
+ * 4,' X,Y,Z,R=', 4E10.3)
+ IF ((IERUST.GT.100)) THEN
+ WRITE(*,1070)
+1070 FORMAT(///'PARTICLE DISCARDED, TOO MANY USTEP ERRORS'///)
+ WRITE(*,*)IQ(NP),E(NP),Z(NP),U(NP),V(NP),W(NP),ZM(NP)
+ * ,WT(NP)
+ IDISC=-1
+ GO TO 1050
+ END IF
+ END IF
+ USTEP=0.d0
+ END IF
+C DO FAST STEP
+C STEP IN VACUUM
+ IF ((USTEP.EQ.0.d0.OR.MEDIUM.EQ.0)) THEN
+ IF ((USTEP.NE.0.d0)) THEN
+ VSTEP=USTEP
+ TVSTEP=VSTEP
+ EDEP=PZERO
+C NO ENERGY LOSS IN VACUUM
+C ADDITIONAL VACUUM TRANSPORT IN EM FIELD
+ IARG=0
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C TRANSPORT ELECTRON
+C Z(NP)=Z(NP)+W(NP)*VSTEP !IN AUSGAB tp18.02.05
+ DNEAR(NP)=DNEAR(NP)-VSTEP
+ IROLD=IR(NP)
+C SAVE PREVIOUS REGION
+C DEFAULT FOR $SET-ANGLES-EM-FIELD; IS ; (NULL)
+C END OF VACUUM STEP
+ END IF
+
+
+ IR(NP)=IRNEW
+C GET NEW REGION IF ANY.
+ IRL=IRNEW
+C GET NEW MEDIUM, IF ANY.
+C The next block of executable code reflects Paul Magnuson's patc
+C h.
+C Patched by BLIF 96/11/27
+ MEDIUM=MED(IRL)
+ IF ((USTEP.NE.0.d0)) THEN
+ IARG=5
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ END IF
+ IF ((EIE.LE.ECUT(IRL))) THEN
+ GO TO 1020
+ END IF
+ IF ((USTEP.NE.0.d0.AND.IDISC.LT.0)) THEN
+ GO TO 1050
+ END IF
+ GO TO 1031
+ END IF
+C GO TRY ANOTHER BIG STEP IN (POSSIBLY) NEW MEDIUM
+ VSTEP=USTEP
+ IF ((USTEP.EQ.USTEP0)) THEN
+ TVSTEP=TUSTEP
+ ELSE
+
+ VSTP=VSTEP/TSCAT
+ IPTH=B0PTH+B1PTH*VSTP
+ IF ((IPTH.GT.NPTH)) THEN
+ WRITE(6,1080)VSTP,IPTH,NPTH
+1080 FORMAT(' OUT OF BOUNDS IPTH: VSTP,IPTH,NPTH=',1PG15.6,2I
+ * 10)
+ STOP
+ END IF
+ PTH=PTH0(IPTH)+VSTP*(PTH1(IPTH)+VSTP*PTH2(IPTH))
+ TVSTEP=PTH*VSTEP
+ END IF
+C PATH LENGTH CORRECTION MACRO TEMPLATE
+C ADDITIONAL PATH LENGTH CORRECTION IN EM FIELD
+C DEFAULT FOR $SET-TVSTEP-EM-FIELD; IS ; (NULL)
+C NOW TAKE IONIZATION LOSSES INTO ACCOUNT
+C ====================
+ EKETMP=EKE
+ ELKTMP=ELKE
+ EKE=EKETMP-0.5d0*DEDX*TVSTEP
+ ELKE=LOG(EKE)
+ LELKE=EKE1(MEDIUM)*ELKE+EKE0(MEDIUM)
+ IF ((LELEC.LT.0)) THEN
+ DEDX01=EDEDX1(LELKE,MEDIUM)*ELKE+EDEDX0(LELKE,MEDIUM)
+ ELSE
+ DEDX01=PDEDX1(LELKE,MEDIUM)*ELKE+PDEDX0(LELKE,MEDIUM)
+ END IF
+C STERNHEIMER CORRECTION OF DENSITY DEPENDENT IONISATION ENERGY LOSS
+C DEDX. SATURATION VALUE OF DEDX AT HIGH ENERGIES IS PRESSURE DEPENDENT
+C AND SATURATES AT LOWER VALUES FOR HIGHER PRESSURE. THEREFORE THE
+C CROSS-SECTION FILE IS ESTABLISHED WITH GAS PRESSURE OF 1.E-6 ATM
+C (CORRESPONDING TO ABOUT 100 KM HIGHT IN ATMOSPHERE). THE CORRECTION
+C INTRODUCED GIVES VALUES ABOUT 3% TO HIGH IN TRANSITION REGION TO
+C SATURATION. THE PARAMETRISATION IS ONLY VALID FOR U.S. STANDARD ATMOS.
+C Formulas and parameters taken from Corsika 6.020 by Dieter Heck & Al
+C Correction by T. Pierog : Z(NP) (in cm) -> -ZM(NP) (in m)
+ IF (ISTERN.EQ.1.AND.PEIE.GE.3.D0) THEN
+ alt=ZM(NP) !sternheimer correction only at high altitude
+ if(alt.lt.0.d0)alt=0.d0
+ DEDX=RHOF*MIN(DEDX01,
+ * (86.65D0-STERNCOR+alt*8.D-4)/RLDU(MEDIUM))
+ ELSE
+C NO DENSITY DEPENDENT STERNHEIMER CORRECTION AT LOW ENERGIES
+ DEDX=RHOF*DEDX01
+ ENDIF
+ if(ionloss.eq.0)dedx=0.d0
+ EKE=EKETMP
+ ELKE=ELKTMP
+C DEFAULT FOR $DEDX-RE-EVALUATION; IS ; (NULL)
+ DE=DEDX*TVSTEP
+C THE FOLLOWING MACRO TEMPLATE ALLOWSS THE USER TO CHANGE THE
+C IONIZATION LOSS (E.G., TO INCLUDE 'LANDAU SAMPLING').
+C DEFAULT IS NULL.
+C DEFAULT FOR $DE-FLUCTUATION; IS ; (NULL)
+ EDEP=DE
+C ENERGY DEPOSITION VARIABLE FOR USER
+C E-LOSS OR -GAIN IN EM FIELD
+ EKEF=EKE-DE
+ EOLD=EIE
+C SAVE OLD VALUE
+ ENEW=EOLD-DE
+C ENERGY AT END OF TRANSPORT
+C NOW MULTIPLE SCATTERING
+ CALL MSCATCX
+C SAMPLE THE MULTIPLE SCATTERING ANGLE
+C WE NOW KNOW DISTANCE AND AMOUNT OF ENERGY LOSS FOR THIS STEP,
+C AND THE ANGLE BY WHICH THE ELECTRON WILL BE SCATTERED. HENCE,
+C IT IS TIME TO CALL THE USER AND INFORM HIM OF THIS TRANSPORT,
+C AFTER WHICH WE WILL DO IT.
+C NOW TRANSPORT,DEDUCT ENERGY LOSS, AND DO MULTIPLE SCATTER.
+C DEFAULT FOR $ADD-WORK-EM-FIELD; IS ; (NULL)
+ IARG=0
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C TRANSPORT ELECTRON
+C Z(NP)=Z(NP)+W(NP)*VSTEP !IN AUSGAB tp18.02.05
+ DNEAR(NP)=DNEAR(NP)-VSTEP
+ IROLD=IR(NP)
+C SAVE PREVIOUS REGION
+C DEFAULT FOR $SET-ANGLES-EM-FIELD; IS ; (NULL)
+ CALL UPHICX(2,1)
+C NOW DONE WITH MULTIPLE SCATTERING_
+C DEFAULT FOR $PRESTA-LCA; IS ; (NULL)
+C NOW UPDATE ENERGY AND SEE IF BELOW CUT
+ PEIE=PEIE-EDEP
+ EIE=PEIE
+ E(NP)=PEIE
+ IF ((EIE.LE.ECUT(IRL))) THEN
+ GO TO 1020
+ END IF
+ MEDOLD=MEDIUM
+ IF ((MEDIUM.NE.0)) THEN
+ EKEOLD=EKE
+ EKE=EIE-RM
+C UPDATE KINETIC ENERGY
+ ELKE=LOG(EKE)
+ LELKE=EKE1(MEDIUM)*ELKE+EKE0(MEDIUM)
+C GET UPDATED INTERVAL
+ END IF
+C REGION CHANGE
+ IF ((IRNEW.NE.IROLD)) THEN
+ IR(NP)=IRNEW
+ IRL=IRNEW
+ MEDIUM=MED(IRL)
+ END IF
+C AFTER TRANSPORT CALL TO USER
+ IARG=5
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C oct 31 bug found by C Ma. ECUT discard now after AUSGAB call
+ IF ((EIE.LE.ECUT(IRL))) THEN
+ GO TO 1020
+ END IF
+C NOW CHECK FOR DEFERRED DISCARD REQUEST. MAY HAVE BEEN SET
+C BY EITHER HOWFARCX, OR ONE OF THE TRANSPORT AUSGAB CALLS
+ IF((IDISC.LT.0))GO TO 1050
+ IF((MEDIUM.NE.MEDOLD))GO TO 1031
+C NRCC UPDATE 87/12/08 -- DEFAULT IS NULL
+ DEMFP=MAX(0.d0,DEMFP-TVSTEP*SIG)
+ IF(((DEMFP.LT.1.E-6)))GO TO1042
+ GO TO 1041
+1042 CONTINUE
+C END USTEP LOOP
+C COMPUTE FINAL SIGMA TO SEE IF RESAMPLE IS NEEDED.
+C THIS WILL TAKE THE ENERGY VARIATION OF THE SIGMA INTO
+C ACCOUNT USING THE FICTITIOUS SIGMA METHOD.
+C ELECTRON
+ IF ((LELEC.LT.0)) THEN
+ SIGF=ESIG1(LELKE,MEDIUM)*ELKE+ESIG0(LELKE,MEDIUM)
+C POSITRON
+ ELSE
+ SIGF=PSIG1(LELKE,MEDIUM)*ELKE+PSIG0(LELKE,MEDIUM)
+ END IF
+ RFICT=DRANEGS(dummy)
+ IF(((RFICT.LE.SIGF/SIG0)))GO TO1032
+ GO TO 1031
+1032 CONTINUE
+C END TSTEP LOOP
+ if(.not.lxfirst)then !first interaction
+ Xfirst=Z(NP)
+ XfirstIn=1d0
+ lxfirst=.true.
+ CALL CONEXPRM(Xfirst)
+ endif
+C NOW SAMPLE ELECTRON INTERACTION
+C E-,CHECK BRANCHING RATIO.
+ IF ((LELEC.LT.0)) THEN
+CC =BREMS/TOTAL
+ EBR1=EBR11(LELKE,MEDIUM)*ELKE+EBR10(LELKE,MEDIUM)
+ IF((EKE.LE.AP(MED(IRL))))EBR1=0.d0
+C HH patch 92/07/24
+C IT WAS BREMSSTRAHLUNG
+ RNNO24=DRANEGS(dummy)
+ IF ((RNNO24.LT.EBR1)) THEN
+ GO TO 1090
+C IT WAS MOLLER, BUT FIRST CHECK THE KINEMATICS.
+C NOT ENOUGH ENERGY FOR MOLLER, SO
+ ELSE
+C FORCE IT TO BE A BREMSSTRAHLUNG---PROVIDED OK KINEMATICALLY.
+ IF ((E(NP).LE.THMOLL(MEDIUM))) THEN
+ IF ((EBR1.LE.0.0)) THEN
+ GO TO 1010
+ END IF
+C BREMS. NOT ALLOWED EITHER
+ GO TO 1090
+ END IF
+ IARG=8
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL MOLLERCX
+C THE FOLLOWING MACRO TEMPLATE ALLOWS THE USER TO CHANGE THE
+C PARTICLE SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING
+C SUCH AS SPLITTING, LEADING PARTICLE SELECTION, ETC.).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-ELECTR'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IARG=9
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ END IF
+ GO TO 1010
+ END IF
+C ELECTRON IS LOWEST ENERGY-FOLLOW IT
+C ELSE E+ INTERACTION. PBR1=BREMS/(BREMS+BHABHA+ANNIH)
+ PBR1=PBR11(LELKE,MEDIUM)*ELKE+PBR10(LELKE,MEDIUM)
+ IF((EKE.LE.AP(MED(IRL))))PBR1=0.d0
+C HH patch 92/07/24
+ RNNO25=DRANEGS(dummy)
+ IF ((RNNO25.LT.PBR1)) THEN
+ GO TO 1090
+ END IF
+C IT WAS BREMSSTRAHLUNG
+C ELSE DECIDE BETWEEN BHABHA AND ANNIHILATION
+C PBR2 IS (BREMS+BHABHA)/(BREMS+BHABHA+ANNIH)
+C IT IS BHABHA
+ PBR2=PBR21(LELKE,MEDIUM)*ELKE+PBR20(LELKE,MEDIUM)
+ IF ((RNNO25.LT.PBR2)) THEN
+ IARG=10
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL BHABHACX
+C THE FOLLOWING MACRO TEMPLATE ALLOWS THE USER TO CHANGE THE
+C PARTICLE SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING
+C SUCH AS SPLITTING, LEADING PARTICLE SELECTION, ETC.).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-ELECTR'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IARG=11
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C IT IS IN-FLIGHT ANNIHILATION
+ ELSE
+ IARG=12
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL ANNIHCX
+C THE FOLLOWING MACRO TEMPLATE ALLOWS THE USER TO CHANGE THE
+C PARTICLE SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING
+C SUCH AS SPLITTING, LEADING PARTICLE SELECTION, ETC.).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-ELECTR'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IARG=13
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ GO TO 1012
+C I.E., IN ORDER TO RETURN TO SHOWER
+C AFTER ANNIHILATION THE GAMMAS ARE BOUND TO BE THE LOWEST ENERGY
+C PARTICLES, SO RETURN AND FOLLOW THEM.
+ END IF
+C END PBR2 ELSE
+ GO TO 1011
+1012 CONTINUE
+C:NEWELECTRON:
+CI.E., RETURN TO SHOWER
+C---------------------------------------------
+CBREMSSTRAHLUNG-CALL SECTION
+C---------------------------------------------
+ RETURN
+1090 IARG=6
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL BREMSCX
+C THE FOLLOWING MACRO TEMPLATE ALLOWS THE USER TO CHANGE THE
+C PARTICLE SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING
+C SUCH AS SPLITTING, LEADING PARTICLE SELECTION, ETC.).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-ELECTR'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+CSPLITTING HAS BEEN REQUESTED
+ IF ((IBRSPL.EQ.1)) THEN
+C STACK OVERFLOW IMMINENT, REDUCE NBRSPL, RAISE FBRSPL
+ IF (((NBRSPL.GT.1).AND.((NP+NBRSPL).GE.100))) THEN
+1101 CONTINUE
+ WRITE(6,1110)100,NBRSPL,(2*NBRSPL+1)/3
+1110 FORMAT('0*** WARNING ***. STACK SIZE = ',I4,' MIGHT OVERFLOW
+ *'/ ' NBRSPL BEING REDUCED, ',I4,'-->',I4/)
+ NBRSPL=(2*NBRSPL+1)/3
+ FBRSPL=1.d0/DBLE(NBRSPL)
+ IF ((NBRSPL.EQ.1)) THEN
+C STACK IS TOO SMALL TO ALLOW SPLITTING, SHUT IT OFF
+ WRITE(6,1120)100
+1120 FORMAT('0*** WARNING ***. STACK SIZE = ',I4,' IS TOO SMALL
+ *'/ ' BREMSSTRAHLUNG SPLITTING NOW SHUT OFF'/)
+ IBRSPL=0
+ END IF
+C KEEP LOOPING UNTIL NBRSPL IS SMALL ENOUGH
+ IF((((NP+NBRSPL).LT.100)))GO TO1102
+ GO TO 1101
+1102 CONTINUE
+ END IF
+C SHUFFLE THE ELECTRON TO THE TOP OF THE STACK
+C NPSTRT IS A POINTER TO THE ORIGINAL LOCATION OF THE ELECTRON
+ IF ((IQ(NP).EQ.0)) THEN
+ NPSTRT=NP-1
+ FDUMMY = U(NP-1)
+ U(NP-1) = U(NP)
+ U(NP) = FDUMMY
+ FDUMMY = V(NP-1)
+ V(NP-1) = V(NP)
+ V(NP) = FDUMMY
+ FDUMMY = W(NP-1)
+ W(NP-1) = W(NP)
+ W(NP) = FDUMMY
+ FDUMMY = E(NP-1)
+ E(NP-1) = E(NP)
+ E(NP) = FDUMMY
+ FDUMMY = WT(NP-1)
+ WT(NP-1) = WT(NP)
+ WT(NP) = FDUMMY
+ IDUMMY = IQ(NP-1)
+ IQ(NP-1) = IQ(NP)
+ IQ(NP) = IDUMMY
+C LATCH IS NON-STANDARD
+ IDUMMY = LATCH(NP-1)
+ LATCH(NP-1) = LATCH(NP)
+ LATCH(NP) = IDUMMY
+ ELSE
+ NPSTRT=NP
+ END IF
+C ADJUST THE WEIGHT OF THE INITIAL PHOTON
+ WT(NP-1)=WT(NP-1)*FBRSPL
+C STORE THE ENERGY OF THE INITIAL PHOTON
+ FRSTBR=E(NP-1)
+C RESTORE THE ELECTRON'S INITIAL ENERGY BECAUSE THE INTERACTION
+C REDUCED IT
+ E(NP)=E(NP)+E(NP-1)
+C TELL AUSGAB THAT A BREMSSTRAHLUNG INTERACTION HAS OCCURRED
+ IARG=7
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C INITIALIZE THE SPLITTING COUNTER
+ ICSPLT=1
+1131 IF(ICSPLT.GE.NBRSPL)GO TO 1132
+C LOOP NBRSPL-1 TIMES (TOTAL NUMBER OF PHOTONS = NBRSPL)
+ ICSPLT=ICSPLT+1
+C TELL AUSGAB THAT A BREMSSTRAHLUNG INTERACTION WILL OCCURRED
+ IARG=6
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C SAMPLE THE BREMSSTRAHLUNG INTERACTION
+C SHUFFLE THE ELECTRON TO THE TOP OF THE STACK
+ CALL BREMSCX
+ IF ((IQ(NP).EQ.0)) THEN
+ FDUMMY = U(NP-1)
+ U(NP-1) = U(NP)
+ U(NP) = FDUMMY
+ FDUMMY = V(NP-1)
+ V(NP-1) = V(NP)
+ V(NP) = FDUMMY
+ FDUMMY = W(NP-1)
+ W(NP-1) = W(NP)
+ W(NP) = FDUMMY
+ FDUMMY = E(NP-1)
+ E(NP-1) = E(NP)
+ E(NP) = FDUMMY
+ FDUMMY = WT(NP-1)
+ WT(NP-1) = WT(NP)
+ WT(NP) = FDUMMY
+ IDUMMY = IQ(NP-1)
+ IQ(NP-1) = IQ(NP)
+ IQ(NP) = IDUMMY
+C LATCH IS NON-STANDARD
+ IDUMMY = LATCH(NP-1)
+ LATCH(NP-1) = LATCH(NP)
+ LATCH(NP) = IDUMMY
+ END IF
+C ADJUST THE PHOTON WEIGHT
+ WT(NP-1)=WT(NP-1)*FBRSPL
+C RESTORE THE ELECTRON'S INITIAL ENERGY
+ E(NP)=E(NP)+E(NP-1)
+C TELL AUSGAB THAT A BREMSSTRAHLUNG INTERACTION HAS OCCURRED
+ IARG=7
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C END OF THE SPLITTING LOOP
+ GO TO 1131
+1132 CONTINUE
+C RESTORE THE ELECTRON'S ENERGY TO WHAT IT HAD AFTER THE
+C FIRST INTERACTION
+ E(NP)=E(NP)-FRSTBR
+C PUT THE ELECTRON BACK TO IT'S ORIGINAL STACK LOCATION
+C THIS WILL PREVENT OVERFLOW BECAUSE USUALLY THE PHOTON
+C HAS LOWER ENERGY
+ FDUMMY = U(NP)
+ U(NP) = U(NPSTRT)
+ U(NPSTRT) = FDUMMY
+ FDUMMY = V(NP)
+ V(NP) = V(NPSTRT)
+ V(NPSTRT) = FDUMMY
+ FDUMMY = W(NP)
+ W(NP) = W(NPSTRT)
+ W(NPSTRT) = FDUMMY
+ FDUMMY = E(NP)
+ E(NP) = E(NPSTRT)
+ E(NPSTRT) = FDUMMY
+ FDUMMY = WT(NP)
+ WT(NP) = WT(NPSTRT)
+ WT(NPSTRT) = FDUMMY
+ IDUMMY = IQ(NP)
+ IQ(NP) = IQ(NPSTRT)
+ IQ(NPSTRT) = IDUMMY
+C LATCH IS NON-STANDARD
+ IDUMMY = LATCH(NP)
+ LATCH(NP) = LATCH(NPSTRT)
+ LATCH(NPSTRT) = IDUMMY
+ END IF
+ IARG=7
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+CPHOTON WAS SELECTED.
+ IF ((IQ(NP).EQ.0)) THEN
+ RETURN
+C I.E., RETURN TO SHOWER
+C ELECTRON WAS SELECTED
+ ELSE
+ GO TO 1010
+ END IF
+C---------------------------------------------
+CELECTRON CUTOFF ENERGY DISCARD SECTION
+C---------------------------------------------
+1020 IF ((EIE.GT.AE(MEDIUM))) THEN
+ IDR=1
+ IF ((LELEC.LT.0)) THEN
+ EDEP=PEIE-PRM
+ ELSE
+ EDEP=PEIE-PRM
+ END IF
+ ELSE
+ IDR=2
+ EDEP=PEIE-PRM
+ END IF
+ IARG=IDR
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+1140 CONTINUE
+CNRCC EXTENSION 86/9/12
+CIT'S A POSITRON. PRODUCE ANNIH. GAMMAS IF EDEP LT PEIE
+CFIRST PICK RANDOM DIRECTION FOR GAMMA
+ IF ((LELEC.GT.0)) THEN
+ IF ((EDEP.LT.PEIE)) THEN
+ COSTHE=DRANEGS(dummy)
+ FLIP=DRANEGS(dummy)
+ IF ((FLIP.LE.0.5)) THEN
+ COSTHE=-COSTHE
+ END IF
+ SINTHE=SQRT(MAX(0.d0,1.d0-COSTHE*COSTHE))
+ E(NP)=PRM
+ IQ(NP)=0
+ U(NP)=0.d0
+ V(NP)=0.d0
+ W(NP)=1.d0
+C MAKE GO ALONG Z-AXIS
+ CALL UPHICX(2,1)
+C UPHI WILL PICK RANDOM AZIMUTHAL ANGLE
+C THE FOLLOWING MACRO TEMPLATE ALLOWS THE USER TO CHANGE THE
+C PARTICLE SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING
+C SUCH AS SPLITTING, LEADING PARTICLE SELECTION, ETC.).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-ELECTR'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+C NOW SET UP SECOND GAMMA IN OPPOSITE DIRECTION.
+ NP=NP+1
+ E(NP)=PRM
+ IQ(NP)=0
+ X(NP)=X(NP-1)
+ Y(NP)=Y(NP-1)
+ Z(NP)=Z(NP-1)
+ IR(NP)=IR(NP-1)
+ XM(NP)=XM(NP-1)
+ YM(NP)=YM(NP-1)
+ ZM(NP)=ZM(NP-1)
+ DM(NP)=DM(NP-1)
+ TM(NP)=TM(NP-1)
+ WT(NP)=WT(NP-1)
+ DNEAR(NP)=DNEAR(NP-1)
+ LATCH(NP)=LATCH(NP-1)+1
+ U(NP)=-U(NP-1)
+ V(NP)=-V(NP-1)
+ W(NP)=-W(NP-1)
+ IARG=14
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C NOW DISCARD THE POSITRON AND TAKE NORMAL RETURN TO FOLLOW
+C THE ANNIHILATION GAMMAS.
+ RETURN
+C I.E., RETURN TO SHOWER
+ END IF
+ END IF
+CEND OF POSITRON BLOCK
+ NP=NP-1
+ IRCODE=2
+CTELL SHOWER A NEGATRON OR UN-ANNIHILATED
+C POSITRON HAS BEEN DISCARDED
+CI.E., RETURN TO SHOWER
+C---------------------------------------------
+CUSER REQUESTED ELECTRON DISCARD SECTION
+C---------------------------------------------
+ RETURN
+CNRCC EXTENSION 86/9/12
+CTHE FOLLOWING NRCC EXTENSION 86/9/12
+1050 IDISC=ABS(IDISC)
+ IF (((LELEC.LT.0).OR.(IDISC.EQ.99))) THEN
+ EDEP=PEIE-PRM
+ ELSE
+ EDEP=PEIE+PRM
+ END IF
+CREPLACES
+CIF(LELEC.LT.0) [EDEP=PEIE-PRM;] ELSE [EDEP=PEIE+PRM;]
+ IARG=3
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ IF((IDISC.EQ.99))GOTO 1140
+CNRCC EXTENSION 86/9/12
+ IRCODE=2
+ NP=NP-1
+ RETURN
+CI.E., RETURN TO SHOWER
+CEND OF SUBROUTINE ELECTR
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE HATCHCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C SETUP WHICH THE USER IS EXPECTED TO DO BEFORE CALLING HATCH IS:
+C 1. SET 'NMED' TO THE NUMBER OF MEDIA TO BE USED.
+C 2. SET THE ARRAY 'MEDIA', WHICH CONTAINS THE NAMES OF THE
+C MEDIA THAT ARE DESIRED. THE CHARACTER FORMAT IS A1, SO
+C THAT MEDIA(IB,IM) CONTAINS THE IB'TH BYTE OF THE NAME OF
+C THE IM'TH MEDIUM IN A1 FORMAT.
+C 3. SET 'DUNIT', THE DISTANCE UNIT TO BE USED.
+C DUNIT.GT.0 MEANS VALUE OF DUNIT IS LENGTH OF DISTANCE UNIT
+C CENTIMETERS. DUNIT.LT.0 MEANS USE THE RADIATION LENGTH OF
+C THE ABS(DUNIT)'TH MEDIUM FOR THE DISTANCE UNIT.
+C 4. FILL THE ARRAY 'MED' WITH THE MEDIUM INDICES FOR THE
+C REGIONS.
+C 5. FILL ARRAYS 'ECUT' AND 'PCUT' WITH THE ELECTRON AND PHOTON
+C CUT-OFF ENERGIES FOR EACH REGION RESPECTIVELY. SETUP WILL
+C RAISE THESE IF NECESSARY TO MAKE THEM AT LEAST AS LARGE AS
+C THE REGION'S MEDIUM'S AE AND AP RESPECTIVELY.
+C 6. FILL 'MED' ARRAY. MED(IR) IS THE MEDIUM INDEX FOR REGION
+C IR. A ZERO MEDIUM INDEX MEANS THE REGION IS IN A VACUUM.
+C 7. FILL THE ARRAY 'IRAYLR' WITH 1 FOR EACH REGION IN WHICH
+C RAYLEIGH (COHERENT) SCATTERING IS TO BE INCLUDED.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ CHARACTER*4 MBUF(72),MDLABL(8)
+ DIMENSION ZEROS(3),LOK(1)
+CNOTE: ABOVE IS ZEROS OF SINE, 0,PI,TWOPI
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/BREMPR/ DL1(6,1),DL2(6,1),DL3(6,1),DL4(6,1),DL5(6,1),DL6(6,
+ *1), ALPHI(2,1),BPAR(2,1),DELPOS(2,1), ASYM(1,50,2), WA(1,50),PZ(1,
+ *50),ZELEM(1,50),RHOZ(1,50), PWR2I(100), DELCM(1),ZBRANG(1),FBRSPL,
+ * NNE(1),IBRDST,IPRDST,IBRSPL,NBRSPL
+ CHARACTER*4 ASYM
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIIN/SINC0,SINC1,SIN0(1002),SIN1(1002)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+C==========
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+C========================
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+C=============================
+ COMMON/USERSC/ SMAX,SMAXIR(3),ESTEPE,ESTEPR(3),ESAVE(3), NOMSCT(3)
+ *,NOPLC(3)
+C===============
+ COMMON/USERVR/ CEXPTR,GWAIT,IFORCE,NFMIN,NFMAX,NFTIME,ISOURC,IFPB,
+ *IQINC,MONOEN
+ COMMON/USERXT/IPHTER(3)
+ character*500 home,host,fhdat,fedat,fmdat,fbdat,fhisto,fldat,frdat
+ common /cdata/home,host,fhdat,fedat,fmdat,fbdat ,fhisto,fldat,frda
+ *t,icasan,imodan
+ character*500 fegsdat,fegsout
+ common/egsfname/ fegsdat, fegsout, ifegsdat, ifegsout
+ common/egsnfname/ nfegsdat, nfegsout
+ common/cxetc/mode,iwrt,i1DMC,iphonu !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BOUNDS,BREMPR,ELECIN,MEDIA,MISC,PHOTIN,STACK,
+C THRESH,UPHIIN,UPHIOT,USEFUL,USER,RANDOM/;
+ DATA MDLABL/' ','M','E','D','I','U','M','='/,LMDL/8/,LMDN/24/,DUNI
+ *TO/1./
+C FORMAT STATEMENTS USED MULTIPLE TIMES IN SETUP
+ DATA I1ST/1/,NSINSS/37/,MXSINC/1002/,ISTEST/0/,NRNA/1000/
+1010 FORMAT(1X,14I5)
+1020 FORMAT(1X,1P,5E14.5)
+1030 FORMAT(72A1)
+c BREMSTRAHLUNG SPLITTING OFF
+ IBRSPL=0
+ IF ((I1ST.NE.0)) THEN
+ I1ST=0
+C RESET FIRST TIME FLAG
+C DO FIRST TIME INITIALIZATION
+ IF ((SMAX.LE.0.d0)) THEN
+ SMAX=1.d10
+ END IF
+ DO 1041 J=1,3
+ IF ((SMAXIR(J).LE.0.d0)) THEN
+ SMAXIR(J)=SMAX
+ END IF
+1041 CONTINUE
+c1042 CONTINUE
+ LATCHI=0
+C DEFAULT FOR $HATCH-USER-INPUT-INIT; IS ; (NULL)
+C SET UP ENERGY PRECISION VARIABLES
+ PRM=RM
+C PRECISE REST MASS
+ PRMT2=2.D0*PRM
+C TWICE THE PRECISION REST MASS
+ PZERO=0.0D0
+C PRECISE ZERO
+C NOW CONSTRUCT PIECEWISE LINEAR FIT TO SINE FUNCTION OVER THE
+C INTERVAL (0,5*PI/2). DIVIDE THIS INTERVAL INTO MXSINC SUB-
+C INTERVALS. EACH OF THESE SUBINTERVALS IS THEN SUBDIVIDED INTO
+C NSINSS SUB-SUB-INTERVALS. THE ANGLES AT THE BOUNDARIES OF
+C THESE SUB-SUB-INTERVALS AND THEIR SINES ARE USED TO COMPUTE
+C LEAST SQUARES COEFFICIENTS FOR THE SUBINTERVAL. AN EXTRA
+C SUBINTERVAL ON EACH SIDE OF THE INTERVAL (0,5*PI/2) IS INCLUDED
+C FOR GOOD MEASURE.
+ NISUB=MXSINC-2
+ FNSSS=NSINSS
+ WID=PI5D2/DBLE(NISUB)
+ WSS=WID/(FNSSS-1.d0)
+ ZEROS(1)=0.d0
+ ZEROS(2)=PI
+C LOOP OVER SUBINTERVALS
+ ZEROS(3)=TWOPI
+ DO 1051 ISUB=1,MXSINC
+ SX=0.d0
+ SY=0.d0
+ SXX=0.d0
+ SXY=0.d0
+C ZERO SUMS
+ XS0=WID*DBLE(ISUB-2)
+ XS1=XS0+WID
+C LOWER & UPPER LIMITS
+C NOW CHECK TO SEE IF ANY ZEROS ARE IN THE INTERVAL
+ IZ=0
+ DO 1061 IZZ=1,3
+ IF (((XS0.LE.ZEROS(IZZ)).AND.(ZEROS(IZZ).LE.XS1))) THEN
+ IZ=IZZ
+ GO TO1062
+ END IF
+1061 CONTINUE
+1062 CONTINUE
+C END OF LOOP OVER ZEROS
+ IF ((IZ.EQ.0)) THEN
+ XSI=XS0
+ ELSE
+ XSI=ZEROS(IZ)
+ END IF
+C LOOP OVER SUB-SUBINTERVALS
+ DO 1071 ISS=1,NSINSS
+ XS=WID*DBLE(ISUB-2)+WSS*DBLE(ISS-1)-XSI
+C ANGLE VALUE
+ YS=SIN(XS+XSI)
+C SINE OF ANGLE
+ SX=SX+XS
+C ACCUMULATE SUMS
+ SY=SY+YS
+ SXX=SXX+XS*XS
+ SXY=SXY+XS*YS
+1071 CONTINUE
+c1072 CONTINUE
+C END SUB-SUBINTERVAL LOOP
+C NOW COMPUTE LEAST SQUARES COEFFICIENTS
+C FORCE FIT THROUGH SINES' ZEROS,
+ IF ((IZ.NE.0)) THEN
+C FOR SMALL REL.ERR.&GOOD
+C VALUES OF SINTHE/THETA NEAR ZERO
+ SIN1(ISUB)=SXY/SXX
+ SIN0(ISUB)=-SIN1(ISUB)*XSI
+C DO FULL LEAST SQUARES
+ ELSE
+ DEL=FNSSS*SXX-SX*SX
+ SIN1(ISUB)=(FNSSS*SXY-SY*SX)/DEL
+ SIN0(ISUB)=(SY*SXX-SX*SXY)/DEL - SIN1(ISUB)*XSI
+ END IF
+1051 CONTINUE
+c1052 CONTINUE
+C END SUB-INTERVAL LOOP
+ SINC0=2.d0
+C SET COEFFICIENTS WHICH DETERMINE INTERVAL
+C NOW TEST FIT, IF REQUESTED
+ SINC1=1.d0/WID
+ IF ((ISTEST.NE.0)) THEN
+C FIRST TEST AT POINTS PREVIOUSLY COMPUTED, EXCLUDING
+C END SUBINTERVALS
+ ADEV=0.d0
+ RDEV=0.d0
+ S2C2MN=10.d0
+ S2C2MX=0.d0
+ DO 1081 ISUB=1,NISUB
+ DO 1091 ISS=1,NSINSS
+ THETA=WID*DBLE(ISUB-1)+WSS*DBLE(ISS-1)
+ CTHET=PI5D2-THETA
+ LTHETA=SINC1*THETA+SINC0
+ LCTHET=SINC1*CTHET+SINC0
+ SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
+ COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
+ SINT=SIN(THETA)
+ COST=COS(THETA)
+ ASD=ABS(SINTHE-SINT)
+ ACD=ABS(COSTHE-COST)
+ ADEV=MAX(ADEV,ASD,ACD)
+ IF((SINT.NE.0.0))RDEV=MAX(RDEV,ASD/ABS(SINT))
+ IF((COST.NE.0.0))RDEV=MAX(RDEV,ACD/ABS(COST))
+ S2C2=SINTHE**2+COSTHE**2
+ S2C2MN=MIN(S2C2MN,S2C2)
+ S2C2MX=MAX(S2C2MX,S2C2)
+ IF ((ISUB.LT.11)) THEN
+ WRITE(6,1100)THETA,SINTHE,SINT,COSTHE,COST
+1100 FORMAT(1PE20.7,4E20.7)
+ END IF
+1091 CONTINUE
+c1092 CONTINUE
+1081 CONTINUE
+c1082 CONTINUE
+C END OF FIXED INTERVAL TEST-OUTPUT RESULTS
+ WRITE(6,1110)MXSINC,NSINSS
+1110 FORMAT(' SINE TESTS,MXSINC,NSINSS=',2I5)
+ WRITE(6,1120)ADEV,RDEV,S2C2MN,S2C2MX
+1120 FORMAT(' ADEV,RDEV,S2C2(MN,MX) =',1PE16.8,3E16.8)
+C NOW DO RANDOM TEST
+ ADEV=0.d0
+ RDEV=0.d0
+ S2C2MN=10.d0
+ S2C2MX=0.d0
+ DO 1131 IRN=1,NRNA
+ THETA=DRANEGS(dummy)
+ THETA=THETA*PI5D2
+ CTHET=PI5D2-THETA
+ LTHETA=SINC1*THETA+SINC0
+ LCTHET=SINC1*CTHET+SINC0
+ SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
+ COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
+ SINT=SIN(THETA)
+ COST=COS(THETA)
+ ASD=ABS(SINTHE-SINT)
+ ACD=ABS(COSTHE-COST)
+ ADEV=MAX(ADEV,ASD,ACD)
+ IF((SINT.NE.0.d0))RDEV=MAX(RDEV,ASD/ABS(SINT))
+ IF((COST.NE.0.d0))RDEV=MAX(RDEV,ACD/ABS(COST))
+ S2C2=SINTHE**2+COSTHE**2
+ S2C2MN=MIN(S2C2MN,S2C2)
+ S2C2MX=MAX(S2C2MX,S2C2)
+1131 CONTINUE
+c1132 CONTINUE
+C END RANDOM ANGLE LOOP
+ WRITE(6,1140)NRNA
+1140 FORMAT(' TEST AT ',I7,' RANDOM ANGLES IN (0,5*PI/2)')
+ WRITE(6,1150)ADEV,RDEV,S2C2MN,S2C2MX
+1150 FORMAT(' ADEV,RDEV,S2C2(MN,MX) =',1PE16.8,3E16.8)
+ END IF
+C END OF SINE TABLE TEST
+C NOW FILL IN POWER OF TWO TABLE. PWR2I(I)=1/2**(I-1)
+ P=1.d0
+ DO 1161 I=1,100
+ PWR2I(I)=P
+ P=P/2.d0
+1161 CONTINUE
+c1162 CONTINUE
+ END IF
+CEND OF FIRST TIME INITIALIZATION
+CFILL IRAYLM ARRAY BASED ON IRAYLR INPUTS
+ DO 1171 J=1,NMED
+c1180 CONTINUE
+ DO 1181 I=1,3
+ IF ((IRAYLR(I).EQ.1.AND.MED(I).EQ.J)) THEN
+C REGION I = MEDIUM J AND WE WANT RAYLEIGH SCATTERING, SO
+C SET FLAG TO PICK UP DATA FOR MEDIUM J AND TRY NEXT MEDIUM.
+ IRAYLM(J)=1
+ GO TO 1182
+ END IF
+C END OF REGION-LOOP
+1181 CONTINUE
+1182 CONTINUE
+C END OF MEDIA-LOOP
+1171 CONTINUE
+c1172 CONTINUE
+C NOW SEARCH FILE FOR DATA FOR REQUESTED MATERIALS
+ REWIND KMPI
+CNRCC VAX ADDITION
+CREADONLY ALLOWS SEVERAL USERS TO READ THE FILE AT ONCE
+Cexplicit file name for HP compiler Nov 23, 1996 DR
+ if(ifegsdat.gt.0)then
+ OPEN(UNIT=KMPI,FILE=fegsdat(1:nfegsdat),STATUS='OLD')
+ else
+ OPEN(UNIT=KMPI,FILE='egs4.dat',STATUS='OLD')
+ endif
+ if(ifegsout.gt.0)then
+ OPEN(UNIT=KMPO,FILE=fegsout(1:nfegsout),STATUS='UNKNOWN')
+ else
+ OPEN(UNIT=KMPO,FILE='egs4.out',STATUS='UNKNOWN')
+ endif
+CNUMBER OF MEDIA FOUND
+ NM=0
+ DO 1191 IM=1,NMED
+C SET FLAG TELLING WHICH MEDIA ARE OK
+C NOW TELL USER IF RAYLEIGH OPTION HAS BEEN REQUESTED
+ LOK(IM)=0
+ IF ((IRAYLM(IM).EQ.1)) THEN
+ WRITE(6,1200)IM
+1200 FORMAT(' RAYLEIGH OPTION REQUESTED FOR MEDIUM NUMBER',I3,/)
+ END IF
+1191 CONTINUE
+c1192 CONTINUE
+CMEDIUM SEARCH LOOP
+c1210 CONTINUE
+C MEDIUM HEADER SEARCH LOOP
+1211 CONTINUE
+1220 CONTINUE
+1221 CONTINUE
+C FIRST LOOK FOR MEDIUM HEADER
+ READ(KMPI,1030,END=1230)MBUF
+ DO 1241 IB=1,LMDL
+ IF((MBUF(IB).NE.MDLABL(IB)))GO TO 1221
+1241 CONTINUE
+c1242 CONTINUE
+C HEADER MATCHES. NOW SEE IF IT IS ONE OF REQUESTED MEDIA
+c1250 CONTINUE
+ DO 1251 IM=1,NMED
+ DO 1261 IB=1,LMDN
+ IL=LMDL+IB
+ IF((MBUF(IL).NE.MEDIA(IB,IM)))GO TO 1251
+ IF((IB.EQ.LMDN))GO TO 1222
+1261 CONTINUE
+c1262 CONTINUE
+1251 CONTINUE
+c1252 CONTINUE
+C END :MDNAME: DO
+C NOT IN NAME TABLE, SO IGNORE IT
+ GO TO 1221
+1222 CONTINUE
+C MDLOOK
+C 'IM' IS THE INDEX OF THE MEDIUM READY TO BE READ
+ IF((LOK(IM).NE.0))GO TO 1220
+C WE ALREADY HAVE THIS ONE
+ LOK(IM)=1
+C SET FOUND FLAG AND STEP MEDIUM COUNTER
+C NOW READY TO READ IN DATA FOR THIS MEDIUM
+ NM=NM+1
+c$$$ WRITE(KMPO,1270)IM,MBUF
+c$$$1270 FORMAT(' DATA FOR MEDIUM #',I3,', WHICH IS:',72A1)
+C NOW PUT OUT LINES SHOWING COMPOSITION OF MEDIUM
+C THE FOLLOWING LINE WAS CHANGED TO STORE THE ELEMENTAL COMPOSITION AFB
+C 88/05/31
+C $UINPUT(KMPI)(MBUF(I),I=1,5),RHO(IM),NE;
+C The next two lines were line prior to Dec 89 mods to get IUNRST
+C $UINPUT(KMPI)(MBUF(I),I=1,5),RHO(IM),NNE(IM);
+C (5A1,5X,F11.0,4X,I2);
+C following used to pick up IUNRST, IAPRIM and EPSTFL
+C Problem is that GASP may or may not be printed, so we make
+C a kludge which will work with all old data files
+C FIRST WE ASSUME THERE IS NO GASP VALUE IN THE LINE
+ READ(KMPI,1,ERR=1280) (MBUF(I),I=1,5),RHO(IM),NNE(IM),IUNRST(IM)
+ * ,EPSTFL(IM),IAPRIM(IM)
+1 FORMAT(5A1,5X,F11.0,4X,I2,9X,I1,9X,I1,9X,I1)
+C IUNRST, EPSTFL AND IAPRIM ARE STORED IN COMIN ELECIN
+ GO TO 1290
+C WE MUST REREAD THE LINE WITH THE CORRECT FORMAT
+1280 BACKSPACE(KMPI)
+C THIS BACKS UP ONE RECORD TO RE-READ IT
+ READ(KMPI,2)(MBUF(I),I=1,5),RHO(IM),NNE(IM),IUNRST(IM),EPSTFL(IM
+ * ), IAPRIM(IM)
+C THE FOLLOWING LINE WAS CHANGED AS WELL AFB 88/05/31
+C $UOUTPUT(KMPO)(MBUF(I),I=1,5),RHO(IM),NE;
+2 FORMAT(5A1,5X,F11.0,4X,I2,26X,I1,9X,I1,9X,I1)
+1290 CONTINUE
+ WRITE(KMPO,1300)(MBUF(I),I=1,5),RHO(IM),NNE(IM)
+C THE FOLLOWING LINE WAS CHANGED AS WELL AFB 88/05/31
+C DO IE=1,NE[
+1300 FORMAT (5A1,',RHO=',1PG11.4,',NE=',I2,',COMPOSITION IS :')
+C THE FOLLOWING LINE, COMMENTED OUT, WAS THE OLD WAY OF READING IN
+C THE ELEMENTAL COMPOSITION OF EACH MEDIUM. THE INFORMATION WAS NOT
+C PASSED ON TO EGS. IN THE PRESENT VERSION IT IS READ IN AND STORED
+C IN COMMON BREMPR. AFB 88/05/31.
+C READ(KMPI,:BYTE:)MBUF;WRITE(KMPO,:BYTE:)MBUF;
+ DO 1311 IE=1,NNE(IM)
+ READ(KMPI,1320)(MBUF(I),I=1,6),(ASYM(IM,IE,I),I=1,2), ZELEM(IM
+ * ,IE),WA(IM,IE),PZ(IM,IE),RHOZ(IM,IE)
+1320 FORMAT (6A1,2A1,3X,F3.0,3X,F9.0,4X,F12.0,6X,F12.0)
+ WRITE(KMPO,1330)(MBUF(I),I=1,6),(ASYM(IM,IE,I),I=1,2), ZELEM(I
+ * M,IE),WA(IM,IE),PZ(IM,IE),RHOZ(IM,IE)
+1330 FORMAT (6A1,2A1,',Z=',F3.0,',A=',F9.3,',PZ=',1PE12.5,',RHOZ=',
+ * 1PE12.5)
+1311 CONTINUE
+c1312 CONTINUE
+C MEDIA AND THRESH
+ WRITE(KMPO,1340)
+1340 FORMAT(' ECHO READ:$LGN(RLC,AE,AP,UE,UP(IM))')
+ READ(KMPI,1020)RLC(IM),AE(IM),AP(IM),UE(IM),UP(IM)
+c$$$ WRITE(KMPO,1020)RLC(IM),AE(IM),AP(IM),UE(IM),UP(IM)
+ TE(IM)=AE(IM)-RM
+C ACTUAL ARRAY SIZES FROM PEGS
+ THMOLL(IM)=TE(IM)*2.d0 + RM
+ WRITE(KMPO,1350)
+1350 FORMAT(' ECHO READ:$LGN(MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE(I
+ *M)),IRAYL')
+ READ(KMPI,1010)MSGE(IM),MGE(IM),MSEKE(IM),MEKE(IM),MLEKE(IM),MCM
+ * FP(IM),MRANGE(IM),IRAYL
+c$$$ WRITE(KMPO,1010)MSGE(IM),MGE(IM),MSEKE(IM),MEKE(IM),MLEKE(IM),MC
+c$$$ * MFP(IM),MRANGE(IM),IRAYL
+ NSGE=MSGE(IM)
+ NGE=MGE(IM)
+ NSEKE=MSEKE(IM)
+ NEKE=MEKE(IM)
+ NLEKE=MLEKE(IM)
+ NCMFP=MCMFP(IM)
+C BREMPR
+ NRANGE=MRANGE(IM)
+ WRITE(KMPO,1360)
+1360 FORMAT(' ECHO READ:($LGN(DL(I,IM)/1,2,3,4,5,6/),I=1,6)')
+ READ(KMPI,1020)(DL1(I,IM),DL2(I,IM),DL3(I,IM),DL4(I,IM),DL5(I,IM
+ * ),DL6(I,IM),I=1,6)
+c$$$ WRITE(KMPO,1020)(DL1(I,IM),DL2(I,IM),DL3(I,IM),DL4(I,IM),DL5(I,I
+c$$$ * M),DL6(I,IM),I=1,6)
+ WRITE(KMPO,1370)
+1370 FORMAT(' ECHO READ:DELCM(IM),($LGN(ALPHI,BPAR, DELPOS(I,IM)),I=1
+ *,2)')
+ READ(KMPI,1020)DELCM(IM),(ALPHI(I,IM),BPAR(I,IM),DELPOS(I,IM),I=
+ * 1,2)
+c$$$ WRITE(KMPO,1020)DELCM(IM),(ALPHI(I,IM),BPAR(I,IM),DELPOS(I,IM),I
+c$$$ * =1,2)
+
+C ELECIN
+ WRITE(KMPO,1380)
+1380 FORMAT(' ECHO READ:$LGN(XR0,TEFF0,BLCC,XCC(IM))')
+ READ(KMPI,1020)XR0(IM),TEFF0(IM),BLCC(IM),XCC(IM)
+c$$$ WRITE(KMPO,1020)XR0(IM),TEFF0(IM),BLCC(IM),XCC(IM)
+ WRITE(KMPO,1390)
+1390 FORMAT(' ECHO READ:$LGN(EKE(IM)/0,1/)')
+ READ(KMPI,1020)EKE0(IM),EKE1(IM)
+c$$$ WRITE(KMPO,1020)EKE0(IM),EKE1(IM)
+ WRITE(KMPO,1400)
+1400 FORMAT(' ECHO READ:($LGN(ESIG,PSIG,EDEDX,PDEDX,EBR1,PBR1,PBR2, T
+ *MXS(I,IM)/0,1/),I=1,NEKE)')
+ READ(KMPI,1020)(ESIG0(I,IM),ESIG1(I,IM),PSIG0(I,IM),PSIG1(I,IM),
+ * EDEDX0(I,IM),EDEDX1(I,IM),PDEDX0(I,IM),PDEDX1(I,IM),EBR10(I,IM),
+ * EBR11(I,IM),PBR10(I,IM),PBR11(I,IM),PBR20(I,IM),PBR21(I,IM),TMXS
+ * 0(I,IM),TMXS1(I,IM),I=1,NEKE)
+c$$$ WRITE(KMPO,1020)(ESIG0(I,IM),ESIG1(I,IM),PSIG0(I,IM),PSIG1(I,IM)
+c$$$ * ,EDEDX0(I,IM),EDEDX1(I,IM),PDEDX0(I,IM),PDEDX1(I,IM),EBR10(I,IM)
+c$$$ * ,EBR11(I,IM),PBR10(I,IM),PBR11(I,IM),PBR20(I,IM),PBR21(I,IM),TMX
+c$$$ * S0(I,IM),TMXS1(I,IM),I=1,NEKE)
+
+C PHOTIN
+ WRITE(KMPO,1410)
+1410 FORMAT(' ECHO READ:EBINDA(IM),$LGN(GE(IM)/0,1/)')
+ READ(KMPI,1020)EBINDA(IM),GE0(IM),GE1(IM)
+c$$$ WRITE(KMPO,1020)EBINDA(IM),GE0(IM),GE1(IM)
+
+ WRITE(KMPO,1420)
+1420 FORMAT(' ECHO READ:($LGN(GMFP,GBR1,GBR2,GBR3,GBR4(I,IM)/0,1/)'
+ * ,',I=1,NGE)')
+ READ(KMPI,1020)(GMFP0(I,IM),GMFP1(I,IM),GBR10(I,IM),GBR11(I,IM)
+ * ,GBR20(I,IM),GBR21(I,IM),GBR30(I,IM),GBR31(I,IM)
+ * ,GBR40(I,IM),GBR41(I,IM),I=1,NGE)
+c$$$ WRITE(KMPO,1020)(GMFP0(I,IM),GMFP1(I,IM),GBR10(I,IM),GBR11(I,IM)
+c$$$ * ,GBR20(I,IM),GBR21(I,IM),GBR30(I,IM),GBR31(I,IM)
+c$$$ * ,GBR40(I,IM),GBR41(I,IM),I=1,NGE)
+
+c Update of cross section to avoid muon pair production and photonuclear effect
+ if(iphonu.eq.0.or.(mode.ge.1.and.mode.le.3))then
+ do I=1,NGE
+ gle=(I+0.61d0-GE0(IM))/GE1(IM) !+0.61 because of the bin width (kind of mean)
+ gmfptot=GMFP1(I,IM)*gle+GMFP0(I,IM)
+ gmfppair0=(1.d0-GBR40(I,IM))*gmfptot
+ gmfppair1=-GBR41(I,IM)*gmfptot
+ gmfpcom0=(GBR40(I,IM)-GBR30(I,IM))*gmfptot
+ gmfpcom1=(GBR41(I,IM)-GBR31(I,IM))*gmfptot
+ gmfpmup0=GBR10(I,IM)*gmfptot
+ gmfpmup1=GBR11(I,IM)*gmfptot
+ gmfpphon0=(GBR20(I,IM)-GBR10(I,IM))*gmfptot
+ gmfpphon1=(GBR21(I,IM)-GBR11(I,IM))*gmfptot
+ gmfpphoe0=GMFP0(I,IM)-gmfppair0-gmfpcom0-gmfpmup0-gmfpphon0
+ gmfpphoe1=GMFP1(I,IM)-gmfppair1-gmfpcom1-gmfpmup1-gmfpphon1
+ gmfptot0=gmfpphoe0+gmfppair0+gmfpcom0 !+gmfpphon0 !include photon-nuc
+ gmfptot1=gmfpphoe1+gmfppair1+gmfpcom1 !+gmfpphon1 !include photon-nuc
+ gmfptot=gmfptot1*gle+gmfptot0
+ if(gmfptot.gt.0.d0)then
+ GMFP0(I,IM)=gmfptot0
+ GMFP1(I,IM)=gmfptot1
+ GBR40(I,IM)=1.d0-gmfppair0/gmfptot
+ GBR41(I,IM)=-gmfppair1/gmfptot
+ GBR30(I,IM)=1.d0-(gmfppair0+gmfpcom0)/gmfptot
+ GBR31(I,IM)=-(gmfppair1+gmfpcom1)/gmfptot
+c GBR20(I,IM)=gmfpphon0/gmfptot !include photon-nu
+c GBR21(I,IM)=gmfpphon1/gmfptot !include photon-nu
+ else
+ GMFP0(I,IM)=0.d0
+ GBR40(I,IM)=0.d0
+ GBR30(I,IM)=0.d0
+ GMFP1(I,IM)=0.d0
+ GBR41(I,IM)=0.d0
+ GBR31(I,IM)=0.d0
+ endif
+ GBR20(I,IM)=0.d0 !comment to include photon-nu
+ GBR21(I,IM)=0.d0 !comment to include photon-nu
+ GBR10(I,IM)=0.d0
+ GBR11(I,IM)=0.d0
+ enddo
+ endif
+
+
+C PHOTIN (CONTINUED)---OPTIONAL RAYLEIGH SCATTERING INPUT
+ IF ((IRAYLM(IM).EQ.1.AND.IRAYL.NE.1)) THEN
+ WRITE(6,1430)IM
+1430 FORMAT(' STOPPED IN HATCHCX: REQUESTED RAYLEIGH OPTION FOR MEDIU
+ *M',I3, /,' BUT RAYLEIGH DATA NOT INCLUDED IN DATA CREATED BY PEGS.
+ *')
+ STOP
+ END IF
+ IF ((IRAYL.EQ.1)) THEN
+ WRITE(KMPO,1440)
+1440 FORMAT(' ECHO READ:NGR(IM)')
+ READ(KMPI,1010)NGR(IM)
+ WRITE(KMPO,1010)NGR(IM)
+ NGRIM=NGR(IM)
+ WRITE(KMPO,1450)
+1450 FORMAT(' ECHO READ:$LGN(RCO(IM)/0,1/)')
+ READ(KMPI,1020)RCO0(IM),RCO1(IM)
+c$$$ WRITE(KMPO,1020)RCO0(IM),RCO1(IM)
+ WRITE(KMPO,1460)
+1460 FORMAT(' ECHO READ:($LGN(RSCT(I,IM)/0,1/),I=1,NGRIM)')
+ READ(KMPI,1020)(RSCT0(I,IM),RSCT1(I,IM),I=1,NGRIM)
+c$$$ WRITE(KMPO,1020)(RSCT0(I,IM),RSCT1(I,IM),I=1,NGRIM)
+ WRITE(KMPO,1470)
+1470 FORMAT(' ECHO READ:($LGN(COHE(I,IM)/0,1/),I=1,NGE)')
+ READ(KMPI,1020)(COHE0(I,IM),COHE1(I,IM),I=1,NGE)
+c$$$ WRITE(KMPO,1020)(COHE0(I,IM),COHE1(I,IM),I=1,NGE)
+ IF ((IRAYLM(IM).NE.1)) THEN
+ WRITE(6,1480)IM
+1480 FORMAT(' RAYLEIGH DATA AVAILABLE FOR MEDIUM',I3, ' BUT OPTIO
+ *N NOT REQUESTED.',/)
+ END IF
+ END IF
+
+
+C THAT'S ALL FOR THIS MEDIUM
+ IF((NM.GE.NMED))GO TO1212
+ GO TO 1211
+1212 CONTINUE
+CLOOP UNTIL WE HAVE ENOUGH. END :MEDIUM: LOOP
+C WE NOW HAVE DATA FOR ALL MEDIA REQUESTED. NOW DO DISTANCE UNIT
+C CHANGE. DATA FROM PEGS IS IN UNITS OF RADIATION LENGTHS.
+C EGS IS RUN IN UNITS OF 'DUNIT' CENTIMETERS, IF DUNIT.GT.0
+C OR IN UNITS OF RLC(-DUNIT) CENTIMETERS IF DUNIT.LT.0.
+C THAT IS, A NEGATIVE DUNIT MEANS UNIT IS TO BE THE RADIATION
+C LENGTH OF THE MEDIUM WHOSE INDEX IS -DUNIT
+CSAVE REQUESTED
+ DUNITR=DUNIT
+ IF ((DUNIT.LT.0.d0)) THEN
+ ID=MAX(1,MIN(1,INT(-DUNIT)))
+ DUNIT=1.d0/RHO(ID)
+ END IF
+ IF ((DUNIT.NE.1.d0)) THEN
+ WRITE(6,1490)DUNITR,DUNIT
+1490 FORMAT(' DUNIT REQUESTED&USED ARE:',1PE14.5,E14.5,'(CM.)')
+ END IF
+ DO 1501 IM=1,NMED
+ DFACT=RLC(IM)/DUNIT
+C CONVERTS RL TO DUNITS
+C CONVERT RL**-1 TO DUNITS**-1
+ DFACTI=1.d0/DFACT
+ I=1
+ GO TO 1513
+1511 I=I+1
+1513 IF(I-(MEKE(IM)).GT.0)GO TO 1512
+ ESIG0(I,IM)=ESIG0(I,IM)*DFACTI
+ ESIG1(I,IM)=ESIG1(I,IM)*DFACTI
+ PSIG0(I,IM)=PSIG0(I,IM)*DFACTI
+ PSIG1(I,IM)=PSIG1(I,IM)*DFACTI
+ EDEDX0(I,IM)=EDEDX0(I,IM)*DFACTI
+ EDEDX1(I,IM)=EDEDX1(I,IM)*DFACTI
+ PDEDX0(I,IM)=PDEDX0(I,IM)*DFACTI
+ PDEDX1(I,IM)=PDEDX1(I,IM)*DFACTI
+ TMXS0(I,IM)=TMXS0(I,IM)*DFACT
+ TMXS1(I,IM)=TMXS1(I,IM)*DFACT
+ GO TO 1511
+1512 CONTINUE
+ I=1
+ GO TO 1523
+1521 I=I+1
+1523 IF(I-(MLEKE(IM)).GT.0)GO TO 1522
+ ERANG0(I,IM)=ERANG0(I,IM)*DFACT
+ ERANG1(I,IM)=ERANG1(I,IM)*DFACT
+ PRANG0(I,IM)=PRANG0(I,IM)*DFACT
+ PRANG1(I,IM)=PRANG1(I,IM)*DFACT
+ GO TO 1521
+1522 CONTINUE
+ TEFF0(IM)=TEFF0(IM)*DFACT
+ BLCC(IM)=BLCC(IM)*DFACTI
+ XCC(IM)=XCC(IM)*SQRT(DFACTI)
+ RLDU(IM)=RLC(IM)/DUNIT
+ I=1
+ GO TO 1533
+1531 I=I+1
+1533 IF(I-(MGE(IM)).GT.0)GO TO 1532
+ GMFP0(I,IM)=GMFP0(I,IM)*DFACT
+ GMFP1(I,IM)=GMFP1(I,IM)*DFACT
+ GO TO 1531
+1532 CONTINUE
+
+cc write Cross sections into a histo file
+c write(*,*)'Cross Sections from EGS4 for ',IM,NGE
+c open(20,file='xsection_egs4.histo',status='unknown')
+c write(20,*)' ! Cross section from EGS4 (Conex)'
+c write(20,*)'set scalel 0.5'
+c write(20,*)'newpage'
+c write(20,*)'zone 1 1 1'
+cc write XS for photon
+c write(20,*)'! Cross section from EGS4 in cm^2/g for Photon '
+c &, '(X0=36.831 g/cm^2)'
+c write(20,*)'openhisto name egs4g'
+c write(20,*)'xmod log xrange 1e-5 1e12'
+c write(20,*)'ymod log yrange 1e-9 1'
+c write(20,*)'htyp pnt'
+c write(20,*)'txt "title [g] cross sections"'
+c write(20,*)'- txt "xaxis E(GeV)"'
+c write(20,*)'+ txt "yaxis [s]?tot!(cm^2/g)"'
+c write(20,*)'+ txt "yaxis [s]?pair!"'
+c write(20,*)'+ txt "yaxis [s]?comp!"'
+c write(20,*)'+ txt "yaxis [s]?ph-eff!"'
+c write(20,*)'+ txt "yaxis [s]?pair [m]!"'
+c write(20,*)'+ txt "yaxis [s]?ph-nuc!"'
+c write(20,*)'! Ek(GeV) tot pair compton photo'
+c & ,' mu pair photo nuc'
+c write(20,*)'array -7'
+c do iiii=1,NGE
+c eee=(iiii-GE0(IM))/GE1(IM)
+c eee=exp(eee)*1.1d0
+c gletest=log(eee)
+c eee=1d-3*eee
+c iii=min(NGE,int(GE1(IM)*GLEtest+GE0(IM)))
+c sigtot=(GMFP1(iii,IM)*GLEtest+GMFP0(iii,IM))
+c if(sigtot.gt.0.d0)sigtot=1.d0/sigtot
+c br4=1.d0-(GBR41(iii,IM)*GLEtest+GBR40(iii,IM))
+c if(eee.le.rmt2*1d-3)br4=0.d0
+c sigpair=sigtot*br4
+c br3=1.d0-(GBR31(iii,IM)*GLEtest+GBR30(iii,IM))
+c sigcompt=sigtot*(br3-br4)
+c br1=GBR11(iii,IM)*GLEtest+GBR10(iii,IM)
+c if(eee.le.rmmut2*1d-3)then
+c br1=0.d0
+c sigpmu=0.d0
+c else
+c sigpmu=sigtot*br1
+c endif
+c br2=GBR21(iii,IM)*GLEtest+GBR20(iii,IM)
+c if(eee.le.pithr*1d-3)then
+c br2=0.d0
+c sigphonu=0.d0
+c else
+c sigphonu=sigtot*(br2-br1)
+c endif
+c sigphoto=sigtot-sigpair-sigcompt-sigpmu-sigphonu
+c write(20,'(1p 7e11.3)')eee,sigtot,sigpair,sigcompt,sigphoto
+c & ,sigpmu,sigphonu
+c enddo
+c write(20,*)'endarray'
+c write(20,*)'closehisto'
+c write(20,*)'plot -htyp lru egs4g+1- plot -htyp poc egs4g+2-'
+c write(20,*)'plot -htyp pot egs4g+3- plot -htyp poq egs4g+4- '
+c write(20,*)'plot -htyp pos egs4g+5- plot -htyp pfc egs4g+6'
+cc write XS for Electron
+c write(20,*)'! Cross section from EGS4 in cm^2/g for Electron '
+c write(20,*)'openhisto name egs4e'
+c write(20,*)'xmod log xrange 1e-5 1e12'
+c write(20,*)'ymod log yrange 1e-4 1e1'
+c write(20,*)'htyp pnt'
+c write(20,*)'txt "title e^-! cross sections"'
+c write(20,*)'- txt "xaxis E(GeV)"'
+c write(20,*)'+ txt "yaxis [s]?tot!(cm^2/g)"'
+c write(20,*)'+ txt "yaxis [s]?brems!"'
+c write(20,*)'+ txt "yaxis [s]?delt!"'
+c write(20,*)'! Ek(GeV) tot brems delta'
+c write(20,*)'array -4'
+c do iiii=1,NGE
+c eee=(iiii-EKE0(IM))/EKE1(IM)
+c eee=1.1*exp(eee)
+c elketest=log(eee)
+c eee=1d-3*eee
+c iii=min(NGE,EKE1(IM)*ELKEtest+EKE0(IM))
+c sigtot=(ESIG1(iii,IM)*ELKEtest+ESIG0(iii,IM))
+c sigbrem=sigtot*(EBR11(iii,IM)*ELKEtest+EBR10(iii,IM))
+c if(eee.le.AP(IM)*1e-3)then
+c sigbrem=0.d0
+c elseif(eee.le.THMOLL(IM)*1e-3)then
+c sigbrem=sigtot
+c endif
+c sigdelt=sigtot-sigbrem
+c write(20,'(p1 5e11.3)')eee,sigtot,sigbrem,sigdelt
+c enddo
+c write(20,*)'endarray'
+c write(20,*)'closehisto'
+c write(20,*)'plot -htyp lru egs4e+1- plot -htyp poc egs4e+2-'
+c write(20,*)'plot -htyp pot egs4e+3'
+cc write XS for Positron
+c write(20,*)'! Cross section from EGS4 in cm^2/g for Positron '
+c write(20,*)'openhisto name egs4p'
+c write(20,*)'xmod log xrange 1e-5 1e12'
+c write(20,*)'ymod log yrange 1e-3 1e1'
+c write(20,*)'htyp pnt'
+c write(20,*)'txt "title e^+! cross sections"'
+c write(20,*)'- txt "xaxis E(GeV)"'
+c write(20,*)'+ txt "yaxis [s]?tot!(cm^2/g)"'
+c write(20,*)'+ txt "yaxis [s]?brems!"'
+c write(20,*)'+ txt "yaxis [s]?bha!"'
+c write(20,*)'+ txt "yaxis [s]?anni!"'
+c write(20,*)'! Ek(GeV) tot brems bhabha annih'
+c write(20,*)'array -5'
+c do iiii=1,NGE
+c eee=(iiii-EKE0(IM))/EKE1(IM)
+c eee=1.1*exp(eee)
+c elketest=log(eee)
+c eee=1d-3*eee
+c iii=min(NGE,EKE1(IM)*ELKEtest+EKE0(IM))
+c sigtot=(PSIG1(iii,IM)*ELKEtest+PSIG0(iii,IM))
+c brbrem=PBR11(iii,IM)*ELKEtest+PBR10(iii,IM)
+c if(eee.le.AP(IM)*1e-3)brbrem=0.d0
+c sigbrem=sigtot*brbrem
+c sigbha=sigtot*(PBR21(iii,IM)*ELKEtest+PBR20(iii,IM)-brbrem)
+c sigann=sigtot-sigbrem-sigbha
+c write(20,'(p1 5e11.3)')eee,sigtot,sigbrem,sigbha,sigann
+c enddo
+c write(20,*)'endarray'
+c write(20,*)'closehisto'
+c write(20,*)'plot -htyp lru egs4p+1- plot -htyp poc egs4p+2-'
+c write(20,*)'plot -htyp pot egs4p+3- plot -htyp pos egs4p+4'
+cc write Energy loss for Electron and Positron
+c write(20,*)'! Energy loss from EGS4 in GeV/g.cm^2 for e- and e+ '
+c write(20,*)'openhisto name egs4l'
+c write(20,*)'xmod log xrange 1e-5 1e12'
+c write(20,*)'ymod log yrange 1e-3 1e0'
+c write(20,*)'htyp pnt'
+c write(20,*)'txt "title Continuous energy losses"'
+c write(20,*)'- txt "xaxis E(GeV)"'
+c write(20,*)'+ txt "yaxis dE/dX?e^-!! (GeV.g^-1!.cm^2!)"'
+c write(20,*)'+ txt "yaxis dE/dX?e^+!! (GeV.g^-1!.cm^2!)"'
+c write(20,*)'! Ek(GeV) electron positron'
+c write(20,*)'array -3'
+c do iii=1,NGE
+c eee=(iii-EKE0(IM))/EKE1(IM)
+c elketest=eee
+c eee=1e-3*exp(eee)
+c ededx=(EDEDX1(iii,IM)*ELKEtest+EDEDX0(iii,IM))*1.d-3
+c pdedx=(PDEDX1(iii,IM)*ELKEtest+PDEDX0(iii,IM))*1.d-3
+c write(20,'(p1 5e11.3)')eee,ededx,pdedx
+c enddo
+c write(20,*)'endarray'
+c write(20,*)'closehisto'
+c write(20,*)'plot -htyp poc egs4l+1- plot -htyp pot egs4l+2'
+c close(20)
+
+
+
+1501 CONTINUE
+c1502 CONTINUE
+CEND IM DO
+C SCALE VACDST. UNDO PREVIOUS SCALE, THEN DO NEW.
+ VACDST=VACDST*DUNITO/DUNIT
+CSAVE OLD DUNIT
+C NOW MAKE SURE ECUT AND PCUT ARE NOT LOWER THAN ANY AE OR AP
+C ALSO SET DEFAULT DENSITIES
+ DUNITO=DUNIT
+ DO 1541 JR=1,3
+C IT IS LEGAL NON-VACUUM MEDIUM.
+ MD=MED(JR)
+ IF (((MD.GE.1).AND.(MD.LE.NMED))) THEN
+ ECUT(JR)=MAX(ECUT(JR),AE(MD))
+C USE STANDARD DENSITY FOR REGIONS NOT SPECIALLY SET UP
+ PCUT(JR)=MAX(PCUT(JR),AP(MD))
+ IF ((RHOR(JR).EQ.0.0)) THEN
+ RHOR(JR)=RHO(MD)
+ END IF
+ END IF
+1541 CONTINUE
+c1542 CONTINUE
+CBREMSSTRAHLUNG ANGULAR DISTRIBUTION INITIALIZATION - DEFAULT IS NULL
+CNEXT LINE ADDED AFB 88/05/31
+ IF ((IBRDST.EQ.1)) THEN
+ DO 1551 IM=1,NMED
+ ZBRANG(IM)=0.d0
+ PZNORM=0.d0
+ DO 1561 IE=1,NNE(IM)
+ ZBRANG(IM)= ZBRANG(IM)+PZ(IM,IE)*ZELEM(IM,IE)*(ZELEM(IM,IE)+
+ * 1.d0)
+ PZNORM=PZNORM+PZ(IM,IE)
+1561 CONTINUE
+c1562 CONTINUE
+ ZBRANG(IM)=(8.116224d-05)*(ZBRANG(IM)/PZNORM)**(1.d0/3.d0)
+1551 CONTINUE
+c1552 CONTINUE
+ END IF
+CPAIR ANGULAR DISTRIBUTION INITIALIZATION - DEFAULT IS NULL
+CNEXT LINE ADDED AFB 91/05/29
+ IF ((IPRDST.GT.0)) THEN
+ DO 1571 IM=1,NMED
+ ZBRANG(IM)=0.d0
+ PZNORM=0.d0
+ DO 1581 IE=1,NNE(IM)
+ ZBRANG(IM)= ZBRANG(IM)+PZ(IM,IE)*ZELEM(IM,IE)*(ZELEM(IM,IE)+
+ * 1.d0)
+ PZNORM=PZNORM+PZ(IM,IE)
+1581 CONTINUE
+c1582 CONTINUE
+ ZBRANG(IM)=(8.116224d-05)*(ZBRANG(IM)/PZNORM)**(1.d0/3.d0)
+1571 CONTINUE
+c1572 CONTINUE
+ END IF
+C SETUP IS NOW COMPLETE
+ IF ((NMED.EQ.1)) THEN
+ WRITE(6,1590)
+1590 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ONE MEDIUM.')
+ ELSE
+ WRITE(6,1600)NMED
+1600 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ',I5,' MEDIA.')
+ END IF
+ CLOSE(UNIT=KMPI,STATUS='KEEP')
+CFREE DATA INPUT FILE-NRCC VAX ADDITION
+ RETURN
+1230 WRITE(6,1610)KMPI
+1610 FORMAT(' END OF FILE ON UNIT ',I2,//, ' PROGRAM STOPPED IN HATCHCX
+ * BECAUSE THE',/, ' FOLLOWING NAMES WERE NOT RECOGNIZED:',/)
+ DO 1621 IM=1,NMED
+ IF ((LOK(IM).NE.1)) THEN
+ WRITE(6,1630)(MEDIA(I,IM),I=1,LMDN)
+1630 FORMAT(40X,'''',24A1,'''')
+ END IF
+1621 CONTINUE
+c1622 CONTINUE
+
+ STOP
+CEND OF SUBROUTINE HATCHCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE MOLLERCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C DISCRETE MOLLER SCATTERING (A CALL TO THIS ROUTINE) HAS BEEN
+C ARBITRARILY DEFINED AND CALCULATED TO MEAN MOLLER SCATTERINGS
+C WHICH IMPART TO THE SECONDARY ELECTRON SUFFICIENT ENERGY THAT
+C IT BE TRANSPORTED DISCRETELY. THE THRESHOLD TO TRANSPORT AN
+C ELECTRON DISCRETELY IS A TOTAL ENERGY OF AE OR A KINETIC ENERGY
+C OF TE=AE-RM. SINCE THE KINETIC ENERGY TRANSFER IS ALWAYS, BY
+C DEFINITION, LESS THAN HALF OF THE INCIDENT KINETIC ENERGY, THIS
+C IMPLIES THAT THE INCIDENT ENERGY, EIE, MUST BE LARGER THAN
+C THMOLL=TE*2+RM. THE REST OF THE COLLISION CONTRIBUTION IS
+C SUBTRACTED CONTINUOUSLY FROM THE ELECTRON AS IONIZATION
+C LOSS DURING TRANSPORT.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIE,PEKSE2,PESE1,PESE2
+ DOUBLE PRECISION PEKIN,H1,DCOSTH
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ IRCODE=1
+CSET FOR NORMAL RETURN
+ PEIE=E(NP)
+CPRECISE ENERGY OF INCIDENT ELECTRON
+ EIE=PEIE
+CENERGY OF INCIDENT ELECTRON
+ PEKIN=PEIE-PRM
+CPRECISE K.E. OF INCIDENT ELECTRON
+ EKIN=PEKIN
+ T0=EKIN/RM
+ E0=T0+1.d0
+ EXTRAE = EIE - THMOLL(MEDIUM)
+ E02=E0*E0
+CBETAI2=E02/(E02-1.0);
+CBLIF 96/2/1 -- not needed for Moller fix-up
+ EP0=TE(MEDIUM)/EKIN
+CG1=(1.-2.*EP0)*BETAI2;
+CBLIF 96/2/1 -- not needed for Moller fix-up
+ G2=T0*T0/E02
+ G3=(2.d0*T0+1.d0)/E02
+C H.H.NAGEL HAS CONSTRUCTED A FACTORIZATION OF THE FREQUENCY
+C DISTRIBUTION FUNCTION FOR THE MOLLER DIFFERENTIAL CROSS
+C SECTION USED AS SUGGESTED BY BUTCHER AND MESSEL.
+C (H.H.NAGEL, OP.CIT., P. 53-55)
+C HOWEVER, A MUCH SIMPLER SAMPLING METHOD WHICH DOES NOT BECOME
+C VERY INEFFICIENT NEAR THMOLL IS THE FOLLOWING. . .
+C LET BR=EKS/EKIN, WHERE EKS IS KINETIC ENERGY TRANSFERED TO THE
+C SECONDARY ELECTRON AND EKIN IS THE INCIDENT KINETIC ENERGY.
+C MODIFIED (7 FEB 1974) TO USE THE TRUE MOLLER CROSS SECTION.
+C THAT IS, INSTEAD OF THE E+ E- AVERAGE GIVEN IN THE ROSSI
+C FORMULA USED BY NAGEL. THE SAMPLING SCHEME IS THAT
+C USED BY MESSEL AND CRAWFORD (EPSDF 1970 P.13)
+C FIRST SAMPLE (1/BR**2) OVER (TE/EKIN,1/2) . . .
+CBLIF 96/2/1 -- Moller fix-up
+C TO RETRY IF REJECTED
+ GMAX=(1.d0+1.25d0*G2)
+1011 CONTINUE
+ RNNO27=DRANEGS(dummy)
+ BR = TE(MEDIUM)/(EKIN-EXTRAE*RNNO27)
+C USE MESSEL AND CRAWFORDS REJECTION FUNCTION.
+ R=BR/(1.d0-BR)
+ RNNO28=DRANEGS(dummy)
+C G1*
+ REJF4=(1.d0+G2*BR*BR+R*(R-G3))
+C BLIF 96/2/1 -- Moller fix-up
+ RNNO28=GMAX*RNNO28
+C BLIF 96/2/1 -- Moller fix-up
+ IF((RNNO28.LE.REJF4))GO TO1012
+ GO TO 1011
+1012 CONTINUE
+CTRY UNTIL ACCEPTED. END REJECTION LOOP
+ PEKSE2=BR*PEKIN
+ IF(PEKSE2.ge.PEIE)GO TO 1011
+CPRECISE KINETIC ENERGY OF SECONDARY ELECTRON #2
+ PESE1=PEIE-PEKSE2
+CPRECISE ENERGY OF SECONDARY ELECTRON #1
+ PESE2=PEKSE2+PRM
+CPRECISE ENERGY OF SECONDARY ELECTRON #2
+ ESE1=PESE1
+CENERGY OF SECONDARY ELECTRON 1
+ ESE2=PESE2
+CENERGY OF SECONDARY ELECTRON 2
+ E(NP)=ESE1
+ E(NP+1)=ESE2
+C SINCE BR.LE.0.5, E(NP+1) MUST BE .LE. E(NP).
+ if(i1DEM.eq.0)then
+C MOLLER ANGLES ARE UNIQUELY DETERMINED BY KINEMATICS
+ H1=(PEIE+PRM)/PEKIN
+C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON
+ DCOSTH=min(1D0,H1*(PESE1-PRM)/(PESE1+PRM))
+ SINTHE=DSQRT(1.D0-DCOSTH)
+ COSTHE=DSQRT(DCOSTH)
+ CALL UPHICX(2,1)
+C RELATED CHANGE AND (X,Y,Z) SETUP FOR 'NEW' ELECTRON
+ NP=NP+1
+ IQ(NP)=-1
+ DCOSTH=min(1D0,H1*(PESE2-PRM)/(PESE2+PRM))
+ SINTHE=-DSQRT(1.D0-DCOSTH)
+ COSTHE=DSQRT(DCOSTH)
+ CALL UPHICX(3,2)
+ else
+ costhe=1.d0
+ sinthe=0.d0
+ CALL UPHICX(2,1)
+ NP=NP+1
+ IQ(NP)=-1
+ CALL UPHICX(3,2)
+ endif
+ RETURN
+CEND OF SUBROUTINE MOLLERCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE MSCATCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ INTEGER EPSTFL(1)
+ COMMON/ELECIN/ EKELIM, EKE0(1),EKE1(1),CMFP0(1),CMFP1(1),RANGE0(1)
+ *,RANGE1(1), XR0(1),TEFF0(1),BLCC(1),XCC(1), PICMP0(1,1),PICMP1(1,1
+ *),EICMP0(1,1),EICMP1(1,1), ESIG0(1000,1),ESIG1(1000,1),PSIG0(1000
+ *,1),PDEDX1(1000,1),PBR20(1000,1),CMFPE1(1,1),
+ *PSIG1(1000,1),EDEDX0(1000,1),EDEDX1(1000,1),PDEDX0(1000,1)
+ *,EBR10(1000,1),EBR11(1000,1),PBR10(1000,1),PBR11(1000,1)
+ *,PBR21(1000,1),TMXS0(1000,1),TMXS1(1000,1), CMFPE0(1,1),
+ *CMFPP0(1,1),CMFPP1(1,1),ERANG0(1,1),ERANG1(1,1),PRANG0(1,1),PRANG1
+ *(1,1),CXC2E0(1,1),CXC2E1(1,1),CXC2P0(1,1),CXC2P1(1,1),CLXAE0(1,1),
+ *CLXAE1(1,1),CLXAP0(1,1),CLXAP1(1,1), THR0(1,1),THR1(1,1),THR2(1,1)
+ *, THRI0(1,1),THRI1(1,1),THRI2(1,1), FSTEP(16),FSQR(16), VERT1(1000
+ *),VERT2(100,16), BLC0,BLC1,RTHR0,RTHR1,RTHRI0,RTHRI1, ICOMP, MPEEM
+ *(1,1), MSMAP(200), MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI, IUNR
+ *ST(1),EPSTFL,IAPRIM(1)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/MULTS/ B0G21,B1G21,G210(7),G211(7),G212(7), B0G22,B1G22,G22
+ *0(8),G221(8),G222(8), B0G31,B1G31,G310(11),G311(11),G312(11), B0G3
+ *2,B1G32,G320(25),G321(25),G322(25), B0BGB,B1BGB,BGB0(8),BGB1(8),BG
+ *B2(8), NG21,NG22,NG31,NG32,NBGB
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIIN/SINC0,SINC1,SIN0(1002),SIN1(1002)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,ELECIN,EPCONT,MISC,MULTS,STACK,THRESH,UPHIIN,
+C UPHIOT,USEFUL,RANDOM/;
+C DEFAULT FOR $PRESTA-MSCAT-1; IS ; (NULL)
+ VSTEFF=TVSTEP*RHOF
+CACCOUNT FOR ALTERED DENSITY
+C GET MOLIERE'S LOWER CASE B PARAMETER, BLC
+ OMEGA0=BLCC(MEDIUM)*VSTEFF/BETA2
+ IF (imscat.eq.0.or.(OMEGA0.LE.1.d0)) THEN
+ SINTHE=0.d0
+ COSTHE=1.d0
+ THETA=0.d0
+c NOSCAT=NOSCAT+1
+ RETURN
+ END IF
+C DEFAULT FOR $MSCAT-OVER-RIDE; IS A CHECK ON OMEGA0.LE.1.0. IF TRUE,
+C THEN [SINTHE=0.0; COSTHE=1.0; THETA=0.0; NOSCAT=NOSCAT+1; RETURN;]
+C OTHERWISE, CONTINUE ON.
+C NOW CONVERT TO MOLIERE'S BIG B
+C 1.30685=2-LN 2, 1.530394=2/(2-LN 2)
+ BLC=LOG(OMEGA0)
+ IF ((BLC.LE.1.30685d0)) THEN
+ B=1.530394d0*BLC
+C BELOW TRANSCENDENTAL LIMIT
+ ELSE
+ IB=B0BGB+BLC*B1BGB
+ IF ((IB.GT.NBGB)) THEN
+ WRITE(6,1010)IB
+1010 FORMAT(' NBGB<IB=',I5)
+ END IF
+ B=BGB0(IB)+BLC*(BGB1(IB)+BLC*BGB2(IB))
+ END IF
+C NOW GET REDUCING ANGLE=[CHI-SUB-C]*SQRT(B);
+C BUT [CHI-SUB-C]=XCC(MEDIUM)*SQRT(VSTEFF)/($EMS*BETA2);
+ XR=XCC(MEDIUM)*SQRT(VSTEFF*B)/(EOLD*BETA2)
+CDEFAULT FOR $PRESTA-MSCAT-2; IS ; (NULL)
+C NOW SET B-INVERSE,BI THAT WILL BE USED IN SAMPLING
+C BI MUST NOT BE LARGER THAN 1./LAMBDA=1/2
+ IF ((B.GT.2.d0)) THEN
+ BI=1.d0/B
+ ELSE
+ BI=0.5d0
+ END IF
+C THE ALPHA'S FOR THE FACTORIZATION ARE
+C MU=1
+C LAMBDA=2
+C G2NORM=1.8
+C G3NORM=4.05
+C C1=MU*G2NORM=1.8
+C C2=G3NORM/(2*MU**2)=2.025
+C ALP1=1-LAMBDA/B=1-2/B
+C ALP2=C1/B=1.8/B
+C ALP3=C2/B=2.025/B
+C ALP1+ALP2+ALP3=1+(2.025+1.8-2.)/B
+C =1+1.825/B
+C ALP1+ALP3=1+0.025/B
+ BMD=1.d0+1.75d0*BI
+ BM1=(1.d0-2.d0/B)/BMD
+ BM2=(1.d0+0.025d0*BI)/BMD
+1021 CONTINUE
+C THIS LOOP IS FOR BETHE CORRECTION FACTOR REJECTION
+C OR OTHER REJECTION
+C GAUSSIAN, F0
+ RMS1=DRANEGS(dummy)
+ IF ((RMS1.LE.BM1)) THEN
+ RMS2=DRANEGS(dummy)
+ IF ((RMS2.EQ.0.0)) THEN
+ RMS2=1.d-30
+ END IF
+ THR=SQRT(MAX(0.d0,-LOG(RMS2)))
+C TAIL,F3
+ ELSE IF((RMS1.LE.BM2)) THEN
+ RMS3=DRANEGS(dummy)
+ RMS4=DRANEGS(dummy)
+ ETA=MAX(RMS3,RMS4)
+C NOW EVALUATE REJECTION FUNCTION, G3(ETA)
+ I31=B0G31+ETA*B1G31
+ G31=G310(I31)+ETA*(G311(I31)+ETA*G312(I31))
+ I32=B0G32+ETA*B1G32
+ G32=G320(I32)+ETA*(G321(I32)+ETA*G322(I32))
+ G3=G31+G32*BI
+ RMS5=DRANEGS(dummy)
+ IF((RMS5.GT.G3))GO TO1021
+ THR=1.d0/ETA
+C CENTRAL CORRECTION, F2
+ ELSE
+ RMS6=DRANEGS(dummy)
+ THR=RMS6
+C COMPUTE REJECTION FUNCTION, G2
+ I21=B0G21+THR*B1G21
+ G21=G210(I21)+THR*(G211(I21)+THR*G212(I21))
+ I22=B0G22+THR*B1G22
+ G22=G220(I22)+THR*(G221(I22)+THR*G222(I22))
+ G2=G21+G22*BI
+ RMS7=DRANEGS(dummy)
+ IF((RMS7.GT.G2))GO TO1021
+ END IF
+C THR IS NOW THE REDUCED ANGLE. NOW GET THE REAL ANGLE
+ THETA=THR*XR
+ IF((THETA.GE.PI))GO TO1021
+C TRY AGAIN IF ] 180 DEGREES
+ LTHETA=SINC1*THETA+SINC0
+ SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
+C THE ABOVE LINE SETS SINTHE=SIN(THETA)
+ RMS8=DRANEGS(dummy)
+ IF(((RMS8**2*THETA.LE.SINTHE)))GO TO1022
+ GO TO 1021
+1022 CONTINUE
+CBETHE CORRECTION FACTOR
+ CTHET=PI5D2-THETA
+ LCTHET=SINC1*CTHET+SINC0
+ COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
+CCOSTHE=COS(THETA)
+ RETURN
+CEND OF SUBROUTINE MSCATCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE PAIRCX
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C FOR A PHOTON ENERGY LESS THAN 2.1 MEV, THE APPROXIMATION IS
+C MADE THAT ONE PAIR ELECTRON (OR POSITRON) HAS ONLY ITS REST
+C MASS ENERGY. FOR PHOTON ENERGY BETWEEN 2.1 MEV AND 50 MEV THE
+C BETHE-HEITLER CROSS SECTION IS EMPLOYED. ABOVE 50 MEV THE
+C COULOMB CORRECTED BETHE-HEITLER CROSS SECTION IS USED.
+C (BUTCHER AND MESSEL, OP. CIT., P. 17-19, 22).
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIG,PESE1,PESE2
+ COMMON/BREMPR/ DL1(6,1),DL2(6,1),DL3(6,1),DL4(6,1),DL5(6,1),DL6(6,
+ *1), ALPHI(2,1),BPAR(2,1),DELPOS(2,1), ASYM(1,50,2), WA(1,50),PZ(1,
+ *50),ZELEM(1,50),RHOZ(1,50), PWR2I(100), DELCM(1),ZBRANG(1),FBRSPL,
+ * NNE(1),IBRDST,IPRDST,IBRSPL,NBRSPL
+ CHARACTER*4 ASYM
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BREMPR,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ PEIG=E(NP)
+CPRECISE ENERGY OF INCIDENT GAMMA
+CENERGY OF INCIDENT GAMMA
+ EIG=PEIG
+ IF ((EIG.LE.2.1)) THEN
+C BELOW 2.1,USE APPROXIMATION
+ ESE2=PRM
+C ENERGY OF SECONDARY 'ELECTRON' #2
+C ABOVE 2.1, MUST SAMPLE
+C DECIDE WHETHER TO USE BETHE-HEITLER(LVX=1,LVL=1,3) OR
+C COULOMB CORRECTED(LVX=2,LVL=4,6) CROSS SECTIONS.
+C SEE RELATED COMMENTS IN BREMS.
+ ELSE
+ IF (EIG.LT.50.) THEN
+ LVX=1
+ LVL0=0
+ ELSE
+ LVX=2
+ LVL0=3
+ END IF
+C AFB 91/05/29 added extra rejection criterion on the loop
+C to prevent negative energy electrons or positrons being
+C produced.
+C RETRY IF REJECTED BECAUSE DEL OUT OF RANGE, OR BY SCREENING
+1011 CONTINUE
+ RNNO30=DRANEGS(dummy)
+C WE'LL NEED AT LEAST ONE RANDOM NUMBER
+C NOW DECIDE WHICH OF THE TWO SUBDISTRIBUTIONS TO USE.
+C USE THE SUBDISTRIBUTION THAT IS
+ RNNO31=DRANEGS(dummy)
+ IF ((RNNO31.GE.BPAR(LVX,MEDIUM))) THEN
+C PROPORTIONAL TO 12*(BR-0.5)**2. IT USES A(DELTA) FOR
+C SCREENING FUNCTION.
+ LVL=LVL0+1
+C FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5)
+ RNNO32=DRANEGS(dummy)
+ RNNO33=DRANEGS(dummy)
+c BR=0.5d0*(1.d0-MAX(RNNO32,RNNO33,RNNO30))
+C MODIFIED BY D. HECK (JAN 10, 2002) TO GIVE BETTER CONTINUITY FOR
+C SMALL BR VALUES IN CONNECTION WITH RMMAR RANDOM GENERATOR
+ BR = 0.5D0 * MIN( RNNO32, RNNO33, RNNO30 )
+C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 1,
+ ELSE
+C I.E., UNIFORM. IT USES C(DELTA) FOR A SCREENING
+C REJECTION FUNCTION.
+ LVL=LVL0+3
+ BR=RNNO30*0.5d0
+ END IF
+C THE SCREENING FUNCTIONS ARE FUNCTIONS OF DELTA=DELCM*DEL,
+C WHERE DELCM= 136.0*EXP(ZG)*RM (SAME AS FOR BREMS)
+C AND WHERE DEL=1./(EG0*BR*(1.0-BR))
+C WITH EG0 = INCIDENT PHOTON ENERGY AND BR=ENERGY FRACTION.
+* IF((BR.EQ.0.d0))GO TO1011
+C CORRECTED 18.12.98
+ IF ( BR*PEIG .LT. PRM ) GOTO 1011
+C TO AVOID DIVISION BY ZERO
+C TRY
+ DEL=1.d0/(EIG*BR*(1.d0-BR))
+ IF((DEL.GE.DELPOS(LVX,MEDIUM)))GO TO1011
+C THE PRECEDING CONDITION ENSURES THAT A(DELTA) AND C(DELTA)
+C WILL BE POSITIVE. IF IT IS NOT SATISFIED,
+C LOOP BACK AND TRY ANOTHER SAMPLE.
+ DELTA=DELCM(MEDIUM)*DEL
+ IF ((DELTA.LT.1.d0)) THEN
+ REJF=DL1(LVL,MEDIUM)+DELTA*(DL2(LVL,MEDIUM)+DELTA*DL3(LVL,ME
+ * DIUM))
+ ELSE
+ REJF=DL4(LVL,MEDIUM)+DL5(LVL,MEDIUM)*LOG(DELTA+DL6(LVL,MEDI
+ * UM))
+ END IF
+ RNSCRN=DRANEGS(dummy)
+C RANDOM NUMBER FOR SCREENING REJECTION
+c IF((((RNSCRN.LE.REJF).AND.(BR.GE.(RM/EIG)))))GO TO1012
+C MODIFIED BY D. HECK (JAN 10, 2002) TO GIVE BETTER CONTINUITY FOR
+C SMALL BR VALUES IN CONNECTION WITH RMMAR RANDOM GENERATOR
+ IF ( RNSCRN .GT. REJF ) GOTO 1011
+* GO TO 1011
+*1012 CONTINUE
+C RETRY UNTIL ACCEPTED
+C BR=PRODUCT ENERGY FRACTION
+ ESE2=BR*EIG
+C ENERGY OF SECONDARY 'ELECTRON' #2
+ END IF
+CEND OF EIG.GT.2.1 ELSE
+C ENERGY GOING TO LOWER SECONDARY HAS NOW BEEN DETERMINED
+ PESE2=ESE2
+CPRECISE ENERGY OF SECONDARY 'ELECTRON' 2
+ PESE1=PEIG-PESE2
+CPRECISE ENERGY OF SECONDARY 'ELECTRON' 1
+ E(NP)=PESE1
+ E(NP+1)=PESE2
+C THIS AVERAGE ANGLE OF EMISSION FOR BOTH PAIR PRODUCTION AND
+C BREMSSTRAHLUNG IS MUCH SMALLER THAN THE AVERAGE ANGLE OF
+C MULTIPLE SCATTERING FOR DELTA T TRANSPORT=0.01 R.L.
+C THE INITIAL AND FINAL MOMENTA ARE COPLANAR
+C SET UP A NEW 'ELECTRON'
+c$$$ IF (((IPRDST.EQ.1).OR.((IPRDST.EQ.2).AND.(EIG.LT.4.14)))) THEN
+c$$$ DO 1021 ICHRG=1,2
+c$$$ IF ((ICHRG.EQ.1)) THEN
+c$$$ ESE=PESE1
+c$$$ ELSE
+c$$$ ESE=ESE2
+c$$$ END IF
+c$$$ PSE=SQRT(MAX(0.d0,(ESE-RM)*(ESE+RM)))
+c$$$ COSTHE=DRANEGS(dble(ICHRG))
+c$$$ COSTHE=MIN(1.d0,1.d0-2.d0*COSTHE)
+c$$$ SINTHE=RM*SQRT((1.d0-COSTHE)*(1.d0+COSTHE))/(PSE*COSTHE+ESE)
+c$$$ COSTHE=(ESE*COSTHE+PSE)/(PSE*COSTHE+ESE)
+c$$$ IF ((ICHRG.EQ.1)) THEN
+c$$$ CALL UPHICX(2,1)
+c$$$ ELSE
+c$$$ NP=NP+1
+c$$$ SINTHE=-SINTHE
+c$$$ CALL UPHICX(3,2)
+c$$$ END IF
+c$$$1021 CONTINUE
+c$$$1022 CONTINUE
+c$$$C jan 15 93 added this line DR
+c$$$ RNNO34=DRANEGS(dummy)
+c$$$ IF ((RNNO34.LE.0.5)) THEN
+c$$$ IQ(NP)=1
+c$$$ IQ(NP-1)=-1
+c$$$ ELSE
+c$$$ IQ(NP)=-1
+c$$$ IQ(NP-1)=1
+c$$$ END IF
+c$$$ RETURN
+c$$$ ELSE IF(((IPRDST.EQ.2).AND.(EIG.GE.4.14))) THEN
+c$$$C ZBRANG=( (1/111)*Zeff**(1/3) )**2
+c$$$ ZTARG=ZBRANG(MEDIUM)
+c$$$C TTEIG = TOTAL INITIAL PHOTON ENERGY IN ELECTRON REST MASS UNITS
+c$$$ TTEIG=EIG/RM
+c$$$ DO 1031 ICHRG=1,2
+c$$$ IF ((ICHRG.EQ.1)) THEN
+c$$$ ESE=PESE1
+c$$$ ELSE
+c$$$ ESE=ESE2
+c$$$ END IF
+c$$$C TTESE = TOTAL FINAL ELECTRON ENERGY IN ELECTRON REST MASS UNITS
+c$$$ TTESE=ESE/RM
+c$$$C TTPSE = TOTAL FINAL ELECTRON MOMENTUM IN ELECTRON REST MASS UNITS
+c$$$ TTPSE=SQRT((TTESE-1.d0)*(TTESE+1.d0))
+c$$$C THIS IS THE RATIO (r IN PIRS0287)
+c$$$ ESEDEI=TTESE/(TTEIG-TTESE)
+c$$$ ESEDER=1.d0/ESEDEI
+c$$$C DETERMINE THE NORMALIZATION
+c$$$ XIMIN=1.d0/(1.d0+(3.141593d0*TTESE)**2)
+c$$$ REJMIN = 2.d0+3.d0*(ESEDEI+ESEDER) - 4.d0*(ESEDEI+ESEDER+1.d0
+c$$$ * -4.d0*(XIMIN-0.5d0)**2)*( 1.d0+0.25d0*LOG( ((1.d0+ESEDER)
+c$$$ * *(1.d0+ESEDEI)/(2.d0*TTEIG))**2+ZTARG*XIMIN**2 ) )
+c$$$ YA=(2.d0/TTEIG)**2
+c$$$ XITRY=MAX(0.01d0,MAX(XIMIN,MIN(0.5d0,SQRT(YA/ZTARG))))
+c$$$ GALPHA=1.d0+0.25d0*LOG(YA+ZTARG*XITRY**2)
+c$$$ GBETA=0.5d0*ZTARG*XITRY/(YA+ZTARG*XITRY**2)
+c$$$ GALPHA=GALPHA-GBETA*(XITRY-0.5d0)
+c$$$ XIMID=GALPHA/(3.d0*GBETA)
+c$$$ IF ((GALPHA.GE.0.d0)) THEN
+c$$$ XIMID=0.5d0-XIMID+SQRT(XIMID**2+0.25d0)
+c$$$ ELSE
+c$$$ XIMID=0.5d0-XIMID-SQRT(XIMID**2+0.25d0)
+c$$$ END IF
+c$$$ XIMID=MAX(0.01d0,MAX(XIMIN,MIN(0.5d0,XIMID)))
+c$$$ REJMID = 2.d0+3.d0*(ESEDEI+ESEDER) - 4.d0*(ESEDEI+ESEDER+1.d0
+c$$$ * -4.d0*(XIMID-0.5d0)**2)*( 1.d0+0.25d0*LOG( ((1.d0+ESEDER)
+c$$$ * *(1.d0+ESEDEI)/(2.d0*TTEIG))**2+ZTARG*XIMID**2 ) )
+c$$$C ESTIMATE MAXIMUM OF THE REJECTION FUNCTION
+c$$$C FOR LATER USE BY THE REJECTION TECHNIQUE
+c$$$ REJTOP=1.02d0*MAX(REJMIN,REJMID)
+c$$$1041 CONTINUE
+c$$$ XITST=DRANEGS(dble(ICHRG))
+c$$$ REJTST = 2.d0+3.d0*(ESEDEI+ESEDER) - 4.d0*(ESEDEI+ESEDER
+c$$$ * +1.d0-4.d0*(XITST-0.5d0)**2)*(1.d0+0.25d0*LOG(((1.d0+ESEDER)
+c$$$ * *(1.d0+ESEDEI)/(2.d0*TTEIG))**2+ZTARG*XITST**2 ) )
+c$$$ RTEST=DRANEGS(dummy)
+c$$$C CONVERT THE SUCCESSFUL CANDIDATE XITST TO AN ANGLE
+c$$$ THETA=SQRT(1.d0/XITST-1.d0)/TTESE
+c$$$C LOOP UNTIL REJECTION TECHNIQUE ACCEPTS XITST
+c$$$ IF((((RTEST.LE.(REJTST/REJTOP)).AND.(THETA.LT.PI))))GO TO104
+c$$$ * 2
+c$$$ GO TO 1041
+c$$$1042 CONTINUE
+c$$$ SINTHE=SIN(THETA)
+c$$$ COSTHE=COS(THETA)
+c$$$ IF ((ICHRG.EQ.1)) THEN
+c$$$ CALL UPHICX(2,1)
+c$$$ ELSE
+c$$$ NP=NP+1
+c$$$ SINTHE=-SINTHE
+c$$$ CALL UPHICX(3,2)
+c$$$ END IF
+c$$$1031 CONTINUE
+c$$$1032 CONTINUE
+c$$$C jan 15 93 added this line DR
+c$$$ RNNO34=DRANEGS(dummy)
+c$$$ IF ((RNNO34.LE.0.5d0)) THEN
+c$$$ IQ(NP)=1
+c$$$ IQ(NP-1)=-1
+c$$$ ELSE
+c$$$ IQ(NP)=-1
+c$$$ IQ(NP-1)=1
+c$$$ END IF
+c$$$ RETURN
+c$$$ ELSE
+ THETA=RM/EIG
+c$$$ END IF
+C DEFAULT FOR $SET-PAIR-ANGLE; IS THETA=RM/EIG;
+ CALL UPHICX(1,1)
+C SET UP A NEW 'ELECTRON'
+ NP=NP+1
+ SINTHE=-SINTHE
+ CALL UPHICX(3,2)
+C NOW RANDOMLY DECIDED WHICH IS POSITRON, AND SET
+C CHARGES ACCORDINGLY
+ RNNO34=DRANEGS(dummy)
+ IF ((RNNO34.LE.0.5)) THEN
+ IQ(NP)=1
+ IQ(NP-1)=-1
+C POSITRON ON TOP
+ ELSE
+ IQ(NP)=-1
+ IQ(NP-1)=1
+C ELECTRON ON TOP
+ END IF
+ RETURN
+CEND OF SUBROUTINE PAIRCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE PHOTOCX
+C K-EDGE VERSION -- 27 JUL 1988/2300
+C******************************************************************
+C******* SPECIAL VERSION FOR TREATING K-EDGE FLUORESCENCE *********
+C******************************************************************
+C Programmers: W. R. Nelson and T. M. Jenkins (SLAC)
+C A.F. Bielajew (NRC) photoelectric angular distn
+C D.W.O. Rogers (NRC) document
+C******************************************************************
+C This is a special K-edge version of an EGS4 subroutine that is
+C patterned after a method developed in 1978 by A. Clark (LBL)
+C with the help of W. R. Nelson (SLAC). It requires subroutine
+C EDGSET (or equivalent for setting up the branching ratios and
+C fluorescent photon energies).
+C
+C This version adds selection of photo-electron angle
+C see 'Photoelectron angle selection in the EGS4 code system'
+C A.F. Bielajew and D.W.O. Rogers, NRC Report PIRS-0052,Oct 86
+C
+C This requires a redefinition of $COMIN-PHOTO which is done
+C in NRCC4MAC(P).MOR and definition of the macro
+C $SELECT-PHOTOELECTRON-DIRECTION (NRCC4MAC(P).MOR)
+C To select the A.D. in any region, one must set the variable
+C IPHTER(IR(NP))=1 passed in COMIN/USER;
+C
+C This version uses a simple model of K-shell fluorescence.
+C To sample fluorescent x-rays from the K-shell in a given region
+C the flag IEDGFL(IR(NP)) (in COMIN/EDGE) must be set non-zero
+C for each region; the value of IEDGFL is the value of Z used for
+C that region - the model must treat the region as a single
+C element for the selection of the fluorescent x-ray.
+C
+C The routine EDGSETCX(REGION1,REGION2) must be called for each
+C sequence of regions region1 to region2 for which the fluorescent
+C x-rays are to be sampled and IEDGFL is set.
+C
+C The relevant arrays are all zeroed at the end of EGS4BLOK so
+C that if the user initializes nothing, the code is the same as
+C the EGS4 default system - i.e. no fluorescent x-rays and no
+C photo-electron A.D.
+C
+C The output from this routine is complex.
+C E < BE => EDEP = E, IBLOBE=1
+C E > BE => IBLOBE=0
+C no K-shell with K-shell
+C ENEW = 0.0 ENEW = 0, or Kalpha
+C EDEP = BINDA EDEP = EBINDA - ENEW
+C E(NP) = EDEP E(NP) = EDEP
+C
+C IARG = 4 CALL MADE from this routine
+C ie energy discarded in middle
+C
+C THEN
+C E<BE E(NP) = 0 with IQ=0, no e- is set up IBLOBE = 1 still
+C E>BE IQ(NP) = -1, E(NP) = Einitial - EBINDA+RM
+C and if flags on for fluorescence and sampled, then
+C NP => NP + 1 and a gamma is set up
+C
+C
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIG
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/EDGE/EKALPH(1),EKBETA(1),BKR1(1),BKR2(1),IEDGFL(3)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+C==========
+C========================
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+C=============================
+ COMMON/USERSC/ SMAX,SMAXIR(3),ESTEPE,ESTEPR(3),ESAVE(3), NOMSCT(3)
+ *,NOPLC(3)
+C===============
+ COMMON/USERVR/ CEXPTR,GWAIT,IFORCE,NFMIN,NFMAX,NFTIME,ISOURC,IFPB,
+ *IQINC,MONOEN
+ COMMON/USERXT/IPHTER(3)
+Cthe next line is the default replacement for this
+C;COMIN/DEBUG,EDGE,EPCONT,MEDIA,PHOTIN,STACK,UPHIOT,USEFUL/;
+Cbut for the photo-electron angle selection, see definition in NRCC4MAC(
+CP)
+ PEIG=E(NP)
+ IF ((E(NP).LE.EBINDA(MEDIUM))) THEN
+ EDEP=PEIG
+ IBLOBE=1
+C BELOW K-EDGE
+C 'K-EDGE P.E. IS POSSIBLE' LOOP
+C 'FLUORESCENT OPTION ON' LOOP
+ ELSE
+ IF ((IEDGFL(IR(NP)) .NE. 0)) THEN
+C SAMPLE TO DECIDE K-EDGE PHOTON VERSUS EITHER
+C AUGER ELECTRON OR L-EDGE P.E. INTERACTION
+ BR=DRANEGS(dummy)
+ IF ((BR .GT. BKR1(MEDIUM))) THEN
+ ENEW=0.d0
+C K-EDGE PHOTON NOT SELECTED
+C 'K-EDGE PHOTON WAS SELECTED' LOOP
+C DETERMINE K-ALPHA OR K-BETA MODE NEXT
+ ELSE
+ IF ((BR .LE. BKR2(MEDIUM))) THEN
+ ENEW=EKALPH(MEDIUM)
+ ELSE
+ ENEW=EKBETA(MEDIUM)
+ END IF
+C END OF 'K-EDGE PHOTON WAS SELECTED' LOOP
+ END IF
+C END OF 'FLUORESCENT OPTION ON' LOOP
+ ELSE
+ ENEW=0.d0
+C FLUORESCENT OPTION OFF
+ END IF
+ EDEP=EBINDA(MEDIUM)-ENEW
+ E(NP)=EDEP
+ IBLOBE=0
+C FLAG INDICATING 'NOT' BELOW BINDING ENERGY
+C END OF 'K-EDGE P.E. IS POSSIBLE' LOOP
+ END IF
+ IARG=4
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+Cgenerates IARG = 4 call
+ IF ((IBLOBE .EQ. 1)) THEN
+ E(NP)=PZERO
+C BELOW K-EDGE FLAG IS ON
+C 'SET UP PARTICLE(S) LOOP
+ ELSE
+ IQ(NP)=-1
+C PHOTOELECTRON (ALWAYS SET UP)
+ E(NP)=PEIG-EBINDA(MEDIUM)+PRM
+C ================================
+ IF ((IPHTER(IR(NP)).EQ.1)) THEN
+ EELEC=E(NP)
+ IF ((EELEC.GT.ECUT(IR(NP)))) THEN
+ BETA=SQRT((EELEC-RM)*(EELEC+RM))/EELEC
+ GAMMA=EELEC/RM
+ ALPHA=0.5d0*GAMMA-0.5d0+1.d0/GAMMA
+ RATIO=BETA/ALPHA
+1011 CONTINUE
+ RNPHT=DRANEGS(dummy)
+ RNPHT=2.d0*RNPHT-1.d0
+ IF ((RATIO.LE.0.2d0)) THEN
+ FKAPPA=RNPHT+0.5d0*RATIO*(1.d0-RNPHT)*(1.d0+RNPHT)
+ COSTHE=(BETA+FKAPPA)/(1.d0+BETA*FKAPPA)
+ XI=1.d0/(1.d0-BETA*COSTHE)
+ ELSE
+ XI=GAMMA*GAMMA*(1.d0+ALPHA*(SQRT(1.d0+RATIO*(2.d0*RNPHT
+ * +RATIO))-1.d0))
+ COSTHE=(1.d0-1.d0/XI)/BETA
+ END IF
+ SINTH2=MAX(0.d0,(1.d0-COSTHE)*(1.d0+COSTHE))
+ RNPHT2=DRANEGS(dummy)
+ IF(RNPHT2.LE.0.5d0*(1.d0+GAMMA)*SINTH2*XI/GAMMA)GO TO1012
+ GO TO 1011
+1012 CONTINUE
+ SINTHE=SQRT(SINTH2)
+ CALL UPHICX(2,1)
+ END IF
+C defined in NRCC4MAC(P).MOR
+ END IF
+C SET UP FLUORESCENT PHOTON
+ IF ((IEDGFL(IR(NP)) .NE. 0)) THEN
+ IF ((BR .GT. BKR1(MEDIUM))) THEN
+ RETURN
+C HOWEVER, K-EDGE NOT CHOSEN ABOVE
+ END IF
+ NP=NP+1
+ E(NP)=ENEW
+ IQ(NP)=0
+C PHOTON COMES OFF ISOTROPICALLY
+ RNISO=DRANEGS(dummy)
+ COSTHE=2.d0*RNISO-1.d0
+ SINTHE=SQRT(MAX(0.d0,1.d0-COSTHE*COSTHE))
+ U(NP)=0.d0
+ V(NP)=0.d0
+ W(NP)=1.d0
+C MAKES THINGS EASIER IN UPHI
+ CALL UPHICX(2,1)
+ X(NP)=X(NP-1)
+ Y(NP)=Y(NP-1)
+ Z(NP)=Z(NP-1)
+ IR(NP)=IR(NP-1)
+ XM(NP)=XM(NP-1)
+ YM(NP)=YM(NP-1)
+ ZM(NP)=ZM(NP-1)
+ DM(NP)=DM(NP-1)
+ TM(NP)=TM(NP-1)
+ WT(NP)=WT(NP-1)
+ DNEAR(NP)=DNEAR(NP-1)
+ LATCH(NP)=LATCH(NP-1)+1
+C END OF FLUORESCENT PHOTON SET UP
+ END IF
+C END OF 'SET UP PARTICLE(S)' LOOP
+ END IF
+ RETURN
+CEND OF SUBROUTINE PHOTOCX
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+cC******************************************************************
+cC STANFORD LINEAR ACCELERATOR CENTER
+c SUBROUTINE EDGSETCX(NREGLO,NREGHI)
+cC K-EDGE VERSION -- 27 JUL 1988/2400
+cC******************************************************************
+cC SUBPROGRAM TO SET UP PARAMETERS FOR K-FLUORESCENCE TRANSPORT
+cC IN ELEMENTS WITH Z=1 THROUGH 100
+cC******************************************************************
+cC Programmers: W. R. Nelson and T. M. Jenkins (SLAC)
+cC W. S. Lockman (U. C. Santa Cruz)
+cC Keith Weaver (UCSF) made all elements available
+cC D.W.O.Rogers (NRC) removed IVALID check, made for
+cC a sequence of regions plus cosmetics
+cC******************************************************************
+cC
+cC This routine must be called after HATCHCX, after IEDGFL has been
+cC filled and before the first call to SHOWER
+cC
+cC The flag IEDGFL(IR) contains the atomic number of the medium for
+cC each region (IR), or it contains zero in order to disable K-edge
+cC fluorescence for that region. The cross sections and energies
+cC are from: E. Storm and H. I. Israel, At. Data and Nucl. Data
+cC Tables 7 (1970) 565.
+cC K-edge fluorescent yields are from: Lederer et al, Table of the
+cC Isotopes (6th Edition).
+cC******************************************************************
+cC
+c implicit double precision (a-h,o-z)
+c COMMON/EDGE/EKALPH(1),EKBETA(1),BKR1(1),BKR2(1),IEDGFL(3)
+c COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+c *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+c COMMON/MEDIAC/MEDIA(24,1)
+c CHARACTER*4 MEDIA
+c COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+c *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+c *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+c *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+c *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+c COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+c DIMENSION EALF(100),EBET(100),OMEG(100),PHOTOK(100),PKA(100)
+cC
+cC------------------------------------------------------------------
+cCAverage photon energies (EALF) (L -> K electron transitions).
+cC (Table 5 of Storm and Israel)
+cC------------------------------------------------------------------
+c DATA EALF/0. , 0. , 0.054, 0.109, 0.184, 0.297, 0.393, 0.524, 0.67
+c *5, 0.849, 1.041, 1.255, 1.487, 1.739, 2.014, 2.307, 2.622, 2.957,
+c *3.312, 3.690, 4.088, 4.508, 4.949, 5.411, 5.895, 6.400, 6.925, 7.4
+c *72, 8.041, 8.631, 9.243, 9.876, 10.532,11.210,11.907,12.630,13.375
+c *,14.142,14.933,15.746, 16.584,17.443,18.327,19.235,20.167,21.122,2
+c *2.103,23.108, 24.138,25.192,26.272,27.378,28.510,29.667,30.851,32.
+c *062, 33.297,34.564,35.858,37.179,38.528,39.906,41.313,42.750, 44.2
+c *18,45.714,47.242,48.801,50.392,52.104,53.670,55.356, 57.078,58.832
+c *,60.620,62.443,64.303,66.200,68.133,70.103, 72.113,74.161,76.246,7
+c *8.378,80.547,82.757,85.018,87.321, 89.662,92.050,94.491,96.977,99.
+c *516,102.10,104.74,107.44, 110.20,113.03,115.93,118.89/
+cC------------------------------------------------------------------
+cCAverage photon energies (EBET) (M -> K electron transitions).
+cC (Table 5 of Storm and Israel)
+cC------------------------------------------------------------------
+c DATA EBET/0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0
+c *. , 0. , 1.838, 2.142, 2.468, 2.817, 3.191, 3.589, 4.012, 4.459, 4
+c *.931, 5.427, 5.947, 6.492, 7.059, 7.649, 8.265, 8.907, 9.572,10.26
+c *3,10.983, 11.730,12.503,13.300,14.126,14.980,15.859,16.767,17.700,
+c * 18.661,19.648,20.785,21.705,22.778,23.878,25.008,26.166, 27.354,2
+c *8.573,29.821,31.103,32.414,33.757,35.131,36.535, 37.966,39.431,40.
+c *930,42.460,44.024,45.622,47.253,48.918, 50.618,52.352,54.123,55.93
+c *0,57.772,59.652,61.572,63.531, 65.529,67.564,69.642,71.759,73.919,
+c *76.121,78.367,80.656, 82.991,85.370,87.796,90.273,92.794,95.365,97
+c *.989,100.66, 103.39,106.17,109.01,111.90,114.85,117.86,120.93,124.
+c *08, 127.29,130.58,133.96,137.41/
+cC------------------------------------------------------------------
+cCFluorescent yields (OMEG) (probability to get fluorescent photon
+cC per K-shell vacancy. (Table 10 of Lederer et al)
+cC------------------------------------------------------------------
+c DATA OMEG/0. ,0. ,0. ,0. ,0. ,0. ,0. ,0. , 0. ,0. ,0. ,0. ,0.0357,
+c *0.0470,0.0604,0.0761, 0.0942,0.115 ,0.138 ,0.163 ,0.190 ,0.219 ,0.
+c *250 ,0.282 , 0.314 ,0.347 ,0.381 ,0.414 ,0.445 ,0.479 ,0.510 ,0.54
+c *0 , 0.567 ,0.596 ,0.622 ,0.646 ,0.669 ,0.691 ,0.711 ,0.730 , 0.748
+c * ,0.764 ,0.779 ,0.793 ,0.807 ,0.819 ,0.830 ,0.840 , 0.850 ,0.859 ,
+c *0.867 ,0.875 ,0.882 ,0.889 ,0.895 ,0.901 , 0.906 ,0.911 ,0.915 ,0.
+c *920 ,0.924 ,0.928 ,0.931 ,0.934 , 0.937 ,0.940 ,0.943 ,0.945 ,0.94
+c *8 ,0.950 ,0.952 ,0.954 , 0.956 ,0.957 ,0.959 ,0.961 ,0.962 ,0.963
+c *,0.964 ,0.966 , 0.967 ,0.968 ,0.969 ,0.970 ,0.971 ,0.972 ,0.972 ,0
+c *.973 , 0.974 ,0.975 ,0.975 ,0.976 ,0.977 ,0.977 ,0.978 ,0.978 , 0.
+c *979 ,0.979 ,0.980 ,0.980 /
+cC------------------------------------------------------------------
+cCProbability for the removal of a K-electron by PE effect (PHOTOK)
+cC =(K-shell PE cross section)/(total PE cross section).
+cC (Table 8 of Storm and Israel)
+cC------------------------------------------------------------------
+c DATA PHOTOK/1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 0.92
+c *8, 0.922, 0.916, 0.911, 0.907, 0.903, 0.900, 0.896, 0.893, 0.890,
+c *0.888, 0.885, 0.883, 0.880, 0.878, 0.876, 0.874, 0.872, 0.871, 0.8
+c *70, 0.869, 0.868, 0.866, 0.865, 0.863, 0.861, 0.860, 0.858, 0.856,
+c * 0.855, 0.853, 0.852, 0.850, 0.848, 0.846, 0.845, 0.843, 0.841, 0.
+c *840, 0.839, 0.838, 0.836, 0.835, 0.833, 0.832, 0.830, 0.829, 0.827
+c *, 0.825, 0.824, 0.823, 0.821, 0.819, 0.818, 0.816, 0.815, 0.814, 0
+c *.813, 0.812, 0.811, 0.809, 0.807, 0.805, 0.803, 0.802, 0.800, 0.79
+c *8, 0.796, 0.794, 0.792, 0.790, 0.788, 0.786, 0.784, 0.782, 0.780,
+c *0.778, 0.776, 0.774, 0.772, 0.770, 0.767, 0.765, 0.762, 0.759, 0.7
+c *56, 0.754, 0.751, 0.749, 0.746/
+cC------------------------------------------------------------------
+cCRelative probability of a K-alpha photon emission (PKA)
+cC =(K-alpha intensity)/(K-alpha intensity + K-beta intensity).
+cC (Table 6 of Storm and Israel)
+cC------------------------------------------------------------------
+c DATA PKA/1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1. , 1.
+c * , 1. , 1. , 1. , 0.955, 0.940, 0.924, 0.914, 0.904, 0.901, 0.898,
+c * 0.897, 0.895, 0.894, 0.893, 0.8925,0.892, 0.891, 0.890, 0.887, 0.
+c *884, 0.879, 0.875, 0.870, 0.866, 0.862, 0.859, 0.855, 0.852, 0.849
+c *, 0.847, 0.844, 0.842, 0.840, 0.838, 0.835, 0.833, 0.831, 0.829, 0
+c *.826, 0.824, 0.821, 0.819, 0.817, 0.815, 0.813, 0.812, 0.811, 0.81
+c *0, 0.809, 0.808, 0.807, 0.806, 0.805, 0.804, 0.803, 0.802, 0.801,
+c *0.800, 0.799, 0.798, 0.797, 0.795, 0.794, 0.794, 0.793, 0.792, 0.7
+c *91, 0.790, 0.789, 0.788, 0.787, 0.786, 0.785, 0.784, 0.783, 0.782,
+c * 0.781, 0.781, 0.780, 0.779, 0.778, 0.778, 0.777, 0.776, 0.775, 0.
+c *774, 0.773, 0.773/
+cC------------------------------------------------------------------
+cC The following are in COMMON/EDGE/ (see macro definition):
+cC------------------------------------------------------------------
+cC EKALPH is the energy of the K-alpha X-ray.
+cC EKBETA is the energy of the K-beta X-ray.
+cC BKR1 is the probability for a K-shell emission times the
+cC probability for a fluorescent photon emission due to an
+cC electron transition from the X -> K shell.
+cC BKR2 is BKR1 times the probability that the fluorescent photon
+cC is due to an electron transition from the L -> K shell.
+cC------------------------------------------------------------------
+cC EBINDA is the energy of the K-edge (in COMMON/PHOTIN/).
+cC------------------------------------------------------------------
+c WRITE(6,1010)
+c1010 FORMAT(' OUTPUT FROM SUBROUTINE EDGSET:'/ ' REGION MEDIUM Zeff N
+c *AME ', ' K-EDGE EKALPH EKBETA BK
+c *R1 BKR2'/)
+c DO 1021 JJ=NREGLO,NREGHI
+c IZ=IEDGFL(JJ)
+c IMED=MED(JJ)
+c IF (IMED.GT.0.) THEN
+c IF ((IZ.GT.0 .AND. IZ.LE.100)) THEN
+c BKR1(IMED)=OMEG(IZ)*PHOTOK(IZ)
+c BKR2(IMED)=BKR1(IMED)*PKA(IZ)
+c EKALPH(IMED)=EALF(IZ)*1.d-3
+c EKBETA(IMED)=EBET(IZ)*1.d-3
+c WRITE(6,1030)JJ,IMED,IZ,(MEDIA(I,IMED),I=1,24),EBINDA(IMED),
+c * EKALPH(IMED), EKBETA(IMED),BKR1(IMED),BKR2(IMED)
+c1030 FORMAT(3(1X,I6),1X,24A1,1X,1P5E10.2)
+c ELSE
+c WRITE(6,1040)JJ,IMED,IZ,(MEDIA(I,IMED),I=1,24)
+c1040 FORMAT(3(1X,I6),1X,24A1,' -- K-EDGE FLUORESCENCE OPTION NOT
+c *ENABLED', ' FOR THIS REGION --')
+c END IF
+c ELSE
+c WRITE(6,1050)JJ,IMED
+c1050 FORMAT(2(1X,I6),' VACUUM')
+c END IF
+c1021 CONTINUE
+c1022 CONTINUE
+c RETURN
+cCEND OF SUBROUTINE EDGSET
+c END
+cCEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE PHOTONCX(IRCODE)
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ DOUBLE PRECISION PEIG
+ COMMON/BOUNDS/ECUT(3),PCUT(3),VACDST
+ COMMON/MEDIA/ RLC(1),RLDU(1),RHO(1),MSGE(1),MGE(1),MSEKE(1),MEKE(1
+ *),MLEKE(1),MCMFP(1),MRANGE(1),IRAYLM(1),NMED
+ COMMON/MEDIAC/MEDIA(24,1)
+ CHARACTER*4 MEDIA
+ COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(3),RHOR(3),IRAYLR(3)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/PHOTIN/ EBINDA(1), GE0(1),GE1(1), GMFP0(1000,1)
+ *,GBR10(1000,1),GBR11(1000,1),GBR20(1000,1),GBR21(1000,1)
+ *,GBR30(1000,1),GBR31(1000,1),GBR40(1000,1),GBR41(1000,1), RCO0(1)
+ *, RSCT0(100,1),RSCT1(100,1), COHE0(1000,1),COHE1(1000,1)
+ *,GMFP1(1000,1),RCO1(1), MPGEM(1,1), NGR(1)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/THRESH/RMT2,RMSQ,ESCD2,AP(1),AE(1),UP(1),UE(1),TE(1),THMOLL
+ *(1)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+C==========
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+C==========
+ logical lxfirst,lxfirstIn
+ common/cxoutput4/Xfirst,XfirstIn,lxfirst,lxfirstIn !also in conex.h
+ double precision eecut,epcut,ehcut,emcut
+ common /cxcut/ eecut,epcut,ehcut,emcut !cutoff el,phot,had,mu also in conex.h
+C========================
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+C=============================
+ COMMON/USERSC/ SMAX,SMAXIR(3),ESTEPE,ESTEPR(3),ESAVE(3), NOMSCT(3)
+ *,NOPLC(3)
+C===============
+ COMMON/USERVR/ CEXPTR,GWAIT,IFORCE,NFMIN,NFMAX,NFTIME,ISOURC,IFPB,
+ *IQINC,MONOEN
+ COMMON/USERXT/IPHTER(3)
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BOUNDS,MEDIA,MISC,EPCONT,PHOTIN,STACK,THRESH,
+C UPHIOT,USEFUL,USER,RANDOM/;
+ IRCODE=1
+CSET UP NORMAL RETURN
+ PEIG=E(NP)
+ EIG=PEIG
+CENERGY OF INCIDENT GAMMA
+ IRL=IR(NP)
+ MEDIUM=MED(IRL)
+ IF ((EIG.LE.PCUT(IRL))) THEN
+ GO TO 1010
+ END IF
+CENTER THIS LOOP FOR EACH PHOTON WITH NEW ENERGY
+1020 CONTINUE
+1021 CONTINUE
+ GLE=LOG(EIG)
+C GLE IS GAMMA LOG ENERGY
+C HERE TO SAMPLE NO. MFP TO TRANSPORT BEFORE INTERACTING
+C =========================
+C THIS DOES AN EXPONENTIAL TRANSFORMATION OF THE PHOTON
+C PATHLENGTH FOR FORWARD GOING PHOTONS ONLY
+ RNNO35=DRANEGS(dummy)
+ IF ((RNNO35 .EQ. 0.d0)) THEN
+ RNNO35=1.d-30
+ END IF
+ DPMFP=-LOG(RNNO35)
+ IF ((CEXPTR.NE.0.d0)) THEN !TP : not used
+ IF ((W(NP).GT.0.d0)) THEN
+ TEMP=CEXPTR*W(NP)
+ BEXPTR=1.d0/(1.d0-TEMP)
+ DPMFP=DPMFP*BEXPTR
+ WT(NP)=WT(NP)*BEXPTR*EXP(-DPMFP*TEMP)
+ END IF
+ END IF
+C DEFAULT FOR $SELECT-PHOTON-MFP; IS: $RANDOMSET RNNO35;
+C DPMFP=-LOG(RNNO35);
+C NOTE: THIS TEMPLATE CAN ALSO BE OVER-RIDDEN BY OTHER SCHEMES,
+C SUCH AS THE 'EXPONENTIAL TRANSFORM' TECHNIQUE.
+C INITIALIZE PREVIOUS REGION
+C HERE EACH TIME WE CHANGE MEDIUM DURING PHOTON TRANSPORT
+ IROLD=IR(NP)
+c1030 CONTINUE
+1031 CONTINUE
+ IF ((MEDIUM.NE.0)) THEN
+ LGLE=GE1(MEDIUM)*GLE+GE0(MEDIUM)
+C SET PWLF INTERVAL
+ GMFPR0=GMFP1(LGLE,MEDIUM)*GLE+GMFP0(LGLE,MEDIUM)
+ END IF
+C PHOTON TRANSPORT LOOP
+c1040 CONTINUE
+1041 CONTINUE
+ IF ((MEDIUM.EQ.0)) THEN
+ TSTEP=VACDST
+ ELSE
+ RHOF=RHOR(IRL)/RHO(MEDIUM)
+C DENSITY RATIO SCALING TEMPLATE
+ GMFP=GMFPR0/RHOF
+ IF ((IRAYLR(IRL).EQ.1)) THEN
+ COHFAC=COHE1(LGLE,MEDIUM)*GLE+COHE0(LGLE,MEDIUM)
+ GMFP=GMFP*COHFAC
+ END IF
+C A RAYLEIGH SCATTERING TEMPLATE
+ TSTEP=GMFP*DPMFP
+ END IF
+C SET DEFAULT VALUES FOR FLAGS SENT BACK FROM USER
+ IRNEW=IR(NP)
+C SET DEFAULT NEW REGION NUMBER
+ IDISC=0
+C ASSUME PHOTON NOT DISCARDED
+ USTEP=TSTEP
+C TRANSFER TRANSPORT DISTANCE TO USER VARIABLE
+ TUSTEP=USTEP
+ IF ((USTEP.GT.DNEAR(NP))) THEN
+ CALL HOWFARCX
+ END IF
+C NOW CHECK FOR USER DISCARD REQUEST
+C USER REQUESTED IMMEDIATE DISCARD
+ IF ((IDISC.GT.0)) THEN
+ GO TO 1050
+ END IF
+ VSTEP=USTEP
+C SET VARIABLE FOR OUTPUT CODE
+ TVSTEP=VSTEP
+ EDEP=PZERO
+C NO ENERGY DEPOSITION ON PHOTON TRANSPORT
+ IARG=0
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C TRANSPORT THE PHOTON
+c Z(NP)=Z(NP)+W(NP)*USTEP !in AUSGAB tp18.02.05
+C DEDUCT FROM DISTANCE TO NEAREST BOUNDARY
+ DNEAR(NP)=DNEAR(NP)-USTEP
+ IF ((MEDIUM.NE.0)) THEN
+ DPMFP=MAX(0.d0,DPMFP-USTEP/GMFP)
+ END IF
+C DEDUCT MFP'S
+ IROLD=IR(NP)
+C SAVE PREVIOUS REGION
+C REGION CHANGE
+ MEDOLD=MEDIUM
+ IF ((IRNEW.NE.IROLD)) THEN
+ IR(NP)=IRNEW
+ IRL=IRNEW
+ MEDIUM=MED(IRL)
+ END IF
+C AFTER TRANSPORT CALL TO USER
+ IARG=5
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C oct 31 bug found by C Ma. PCUT discard now after AUSGAB call
+ IF ((EIG.LE.PCUT(IRL))) THEN
+ GO TO 1010
+ END IF
+C NOW CHECK FOR DEFERRED DISCARD REQUEST. MAY HAVE BEEN SET
+C BY EITHER HOWFARCX, OR ONE OF THE TRANSPORT AUSGAB CALLS
+ IF((IDISC.LT.0))GO TO 1050
+C TIME FOR AN INTERACTION
+ IF((MEDIUM.NE.MEDOLD))GO TO 1042
+ IF ((MEDIUM.NE.0.AND.DPMFP.LE.1.E-6)) THEN
+ GO TO 1032
+ END IF
+ GO TO 1041
+1042 CONTINUE
+C :PTRANS: LOOP
+ GO TO 1031
+1032 CONTINUE
+C :PNEWMEDIUM: LOOP
+ if(.not.lxfirst)then !first interaction
+ Xfirst=Z(NP)
+ XfirstIn=1d0
+ lxfirst=.true.
+ CALL CONEXPRM(Xfirst)
+ endif
+C IT IS FINALLY TIME TO INTERACT.
+C THE FOLLOWING MACRO ALLOWS ONE TO INTRODUCE RAYLEIGH SCATTERING
+ IF ((IRAYLR(IRL).EQ.1)) THEN
+ RNNO37=DRANEGS(dummy)
+ IF ((RNNO37.LE.(1.d0-COHFAC))) THEN
+ IARG=23
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+1060 CONTINUE
+1061 CONTINUE
+ XXX=DRANEGS(dummy)
+ LXXX=RCO1(MEDIUM)*XXX+RCO0(MEDIUM)
+ X2=RSCT1(LXXX,MEDIUM)*XXX+RSCT0(LXXX,MEDIUM)
+ Q2=X2*RMSQ/(20.60744d0*20.60744d0)
+ COSTHE=1.d0-Q2/(2.d0*E(NP)*E(NP))
+ IF((ABS(COSTHE).GT.1.d0))GO TO 1060
+ CSQTHE=COSTHE*COSTHE
+ REJF=(1.d0+CSQTHE)/2.d0
+ RNNORJ=DRANEGS(dummy)
+ IF((RNNORJ.LE.REJF))GO TO1062
+ GO TO 1061
+1062 CONTINUE
+ SINTHE=SQRT(1.d0-CSQTHE)
+ CALL UPHICX(2,1)
+ IARG=24
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ GOTO 1020
+ END IF
+ END IF
+
+ RNNO36=DRANEGS(dummy)
+C THIS RANDOM NUMBER DETERMINES WHICH INTERACTION
+C GBR4=1-PAIR/(PAIR+COMPTON+PHOTO+mupp+photonuc)=1-PAIR/GTOTAL
+C IT WAS A PAIR PRODUCTION
+
+
+ GBR4=GBR41(LGLE,MEDIUM)*GLE+GBR40(LGLE,MEDIUM)
+ IF (((RNNO36.GE.GBR4).AND.(E(NP).GT.RMT2) )) THEN
+ IARG=15
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL PAIRCX
+C THE FOLLOWING MACRO ALLOWS THE USER TO CHANGE THE PARTICLE
+C SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING (SPLITTING,
+C LEADING PARTICLE SELECTION, ETC.)).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-PHOTON'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IARG=16
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+
+ CALL AUSGABCX(IARG)
+ END IF
+ GO TO 1022
+ END IF
+C GBR3=1-(PAIR+COMPTON)/GTOTAL
+C IT WAS A COMPTON
+ GBR3=GBR31(LGLE,MEDIUM)*GLE+GBR30(LGLE,MEDIUM)
+ IF ((RNNO36.GE.GBR3)) THEN
+ IARG=17
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL COMPTCX
+C THE FOLLOWING MACRO ALLOWS THE USER TO CHANGE THE PARTICLE
+C SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING (SPLITTING,
+C LEADING PARTICLE SELECTION, ETC.)).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-PHOTON'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+C ==========================
+ IF ((IQ(NP).EQ.0 .AND. E(NP-1).LT.ECUT(IR(NP-1)))) THEN
+ IQ(NP)=IQ(NP-1)
+ IQ(NP-1)=0
+ T=E(NP)
+ E(NP)=E(NP-1)
+ E(NP-1)=T
+ T=U(NP)
+ U(NP)=U(NP-1)
+ U(NP-1)=T
+ T=V(NP)
+ V(NP)=V(NP-1)
+ V(NP-1)=T
+ T=W(NP)
+ W(NP)=W(NP-1)
+ W(NP-1)=T
+ END IF
+ IARG=18
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+C NOT PHOTON
+ IF((IQ(NP).NE.0))GO TO 1022
+ GO TO 1100
+ ENDIF
+
+C GBR1=(MU+MU-)/GTOTAL
+ GBR1 = GBR11(LGLE,MEDIUM)*GLE+GBR10(LGLE,MEDIUM)
+C INCREASE MU-PAIR PRODUCTION THRESHOLD BY MUON CUT ENERGY
+C TO PREVENT HANGUP IN SUBR. MUPAIR
+ IF(RNNO36.LE.GBR1.AND.E(NP).GT.2.d0*RMMUT2+emcut*1.D3)THEN
+C MU+MU- PAIR FORMATION
+ IARG=25
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL CXMUPAIR
+C THE FOLLOWING MACRO ALLOWS THE USER TO CHANGE THE PARTICLE
+C SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING (SPLITTING,
+C LEADING PARTICLE SELECTION, ETC.)).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-PHOTON'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IARG=26
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ GO TO 1022
+ ENDIF
+
+C GBR2=PHOTONUC/GTOTAL
+ GBR2 = GBR21(LGLE,MEDIUM)*GLE+GBR20(LGLE,MEDIUM)
+ IF ( RNNO36 .LE. GBR2 .AND. E(NP) .GT. PITHR ) THEN
+C PHOTONUCLEAR REACTION
+ IARG=27
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL CXPIGEN
+ IARG=28
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ GO TO 1022
+C IT WAS PHOTOELECTRIC EFFECT
+ ELSE
+ IARG=19
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ CALL PHOTOCX
+C THE FOLLOWING MACRO ALLOWS THE USER TO CHANGE THE PARTICLE
+C SELECTION SCHEME (E.G., ADDING IMPORTANCE SAMPLING (SPLITTING,
+C LEADING PARTICLE SELECTION, ETC.)).
+C (DEFAULT MACRO IS TEMPLATE '$PARTICLE-SELECTION-PHOTON'
+C WHICH IN TURN HAS THE 'NULL' REPLACEMENT ';')
+ IF ((NP.EQ.0)) THEN
+ IRCODE=2
+ RETURN
+ END IF
+C FOR SPECIAL PHOTO SUBPROGRAM
+C WHERE STACK BECOMES EMPTY (I.E.,
+C FOR FOLLOWING FLUORESCENT PHOTONS)
+ IARG=20
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ IF((IQ(NP).EQ.-1))GO TO 1022
+ END IF
+C END OF PHOTO ELECTRIC BLOCK
+C IF HERE, THEN GAMMA IS LOWEST ENERGY PARTICLE.
+1100 PEIG=E(NP)
+ EIG=PEIG
+ IF((EIG.LT.PCUT(IRL)))GO TO 1010
+ GO TO 1021
+1022 CONTINUE
+C:PNEWENERGY: LOOP
+C IF HERE, MEANS ELECTRON TO BE TRANSPORTED NEXT
+ RETURN
+C---------------------------------------------
+CPHOTON CUTOFF ENERGY DISCARD SECTION
+C---------------------------------------------
+1010 IF ((EIG.GT.AP(MEDIUM))) THEN
+ IDR=1
+ ELSE
+ IDR=2
+ END IF
+ EDEP=PEIG
+CGET ENERGY DEPOSITION FOR USER
+ IARG=IDR
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ IRCODE=2
+ NP=NP-1
+C---------------------------------------------
+CUSER REQUESTED PHOTON DISCARD SECTION
+C---------------------------------------------
+ RETURN
+1050 EDEP=PEIG
+ IARG=3
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ IRCODE=2
+ NP=NP-1
+ RETURN
+CEND OF SUBROUTINE PHOTON
+ END
+CEGS4.MOR RECEIVED VIA BITNET JAN 29 AT NRCC +MINOR CHANGES
+C******************************************************************
+C STANFORD LINEAR ACCELERATOR CENTER
+ SUBROUTINE UPHICX(IENTRY,LVL)
+C VERSION 4.00 -- 26 JAN 1986/1900
+C******************************************************************
+C UPHI STANDS FOR 'UNIFORM PHI DISTRIBUTION'.
+C SET COORDINATES FOR NEW PARTICLE OR RESET DIRECTION COSINES OF
+C OLD ONE. GENERATE RANDOM AZIMUTH SELECTION AND REPLACE THE
+C DIRECTION COSINES WITH THEIR NEW VALUES.
+C ALL FRAMES ARE LEFT-HANDED.
+C******************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT, IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100)
+ *,DNEAR(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/UPHIIN/SINC0,SINC1,SIN0(1002),SIN1(1002)
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+ SAVE a,b,c
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,EPCONT,STACK,UPHIIN,UPHIOT,RANDOM/;
+ IARG=21
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ GO TO (1010,1020,1030),IENTRY
+C IENTRY OUT-OF-BOUNDS IF HERE
+ GO TO 1040
+1010 CONTINUE
+CNOTE: AFB 88/12/12 ADDED SEMI-COLON, ELSE BUG WHEN OVERRIDING SIN
+CTABLE LOOK-UP
+ if(i1DEM.eq.0)then
+ LTHETA=SINC1*THETA+SINC0
+ SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
+ CTHET=PI5D2-THETA
+ LCTHET=SINC1*CTHET+SINC0
+C USE THE FOLLOWING ENTRY IF SINTHE AND COSTHE ARE ALREADY KNOWN.
+C SELECT PHI UNIFORMLY OVER THE INTERVAL (0,TWO PI). THEN USE
+C PWLF OF SIN FUNCTION TO GET SIN(PHI) AND COS(PHI). THE COSINE
+C IS GOTTEN BY COS(PHI)=SIN(9*PI/4 - PHI).
+ COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
+ else
+ SINTHE=0.d0
+ COSTHE=1.d0
+ endif
+1020 RNNO38=DRANEGS(dummy)
+ PHI=RNNO38*TWOPI
+ LPHI=SINC1*PHI+SINC0
+ SINPHI=SIN1(LPHI)*PHI+SIN0(LPHI)
+ CPHI=PI5D2-PHI
+ LCPHI=SINC1*CPHI+SINC0
+C USE THE FOLLOWING ENTRY FOR THE SECOND OF TWO PARTICLES WHEN WE
+C KNOW TWO PARTICLES HAVE A RELATIONSHIP IN THEIR CORRECTIONS.
+C NOTE: SINTHE AND COSTHE CAN BE CHANGED OUTSIDE THROUGH COMMON.
+C LVL IS A PARAMETER TELLING WHICH PARTICLES TO WORK WITH.
+C THETA (SINTHE AND COSTHE) ARE ALWAYS RELATIVE TO THE DIRECTION
+C OF THE INCIDENT PARTICLE BEFORE ITS DIRECTION WAS ADJUSTED.
+C THUS WHEN TWO PARTICLES NEED TO HAVE THEIR DIRECTIONS COMPUTED,
+C THE ORIGINAL INCIDENT DIRECTION IS SAVED IN THE VARIABLE A,B,C
+C SO THAT IT CAN BE USED ON BOTH CALLS.
+C LVL=1 -- OLD PARTICLE, SAVE ITS DIRECTION AND ADJUST IT
+C LVL=2 -- NEW PARTICLE. ADJUST DIRECTION USING SAVED A,B,C
+C LVL=3 -- BREMSSTRAHLUNG GAMMA. SAVE ELECTRON DIRECTION (NEXT
+C TO TOP OF STACK), AND THEN ADJUST GAMMA DIRECTION.
+ COSPHI=SIN1(LCPHI)*CPHI+SIN0(LCPHI)
+1030 GO TO (1050,1060,1070),LVL
+C LVL OUT-OF-BOUNDS IF HERE
+ GO TO 1040
+1050 A=U(NP)
+ B=V(NP)
+ C=W(NP)
+ GO TO 1080
+1070 A=U(NP-1)
+ B=V(NP-1)
+ C=W(NP-1)
+1060 X(NP)=X(NP-1)
+ Y(NP)=Y(NP-1)
+ Z(NP)=Z(NP-1)
+ IR(NP)=IR(NP-1)
+ XM(NP)=XM(NP-1)
+ YM(NP)=YM(NP-1)
+ ZM(NP)=ZM(NP-1)
+ DM(NP)=DM(NP-1)
+ TM(NP)=TM(NP-1)
+ WT(NP)=WT(NP-1)
+ DNEAR(NP)=DNEAR(NP-1)
+C SEE H.H. NAGEL DISSERTATION FOR COORDINATE SYSTEM DESCRIPTION.
+C A ROTATION IS PERFORMED TO TRANSFORM DIRECTION COSINES OF THE
+C PARTICLE BACK TO THE PHYSICAL FRAME (FROM THE TRANSPORT FRAME)
+ LATCH(NP)=LATCH(NP-1)+1
+C IF SINPS2 IS SMALL, NO ROTATION IS NEEDED
+CSMALL POLAR ANGLE CASE
+1080 SINPS2=A*A+B*B
+ IF ((SINPS2.LT.1.0E-20)) THEN
+ U(NP)=SINTHE*COSPHI
+ V(NP)=SINTHE*SINPHI
+ W(NP)=C*COSTHE
+C END SMALL POLAR ANGLE CASE
+C LARGE POLAR ANGLE CASE
+ ELSE
+ SINPSI=SQRT(SINPS2)
+ US=SINTHE*COSPHI
+ VS=SINTHE*SINPHI
+ SINDEL=B/SINPSI
+ COSDEL=A/SINPSI
+ U(NP)=C*COSDEL*US-SINDEL*VS+A*COSTHE
+ V(NP)=C*SINDEL*US+COSDEL*VS+B*COSTHE
+ W(NP)=-SINPSI*US+C*COSTHE
+C END LARGE POLAR ANGLE CASE
+ END IF
+C DEFAULT FOR $PRESTA-LCDV; IS ; (NULL)
+ IARG=22
+ IF ((IAUSFL(IARG+1).NE.0)) THEN
+ CALL AUSGABCX(IARG)
+ END IF
+ RETURN
+CREACH THIS POINT IF EITHER IENTRY OR LVL NE 1,2, OR 3
+1040 WRITE(6,1090)IENTRY,LVL
+1090 FORMAT(' STOPPED IN UPHI WITH IENTRY,LVL=',2I6)
+ STOP
+CEND OF SUBROUTINE UPHI
+ END
+c Last modification : 03.07.2020 link to CORSIKA 8 by T. Pierog
+c 07.04.2008 Compatibility gcc4 by T. Pierog
+c 17.01.2008 Link CONEX-CORSIKA by T. Pierog
+c 11.10.2005 Link CONEX-EGS4 by T. Pierog v3.059
+c 26.08.2005 : update grammage <-> convertion
+c 31.03.2005 : correction of the 3D propagation (like hadrons)
+c 09.02.2005 : etotsource update for energy conservation check
+c 15.11.2004 : Conex routines for Mu pair Production and Photonuclear
+c effect in EGS4,adapted from CORSIKA routines by D. Heck.
+
+c options to be prepocessed by cpp are :
+c -D__QGSJET__ to compile with QGSJet MC model
+c -D__GHEISHA__ to compile with Gheisha MC model
+c -D__NEXUS__ to compile with Nexus model
+c -D__SIBYLL21__ to compile with Sibyll model
+c -D__QGSJETII__ to compile with QGSJet-II-3 model
+c -D__EPOS__ to compile with EPOS model
+c
+c -D__CXDEBUG__ to allow debugging commands (print ...)
+c -D__ANALYSIS__ to allow analysis tools from CONEX (into histo file)
+c -D__MC3D__ to allow 3D simulations and low energy MC (moments, etc...)
+c -D__CXLATCE__ to allow 3D calculations in CE (moments, etc...)
+c -D__COAST__ to allow linking to ROOT (for plotting ...)
+c
+c -D__CXSUB__ to set conex as a subroutine
+c -D__CXCORSIKA__ to compile in CORSIKA 7
+c -D__CORSIKA8__ to compile with CORSIKA 8
+c
+c -D__PRESHOW__ to include preshowering for Gamma induced Shower
+c
+c -D__ALL__ to have all MC model in 3D + analysis and debug (as before)
+c -D__STD__ to have the minimum for plots : qgsjet+gheisha+analysis
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+C********************************************************************
+C
+ SUBROUTINE AUSGABCX(IARG)
+C
+C IN GENERAL, AUSGAB IS A ROUTINE WHICH IS CALLED UNDER A SERIES
+C OF WELL DEFINED CONDITIONS SPECIFIED BY THE VALUE OF IARG (SEE THE
+C EGS4 MANUAL FOR THE LIST). THIS IS A PARTICULARILY SIMPLE AUSGAB.
+C WHENEVER THIS ROUTINE IS CALLED WITH IARG=3 , A PARTICLE HAS
+C BEEN DISCARDED BY THE USER IN HOWFAR
+C WE GET AUSGAB TO PRINT THE REQUIRED INFORMATION AT THAT POINT
+C
+C********************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI,NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+ COMMON/EPCONT/EDEP,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, RHOF,EOLD,ENEW
+ *,EKE,ELKE,BETA2,GLE,TSCAT,IDISC,IROLD,IRNEW,IAUSFL(30)
+ DOUBLE PRECISION EDEP
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PZERO,PRM,PRMT2
+c...............
+#include "conex.h"
+#include "conexep.h"
+#ifndef __CXSUB__
+ parameter (mtimx=30)
+ COMMON /NPTLC/ eleft(mtimx),iutime(5),itime(mtimx),mtime(mtimx)
+ & ,nptlc
+#endif
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ dimension ep(3)
+ logical fpair,fpass,mc2ce
+#ifdef __CXDEBUG__
+ logical lebal
+#endif
+ logical cx2cors
+#ifndef __CXCORSIKA__
+ logical axispro
+#endif
+
+ double precision Etmp,Utmp,Vtmp,Wtmp
+ integer IQtmp
+ save Etmp,Utmp,Vtmp,Wtmp,IQtmp
+c...............
+
+ IF (IARG.eq.0) THEN !called before propagation in EGS with all info available
+
+c......................................................................
+
+#ifndef __CXSUB__
+C Print progress in terms of remaining energy (by H.J. Drescher)
+ nptlc=nptlc+1
+ if(nptlc.eq.1)il=0
+ if (mod(nptlc,1000000).eq.0) then
+ ETOT=0.d0
+ do i=1,NP
+ ETOT=ETOT+E(i)*WT(i)
+ enddo
+ il=il+1
+ il1=mod(il-1,mtimx)+1
+ il2=mod(il,mtimx)+1
+ if (il.le.mtimx) il2=1
+ eleft(il1)=ETOT/1000.d0+estck(1) !---kw---estack->estck
+ call timer(iutime)
+ itime(il1)=iutime(3)
+ mtime(il1)=iutime(4)
+ speed=-(eleft(il1)-eleft(il2))
+ $ /max(dble(itime(il1)-itime(il2))
+ $ +dble(mtime(il1)-mtime(il2))/1000.d0,1d-3)
+ timeleft=eleft(il1)/max(speed,0.001d0)
+ if(timeleft.lt.864000.d0)then
+ ifinal=mod(itime(il1)-iutime(5)*60,86400)+int(timeleft)
+ write(6,1110)nptlc,eleft(il1)
+ $ ,int(timeleft/60.d0),int(mod(timeleft,60.d0))
+ $ ,mod(ifinal/3600,24),mod(ifinal,3600)/60,mod(ifinal,60)
+ 1110 format(i10,g13.6,1x,i5,":",i2.2," ",i2,":",i2.2,":",i2.2
+ $ ,3i4)
+ endif
+ endif
+#endif
+c......................................................................
+
+c Analyse shower
+
+#ifdef __CXDEBUG__
+ if(isxegs.ge.7)write(ifckegs,*)'AUSGAB',' iq',iq(np),' E'
+ & ,E(np),' edep',edep,' z',z(np),' vstep',vstep,' u',u(np)
+ & ,' v',v(np),' w',w(np),' x',x(np),' y',y(np),' xm'
+ & ,xm(np),' ym',ym(np),' dm',dm(np),' zm',zm(np),' tm'
+ & ,tm(np),' wt',wt(np),' gen',LATCH(NP)
+#endif
+ wei=WT(NP)
+ gen=dble(LATCH(NP))
+ efin=E(NP)-EDEP !after propagation, EDEP is lost
+ if(iq(np).eq.0)then
+ am=0.d0
+ cxecut1=epcut*1000.d0
+ else
+ am=prm
+ cxecut1=eecut*1000.d0+am
+ endif
+ egslow=eelow*1000.d0+am
+ cxecut2=emin*1000.d0+am
+ if(E(NP).ge.cxecut2)then!particle above lowest threshold : tracked ====>
+ imode=4
+ dist01=DM(NP)
+ h01=heightt(dist01,radtr0)
+ h1=ZM(NP)
+ t1=TM(NP)
+ z1=Z(NP)
+ pinv=1.d0/sqrt(U(NP)**2+V(NP)**2+W(NP)**2) !normalization of the direction
+ if(mode.eq.8.or.mode.eq.3)then !hybrid mode
+ mc2ce=.true.
+ else
+ mc2ce=.false.
+ endif
+#ifdef __CXDEBUG__
+ lebal=.false.
+#endif
+ zmcl=zmclow
+ cx2cors=.false. !low energy monte-carlo in CORSIKA
+#ifdef __CXCORSIKA__
+c if particle is going backward in shower frame, it should go directly to
+c low energy MC in CORSIKA (to better take into account magnetic field in
+c CORSIKA because otherwise this particle will stay in CONEX)
+ if(W(NP).lt.0d0)then
+ imode=5
+ cx2cors=.true.
+ efin=E(NP)
+#ifdef __CXDEBUG__
+ if(isx.ge.3)
+ * write(ifck,'(a)')' Backward going particle ...'
+#endif
+ goto 10
+ endif
+#endif
+ if(cxecut1.le.egslow.and.zmcl.lt.zshmax)then
+ cx2cors=.true. ! particle can be sent in CORSIKA stack
+ cxecut1=egslow ! low energy MC replace CE, and so particles should be transferred the same way (not at zmclow but at usual zsource)
+ endif
+#ifndef __CXCORSIKA__
+ axispro=.true. !stop propagation if particle projection on shower axis reached ground
+#endif
+ if(z1.ge.zmcl.and.(E(NP).le.egslow
+ & .or.(LATCH(NP).ge.500d0.and.E(NP).le.10d0*egslow) !low energy EM particles from hadrons
+ & .or.LATCH(NP).ge.900d0))then !EM particles from muons
+#ifdef __CXCORSIKA__
+ cx2cors=.true. !particle is sent to CORSIKA stack instead of source
+#else
+ if(LATCH(NP).GE.500d0)then
+ mc2ce=.false. !no CE if already in low energy MC
+ else
+ cx2cors=.false. !low energy MC instead of CE
+ endif
+#endif
+ endif
+ px=V(NP)*pinv !not in GEV ... it is only for the direction
+ py=U(NP)*pinv !U=y and V=x because EGS4 frame is left-handed
+ pz=W(NP)*pinv
+ costhi=1.d0/pz !for projection from shower axis to particle direction
+ if(i1DMC.le.1)then !3D treatment
+ x1=XM(NP)
+ y1=YM(NP)
+ x01=X(NP)
+ y01=Y(NP)
+ ep(1)=px
+ ep(2)=py
+ ep(3)=pz
+ rtr1=sqrt(x1*x1+y1*y1) !radial distance to obs point
+ if(rtr1.gt.1.d-20)then
+ sinphiP=y1/rtr1
+ cosphiP=x1/rtr1
+ sintheP=rtr1/(h1+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ call ToObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P from shower frame to obs. frame
+ cosx=ep(1)
+ siny=ep(2)
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in particle frame
+ jinv=0
+ ct=ep(3) !local cosine
+ if(abs(ct).ge.1.d0)ct=sign(1.d0,ct)
+ st=dsqrt(1.d0-ct*ct) !local sin
+
+ radtr=(radearth+h1)*st !local impact radius
+ depthmaxi=depthmax(radtr) !local maximum depth
+ dist1=distant(h1,radtr) !local slant distance to obs level, m
+ sz1=deptht(dist1,radtr) !local slant depth, g/cm^2
+ if(i1DMC.eq.0)then
+ call updateDist(sz1,sz2,VSTEP,z1,z2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,h01,h02,pz,ct,depthmaxi,radtr,jinv)
+ zstep=z2-z1
+ else
+ zstep=VSTEP/costhi
+ z2=z1+zstep ! depth along shower axis
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ endif
+ if(pz.le.0d0)mc2ce=.false. !if backward going Part : no source
+ else !1D treatment
+ zstep=VSTEP/costhi
+ z2=z1+zstep ! depth along shower axis
+ endif
+
+ if(efin.lt.cxecut2)then !if ekin under threshold, propagation until the limit
+ efin=cxecut2
+ vstepn=(E(NP)-efin)/EDEP*VSTEP
+ if(i1DMC.eq.0)then
+ call updateDist(sz1,sz2,vstepn,z1,z2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,h01,h02,pz,ct,depthmaxi,radtr,jinv)
+ zstep=z2-z1
+ elseif(i1DMC.eq.1)then
+ zstep=vstepn/costhi
+ z2=z1+zstep ! depth along shower axis
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ else
+ zstep=(E(NP)-cxecut2)/EDEP*zstep
+ z2=z1+zstep ! depth along shower axis
+ endif
+ imode=1 !particle will disappear
+ IDISC=-1
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+
+ if(mc2ce)then
+ j=int((z1-ZZo)/dZZ)+1
+ zsource=ZZo+dble(j)*dZZ !next bin edge
+ if(efin.lt.cxecut1.and.z2.ge.zsource)then !go to source function
+ zstepn=max(0d0,zsource-z1)
+ if(i1DMC.ne.2)then
+ call updateSlant(z1,zsource,sz1,sz2o,dlo,dist01,dist02o
+ & ,dist1,dist2o,h1,h2o,costhi,ct,depthmaxi,radtr,jinvo)
+ if(i1DMC.eq.0)then
+ if(jinvo.eq.0)then
+ vstepn=sz2o-sz1
+ else
+ vstepn=2.d0*depthmaxi-sz2o-sz1
+ endif
+ else
+ vstepn=zstepn*costhi
+ endif
+ eint=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ else
+ eint=E(NP)-zstepn*EDEP/zstep
+ endif
+
+
+ if(eint.lt.cxecut1.and.eint.gt.0.d0)then !if this energy still below the cutoff
+ imode=5
+ zstepn=max(0d0,zsource-z1-min(0.001d0*dZZ,0.5d0*zstep))!to be sure not to count the particle after zsource
+ if(i1DMC.ne.2)then
+ z2o=z1+zstepn
+ call updateSlant(z1,z2o,sz1,sz2o,dlo,dist01,dist02o
+ & ,dist1,dist2o,h1,h2o,costhi,ct,depthmaxi,radtr,jinvo)
+ if(i1DMC.eq.0)then
+ if(jinvo.eq.0)then
+ vstepn=sz2o-sz1
+ else
+ vstepn=2.d0*depthmaxi-sz2o-sz1
+ endif
+ else
+ vstepn=zstepn*costhi
+ endif
+ eint=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ else
+ eint=E(NP)-zstepn*EDEP/zstep
+ endif
+ if(EDEP.gt.0d0)then
+ efin=eint
+ EDEP=E(NP)-efin
+ endif
+ zstep=zstepn
+ z2=z2o
+ if(i1DMC.le.1)then !3D treatment
+ sz2=sz2o
+ dl=dlo
+ dist02=dist02o
+ dist2=dist2o
+ h2=h2o
+ jinv=jinvo
+ endif
+ endif
+ endif
+ endif
+
+
+
+ if(i1DMC.le.1)then !3D treatment
+ if((jinv.eq.1.and.radtr.le.RadGrd))then !if particle reached ground
+ vstepn=sz2-sz1
+ efin=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ EDEP=E(NP)-efin
+ IDISC=-1
+ imode=2 !particle reach the ground
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ elseif(h2.ge.eatm(mxatm)*0.99999999d0)then
+ sz2=0.d0
+ IDISC=-1
+ imode=2 ! particle leaves the atm.
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+
+#ifndef __CXCORSIKA__
+c particle projection on axis reach ground
+ if(axispro)then
+ if(dist02.le.0.d0.and..not.
+ & (goOutGrd.or.radtr0.gt.RadGrd))then
+ z2=depthmaxi0
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ if(jinv.eq.0)then
+ vstepn=sz2-sz1
+ else
+ vstepn=2.d0*depthmaxi-sz2-sz1
+ endif
+ efin=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ EDEP=E(NP)-efin
+ IDISC=-1
+ imode=2
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+
+
+c Maximum or minimum slant depth reached
+
+ if(z2.gt.1.0000001d0*zshmax
+ & .or.(i1DMC.eq.1.and.
+ & z2.lt.1.000000001d0*zshmin.and.pz.le.0.d0))then
+ jinv=0
+ if(z2.ge.zshmax)then
+ z2=zshmax
+ else
+ z2=zshmin
+ endif
+ call updateSlant(z1,z2,sz1,sz2,dl,dist01,dist02,dist1
+ & ,dist2,h1,h2,costhi,ct,depthmaxi,radtr,jinv)
+ if(jinv.eq.0)then
+ vstepn=sz2-sz1
+ else
+ vstepn=2.d0*depthmaxi-sz2-sz1
+ endif
+ efin=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ EDEP=E(NP)-efin
+ IDISC=-1
+ imode=2
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+ endif
+#else
+c Test ground position in case of flat HGrd
+ if(lFlat)then
+ call updateFlat(x1,y1,h1,h2,dl,cosx,siny,imode)
+ if(imode.eq.2)then
+ dls=sign(dl,ct)
+ call dl2dz(dls,dz,h1,h2,dist1,dist2,radtr)
+ dl=abs(dls)
+ vstepn=dz
+ efin=E(NP)-min(1.d0,vstepn/vstep)*EDEP
+ EDEP=E(NP)-efin
+ IDISC=-1
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+ endif
+#endif
+
+ dl=abs(dl)
+
+ x2=x1+dl*cosx ! new x
+ y2=y1+dl*siny ! new y
+ x02=x01+dl*px ! new x in shower frame
+ y02=y01+dl*py ! new y in shower frame
+
+
+ else !1D treatment
+
+
+c Maximum slant depth reached
+ if(z2.ge.XmaxP)then
+ jinv=0
+ z2=XmaxP
+ zstepn=z2-z1
+ efin=E(NP)-zstepn*EDEP/zstep
+ EDEP=E(NP)-efin
+ IDISC=-1
+ imode=2
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+ dzs=sign(abs(z2-z1),depthmaxi0-z1)
+ call dz2dl(dzs,dl0,h1,h2,radtr0,idum)
+ dist02=dist01-dl0
+ if(dist02.lt.-1.d-6.and..not.
+ & (goOutGrd.or.radtr0.gt.RadGrd))then
+ dist02=-1.d-6
+ z2=1.000000001d0*depthmaxi0
+ zstepn=z2-z1
+ efin=E(NP)-zstepn*EDEP/zstep
+ EDEP=E(NP)-efin
+ IDISC=-1
+ imode=2
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+
+ dl=abs(dist01-dist02)
+ h2=heightt(dist02,radtr0)
+ px=0.d0
+ py=0.d0
+ pz=1.d0
+ dist=dist02-sign(DistAlt,zsaxis)
+ x2=dist*xsaxis
+ y2=dist*ysaxis
+ x02=0.d0
+ y02=0.d0
+ endif !end 3D or 1D
+
+c Ground reached
+ if(h2.le.HGrd)then
+ IDISC=-1
+ imode=2
+#ifdef __CXDEBUG__
+ lebal=.true.
+#endif
+ endif
+ X(NP)=x02
+ Y(NP)=y02
+ Z(NP)=z2
+ XM(NP)=x2
+ YM(NP)=y2
+ ZM(NP)=h2
+ DM(NP)=dist02
+ if(iq(np).eq.0)then
+ t2=t1+dl !/beta=1
+ else
+ t2=t1+dl/sqrt((1.d0-(am/efin))*(1.d0+(am/efin)))
+ endif
+ TM(NP)=t2
+ if(abs(z2-z1).gt.1d-20)then
+ call cana2(h1,x01,y01,x1,y1,dist01,z1,t1,E(NP),h2,x02,y02,x2
+ $ ,y2,dist02,z2,t2,efin,px,py,pz,am,wei,gen,IQ(NP),imode)
+ endif
+
+#ifdef __CXDEBUG__
+ if(lebal)then
+ if(iq(np).eq.0)then
+ ebal=efin
+ else
+ ebal=efin+iq(np)*am
+ endif
+ else
+ ebal=0d0
+ endif
+ etotsource=etotsource-(EDEP+ebal)*1.d-3*wei
+#endif
+#ifdef LEADING_INTERACTIONS_TREE
+ if(leadingParticle) then
+ ptlIntIn=-1d0
+ mult=0
+ matrg=0
+ call outpart2(ptlIntIn,mult,matrg,z2,h2)
+ countInt=countInt+1
+ leadingParticle=.false.
+ endif
+#endif
+c if particle below CE threshold after propagation : sent in CE and lost for EGS
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(imode.eq.2)then !go to corsika stack if ground reached
+ imode=5
+ cx2cors=.true.
+#ifdef __CXDEBUG__
+ if(isx.ge.3)
+ * write(ifck,'(a)')' out in corsika ...'
+#endif
+ endif
+ 10 continue
+#endif
+ if(imode.eq.5)then !go to source function
+#if __CXCORSIKA__ || __CORSIKA8__
+ if(z(np).ge.XmaxP)cx2cors=.true. ! particle has to be sent in CORSIKA stack because last bin of CE is past
+#endif
+ if(cx2cors)then !go to corsika stack
+#ifdef __CXDEBUG__
+ if(isx.ge.3)
+ * write(ifck,'(a,i3,a/)')' ausgab: id=',IQ(NP),' (corsika)'
+#endif
+ Etot=efin*1.d-3
+ amass=am*1.d-3
+ id=-SIGN(10+2*abs(IQ(NP)),IQ(NP))
+ ekin=Etot-amass
+ call cxconv(ekin,amass,id)
+#ifdef __CORSIKA8__
+ !put here call to CORSIKA8 stack
+#else
+#ifdef __CXCORSIKA__
+ if(IDISC.eq.-1)then
+ call d2cors(3)
+ else
+ call d2cors(2)
+ endif
+#else
+ call d2a
+#endif
+#endif
+ else
+#ifdef __CXDEBUG__
+ if(isx.ge.3)
+ * write(ifck,'(a,i3,a/)')' ausgab: id=',IQ(NP)
+ * ,' (source function)'
+#endif
+#ifdef __CXLATCE__
+c alpha and beta are defined like in CE
+c alpha=sin(theta)*cos(phi), beta=sin(theta)*sin(phi)
+c with sin(theta)=sqrt(px**2+py**2) and cos(phi)=px/sqrt(px**2+py**2)
+ alpha=px
+ beta=py
+ call ConvPartLept3d(alpha,beta,X(NP),Y(NP),(efin-am)*1d-3
+ * ,Z(NP),Wei,iq(NP))
+#else
+ call ConvPartLept((efin-am)*1d-3,Z(NP),wei,iq(NP))
+#endif
+ endif
+ IDISC=-1
+ endif
+
+
+ else !<============= if below thresholds : lost
+
+ IDISC=-1
+
+#ifdef __CXCORSIKA__
+
+c energy threshold can be different in CORSIKA so send it there
+ Etot=E(NP)*1.d-3
+ amass=am*1.d-3
+ id=-SIGN(10+2*abs(IQ(NP)),IQ(NP))
+ ekin=Etot-amass
+ call cxconv(ekin,amass,id)
+ call d2cors(2)
+
+#else
+
+ wei=WT(NP) !count lost energy for energy deposit
+ efin=(E(NP)+dble(IQ(NP))*prm)*1.d-3
+#ifdef __CXDEBUG__
+ etotsource=etotsource-efin*wei
+#endif
+ if(iwrt.ge.2)
+ & call Profana(Z(NP),depthmaxi0,efin,efin,wei,999,1)
+
+#endif
+ endif
+
+c......................................................................
+
+c non electromagnetic particles
+ elseif(IARG.eq.100)then !transfer back particle to CONEX
+ Etot=E(NP)*1.d-3
+ id=IQ(NP)
+ if(id.eq.-9999)then !temporary particle for photo-nuclear int.
+ call cxidmass(111,am) !rho0 is used to replace gamma
+c am=pmass(2) !we will use charge pion for that
+ else
+ call cxidmass(id,am)
+ endif
+ ekin=Etot-am
+ if(ekin.ge.enymin)then
+c if(id.ne.-9999)then !temporary particle for photo-nuclear int.
+#ifdef __CORSIKA8__
+ !put here call to CORSIKA8 stack
+#else
+ call cxconv(ekin,am,id)
+ call d2a
+#endif
+c else
+c call cxconv(0.5d0*ekin,am,id)
+c call d2a
+c call cxconv(0.5d0*ekin,am,id)
+c call d2a
+c endif
+#ifdef __CXDEBUG__
+ if(isx.ge.6)then
+ ebal=dptl(4)
+ ida=abs(id)
+ if(ida.ge.1000..and.id.ne.-9999)
+ & ebal=ebal-sign(pmass(7),dble(id)) !if anti-baryon, count mass twice
+ etotsource=etotsource-ebal*dptl(11)
+ endif
+#endif
+ elseif(iwrt.ge.2)then
+ ida=abs(id)
+ if(id.ge.1000)then !baryon
+ ebal=ekin !count only kinetic energy (mass come from nucleus)
+ edep=ebal
+ iimode=1 !edep is deposed
+ elseif(ida.eq.14)then
+ ebal=Etot !for muons count total energy for energy balance
+ edep=Etot/3.d0 !only one third of the total energy will be deposed
+ iimode=-1 !edep is deposed and ebal for energy balance
+ else
+ ebal=Etot !if not baryon or muon (omega or rho or ???) count total energy
+ edep=ebal
+ iimode=1 !edep is deposed
+ endif
+ call Profana(0.99999d0*Z(NP),zshmax
+ & ,ebal,edep,WT(NP),999,iimode) !count energy
+#ifdef __CXDEBUG__
+ etotsource=etotsource-ebal*WT(NP)
+#endif
+ endif
+ NP=NP-1
+
+c......................................................................
+
+c store particle direction and energy in case of LPM effect (>10^16 eV)
+ elseif(E(NP).ge.1D10.and.ilpmeffect.eq.1)then
+ if(IARG.eq.6.or.IARG.eq.15)then
+ IQtmp=IQ(NP) ! 6=before bremsstrhalung, 15=before pair prod
+ Etmp=E(NP)
+ Utmp=U(NP)
+ Vtmp=V(NP)
+ Wtmp=W(NP)
+ elseif(IARG.eq.7)then !test LPM for bremstrahlung
+ fpair=.false. !bremstrahlung
+ E1=Etmp !Primary electron
+ if(IQ(NP).eq.0)then !Photon on top
+ E0=E(NP) !Photon
+ E2=E(NP-1) !secondary electron
+ else !electron on top
+ E0=E(NP-1) !Photon
+ E2=E(NP) !secondary electron
+ endif
+ dist=DM(NP) ! slant distance along shower axis
+ alt=heightt(dist,radtr0) !altitude in m for slant depth Z
+ call cxlpmeffect(E0,E1,E2,alt,fpair,fpass) !test lpm effect :
+ if(fpass)then !if fpass=.true. : lpm occure -> forget photon an secondary elec
+ NP=NP-1
+ IQ(NP)=IQtmp
+ E(NP)=Etmp
+ U(NP)=Utmp
+ V(NP)=Vtmp
+ W(NP)=Wtmp
+ endif
+ elseif(IARG.eq.16)then !test LPM for pair production
+ fpair=.true. !pair production
+ E0=Etmp !Photon
+ E1=E(NP) !Primary electron
+ E2=E(NP-1) !secondary electron
+ dist=DM(NP) ! slant distance along shower axis
+ alt=heightt(dist,radtr0) !altitude in m for slant depth Z
+ call cxlpmeffect(E0,E1,E2,alt,fpair,fpass) !test lpm effect :
+ if(fpass)then !if fpass=.true. : lpm occure -> forget elec and restore photon
+ NP=NP-1
+ IQ(NP)=IQtmp
+ E(NP)=Etmp
+ U(NP)=Utmp
+ V(NP)=Vtmp
+ W(NP)=Wtmp
+ endif
+ endif
+ END IF
+c......................................................................
+
+C OUTPUT E(NP),IARG,IR(NP),NP,IQ(NP),X(np),Y(np),Z(np)
+C ,XM(NP),YM(NP),ZM(NP),TVSTEP,VSTEP
+C ;(G13.6,4I10,1x,10(G13.6,1x));
+
+ RETURN
+ END
+
+C********************************************************************
+C
+ SUBROUTINE CXCONV(Ekin,am,id)
+C
+C Subroutine to convert EGS Stack to CONEX stack
+C input : Kinetic energy and mass in GeV, CONEX particle id
+C********************************************************************
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI,NP
+ DOUBLE PRECISION E
+ COMMON/XYZAT/XM(100),YM(100),ZM(100),DM(100),TM(100)
+c...............
+#include "conex.h"
+#include "conexep.h"
+ dimension ep(3)
+
+
+ Etot=Ekin+am
+ p=sqrt((Etot+am)*(Etot-am))
+ x01=X(NP)
+ y01=Y(NP)
+ dist01=DM(NP)
+ z1=Z(NP)
+ x1=XM(NP)
+ y1=YM(NP)
+ h1=ZM(NP)
+ t1=TM(NP)
+ wei=WT(NP)
+ if(i1DMC.le.1)then !3D treatment
+ ep(1)=V(NP) !not in GEV ... it is only for the direction
+ ep(2)=U(NP) !U=y and V=x because EGS4 frame is left-handed
+ ep(3)=W(NP)
+ rtr1=sqrt(x1*x1+y1*y1)
+ if(rtr1.gt.1.d-20)then
+ sinphiP=y1/rtr1
+ cosphiP=x1/rtr1
+ sintheP=rtr1/(h1+radearth)
+ costheP=sqrt(1.d0-sintheP*sintheP)
+ else
+ sinphiP=0.d0
+ cosphiP=1.d0
+ sintheP=0.d0
+ costheP=1.d0
+ endif
+ call ToObs(ep,sinphi,cosphi,sinthet,costhet) !direction of P from shower frame to obs. frame
+ call FromObs(ep,sinphiP,cosphiP,sintheP,costheP) !direction of P in particle frame
+ else
+ x01=0.d0
+ y01=0.d0
+ ep(1)=0.d0
+ ep(2)=0.d0
+ ep(3)=1.d0
+ endif !end 3D or 1D
+ do i=1,3
+ dptl(i)=ep(i)*p
+ enddo
+ dptl(4)=Etot
+ dptl(5)=am
+ dptl(6)=x1
+ dptl(7)=y1
+ dptl(8)=h1
+ dptl(9)=t1
+ dptl(10)=dble(id)
+ dptl(11)=wei
+ dptl(12)=100d0+LATCH(NP) !hadronic particles from EM int.
+ if(abs(id).le.12)dptl(12)=dptl(12)+500d0 !particle for low energy MC
+ dptl(13)=z1
+ dptl(14)=x01
+ dptl(15)=y01
+ dptl(16)=dist01
+
+
+ RETURN
+ END
+
+C******************************************************************
+
+ SUBROUTINE CXMUPAIR
+
+C******************************************************************
+C C(one)X MU(ON) PAIR (FORMATION)
+C
+C MUON ID +/- 14
+C
+C TREATS THE MUON PAIR PRODUCTION ACCORDING REFERENCE:
+C H. BURKHARDT, S.R. KELNER, R.P. KOKOULIN,
+C REPORT CERN-SL-2002-016 (AP) CLIC NOTE 511
+C A.G. BOGDANOV ET AL., IEEE TRANS. NUCL. SCI. 53 (2006) 513
+C AND THE GEANT4 MANUAL: GAMMA CONVERSION INTO A MUON-ANTI_MUON PAIR
+C
+C REDESIGN: D. HECK IK FZK KARLSRUHE AUGUST 11, 2009
+C
+C author : T. Pierog - last modification : 27.11.2009
+C based on the modifications for the Corsika code by D. Heck.
+C******************************************************************
+ double precision airz,aira,airw,airavz,airava,airi
+ common/cxair/airz(3),aira(3),airw(3),airavz,airava,airi(3)!also in geisha_conex and nexus_conex and conex.h
+ DOUBLE PRECISION E,X,Y,Z,U,V,W,DNEAR,WT
+ INTEGER IQ,IR,LATCH,LATCHI,NP
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ DOUBLE PRECISION PZERO,PRM,PRMT2,RM
+ INTEGER MEDIUM,MEDOLD,IBLOBE
+ COMMON/USEFUL/PZERO,PRM,PRMT2,RM,MEDIUM,MEDOLD,IBLOBE
+ DOUBLE PRECISION PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ DOUBLE PRECISION AAIR(3),ZAIR(3),dranegs
+ DOUBLE PRECISION AEXP,AUXIL,AUX5,BETA4,C1,C1NUM,C2,SE,
+ * DELMAX,DELTA,DN,F1,F1MAX,F2,F2MAX,
+ * OB3,PEIG,PHI,PHI1,PSI,PXXI,RHO,RHOMAX,
+ * SUM1,SUM2,SUM3,TERM1,TERM2,THETAM,THETAP,TT,UU,
+ * WW,WINF,W_MAX,XMAX,XMIN,XMINS,XPLUS,XPXM,ZEXP
+ INTEGER JE
+ SAVE
+ DATA AAIR / 14.D0, 16.D0, 40.D0 /
+ DATA ZAIR / 7.D0, 8.D0, 18.D0 /
+ DATA OB3 / 0.333333333333333D0 /
+ SE = SQRT( EXP(1.D0) )
+CDEFAULT REPLACEMENT PRODUCES THE FOLLOWING:
+CCOMIN/DEBUG,BREMPR,STACK,THRESH,UPHIOT,USEFUL,RANDOM/;
+ PEIG=E(NP)
+C SELECT TARGET NUCLEUS
+C PRECISELY IT SHOULD BE SELECTED FROM THE CROSS SECTION RATIO.
+C CROSS SECTION RATIO GOES APPROXIMATELY LIKE COMPOS * Z**1.735
+C AND DOES NOT DEPEND STRONGLY ON THE ENERGY
+ SUM1 = airw(1) * ZAIR(1)**1.735D0
+ SUM2 = SUM1 + airw(2) * ZAIR(2)**1.735D0
+ SUM3 = SUM2 + airw(3) * ZAIR(3)**1.735D0
+ RD=dranegs(SUM2)
+ IF ( RD*SUM3 .LE. SUM1 ) THEN
+ JE = 1 !NITROGEN TARGET
+ ELSEIF ( RD*SUM3 .LE. SUM2 ) THEN
+ JE = 2 !OXYGEN TARGET
+ ELSE
+ JE = 3 !ARGON TARGET
+ ENDIF
+C BOUNDARIES OF INTEGRATION
+ XMIN = .5D0 - SQRT( .25D0 - PRRMMU/PEIG )
+ XMAX = .5D0 + SQRT( .25D0 - PRRMMU/PEIG )
+C CALCULATE DN BY EQ.(4)
+ AEXP = AAIR(JE)**.27D0
+ DN = 1.54D0 * AEXP
+C C1NUM IS NUMERATOR OF EQ.(24)
+ C1NUM = ( .335D0 * AEXP )**2
+ ZEXP = 183.D0 * ZAIR(JE)**(-OB3)
+C CALCULATE WINF BY EQ.(3A)
+ WINF = ZEXP * PRRMMU / ( DN * PRM )
+C CALCULATE DELMAX AND W_MAX ACCORDING EQ.(3) FOR XPLUS = 0.5
+ DELMAX = 2.D0 * PRRMMU**2 / PEIG
+ W_MAX = WINF * ( 1.D0 + (DN * SE - 2.D0) * DELMAX/PRRMMU ) /
+ * ( 1.D0 + ZEXP * SE *DELMAX/PRM )
+
+C STEP 1) : SAMPLING OF THE MUON ENERGY FRACTIONS
+C ENTRY POINT IF JUMPING BACK
+ 2 CONTINUE
+C AS DISTRIBUTION IS SYMMETRIC AROUND PEIG/2, WE SAMPLE
+C THE MUON WITH LOWER ENERGY ONLY BETWEEN XMIN AND PEIG/2
+C THUS WE FORCE XPLUS TO BE THE MUON WITH HIGHER ENERGY
+ XMINS = XMIN + .5D0 * dranegs(DELMAX) * (XMAX - XMIN)
+ XPLUS = 1.D0 - XMINS
+C CALCULATE DELTA BY EQ.(3A)
+ XPXM = XPLUS * XMINS
+ PXXI = 1.D0 / ( PEIG * XPXM )
+ DELTA = .5D0 * PRRMMU**2 * PXXI
+C CALCULATE W BY EQ.(3)
+ WW = WINF * ( 1.D0 + (DN * SE - 2.D0) * DELTA / PRRMMU ) /
+ * ( 1.D0 + ZEXP * SE * DELTA/PRM )
+C LIMIT W TO AVOID NEGATIVE LOGARITHM (NEGATIVE CROSS SECTION)
+ WW = MAX( WW, 1.D0 )
+C CALCULATE EQ. (PAGE 9 TOP)
+ AUXIL = ( 1.D0 - 4.D0*OB3*XPXM ) * LOG(WW) / LOG(W_MAX)
+ IF ( dranegs(WW) .GT. AUXIL ) GOTO 2
+C NOW WE HAVE DETERMINED THE ENERGY FRACTIONS OF THE TWO MUONS
+
+C STEP 2)
+C CALCULATE C1 BY EQ.(24)
+ C1 = C1NUM * PRRMMU * PXXI
+ F1MAX = (1.D0 - XPXM) / (1.D0 + C1)
+C ENTRY POINT IF JUMPING BACK
+ 3 CONTINUE
+ RD1=dranegs(F1MAX)
+C CALCULATE F1 BY EQ.(23)
+ F1 = ( 1.D0 - 2.D0*XPXM + 4.D0*XPXM*RD1*(1.D0-RD1) ) /
+ * ( 1.D0 + C1/(RD1*RD1) )
+ IF ( F1 .LT. 0.D0 .OR. F1 .GT. F1MAX ) F1 = 0.D0
+ IF ( dranegs(F1)*F1MAX .GT. F1 ) GOTO 3
+ TT = RD1
+
+C STEP 3)
+C CALCULATE F2MAX BY EQ.(26)
+ F2MAX = 1.D0 - 2.D0*XPXM * (1.D0 - 4.D0*TT*(1.D0-TT) )
+C ENTRY POINT IF JUMPING BACK
+ 4 CONTINUE
+ PSI = dranegs(F2MAX) * TWOPI
+C CALCULATE F2 BY EQ.(25)
+ F2 = 1.D0 - 2.D0 * XPXM
+ * + 4.D0*XPXM*TT*(1.D0-TT) * ( 1.D0 + COS(2.D0*PSI) )
+ IF ( F2 .LT. 0.D0 .OR. F2 .GT. F2MAX ) F2 = 0.D0
+ IF ( dranegs(F2)*F2MAX .GT. F2 ) GOTO 4
+
+C STEP 4)
+C CALCULATE SECOND AND FIRST TERM OF EQ.(29)
+ TERM2 = PRM / (ZEXP * PRRMMU)
+ TERM1 = PRRMMU / (2.D0 * PEIG * XPXM * TT)
+ C2 = 4.D0/SQRT(XPXM) * (TERM1**2 + TERM2**2)**2
+C CALCULATE RHOMAX BY EQ.(28)
+ RHOMAX = 1.9D0/AEXP * (1.D0/TT - 1.D0)
+C CALCULATE BETA BY EQ.(31)
+ BETA4 = LOG( (C2 + RHOMAX**2)/C2 )
+ RD=dranegs(BETA4)
+C CALCULATE RHO BY EQ.(30)
+ RHO = ( C2 * ( EXP( RD*BETA4 ) - 1.D0 ) )**0.25D0
+
+C STEP 5)
+C CALCULATE UU AND GAMMA+- BY EQ.(32)
+ UU = SQRT( 1.D0/TT - 1.D0 )
+ AUX5 = 0.5D0 * RHO * COS(PSI)
+C CALCULATE THETAP AND THETAM BY EQ.(33)
+ THETAP = PRRMMU/(PEIG*XPLUS) * (UU + AUX5)
+ THETAM = PRRMMU/(PEIG*XMINS) * (UU - AUX5)
+ IF ( ABS(THETAP) .GT. PI .OR. ABS(THETAM) .GT. PI ) GOTO 3
+ PHI1 = SIN(PSI) * 0.5D0 * RHO / UU
+
+C PRECISE ENERGY OF SECONDARY MUON 1 (WITH HIGHER ENERGY)
+ E(NP) = PEIG * XPLUS
+C PRECISE ENERGY OF SECONDARY MUON 2 (WITH LOWER ENERGY)
+ E(NP+1) = PEIG * XMINS
+C CALCULATION OF ANGLES BY EQ.(16)
+ SINTHE = SIN( THETAP )
+ COSTHE = COS( THETAP )
+ RD=dranegs(THETAP)
+ PHI = RD * TWOPI
+ COSPHI = COS( PHI + PHI1 )
+ SINPHI = SIN( PHI + PHI1 )
+ CALL UPHICX( 3,1 )
+C SET UP A NEW MUON
+ NP = NP+1
+C CALCULATION OF ANGLES BY EQ.(16)
+ SINTHE = -SIN( THETAM )
+ COSTHE = COS( THETAM )
+ COSPHI = COS( PHI - PHI1 )
+ SINPHI = SIN( PHI - PHI1 )
+ CALL UPHICX( 3,2 )
+C NOW RANDOMLY DECIDE WHICH IS POSITIVE MUON, AND SET
+C CHARGES ACCORDINGLY
+ RD=dranegs(SINPHI)
+ IF ( RD .LE. .5D0 ) THEN
+C POSITIVE MUON ON TOP OF STACK
+ IQ(NP) = 14
+ IQ(NP-1) = -14
+ ELSE
+C NEGATIVE MUON ON TOP OF STACK
+ IQ(NP) = -14
+ IQ(NP-1) = 14
+ ENDIF
+
+C POLARISATION OF MUON (FOR ANGULAR CORRELATION IN IT''S DECAY)
+c POLART = 2.D0*RD(2) - 1.D0
+c POLARF = TWOPI*RD(3)
+
+ RETURN
+CEND OF SUBROUTINE CXMUPAIR
+ END
+C=======================================================================
+
+ SUBROUTINE CXPIGEN
+
+C-----------------------------------------------------------------------
+C C(one)X PI(ON) GEN(ERATION)
+C
+C THIS SUBROUTINE STEERS THE PHOTONUCLEAR REACTION:
+C FOR PRODUCTION OF 1 PION, PIGEN1 IS CALLED.
+C FOR PRODUCTION OF 2 PIONS, PIGEN2 IS CALLED.
+C AT HIGHER ENERGIES Hadronic MC IS CALLED FOR PRODUCTION OF MORE PARTICLES
+C OR RHOGEN IS CALLED FOR PRODUCTION OF RHO OR OMEGA MESON.
+C THIS SUBROUTINE IS CALLED FROM PHOTON.
+c-- Author : The CORSIKA development group 21/04/1994
+c Last modification : T. Pierog - 15.11.2004 - for CONEX
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/CXEGSDEB/ifckegs,isxegs
+C-----------------------------------------------------------------------
+
+ PEIG = E(NP)
+ RD1=dranegs(dummy)
+ IF ( RD1 .GT. (PEIG-400.D0)*0.001D0 ) THEN
+#ifdef __CXDEBUG__
+ IF(isxegs.ge.5)WRITE(ifckegs,*) 'CXPIGEN1 : E=',E(NP)
+#endif
+C FOR ENERGIES BETWEEN 400 MEV AND 1400 MEV (=1000+400) DECIDE
+C BY CHANCE WHETHER ONE OR TWO PIONS ARE GENERATED
+C (PEIG<400, always 1 pion production)
+C PIGEN1 TREATS THE PRODUCTION OF 1 PION
+ CALL CXPIGEN1
+ ELSEIF ( RD1 .GT. (PEIG-2000.D0)*0.001D0 ) THEN
+#ifdef __CXDEBUG__
+ IF(isxegs.ge.5)WRITE(ifckegs,*) 'CXPIGEN2 : E=',E(NP)
+#endif
+C FOR ENERGIES BETWEEN 2000MEV AND 3000MEV (=1000+2000) DECIDE
+C BY CHANCE WHETHER 2 (PIGEN2) OR MORE PIONS (SDPM) ARE GENERATED
+C PIGEN2 TREATS THE PRODUCTION OF 2 PIONS
+ CALL CXPIGEN2
+ ELSE
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXRHOGEN: E=',E(NP)
+#endif
+
+C FOR ENERGIES ABOVE 2 GEV TAKE BY CHANCE DIFFRACTIVE INTERACTION
+C LEADING TO A RHO (90%) OR OMEGA (10%) BY CALLING RHOGEN
+C FIRST CALCULATE REST MASS OF AVERAGE AIR TARGET (MASS # 14.6)
+ AUXIL = airava * pmass(7)
+C ENERGY IN CM SYSTEM (GEV)
+ ECMVM = SQRT( AUXIL*(AUXIL + 2.D0*PEIG*0.001D0) )
+C THE FRACTION IS THE RATIO OF VECTOR MESON PRODUCTION CROSS-SECTION
+C (TO BE CALCULATED ACCORDING R. ENGEL ET AL., PHYS. REV. D55
+C (1997) 6957) TO TOTAL PHOTONUCLEAR CROSS-SECTION
+C (SEE T. STANEV ET AL., PHYS. REV. D32 (1985) 1244)
+C THE FRACTION LEADING TO A RHO (90%) OR OMEGA (10%) IS FITTED BY
+* VMFRAC = .11195D0 * ECMVM**0.0870D0 + .51892D0/(ECMVM**1.2891D0)
+C NEW FIT RESPECTING STEEPER INCREASE OF CUDELL CROSS SECTIONS
+C AT ENERGIES ABOVE 200 GEV (LAB)
+C THE FIT NOW INCLUDES THE FRACTION GOING TO EXCITED NUCLEAR STATES
+C (BUT THE EXCITED TARGET NUCLEI DO NOT CONTRIBUTE TO SHOWER)
+ VMFRAC = .17560D0 * ECMVM**0.037303 + .68008D0/(ECMVM**1.3021D0)
+ RD1=dranegs(dummy)
+#ifdef __CXDEBUG__
+ IF ( isxegs.ge.6 ) WRITE(ifckegs,*) 'PIGEN : VMFRAC,RD=',
+ * VMFRAC,RD1
+#endif
+ IF ( RD1 .LT. VMFRAC ) THEN
+ CALL CXRHOGEN
+ ELSE
+C AT HIGHER ENERGIES MORE THAN 2 PIONS ARE GENERATED BY HIGH ENERGY
+C HADRONIC INTERACTION MODEL
+C REPLACE CURRENT EGS4-PARTICLE BY A PION TO BE SENT TO CONEX STACK
+ iq(np)=-9999
+C END OF MANY PION GENERATION
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*CMZ : 05/02/2004 11.22.33 by D. HECK IK FZK KARLSRUHE
+*-- Author : The CORSIKA development group 21/04/1994
+C=======================================================================
+
+ SUBROUTINE CXPIGEN1
+
+C-----------------------------------------------------------------------
+C C(one)X PI(ON) GEN(ERATION) 1 (PION)
+C
+C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION
+C GAMMA + NUCLEON -----> PION + NUCLEON
+C THIS SUBROUTINE IS CALLED FROM PIGEN.
+c-- Author : The CORSIKA development group 21/04/1994
+c Last modification : T. Pierog - 15.11.2004 - for CONEX
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+
+C-----------------------------------------------------------------------
+
+
+ PEIG = E(NP)
+C NUMBERS AT THE VARIABLES MEAN :
+C 1 INCOMING GAMMA RAY
+C 2 HIT NUCLEON
+C 3 PRODUCED PION
+C 4 RECOILING NUCLEON
+C LOOK WHICH TYPE OF REACTION
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+C 0.49923 IS THE FRACTION OF PROTONS IN AIR
+ IF ( RD1 .LE. 0.49923D0 ) THEN
+C HIT NUCLEON IS PROTON
+ AMASS2 = AMSPR
+C 33% CHANCE FOR CHARGE EXCHANGE
+ IF ( RD2 .LE. 0.3333333D0 ) THEN
+C PI(+) + NEUTRON PRODUCED
+ IQ(NP) = 120
+ AMASS3 = PICMS
+ IQ(NP+1) = 1220
+ AMASS4 = AMSNT
+ ELSE
+C PI(0) + PROTON PRODUCED
+ IQ(NP) = 110
+ AMASS3 = PI0MS
+ IQ(NP+1) = 1120
+ AMASS4 = AMSPR
+ ENDIF
+ ELSE
+C HIT NUCLEON IS NEUTRON
+ AMASS2 = AMSNT
+C 33% CHANCE FOR CHARGE EXCHANGE
+ IF ( RD2 .LE. 0.3333333D0 ) THEN
+C PI(-) + PROTON PRODUCED
+ IQ(NP) = -120
+ AMASS3 = PICMS
+ IQ(NP+1) = 1120
+ AMASS4 = AMSPR
+ ELSE
+C PI(0) + NEUTRON PRODUCED
+ IQ(NP) = 110
+ AMASS3 = PI0MS
+ IQ(NP+1) = 1220
+ AMASS4 = AMSNT
+ ENDIF
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXPIGEN1: ID1,ID2',IQ(NP)
+ & ,IQ(NP+1)
+#endif
+ AMAS2I = 1.D0/AMASS2
+C TOTAL LABORATORY ENERGY AND ITS INVERSE
+ W0 = PEIG+AMASS2
+ W0I = 1.D0/W0
+C TOTAL.C.M. ENERGY AND INVERSE OF TOTAL C.M.ENERGY
+ W0S = SQRT(AMASS2*(AMASS2+2.D0*PEIG))
+ W0SI = 1.D0/W0S
+C THRESHOLD ENERGY
+ ETH = 0.5D0*((AMASS3+AMASS4)**2-AMASS2**2)*AMAS2I
+C BETA,GAMMA, ESQ, BRATIO, G3 ARE AUXILIARY QUANTITIES
+ BETA = PEIG*W0I
+ GAMMA = W0*W0SI
+ ED = 0.5D0*((AMASS3-AMASS4)**2-AMASS2**2)*AMAS2I
+ ESQ = SQRT((PEIG-ETH)*(PEIG-ED))
+ BRATIO = PEIG/ESQ
+ G3 = W0I*BRATIO*(PEIG-ETH+AMASS3*AMAS2I*(AMASS3+AMASS4))
+C C.M. ENERGY OF PION
+ E3CM = G3*AMASS2*GAMMA/BRATIO
+C C.M. PION MOMENTUM
+ P3CM = AMASS2*W0SI*ESQ
+ B3CM2 = P3CM**2/(P3CM**2+AMASS3**2)
+ B3CM = SQRT(B3CM2)
+C DETERMINE THETA IN C.M. SYSTEM BY CHANCE.
+
+ IF ( PEIG .LE. 900.D0 ) THEN
+C GAMMA ENERGY IS BELOW 900 MEV
+ 210 CONTINUE
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+ IF ( IQ(NP) .EQ. 110 ) THEN
+C NEUTRAL PION EMITTED, TAKE PURE
+C DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2
+ COSTE3 = 2.D0*RD1-1.D0
+ IF ( RD2 .GT. 1.D0-0.6D0*COSTE3**2 ) GOTO 210
+ ELSE
+C CHARGED PION EMITTED, TAKE MODIFIED DIPOLE RADIATION
+C WITH ASYMMETRY TERM 1/(1-BETACM*COSTE3)**2
+ COSTE3 = 1.D0/B3CM - 1.D0/(RD1*2.D0*B3CM2/(1.D0-B3CM2)
+ * + B3CM/(1.D0+B3CM))
+ IF ( RD2*2.5D0 .GT. 1.D0+COSTE3*(-1.8D0 + COSTE3*
+ * (.65D0 + COSTE3*(.34D0 -.18D0*COSTE3 ))) ) GOTO 210
+ ENDIF
+
+ ELSEIF ( PEIG .LE. 1300.D0 ) THEN
+C GAMMA ENERGY BETWEEN 900 AND 1300 MEV
+ 220 CONTINUE
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+ IF ( IQ(NP) .EQ. 110 ) THEN
+C NEUTRAL PION EMITTED, TAKE PURE QUADRUPOLE
+C RADIATION: W(COSTH) = 1+6*COSTH**2-5*COSTH**4
+ COSTE3 = 2.D0*RD1-1.D0
+ IF ( 2.8D0*RD2 .GT.
+ * 1.D0+6.D0*COSTE3**2-5.D0*COSTE3**4 ) GOTO 220
+ ELSE
+C CHARGED PION EMITTED, TAKE MODIFIED QUADRUPOLE
+C RADIATION WITH ASYMMETRY TERM: 1/(1-BETACM*COSTE3)**2
+ COSTE3 = 1.D0/B3CM - 1.D0/(RD1*2.D0*B3CM2/(1.D0-B3CM2)
+ * + B3CM/(1.D0+B3CM))
+ IF ( 13.2D0*RD2 .GT. 1.D0 + COSTE3*(-2.18D0 + COSTE3*(7.20D0
+ * + COSTE3*(-2.55D0 + COSTE3*(-15.39D0 + COSTE3*(6.36D0
+ * + COSTE3*(13.80D0 - COSTE3*8.235D0)))))) ) GOTO 220
+ ENDIF
+
+ ELSE
+C ABOVE 1300 MEV THE ANGULAR DISTRIBUTION IS DETERMINED
+C BY THE TRANSVERSE MOMENTUM OF THE PION
+ PT = 1.D3*CXPTRANS()
+ COSTE3 = SQRT(MAX( 0.D0, (P3CM-PT)*(P3CM+PT) )) / P3CM
+ ENDIF
+C PRECISE ENERGY OUTGOING PION = PEOP
+ PEOP = GAMMA*(E3CM+BETA*P3CM*COSTE3)
+C ENERGY OF OUTGOING PION IN STACK POSITION NP
+ E(NP) = PEOP
+ AMOM3 = SQRT(MAX( 0.D0, (PEOP-AMASS3)*(PEOP+AMASS3) ))
+ IF ( i1DEM.eq.0 .and. AMOM3 .GT. 0.D0 ) THEN
+C MOMENTUM OF OUTGOING PION = AMOM3
+C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (PION)
+C SEE SLAC-265, P. 52
+ COSTHE = (AMASS4**2 - AMASS2**2 - AMASS3**2 + 2.D0*PEOP*W0
+ * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3)
+ SINTHE = SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 2,1 )
+C TOTAL ENERGY OF RECOILING NUCLEON = ENUCL
+ ENUCL = W0-PEOP
+C TREAT THE NUCLEON
+ NP = NP+1
+ E(NP) = max(AMASS4,ENUCL)
+ IF ( i1DEM.eq.0 .and. ENUCL.gt.AMASS4) THEN
+C MOMENTUM OF RECOIL NUCLEON
+ AMOM4 = SQRT( (ENUCL-AMASS4)*(ENUCL+AMASS4) )
+C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR RECOIL NUCLEON
+C SEE SLAC-265, P. 52
+ COSTHE = (AMASS3**2 - AMASS2**2 - AMASS4**2 + 2.D0*ENUCL*W0
+ * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM4)
+ SINTHE = -SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 3,2 )
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXPIGEN1: E1,E2',E(NP-1),E(NP)
+#endif
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE CXPIGEN2
+
+C-----------------------------------------------------------------------
+C C(one)X PI(ON) GEN(ERATION) 2 (PIONS)
+C
+C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION
+C GAMMA + NUCLEON -----> PION + PION + NUCLEON
+C THIS SUBROUTINE IS CALLED FROM PIGEN.
+c-- Author : The CORSIKA development group 21/04/1994
+c Last modification : T. Pierog - 15.11.2004 - for CONEX
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ COMMON/CXEGSDEB/ifckegs,isxegs
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+
+C-----------------------------------------------------------------------
+
+
+
+ PEIG = E(NP)
+C NUMBERS AT THE VARIABLES MEAN :
+C 1 INCOMING GAMMA RAY
+C 2 HIT NUCLEON
+C 3 FIRST PRODUCED PION
+C 4 SECOND PRODUCED PION
+C 5 RECOILING NUCLEON
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+C LOOK WHICH TYPE OF REACTION
+C 0.49923 IS THE FRACTION OF PROTONS IN AIR
+ IF ( RD1 .LE. 0.49923D0 ) THEN
+C HIT NUCLEON IS PROTON
+ AMASS2 = AMSPR
+C BRANCHING FOR COLLISION WITH PROTON
+ IF ( RD2 .LE. 0.3D0 ) THEN
+C PI(0) + PI(0) + PROTON
+ IQ(NP) = 110
+ AMASS3 = PI0MS
+ IQ(NP+1) = 110
+ AMASS4 = PI0MS
+ IQ(NP+2) = 1120
+ AMASS5 = AMSPR
+ ELSEIF ( RD2 .LE. 0.6D0 ) THEN
+C PI(+) + PI(-) + PROTON
+ IQ(NP) = 120
+ AMASS3 = PICMS
+ IQ(NP+1) = -120
+ AMASS4 = PICMS
+ IQ(NP+2) = 1120
+ AMASS5 = AMSPR
+ ELSE
+C PI(+) + PI(0) + NEUTRON
+ IQ(NP) = 120
+ AMASS3 = PICMS
+ IQ(NP+1) = 110
+ AMASS4 = PI0MS
+ IQ(NP+2) = 1220
+ AMASS5 = AMSNT
+ ENDIF
+ ELSE
+C HIT NUCLEON IS NEUTRON
+C BRANCHING FOR COLLISION WITH NEUTRON
+ AMASS2 = AMSNT
+ IF ( RD2 .LE. 0.3D0 ) THEN
+C PI(0) + PI(0) + NEUTRON
+ IQ(NP) = 110
+ AMASS3 = PI0MS
+ IQ(NP+1) = 110
+ AMASS4 = PI0MS
+ IQ(NP+2) = 1220
+ AMASS5 = AMSNT
+ ELSEIF ( RD2 .LE. 0.6D0 ) THEN
+C PI(+) + PI(-) + NEUTRON
+ IQ(NP) = 120
+ AMASS3 = PICMS
+ IQ(NP+1) = -120
+ AMASS4 = PICMS
+ IQ(NP+2) = 1220
+ AMASS5 = AMSNT
+ ELSE
+C PI(-) + PI(0) + PROTON
+ IQ(NP) = -120
+ AMASS3 = PICMS
+ IQ(NP+1) = 110
+ AMASS4 = PI0MS
+ IQ(NP+2) = 1120
+ AMASS5 = AMSPR
+ ENDIF
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXPIGEN2: ID1,ID2,ID3',IQ(NP)
+ & ,IQ(NP+1),IQ(NP+2)
+#endif
+C CALCULATE AUXILIARY PARAMETERS
+ ECM = SQRT(AMASS2*(AMASS2+2.D0*PEIG))
+C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV
+C HERE ALL ENERGIES ARE USED IN MEV
+ AUX1 = (AMASS3+AMASS4)**2
+ AUX2A = (ECM - AMASS5)**2
+ AUX2 = AUX2A-AUX1
+ AUX3 = (AMASS3+AMASS5)**2
+ AUX4A = (ECM - AMASS4)**2
+ AUX4 = AUX4A-AUX3
+ AUX5 = (AMASS3-AMASS4)*(AMASS3+AMASS4)
+ AUX6 = (ECM-AMASS5)*(ECM+AMASS5)
+ AUX7 = 0.5D0/ECM
+ BETA = PEIG/(AMASS2+PEIG)
+ GAMMA = 2.D0*(PEIG+AMASS2)*AUX7
+ 230 CONTINUE
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+C ARE INVARIANT MASS SQUARES INSIDE BOUNDARY OF DALITZ PLOT?
+ AM34SQ = AUX2*RD1+AUX1
+ AM35SQ = AUX4*RD2+AUX3
+ AM34I = 0.5D0/SQRT(AM34SQ)
+ E3STAR = (AUX5+AM34SQ)*AM34I
+ E5STAR = (AUX6-AM34SQ)*AM34I
+ ROOT1 = SQRT(MAX( 0.D0, (E3STAR-AMASS3)*(E3STAR+AMASS3) ))
+ ROOT2 = SQRT(MAX( 0.D0, (E5STAR-AMASS5)*(E5STAR+AMASS5) ))
+C REJECT RANDOM NUMBERS, IF NOT INSIDE KINEMATIC BOUNDARY
+ DISCR = AM35SQ-(E3STAR+E5STAR)**2
+ IF ( DISCR .GT. -((ROOT1-ROOT2)**2) ) GOTO 230
+ IF ( DISCR .LT. -((ROOT1+ROOT2)**2) ) GOTO 230
+C E3CM,E4CM,E5CM ARE ENERGIES IN C.M. SYSTEM
+ E4CM = (ECM**2+AMASS4**2-AM35SQ)*AUX7
+ E5CM = (ECM**2+AMASS5**2-AM34SQ)*AUX7
+C NOW TAKE PION WITH HIGHEST ENERGY AS PARTICLE 3
+ E3CM = ECM-E4CM-E5CM
+ IF ( E4CM .GT. E3CM ) THEN
+C INTERCHANGE PARTICLE 3 AND 4
+ HELP = E3CM
+ E3CM = E4CM
+ E4CM = HELP
+ HELP = AMASS3
+ AMASS3 = AMASS4
+ AMASS4 = HELP
+ IHELP = IQ(NP)
+ IQ(NP) = IQ(NP+1)
+ IQ(NP+1) = IHELP
+ ENDIF
+C P3CM,P4CM,P5CM ARE MOMENTA IN C.M. SYSTEM
+C P3SQ,P4SQ,P5SQ ARE SQUARED MOMENTA IN C.M. SYSTEM
+ P3SQ = (E3CM-AMASS3)*(E3CM+AMASS3)
+ P3CM = SQRT(MAX( 0.D0, P3SQ ))
+ P4SQ = (E4CM-AMASS4)*(E4CM+AMASS4)
+ P4CM = SQRT(MAX( 0.D0, P4SQ ))
+ P5SQ = (E5CM-AMASS5)*(E5CM+AMASS5)
+ P5CM = SQRT(MAX( 0.D0, P5SQ ))
+ COSA = (P5SQ-P3SQ-P4SQ)/(2.D0*P3CM*P4CM)
+ SINA =-SQRT(MAX( 0.D0, (1.D0-COSA)*(1.D0+COSA) ))
+ COSB = (P4SQ-P3SQ-P5SQ)/(2.D0*P3CM*P5CM)
+ SINB = SQRT(MAX( 0.D0, (1.D0-COSB)*(1.D0+COSB) ))
+C NOW SELECT THE THREE INDEPENDENT ANGLES IN C.M. SYSTEM
+ PT3 = 1.D3*CXPTRANS()
+ SIN3CM = MIN( 1.D0, PT3/P3CM )
+ COS3CM = SQRT((1.D0-SIN3CM)*(1.D0+SIN3CM))
+ PSI = TWOPI*dranegs(dummy)
+ SINPSI = SIN(PSI)
+ COSPSI = COS(PSI)
+C THIRD INDEPENDENT ANGLE PHI IS CHOOSEN LATER IN SUBR. UPHI
+C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 3 (PION)
+ E(NP) = GAMMA*(E3CM+BETA*P3CM*COS3CM)
+C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (PION)
+ IF (i1DEM.eq.0) THEN
+ COSTHE = MIN((BETA*E3CM+P3CM*COS3CM)*GAMMA
+ * /SQRT(MAX(0.D0,(E(NP)-AMASS3)*(E(NP)+AMASS3) )),1.D0)
+ SINTHE = SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+C SINPHI AND COSPHI ARE NOW SET IN SUBR. UPHI
+ CALL UPHICX( 2,1 )
+ SINFI3 = SINPHI
+ COSFI3 = COSPHI
+C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 4 = PION
+ COS4CM = COS3CM*COSA-SIN3CM*COSPSI*SINA
+ NP = NP+1
+ E(NP) = GAMMA*(E4CM+BETA*P4CM*COS4CM)
+ SINT4 = SQRT(MAX( 0.D0, (1.D0-COS4CM)*(1.D0+COS4CM) ))
+ IF ( SINT4 .NE. 0.D0 ) THEN
+ SINT4I = 1.D0/SINT4
+ AUXA = COS3CM*COSPSI*SINA+SIN3CM*COSA
+C COSPHI AND SINPHI ARE IN LAB SYSTEM FOR PARTICLE 4 (PION)
+ COSPHI = (COSFI3*AUXA-SINFI3*SINPSI*SINA)*SINT4I
+ SINPHI = (SINFI3*AUXA+COSFI3*SINPSI*SINA)*SINT4I
+ ELSE
+ COSPHI = 0.D0
+ SINPHI = 1.D0
+ ENDIF
+C COSTHE AND SINTHE ARE IN LAB SYSTEM FOR PARTICLE 4 (PION)
+ IF (i1DEM.eq.0) THEN
+ COSTHE = MIN((BETA*E4CM+P4CM*COS4CM)*GAMMA
+ * /SQRT(MAX( 0.D0, (E(NP)-AMASS4)*(E(NP)+AMASS4) )),1.D0)
+ SINTHE = SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 3,2 )
+C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 5 = RECOIL NUCLEON
+ COS5CM = COS3CM*COSB-SIN3CM*COSPSI*SINB
+ ENUCL = GAMMA*(E5CM+BETA*P5CM*COS5CM)
+ NP = NP+1
+ E(NP) = max(AMASS5,ENUCL)
+ SINT5 = SQRT(MAX( 0.D0, (1.D0-COS5CM)*(1.D0+COS5CM) ))
+ IF ( SINT5 .NE. 0.D0 ) THEN
+ SINT5I = 1.D0/SINT5
+ AUXB = COS3CM*COSPSI*SINB+SIN3CM*COSB
+C COSPHI AND SINPHI ARE IN LAB SYSTEM FOR PART. 5 (NUCLEON)
+ COSPHI = (COSFI3*AUXB-SINFI3*SINPSI*SINB)*SINT5I
+ SINPHI = (SINFI3*AUXB+COSFI3*SINPSI*SINB)*SINT5I
+ ELSE
+ COSPHI = 0.D0
+ SINPHI = 1.D0
+ ENDIF
+C COSTHE AND SINTHE ARE IN LAB SYSTEM FOR PARTICLE 5 (NUCLEON)
+ IF (i1DEM.eq.0.and.ENUCL.gt.AMASS5) THEN
+ COSTHE=MIN((BETA*E5CM+P5CM*COS5CM)*GAMMA
+ * /SQRT( (ENUCL-AMASS5)*(ENUCL+AMASS5) ) , 1.D0)
+ SINTHE = SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 3,2 )
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXPIGEN2: E1,E2,E3',E(NP-2)
+ & ,E(NP-1),E(NP)
+#endif
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE CXRHOGEN
+
+C-----------------------------------------------------------------------
+C C(one)XRHO GEN(ERATION BY PHOTONUCLEAR REACTION)
+C
+C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION
+C GAMMA + NUCLEON -----> RHO + NUCLEON (90%)
+C GAMMA + NUCLEON -----> OMEGA + NUCLEON (10%)
+C HIGHER MASS VECTOR MESONS ARE OMITTED. THE RATIO FOR PRODUCTION
+C OF RHO AND OMEGA IS ASSUMED TO BE 9:1
+C LITERATURE: A. DONNACHIE & G. SHAW, ELECTROMAGNETIC INTERACTIONS OF
+C HADRONS (PLENUM PRESS, NEW YORK, 1978)
+C A. MUECKE ET AL., SOPHIA: MONTE CARLO SIMULATIONS OF
+C PHOTOHADRONIC PROCESSES IN ASTROPHYSICS,
+C COMPUT. PHYS. COMMUN. (1999) IN PRESS
+C THIS SUBROUTINE IS CALLED FROM CXPIGEN.
+c-- Author : The CORSIKA development group 21/04/1994
+c Last modification : T. Pierog - 15.11.2004 - for CONEX
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ COMMON/STACK/E(100),X(100),Y(100),Z(100),U(100),V(100),W(100),DNEA
+ *R(100),WT(100),IQ(100),IR(100),LATCH(100),LATCHI, NP
+ COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
+ COMMON/CRMUPI/PRRMMU,RMMUT2,PITHR,PICMS,PI0MS,AMSPR,AMSNT
+ common/cx1dem/i1DEM,imscat,ionloss !also in conex.h
+ COMMON/CXEGSDEB/ifckegs,isxegs
+
+C-----------------------------------------------------------------------
+
+ PEIG = E(NP)
+C NUMBERS AT THE VARIABLES MEAN :
+C 1 INCOMING GAMMA RAY
+C 2 HIT NUCLEON
+C 3 PRODUCED MESON
+C 4 RECOILING NUCLEON
+C LOOK WHICH TYPE OF REACTION
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+ RD3=dranegs(dummy3)
+C 0.49923 IS THE FRACTION OF PROTONS IN AIR
+ IF ( RD1 .LE. 0.49923D0 ) THEN
+C HIT NUCLEON IS PROTON
+ IQ(NP+1) = 1120
+ AMASS2 = AMSPR
+ ELSE
+C HIT NUCLEON IS NEUTRON
+ IQ(NP+1) = 1220
+ AMASS2 = AMSNT
+ ENDIF
+ AMAS2I = 1.D0/AMASS2
+ AMAS2S = AMASS2**2
+ AMASS4 = AMASS2
+ IF ( RD2 .LT. 0.1D0 ) THEN
+C PRESENTLY WE ARE ONLY TAKING INTO ACCOUNT RHO AND OMEGA MESON.
+C PHI MESON IS NEGLECTED
+C 10% CHANCE FOR OMEGA MESON
+ IQ(NP) = 221
+ ELSE
+C GENERATED MESON IS RHO(0)
+ IQ(NP) = 111
+ ENDIF
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXRHOGEN: ID1,ID2',IQ(NP)
+ & ,IQ(NP+1)
+#endif
+ call cxidmass(IQ(NP),AMASS3)
+C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CONEX IN GEV
+ AMASS3 = AMASS3*1.D3
+C TOTAL LABORATORY ENERGY AND ITS INVERSE
+ W0 = PEIG+AMASS2
+ W0I = 1.D0/W0
+C TOTAL.C.M. ENERGY AND INVERSE OF TOTAL C.M.ENERGY
+ W0S = SQRT(AMASS2*(AMASS2+2.D0*PEIG))
+ W0SI = 1.D0/W0S
+C THRESHOLD ENERGY
+ ETH = 0.5D0*((AMASS3+AMASS4)**2-AMAS2S)*AMAS2I
+C BETA, GAMMA, ESQ, G3 ARE AUXILIARY QUANTITIES
+ BETA = PEIG*W0I
+ GAMMA = W0*W0SI
+ ED = 0.5D0*((AMASS3-AMASS4)**2-AMAS2S)*AMAS2I
+ ESQ = SQRT((PEIG-ETH)*(PEIG-ED))
+ G3 = W0I*(PEIG-ETH+AMASS3*AMAS2I*(AMASS3+AMASS4))
+C C.M. ENERGY OF MESON
+ E3CM = G3*AMASS2*GAMMA
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C THE FOLLOWING SELECTION OF TRANSFERRED MOMENTUM IS IN ANALOGY WITH
+C PROGRAM SOPHIA (SUBROUT. GAMMA_H OF R. ENGEL). ANGULAR DISTRIBUTION
+C IS ACCORDING D(SIGMA)/DT = EXP( B_DIFFRACTIVE * T)
+C WITH B_DIFFRACTIVE = 8 GEV^-2 = 8*10-6 [MEV^-2]
+ BDIFF = 8.D-6
+C AUXILIAR QUANTITIES AUX3, E2, E4, PCM2, PCM4
+ AUX3 = 0.5D0 * AMASS3**2 * W0SI
+ E2 = 0.5D0 * (W0S + AMAS2S * W0SI)
+ E4 = E2 - AUX3
+ PCM2 = SQRT( (E2-AMASS2)*(E2+AMASS2) )
+ PCM4 = SQRT( (E4-AMASS2)*(E4+AMASS2) )
+C BOUNDARIES FOR MOMENTUM TRANSFER TMIN AND TMAX
+ TMIN = AUX3**2 - (PCM2 + PCM4)**2
+ TMAX = AUX3**2 - (PCM2 - PCM4)**2
+#ifdef __CXDEBUG__
+ IF(isxegs.ge.6)WRITE(ifckegs,*)
+ * 'RHOGEN: E2,E4,PCM2,PCM4,TMIN,TMAX=',
+ * SNGL(E2*0.001),SNGL(E4*0.001),SNGL(PCM2*0.001),
+ * SNGL(PCM4*0.001),SNGL(TMIN*0.001),SNGL(TMAX*0.001)
+#endif
+C SELECT THE MOMENTUM TRANSFER T BY CHANCE
+ T = RD3*(EXP(BDIFF*TMAX)-EXP(BDIFF*TMIN))+EXP(BDIFF*TMIN)
+ T = LOG(T) / BDIFF
+C KINEMATIC CALCULATION OF LONGITUDINAL MOMENTUM
+ PLNG3 = (E2*E4 + 0.5D0*T - AMAS2S) / PCM2
+ PLNG3 = ABS(PLNG3)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C PRECISE ENERGY OUTGOING MESON = PEOM
+ PEOM = GAMMA*(E3CM+BETA*PLNG3)
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'RHOGEN: RD,T,PLNG3,PEOM=',
+ * SNGL(RD3),SNGL(T),SNGL(PLNG3),SNGL(PEOM)
+#endif
+C ENERGY OF OUTGOING MESON IN STACK POSITION NP
+ E(NP) = PEOM
+C MOMENTUM OF OUTGOING MESON IS AMOM3
+C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (MESON)
+C SEE SLAC-265, P. 52
+ AMOM3 = SQRT(MAX( 0.D0, (PEOM-AMASS3)*(PEOM+AMASS3) ))
+ IF ( i1DEM.eq.0 .and. AMOM3 .GT. 0.D0 ) THEN
+ COSTHE = (AMASS4**2 - AMAS2S - AMASS3**2 + 2.D0*PEOM*W0
+ * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3)
+ SINTHE = SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 2,1 )
+C TOTAL ENERGY OF RECOILING NUCLEON ( = ENUCL)
+ ENUCL = max(AMASS4,W0-PEOM) !?????????? tp to avoid precision problem
+ NP = NP+1
+ E(NP) = ENUCL
+ IF (i1DEM.eq.0.and.ENUCL.gt.AMASS4) THEN
+C RECOIL ENERGY IS TOO LARGE, MUST TREAT THE NUCLEON
+C MOMENTUM OF RECOIL NUCLEON
+ AMOM4 = SQRT( (ENUCL-AMASS4)*(ENUCL+AMASS4) )
+C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR RECOIL NUCLEON
+C SEE SLAC-265, P. 52
+ COSTHE = (AMASS3**2 - AMAS2S - AMASS4**2 + 2.D0*ENUCL*W0
+ * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM4)
+ SINTHE = -SQRT(MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ))
+ ELSE
+ COSTHE = 1.D0
+ SINTHE = 0.D0
+ ENDIF
+ CALL UPHICX( 3,2 )
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#ifdef __CXDEBUG__
+ IF (isxegs.ge.6) WRITE(ifckegs,*) 'CXRHOGEN: E1,E2',E(NP-1),E(NP)
+#endif
+
+ RETURN
+ END
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXPTRANS()
+
+C-----------------------------------------------------------------------
+C C(one)X P(ion) TRANS(VERSE MOMENTUM)
+C
+C RANDOM SELECTION OF TRANSVERSE MOMENTUM
+C DISTRIBUTION IS OF FORM X*EXP(-X)
+C THIS FUNCTION IS CALLED FROM CXPIGEN1, CXPIGEN2.
+c-- Author : The CORSIKA development group 21/04/1994
+c Last modification : T. Pierog - 15.11.2004 - for CONEX
+C-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+ COMMON/CXEGSDEB/ifckegs,isxegs
+
+ save GX,HX,FIRST
+ dimension GX(0:50),HX(0:50)
+ LOGICAL FIRST
+C DX IS STEPSIZE FOR APPROXIMATING CURVE
+ DATA FIRST / .TRUE. /, DX / 0.5D0 /, C34 / 2.D1 /
+C-----------------------------------------------------------------------
+
+C COMPUTE FUNCTION VALUES AND INTEGRAL OF STEP FUNCTION H(X)
+C APPROXIMATING Y(X) = X * EXP(1-X) WITH H(X) > Y(X)
+ IF ( FIRST ) THEN
+ FIRST = .FALSE.
+ IMAX = int ( C34 / DX )
+ GX(0) = 0.D0
+ HX(0) = DX*EXP(1.D0-DX)
+ DO I = 1, IMAX
+ X = I*DX
+ IF ( X .LT. 1.D0 ) X = X + DX
+ HX(I) = X*EXP(1.D0-X)
+ GX(I) = GX(I-1) + HX(I-1)
+ ENDDO
+ SUMI = 1.D0 / GX(IMAX)
+ DO I = 1, IMAX
+ GX(I) = GX(I) * SUMI
+ ENDDO
+ ENDIF
+
+C-----------------------------------------------------------------------
+C GET RANDOM VARIABLE DISTRIBUTED AS HX(X)
+ 11 CONTINUE
+ RD1=dranegs(dummy1)
+ RD2=dranegs(dummy2)
+ I = 0
+ 1 CONTINUE
+ I = I+1
+ IF ( GX(I) .LT. RD1 ) GOTO 1
+ XX = ( (RD1-GX(I-1))/(GX(I)-GX(I-1)) + I-1 ) * DX
+ ZZ = HX(I-1)
+C GET RANDOM VARIABLE DISTRIBUTED AS Y(X) BY REJECTION METHOD
+ TT = XX * EXP(1.D0-XX)
+ IF ( RD2*ZZ .GT. TT ) GOTO 11
+
+C GET REQUIRED PEAK VALUE
+ CXPTRANS = XX * 0.1d0
+#ifdef __CXDEBUG__
+ IF ( isxegs.ge.7 ) WRITE(ifckegs,*) 'CXPTRANS: PT = '
+ & ,SNGL(CXPTRANS)
+#endif
+
+ RETURN
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE CXLPMEFFECT(E0,E1,E2,ALT,FPAIR,FPASS)
+
+C-----------------------------------------------------------------------
+C C(one)X L(ANDAU-)P(OMARANCHUK-)M(IGDAL-)EFFECT
+C
+C PERFORMS LPM-CHECK AND REJECTION
+C REFERENCES: A.B.MIGDAL, PHYS.REV.103 (1956) 1811
+C E. KONISHI ET AL., J.PHYS.G:NUCL.PART.PHYS. 17(1991)719
+C D. HECK, J. KNAPP, FZKA 6097 (1998)
+C THIS SUBROUTINE IS CALLED FROM AUSGAB IN EGS4
+C ARGUMENTS: (ENERGIES IN MEV)
+C PAIR BREMS
+C E0 = ENERGY OF PHOTON ENERGY OF PHOTON
+C E1 = ENERGY OF ELECTRON/POSITRON ENERGY OF PRIM. ELECTRON
+C E2 = ENERGY OF ELECTRON/POSITRON ENERGY OF SECD. ELECTRON
+C ALT = ALTITUDE OF PARTICLE (M)
+C FPAIR = FLAG INDICATING PAIR (TRUE) OR BREMS (FALSE) EVENT
+C FPASS = FLAG INDICATING THAT PAIR/BREMS EVENT SHOULD BE SKIPPED
+C TRUE=interaction should be skipped
+C last modification : 15.09.2004 by T. Pierog. This subroutine comes from
+C CORSIKA test version 6.176.
+C-----------------------------------------------------------------------
+
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ LOGICAL FPAIR,FPASS
+ EXTERNAL rhoair,dranegs
+C CONLPM IS (1.3710*10**3)**2 * RAD.LENGTH(AIR)*(ELECTR.REST MASS) *100 (from rho in m)
+C UNITS ARE (/CM) (CM) (MEV) (rhoair in g/(cm^2 m) )
+C WE TAKE THE RADIATION LENGTH IN (G/CM**2) AND DIVIDE BY PRESSURE
+C SEE MIGDAL EQ. (60) OR KONISHI EQ. (7) & (8)
+ DATA CONLPM /3.5156D9/ !(origin : 3.5156D7)
+C WE DERIVE: FOVERZLOG = -1/( LN(S1SQLPM) ) = 5.4513722D-2
+ DATA FOVERZLOG /5.4513722D-2/
+C WE USE S1SQLPM = S1**2 = ( Z**(1/3) / 190 )**4 = 1.0796917D-8
+ DATA S1SQLPM /1.0796917D-8/
+C-----------------------------------------------------------------------
+
+ FPASS = .FALSE.
+C SEE MIGDAL, EQ. (47)
+ SSQ = CONLPM * E0 / (E1 * E2 * RHOAIR(ALT) )
+ IF ( SSQ .LT. 1.D0 ) THEN
+C LPM EFFECT IS SIGNIFICANT
+#ifdef __CXDEBUG__
+ IF (ISX.GE.5)
+ * WRITE(IFCK,1) E0*.001D0,E1*.001D0,E2*.001D0,ALT,FPAIR
+ 1 FORMAT(' LPMEFF: E0,E1,E2,ALT,FPAIR= ',1P,4E10.3,L2)
+#endif
+ IF ( SSQ .LT. S1SQLPM ) THEN
+C SEE MIGDAL, EQ. (58)
+ XI = 2.D0
+ ELSE
+ XI = 1.D0 - FOVERZLOG * LOG(SSQ)
+ ENDIF
+ SSQ = SSQ / XI
+ S = SQRT(SSQ)
+ IF ( S .LT. 0.1D0 ) THEN
+C SEE MIGDAL, EQ.(46) AND (47)
+ GLPM = SSQ * ( 14.1D0 + 2.36D0 / (S + 0.1D0) )
+ PHII = 6.D0 * S - 16.D0 * SSQ
+ ELSE
+ GLPM = SSQ * ( 24.D0 + 0.0394D0 / ( S - 0.08D0) )
+ PHII = 6.D0 * S + 24.D0 * SSQ *
+ * (PI * 0.25D0 - ATAN( 0.944D0 + 0.59D0/S ) )
+ ENDIF
+ GLPM = GLPM / ( 1.D0 + GLPM)
+ EGSQ = E0**2
+ AB = 4.D0 * E1 * E2
+C SEE MIGDAL, EQ.(61) AND (63)
+ IF ( FPAIR ) THEN
+ AB = -AB
+ ENDIF
+ F = XI*( EGSQ*(GLPM+2.D0*PHII) + PHII*AB )/(3.D0*EGSQ+AB)
+ IF ( DRANEGS(dummy) .GT. F ) FPASS = .TRUE.
+#ifdef __CXDEBUG__
+ IF (ISX.GE.5) WRITE(IFCK,*) 'LPMEFF: FPASS= ',FPASS
+#endif
+ ENDIF
+
+ RETURN
+ END
+
+#ifndef __CXCORSIKA__
+*-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007
+C=======================================================================
+
+ SUBROUTINE CONEXPRM(Xfirsti)
+
+C-----------------------------------------------------------------------
+C CONEX PR(I)M(ARY)
+C
+C THIS SUBROUTINE IS CALLED FROM CONEX TO RECORD THE FIRST
+C INTERACTION
+C-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION Xfirsti,dum
+C-----------------------------------------------------------------------
+ dum=Xfirsti
+ END
+
+#endif
diff --git a/Processes/CONEXSourceCut/conex_mod8.F b/Processes/CONEXSourceCut/conex_mod8.F
new file mode 100644
index 000000000..70e7a8b5b
--- /dev/null
+++ b/Processes/CONEXSourceCut/conex_mod8.F
@@ -0,0 +1,7188 @@
+c Preprocessed Standard Conex subroutine in 2 file s
+c conex_mod8.F for all hadronic model independent part of Conex
+c (conex_cors8.F for all hadronic model independent part of Conex)
+c Utilities routines
+c (created by K. Werner; updated by S. Ostapchenko, T. Pierog,
+c V. Chernatkin and D. Heck (Corsika parts))
+c Last modifications 03.07.2020 adapt to CORSIKA8 by T.Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+ subroutine IniModel(model)
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+ if(model.eq.1.or.(ilowegy.eq.1.and.MCleModel.eq.1)) then
+#ifndef __NEXUS__
+ stop'please compile with requested model'
+#else
+ call IniNexus
+#endif
+ endif
+ if(model.eq.2.or.(ilowegy.eq.1.and.MCleModel.eq.2)) then
+#ifndef __QGSJET__
+ stop'please compile with requested model'
+#else
+ call IniQGSjet
+#endif
+ endif
+ if(ilowegy.eq.1.and.MCleModel.eq.3) then
+#ifndef __GHEISHA__
+ stop'please compile with requested model'
+#else
+ call IniGheisha
+#endif
+ endif
+ if(model.eq.4.or.(ilowegy.eq.1.and.MCleModel.eq.4)) then
+#ifndef __EPOS__
+ stop'please compile with requested model'
+#else
+ call IniEpos
+#endif
+ endif
+ if(model.eq.5) then
+#ifndef __SIBYLL21__
+ stop'please compile with requested model'
+#else
+ call IniSibyll
+#endif
+ endif
+ if(model.eq.6.or.(ilowegy.eq.1.and.MCleModel.eq.6)) then
+#ifndef __QGSJETII__
+ stop'please compile with requested model.'
+#else
+ call IniQGSJetII
+#endif
+ endif
+ if(ilowegy.eq.1.and.MCleModel.eq.7) then
+#ifndef __FLUKA__
+ stop'please compile with requested model'
+#else
+ call IniFluka
+#endif
+ endif
+ if(ilowegy.eq.1.and.MCleModel.eq.8) then
+#ifndef __FLUKA__
+ stop'please compile with requested model'
+#else
+ call IniUrQMD
+#endif
+ endif
+ if(model.eq.9.or.(ilowegy.eq.1.and.MCleModel.eq.9)) then
+#ifndef __DPMJET__
+ stop'please compile with requested model'
+#else
+ call IniDPMJET
+#endif
+ endif
+
+ end
+
+ subroutine IniEvtModel(model)
+c additional initialization procedure for neXus
+
+#ifdef __NEXUS__
+ if(model.eq.1)then
+ call IniEvtNex
+ endif
+#endif
+
+c additional initialization procedure for QGSjet
+#ifdef __QGSJET__
+ if(model.eq.2)then
+ call IniEvtQGS
+ endif
+#endif
+
+c additional initialization procedure for GHEISHA
+
+#ifdef __GHEISHA__
+ if(model.eq.3)then
+ call IniEvtGhe
+ endif
+#endif
+
+c additional initialization procedure for EPOS
+
+#ifdef __EPOS__
+ if(model.eq.4)then
+ call IniEvtEpo
+ endif
+#endif
+
+c additional initialization procedure for SIBYLL
+
+#ifdef __SIBYLL21__
+ if(model.eq.5)then
+ call IniEvtSib
+ endif
+#endif
+
+c additional initialization procedure for QGSjet
+#ifdef __QGSJETII__
+ if(model.eq.6)then
+ call IniEvtQGSII
+ endif
+#endif
+
+#ifdef __FLUKA__
+ if(model.eq.7)then
+ call IniEvtFlu
+ endif
+#endif
+
+#ifdef __URQMD__
+ if(model.eq.8)then
+ call IniEvtUrq
+ endif
+#endif
+
+#ifdef __DPMJET__
+ if(model.eq.9)then
+ call IniEvtDPM
+ endif
+#endif
+
+ end
+
+ subroutine emsModel(modelxs,iret)
+ implicit none
+ integer modelxs,iret
+#ifdef __NEXUS__
+ if(modelxs.eq.1)call emsnex(iret) !nexus
+#endif
+#ifdef __QGSJET__
+ if(modelxs.eq.2)call emsqgs(iret) !QGSjet
+#endif
+#ifdef __GHEISHA__
+ if(modelxs.eq.3)call emsghe(iret) !GHEISHA
+#endif
+#ifdef __EPOS__
+ if(modelxs.eq.4)call emsepo(iret) !EPOS
+#endif
+#ifdef __SIBYLL21__
+ if(modelxs.eq.5)call emssib(iret) !SIBYLL
+#endif
+#ifdef __QGSJETII__
+ if(modelxs.eq.6)call emsqgsII(iret) !QGSjet-II
+#endif
+#ifdef __FLUKA__
+ if(modelxs.eq.7)call emsflu(iret) !FLUKA
+#endif
+#ifdef __URQMD__
+ if(modelxs.eq.8)call emsurq(iret) !URQMD
+#endif
+#ifdef __DPMJET__
+ if(modelxs.eq.9)call emsdpm(iret) !DPMJET
+#endif
+ end
+
+
+ subroutine MODELSIGMA(model,np,ek,am,Siginemb)
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conexep.h"
+#include "conex.incnex"
+ Siginemb=0d0
+ e=ek
+ et=ek+am
+ pl=sqrt(max(0.d0,(et+am)*(et-am)))
+ if(model.eq.0)then !mixed model
+#ifdef __MODEL__
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ endif
+ call EPOSIGMA(Ipar,e,Siginemb1) !EPOS cs called with kinetic energy
+ call QGSSIGMAII(Ipar,et,Siginemb2) !qgsjet-II cs called with total energy
+ Siginemb=0.5*(Siginemb1+Siginemb2)
+#else
+ stop'please compile with requested model (MODELSIGMA)'
+#endif
+#ifdef __NEXUS__
+ elseif(model.eq.1)then !neXus
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ endif
+ call NXSSIGMA(Ipar,e,Siginemb) !nexus cs called with kinetic energy
+#endif
+#ifdef __QGSJET__
+ elseif(model.eq.2)then !QGSJet
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ endif
+ call QGSSIGMA(Ipar,et,Siginemb) !qgsjet cs called with total energy
+#endif
+#ifdef __GHEISHA__
+ elseif(model.eq.3)then !Gheisha
+ Ipar=np
+ if(np.eq.6)Ipar=2
+ if(np.eq.7)Ipar=1
+ call GHESIGMA(Ipar,e,Siginemb,SIGEL) !Gheisha cs called with kinetic energy
+#endif
+#ifdef __EPOS__
+ elseif(model.eq.4)then !EPOS
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ endif
+ call EPOSIGMA(Ipar,e,Siginemb) !EPOS cs called with kinetic energy
+#endif
+#ifdef __SIBYLL21__
+ elseif(model.eq.5)then !Sibyll
+ Ipar=np
+ call SIBSIGMA(Ipar,et,Siginemb) !Sibyll cs called with total energy
+#endif
+#ifdef __QGSJETII__
+ elseif(model.eq.6)then !QGSJet-II
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ endif
+ call QGSSIGMAII(Ipar,et,Siginemb) !qgsjet-II cs called with total energy
+#endif
+#ifdef __FLUKA__
+ elseif(model.eq.7)then !FLUKA
+ pl=sqrt(max(0.d0,(et+am)*(et-am)))
+ Ipar=np
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ endif
+ call FLUSIGMA(Ipar,e,pl,Siginemb) !FLUKA cs called with kinetic energy and momentum
+#endif
+#ifdef __URQMD__
+ elseif(model.eq.8)then !URQMD
+ Ipar=np
+ call URQSIGMA(Ipar,e,Siginemb) !URQMD cs called with kinetic energy
+#endif
+#ifdef __DPMJET__
+ elseif(model.eq.9)then !DPMJET
+ iclproxs=2 !nucleons
+ if(np.eq.2.or.np.eq.6)then
+ iclproxs=1 !pions
+ Ipar=2
+ elseif(np.ge.3.and.np.le.5)then
+ iclproxs=3 !kaons
+ Ipar=3
+ elseif(np.eq.7)then
+ Ipar=1
+ else
+ Ipar=np
+ endif
+ call DPMSIGMA(Ipar,e,Siginemb) !DPMJET cs called with kinetic energy
+#endif
+ else
+ stop'please compile with requested model (MODELSIGMA)'
+ endif
+ end
+
+
+#ifdef __NEXUS__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE NXSSIGMA(Ipar,Ekin,SIGINEL)
+C-----------------------------------------------------------------------
+C neXus3 cross sections (RE 06/03)
+C
+C input: Ipar 1 p/n-air
+C 2 pi-air
+C 3 K-air
+C >10 nucleus (A=Ipar/10) - air
+C Ekin projectile kinetic energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+
+
+ if(Ipar.le.3)then
+
+ SIGINEL = cxnxscrse(Ekin,1,0,0)
+
+ elseif(Ipar.ge.10)then !Nucleus
+
+ ma=Ipar/10
+ SIGINEL = cxnxscrse(Ekin,ma,0,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No neXus cross section for this particle'
+
+ endif
+
+
+ END
+#endif
+
+#ifdef __QGSJET__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE QGSSIGMA(Ipar,Etot,SIGINEL)
+C-----------------------------------------------------------------------
+C QGSjet03 cross sections (RE 06/03)
+C
+C input: Ipar 1 p/n-air
+C 2 pi-air
+C 3 K-air
+C >10 nucleus (A=Ipar/10) - air
+C Etot projectile total energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+
+ if(Ipar.le.3)then
+
+ SIGINEL = qgscrse(Etot,1,0,0)
+
+ else if(Ipar.ge.10)then !Nucleus
+
+ ma=Ipar/10
+ SIGINEL = qgscrse(Etot,ma,0,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No QGSJet cross section for this particle'
+
+ endif
+
+ END
+
+#endif
+
+#ifdef __GHEISHA__
+C-----------------------------------------------------------------------
+ SUBROUTINE GHESIGMA(Idi,Ekin,SIGINEL,SIGEL)
+C-----------------------------------------------------------------------
+C Gheisha cross sections (RE 06/03)
+C
+C input: Id 1 p/n-air
+C 2 pi-air ((pip+pim)/2)
+C 3 K-air ((Kp+Km)/2)
+C 4 Kl-air
+C 5 Ks-air
+C >10 nucleus (A=Ipar/10) - air
+C Ekin projectile kinetic energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C (iquasiel=0 : without quasi-elastic, iquasiel=1, with)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ common/ghecsquel/anquasiel,iquasiel
+ real anquasiel
+ real GHETABCX(0:10,21)
+ data (GHETABCX(0,k),k=1,21) /
+ & 0.255860E+03,0.281492E+03,0.295567E+03,0.144902E+03,0.224367E+03
+ & ,0.243389E+03,0.163012E+03
+ & ,0.255860E+03,33.9845428,37.1037254,18.7059803,32.0806122
+ & ,33.2575989,22.2932968
+ & ,0.176698E+03,0.133947E+03,0.133947E+03,0.779889E+02,0.728328E+02
+ & ,0.726277E+02,0.778469E+02 /
+ data (GHETABCX(1,k),k=1,21) /
+ & 0.258983E+03,0.266648E+03,0.279980E+03,0.141426E+03,0.234702E+03
+ & ,0.254316E+03,0.159121E+03
+ & ,177.488327,21.369585,24.2307854,8.23070812,22.1758099
+ & ,21.7302551,11.6256256
+ & ,0.156630E+03,0.139122E+03,0.139122E+03,0.655561E+02,0.612038E+02
+ & ,0.611662E+02,0.654509E+02 /
+ data (GHETABCX(2,k),k=1,21) /
+ & 0.267444E+03,0.263215E+03,0.276376E+03,0.142543E+03,0.236345E+03
+ & ,0.255972E+03,0.160372E+03
+ & ,0.79815197,3.7912941,4.9971962,1.24174988,3.74159217
+ & ,5.56045818,2.3606503
+ & ,0.144324E+03,0.132730E+03,0.574985E+03,0.607903E+02,0.572235E+02
+ & ,0.571501E+02,0.574256E+02 /
+ data (GHETABCX(3,k),k=1,21) /
+ & 0.277400E+03,0.259933E+03,0.272929E+03,0.143490E+03,0.227779E+03
+ & ,0.297157E+03,0.161437E+03
+ & ,1.07984018,2.40868378,1.89947307,0.138723105,1.1398896
+ & ,0.499438465,0.820548415
+ & ,0.129844E+03,0.119041E+03,0.119041E+03,0.504331E+02,0.505850E+02
+ & ,0.505178E+02,0.503575E+02 /
+ data (GHETABCX(4,k),k=1,21) /
+ & 0.280586E+03,0.256632E+03,0.269463E+03,0.144764E+03,0.262507E+03
+ & ,0.236638E+03,0.162875E+03
+ & ,1.35714746,1.60609698,1.82574916,0.421879053,0.650433302
+ & ,0.971257389,0.646709323
+ & ,0.122093E+03,0.106377E+03,0.106377E+03,0.445833E+02,0.439863E+02
+ & ,0.439316E+02,0.445313E+02 /
+ data (GHETABCX(5,k),k=1,21) /
+ & 0.280586E+03,0.252974E+03,0.265623E+03,0.146090E+03,0.211412E+03
+ & ,0.228997E+03,0.164368E+03
+ & ,0.825052261,0.267928243,1.04222524,0.734463155,1.49724424
+ & ,0.232366323,0.334274232
+ & ,0.116319E+03,0.939736E+02,0.939736E+02,0.398568E+02,0.388705E+02
+ & ,0.388460E+02,0.398301E+02 /
+ data (GHETABCX(6,k),k=1,21) /
+ & 0.280586E+03,0.246789E+03,0.259129E+03,0.146254E+03,0.208417E+03
+ & ,0.225764E+03,0.164535E+03
+ & ,0.554720938,0.262696952,0.516794324,0.285888463,0.411290705
+ & ,0.,0.33578822
+ & ,0.109096E+03,0.868448E+02,0.868448E+02,0.358476E+02,0.355725E+02
+ & ,0.355502E+02,0.358203E+02 /
+ data (GHETABCX(7,k),k=1,21) /
+ & 0.280586E+03,0.244759E+03,0.256997E+03,0.150972E+03,0.211365E+03
+ & ,0.228963E+03,0.169843E+03
+ & ,0.,0.,0.,0.,0.,0.,0.
+ & ,0.107451E+03,0.849422E+02,0.849422E+02,0.326919E+02,0.334941E+02
+ & ,0.334845E+02,0.326771E+02 /
+ data (GHETABCX(8,k),k=1,21) /
+ & 0.280586E+03,0.206607E+03,0.216938E+03,0.158192E+03,0.197834E+03
+ & ,0.214317E+03,0.177968E+03
+ & ,0.,0.,0.,0.,0.,0.,0.
+ & ,0.918145E+02,0.637644E+02,0.637644E+02,0.243442E+02,0.231964E+02
+ & ,0.231947E+02,0.243439E+02 /
+ data (GHETABCX(9,k),k=1,21) /
+ & 0.280586E+03,0.205548E+03,0.215825E+03,0.165259E+03,0.191394E+03
+ & ,0.207343E+03,0.185917E+03
+ & ,0.,0.,0.,0.,0.,0.,0.
+ & ,0.872840E+02,0.525249E+02,0.525249E+02,0.229987E+02,0.194206E+02
+ & ,0.194205E+02,0.229985E+02 /
+ data (GHETABCX(10,k),k=1,21) /
+ & 0.280586E+03,0.204708E+03,0.214943E+03,0.178999E+03,0.188278E+03
+ & ,0.203968E+03,0.201374E+03
+ & ,0.,0.,0.,0.,0.,0.,0.
+ & ,0.834731E+02,0.370992E+02,0.370992E+02,0.197360E+02,0.185518E+02
+ & ,0.185518E+02,0.197360E+02 /
+ SAVE
+
+
+ Id=Idi
+ if(Id.eq.100)Id=1
+
+ if(Id.le.5)then
+
+ Ipar=Id
+ if(Ekin.ge.3.7d0)then
+ al = log(Ekin/3.7037d0)/1.098612289d0 !ln(Ekin/3.7037)/ln(3) (4 bins between 3.7 and 100 Gev)
+ al = al+7.d0
+ i1 = int(al)
+ else
+ al = log(Ekin)/0.18310205d0 !ln(Ekin)/ln(3)/6 (7 bins between 1 and 3 Gev)
+ i1 = int(al)
+ endif
+ if(i1.lt.0) then
+ i1 = 0
+ else if(i1.gt.9) then !crazy xs above 100 GeV
+ i1 = 9
+ endif
+ i2 = i1+1
+ dl =min(1.d0, al - i1)
+ dl1=max(0.d0,1.d0-dl)
+
+
+ if(iquasiel.eq.0)then
+
+c Inelastic = Inelastic from gheisha - quasi-elastic !
+
+ if(Ipar.eq.1)then
+ SIGINEL = dble(GHETABCX(i2,Ipar)-GHETABCX(i2,Ipar+7))*dl
+ & + dble(GHETABCX(i1,Ipar)-GHETABCX(i1,Ipar+7))*dl1
+ SIGEL = dble(GHETABCX(i2,Ipar+14))*dl + dble(GHETABCX(i1,Ipar+14))
+ & *dl1
+ elseif(Ipar.eq.2)then
+ SIGINEL = 0.5d0*(dble(GHETABCX(i2,Ipar)+GHETABCX(i2,Ipar+1)
+ & -GHETABCX(i2,Ipar+7)-GHETABCX(i2,Ipar+8))*dl
+ & + dble(GHETABCX(i1,Ipar)+GHETABCX(i1,Ipar+1)
+ & -GHETABCX(i1,Ipar+7)-GHETABCX(i1,Ipar+8))*dl1)
+ SIGEL = 0.5d0*(dble(GHETABCX(i2,Ipar+14)+GHETABCX(i2,Ipar+15))*dl
+ & + dble(GHETABCX(i1,Ipar+14)+GHETABCX(i1,Ipar+15))*dl1)
+ elseif(Ipar.eq.3)then
+ SIGINEL = 0.5d0*(dble(GHETABCX(i2,Ipar+1)+GHETABCX(i2,Ipar+2)
+ & -GHETABCX(i2,Ipar+8)-GHETABCX(i2,Ipar+9))*dl
+ & + dble(GHETABCX(i1,Ipar+1)+GHETABCX(i1,Ipar+2)
+ & -GHETABCX(i1,Ipar+8)-GHETABCX(i1,Ipar+9))*dl1)
+ SIGEL = 0.5d0*(dble(GHETABCX(i2,Ipar+15)+GHETABCX(i2,Ipar+16))*dl
+ & + dble(GHETABCX(i1,Ipar+15)+GHETABCX(i1,Ipar+16))*dl1)
+ elseif(Ipar.ge.4)then
+ Ipar=Ipar+2
+ SIGINEL = dble(GHETABCX(i2,Ipar)-GHETABCX(i2,Ipar+7))*dl
+ & + dble(GHETABCX(i1,Ipar)-GHETABCX(i1,Ipar+7))*dl1
+ SIGEL = dble(GHETABCX(i2,Ipar+14))*dl + dble(GHETABCX(i1,Ipar+14))
+ & *dl1
+ endif
+
+ else
+
+c Inelastic = Inelastic from gheisha !
+
+ if(Ipar.eq.1)then
+ SIGINEL = dble(GHETABCX(i2,Ipar))*dl
+ & + dble(GHETABCX(i1,Ipar))*dl1
+ SIGEL = dble(GHETABCX(i2,Ipar+14))*dl + dble(GHETABCX(i1,Ipar+14))
+ & *dl1
+ elseif(Ipar.eq.2)then
+ SIGINEL = 0.5d0*(dble(GHETABCX(i2,Ipar)+GHETABCX(i2,Ipar+1)
+ & )*dl
+ & + dble(GHETABCX(i1,Ipar)+GHETABCX(i1,Ipar+1)
+ & )*dl1)
+ SIGEL = 0.5d0*(dble(GHETABCX(i2,Ipar+14)+GHETABCX(i2,Ipar+15))*dl
+ & + dble(GHETABCX(i1,Ipar+14)+GHETABCX(i1,Ipar+15))*dl1)
+ elseif(Ipar.eq.3)then
+ SIGINEL = 0.5d0*(dble(GHETABCX(i2,Ipar+1)+GHETABCX(i2,Ipar+2)
+ & )*dl
+ & + dble(GHETABCX(i1,Ipar+1)+GHETABCX(i1,Ipar+2)
+ & )*dl1)
+ SIGEL = 0.5d0*(dble(GHETABCX(i2,Ipar+15)+GHETABCX(i2,Ipar+16))*dl
+ & + dble(GHETABCX(i1,Ipar+15)+GHETABCX(i1,Ipar+16))*dl1)
+ elseif(Ipar.ge.4)then
+ Ipar=Ipar+2
+ SIGINEL = dble(GHETABCX(i2,Ipar))*dl
+ & + dble(GHETABCX(i1,Ipar))*dl1
+ SIGEL = dble(GHETABCX(i2,Ipar+14))*dl + dble(GHETABCX(i1,Ipar+14))
+ & *dl1
+ endif
+
+ endif
+
+ else !Nucleus
+
+ if(Id.eq.10)then !nucleon
+ Ipar=1120
+ elseif(Id.eq.20)then !deuterium
+ Ipar=17
+ elseif(Id.eq.30)then !tritium
+ Ipar=18
+ elseif(Id.eq.40)then !alpha
+ Ipar=19
+ else !should not be call (no cs for nucleus in gheisha)
+ write(*,*)'Nucleus-air cross section request for Gheisha !!!'
+ &,id,Ekin
+ write(*,*)'Energy too low for nucleus primary collision ...'
+ siginel=1e-30
+ sigel=1e-30
+ return
+ endif
+
+ call ghecrse(Ekin,Ipar,0,7,14,sigi,sige)
+ SIGINEL = sigi
+ SIGEL = sige
+
+ endif
+
+
+ END
+#endif
+
+
+#ifdef __EPOS__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE EPOSIGMA(Ipar,Ekin,SIGINEL)
+C-----------------------------------------------------------------------
+C EPOS cross sections (TP 06/0t)
+C
+C input: Ipar 1 p/n-air
+C 2 pi-air
+C 3 K-air
+C >10 nucleus (A=Ipar/10) - air
+C Ekin projectile kinetic energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+
+
+ if(Ipar.le.3)then
+
+ SIGINEL = cxepocrse(Ekin,1,0,0)
+
+ elseif(Ipar.ge.10)then !Nucleus
+
+ ma=Ipar/10
+ SIGINEL = cxepocrse(Ekin,ma,0,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No EPOS cross section for this particle'
+
+ endif
+
+
+ END
+#endif
+
+#ifdef __SIBYLL21__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE SIBSIGMA(Ipari,Etot,SIGINEL)
+C-----------------------------------------------------------------------
+C Sibyll 2.1 cross sections
+C
+C input: Ipar 1 : proton / air
+c 2 : charged pions / air
+c 3 : charged kaons / air
+c 4 : K-long / air
+c 5 : K-short / air
+c 6 : neutral pion / air
+c 7 : neutron / air
+c >10 : nucleus (A=Ipar/10) / air
+C Etot projectile total energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ dimension isibcx(7)
+ data isibcx/13,7,9,11,12,6,14/ !conversion from Ipar to Sibyll code
+
+ Ipar=Ipari
+ ma=Ipar/10
+ if(ma.eq.1)Ipar=ma
+
+ if(Ipar.le.7)then
+
+ SIGINEL = sibcrse(Etot,1,isibcx(Ipar))
+
+ elseif(Ipar.ge.10)then !Nucleus
+
+ SIGINEL = sibcrse(Etot,ma,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No Sibyll cross section for this particle'
+
+ endif
+
+
+ END
+#endif
+
+#ifdef __QGSJETII__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE QGSSIGMAII(Ipar,Etot,SIGINEL)
+C-----------------------------------------------------------------------
+C QGSjet-II cross sections (RE 06/03)
+C
+C input: Ipar 1 p/n-air
+C 2 pi-air
+C 3 K-air
+C >10 nucleus (A=Ipar/10) - air
+C Etot projectile total energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+
+
+ if(Ipar.le.3)then
+
+ SIGINEL = qgsIIcrse(Etot,1,0,0)
+
+ else if(Ipar.ge.10)then !Nucleus
+
+ ma=Ipar/10
+ SIGINEL = qgsIIcrse(Etot,ma,0,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No QGSJet-II cross section for this particle'
+
+ endif
+
+
+ END
+
+#endif
+
+#ifdef __DPMJET__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE DPMSIGMA(Ipar,Etot,SIGINEL)
+C-----------------------------------------------------------------------
+C DPMJETIII cross sections
+C
+C input: Ipar 1 : proton / air
+c 2 : charged pions / air
+c 3 : charged kaons / air
+c 4 : K-long / air
+c 5 : K-short / air
+c 6 : neutral pion / air
+c 7 : neutron / air
+c >10 : nucleus (A=Ipar/10) / air
+C Etot projectile lab energy per nucleon (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit none
+ double precision Etot,SIGINEL,dpmcrse
+ integer Ipar,ma
+
+ ma=max(1,Ipar/10)
+
+ SIGINEL = dpmcrse(Etot,ma,0)
+
+
+ END
+#endif
+
+#ifdef __FLUKA__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE FLUSIGMA(Ipar,Ek,Pl,SIGINEL)
+C-----------------------------------------------------------------------
+C FLUKA cross sections (TP 09/11)
+C
+C input: Ipar CONEX simple Particle type
+C >10 nucleus (A=Ipar/10) - air
+C Etot projectile kinetic energy (GeV) per nucleon
+C Pl projectile momentum (GeV/c) per nucleon
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit none
+#include "conex.incnex"
+ integer icnx2nxs(7),Ipar,ma
+ double precision siginel,Ek,Pl,fflucrse,flucrse
+ data icnx2nxs/1120, 120, 130, -20, 20, 110, 1220/
+
+
+ if(Ipar.le.7)then
+
+ xsekin=Ek
+ xspnll=Pl
+ idprojxs=icnx2nxs(Ipar)
+ SIGINEL = fflucrse()
+ if(Ipar.eq.2.or.Ipar.eq.3)then !average between + and -
+ idprojxs=-icnx2nxs(Ipar)
+ SIGINEL = 0.5d0*(SIGINEL+fflucrse())
+ endif
+
+ else if(Ipar.ge.10)then !Nucleus
+
+ ma=Ipar/10
+ SIGINEL = flucrse(Ek,ma,0,0)
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No FLUKA cross section for this particle'
+
+ endif
+
+
+ END
+
+#endif
+
+#ifdef __URQMD__
+
+C-----------------------------------------------------------------------
+ SUBROUTINE URQSIGMA(Ipari,Ek,SIGINEL)
+C-----------------------------------------------------------------------
+C UrQMD 1.3 cross sections
+C
+C input: Ipar 1 : proton / air
+c 2 : charged pions / air
+c 3 : charged kaons / air
+c 4 : K-long / air
+c 5 : K-short / air
+c 6 : neutral pion / air
+c 7 : neutron / air
+c >10 : nucleus (A=Ipar/10) / air
+C Ek projectile kinetic energy (GeV)
+C
+C output: SIGINEL inelastic cross section (mb)
+C-----------------------------------------------------------------------
+ implicit none
+ double precision Ek,SIGINEL,urqcrse
+ integer icnx2nxs(7),Ipar,Ipari,ma,idpj
+ data icnx2nxs/1120, 120, 130, -20, 20, 110, 1220/
+
+ SIGINEL=0d0
+ Ipar=Ipari
+ ma=Ipar/10
+ if(ma.eq.1)Ipar=ma
+
+ if(Ipar.le.7)then
+
+ idpj=icnx2nxs(Ipar)
+ SIGINEL = urqcrse(Ek,idpj)
+ if(Ipar.le.3.or.Ipar.eq.7)then !average between + and -
+ idpj=-icnx2nxs(Ipar)
+ SIGINEL = 0.5d0*(SIGINEL+urqcrse(Ek,idpj))
+ endif
+
+ else
+
+ write(*,*)'Particle',Ipar
+ stop'No URQMD cross section for this particle'
+
+ endif
+
+ END
+#endif
+
+#ifndef __CORSIKA8__
+
+#ifdef __NEXUS__
+c-----------------------------------------------------------------------
+ function rangen()
+c-----------------------------------------------------------------------
+c generates a safe random number simple precision
+c (for NEXUS : no argument)
+c-----------------------------------------------------------------------
+ double precision dummy,drangen
+ 1 rangen=real(drangen(dummy))
+ if(rangen.le.0..or.rangen.ge.1.)goto 1
+
+ return
+ end
+
+#endif
+#ifdef __EPOS__
+c-----------------------------------------------------------------------
+ function rangen()
+c-----------------------------------------------------------------------
+c generates a safe random number simple precision
+c (for NEXUS : no argument)
+c-----------------------------------------------------------------------
+ double precision dummy,drangen
+ 1 rangen=real(drangen(dummy))
+ if(rangen.le.0..or.rangen.ge.1.)goto 1
+
+ return
+ end
+
+#endif
+
+#endif
+#ifdef __URQMD__
+c 18.11.2011 Link routines between UrQMD 1.3 and CONEX.
+c author T. Pierog based on CORSIKA and EPOS link to UrQMD
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+c-----------------------------------------------------------------------
+ subroutine IniUrQMD
+c-----------------------------------------------------------------------
+c Primary initialization for UrQMD 1.31
+c-----------------------------------------------------------------------
+ implicit none
+c CONEX includes
+#include "conex.h"
+#include "conex.incnex"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ character*500 furqdat
+ integer ifurqdat, nfurqdat
+ common/urqfname/ furqdat, ifurqdat, nfurqdat
+
+ include 'boxinc.f'
+ include 'inputs.f'
+ include 'options.f'
+
+c commons from coms.f
+ integer Ap, At, Zp, Zt, npart, nbar, nmes, ctag
+ integer nsteps,ranseed,event,eos,dectag,uid_cnt
+ integer NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+ common /sys/ npart, nbar, nmes, ctag,nsteps,uid_cnt,
+ + ranseed,event,Ap,At,Zp,Zt,eos,dectag,
+ + NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+
+c local
+ INTEGER i,io,ia,ie,id
+ CHARACTER CTPStrg(numctp)*60, CTOStrng(numcto)*60
+ integer mxie,mxid,mxia
+ parameter (mxie=41,mxid=10,mxia=3)
+ character adum
+ double precision sig_u1,ekdummy
+ integer iamaxu,idmaxu,iemaxu
+ common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamaxu,idmaxu,iemaxu
+ double precision xs(3),bim(3)
+ common /cxs_u2/ xs
+ integer iudebug
+ data bim/6.d0,6.d0,7.d0/
+ integer init
+ data init/0/
+ SAVE
+
+ if(init.ge.1)return
+ init=init+1
+#ifdef __CXDEBUG__
+ call utisx1('iniurqmd ',4)
+ write(*,'(a)')'initialize URQMD ...'
+#endif
+
+C-----------------------------------------------------------------------
+
+ IF ( isx.ge.2 ) THEN
+ IUDEBUG = isx-1
+ ELSE
+ IUDEBUG = 0
+ ENDIF
+
+ WRITE (*,*)
+ $ '############################################################'
+ WRITE (*,*)
+ $ '## ##'
+ WRITE (*,*)
+ $ '## UrQMD 1.3.1 University of Frankfurt ##'
+ WRITE (*,*)
+ $ '## urqmd@th.physik.uni-frankfurt.de ##'
+ WRITE (*,*)
+ $ '## ##'
+ WRITE (*,*)
+ $ '############################################################'
+ WRITE (*,*)
+ $ '## ##'
+ WRITE (*,*)
+ $ '## please cite when using this model: ##'
+ WRITE (*,*)
+ $ '## S.A.Bass et al. Prog.Part.Nucl.Phys. 41 (1998) 225 ##'
+ WRITE (*,*)
+ $ '## M.Bleicher et al. J.Phys. G25 (1999) 1859 ##'
+ WRITE (*,*)
+ $ '## ##'
+ WRITE (*,*)
+ $ '############################################################'
+
+C SET THE 'LARGE' CROSS-SECTIONS FOR ALL 3 TARGET ELEMENTS
+ DO I = 1, 3
+ XS(I) = 10.D0 * PI * BIM(I)**2
+ ENDDO
+
+C SET NMAX TO DEFAULT VALUE
+ call set0
+ call params
+
+C THIS IS THE SUBSTITUE FOR THE URQMD INPUT ROUTINE
+C INITIALIZE COUNTERS
+ boxflag = 0
+ mbflag = 0
+ edens = 0.d0
+ para = 0
+ solid = 0
+ mbox = 0
+ io = 0
+
+C THE FOLLOWING FLAGS CHECK, WHETHER ALL NECESSARY INPUT IS GIVEN
+C PROJECTILE
+ prspflg = 0
+C TARGET
+ trspflg = 0
+C
+ srtflag = 0
+ firstev = 0
+C EXCITATION FUNCTION
+ nsrt = 1
+ npb = 1
+ efuncflag = 0
+C DEFAULT NUMBER OF EVENTS
+ nevents = 1
+C DEFAULT NUMBER OF TIMESTEPS
+ nsteps = 1000
+
+C SKIP CONDITIONS ON UNIT 13, 14, 15, 16 & 18
+C SUPPRESS ALL OUTPUT
+ bf13 = .true.
+ bf14 = .true.
+ bf15 = .true.
+ bf16 = .true.
+ bf18 = .true.
+ bf19 = .true.
+ bf20 = .true.
+C SET DEBUG OUTPUT DEPENDING ON CHOSEN DEBUG LEVEL
+C SET THE OUTPUT OF UNITS 13, 14, 15 TO THE DEBUG OUTPUT UNIT
+ IF ( IUDEBUG .EQ. 1 ) THEN
+ bf13 = .true.
+ bf14 = .false.
+ call uounit(14,IFCK)
+ bf15 = .true.
+ ELSEIF ( IUDEBUG .EQ. 2 ) THEN
+ bf13 = .false.
+ call uounit(13,IFCK)
+ bf14 = .true.
+ bf15 = .true.
+ ELSEIF ( IUDEBUG .GT. 2 ) THEN
+ bf13 = .true.
+ bf14 = .true.
+ bf15 = .false.
+ call uounit(15,IFCK)
+ ENDIF
+ do i = 1, numcto
+ CTOdc(i) = ' '
+ enddo
+ do i = 1, numctp
+ CTPdc(i) = ' '
+ enddo
+ do i = 1, maxstables
+ stabvec(i) = 0
+ enddo
+ nstable = 0
+
+C DEFAULT SETTINGS FOR CTParam AND CTOption
+C DEFAULT SETTINGS FOR CTParam
+ CTParam(1)=1.d0
+ CTPStrg(1)='scaling factor for decay-width'
+ CTParam(2)=0.52d0
+ CTPStrg(2)='used for minimal stringmass & el/inel cut in makestr'
+ CTParam(3)=2.d0
+ CTPStrg(3)='velocity exponent for modified AQM'
+ CTParam(4)=0.3d0
+ CTPStrg(4)='transverse pion mass, used in make22 & strexct'
+ CTParam(5)=0.d0
+ CTPStrg(5)='probabil. for quark rearrangement in cluster'
+ CTParam(6)=0.37d0
+ CTPstrg(6)='strangeness probability'
+ CTParam(7)=0.d0
+ CTPStrg(7)='charm probability (not yet implemented in UQMD)'
+ CTParam(8)=0.093d0
+ CTPStrg(8)='probability to create a diquark'
+ CTParam(9)=0.35d0
+ CTPStrg(9)='kinetic energy cut off for last string break'
+ CTParam(10)=0.25d0
+ CTPStrg(10)='min. kinetic energy for hadron in string'
+ CTParam(11)=0.d0
+ CTPStrg(11)='fraction of non groundstate resonances'
+ CTParam(12)=.5d0
+ CTPStrg(12)='probability for rho 770 in String'
+ CTParam(13)=.27d0
+ CTPStrg(13)='probability for rho 1450 (rest->rho1700)'
+ CTParam(14)=.49d0
+ CTPStrg(14)='probability for omega 782'
+ CTParam(15)=.27d0
+ CTPStrg(15)='probability for omega 1420(rest->om1600)'
+ CTParam(16)=1.0d0
+ CTPStrg(16)='mass cut betw. rho770 and rho 1450'
+ CTParam(17)=1.6d0
+ CTPSTRG(17)='mass cut betw. rho1450 and rho1700'
+ CTParam(18)=.85d0
+ CTPStrg(18)='mass cut betw. om 782 and om1420'
+ CTParam(19)=1.55d0
+ CTPStrg(19)='mass cut betw. om1420 and om1600'
+ CTParam(20)=0.0d0
+ CTPStrg(20)=' distance for second projectile'
+ CTParam(21)=0.0d0
+ CTPStrg(21)=' deformation parameter'
+
+ CTParam(25)=.9d0
+ CTPStrg(25)=' probability for diquark not to break'
+ CTParam(26)=50.d0
+ CTPStrg(26)=' maximum trials to get string masses'
+ CTParam(27)=1.d0
+ CTPStrg(27)=' scaling factor for xmin in string excitation'
+ CTParam(28)=1.d0
+ CTPStrg(28)=' scaling factor for transverse fermi motion'
+ CTParam(29)=0.4d0
+ CTPStrg(29)=' single strange di-quark suppression factor '
+ CTParam(30)=1.5d0
+ CTPStrg(30)=' radius offset for initialization '
+ CTParam(31)=1.6d0
+ CTPStrg(31)=' sigma of gaussian for tranverse momentum tranfer '
+ CTParam(32)=0.d0
+ CTPStrg(32)=' alpha-1 for valence quark distribution '
+ CTParam(33)=2.5d0
+ CTPStrg(33)=' betav for valence quark distribution (DPM)'
+ CTParam(34)=0.1d0
+ CTPStrg(34)=' minimal x multiplied with ecm '
+ CTParam(35)=3.0d0
+ CTPStrg(35)=' offset for cut for the FSM '
+ CTParam(36)=0.275d0
+ CTPStrg(36)=' fragmentation function parameter a '
+ CTParam(37)=0.42d0
+ CTPStrg(37)=' fragmentation function parameter b '
+ CTParam(38)=1.08d0
+ CTPStrg(38)=' diquark pt scaling factor '
+ CTParam(39)=0.8d0
+ CTPStrg(39)=' strange quark pt scaling factor '
+ CTParam(40)=0.5d0
+ CTPStrg(40)=' betas-1 for valence quark distribution (LEM)'
+ CTParam(41)=0.d0
+ CTPStrg(41)=' distance of initialization'
+ CTParam(42)=0.55d0
+ CTPStrg(42)=' width of gaussian -> pt in string-fragmentation '
+ CTParam(43)=5.d0
+ CTPStrg(43)=' maximum kinetic energy in mesonic clustr '
+ CTParam(44)=0.8d0
+ CTPStrg(44)=' prob. of double vs. single excitation for AQM inel.'
+ CTParam(45)=0.5d0
+ CTPStrg(45)=' offset for minimal mass generation of strings'
+ CTParam(46)=800000.d0
+ CTPStrg(46)=' maximal number of rejections for initialization'
+ CTParam(47)=1.0d0
+ CTPStrg(47)=' field feynman fragmentation funct. param. a'
+ CTParam(48)=2.0d0
+ CTPStrg(48)=' field feynman fragmentation funct. param. b'
+
+ CTParam(50)=1.d0
+ CTPStrg(50)=' enhancement factor for 0- mesons'
+ CTParam(51)=1.d0
+ CTPStrg(51)=' enhancement factor for 1- mesons'
+ CTParam(52)=1.d0
+ CTPStrg(52)=' enhancement factor for 0+ mesons'
+ CTParam(53)=1.d0
+ CTPStrg(53)=' enhancement factor for 1+ mesons'
+ CTParam(54)=1.d0
+ CTPStrg(54)=' enhancement factor for 2+ mesons'
+ CTParam(55)=1.d0
+ CTPStrg(55)=' enhancement factor for 1+-mesons'
+ CTParam(56)=1.d0
+ CTPStrg(56)=' enhancement factor for 1-*mesons'
+ CTParam(57)=1.d0
+ CTPStrg(57)=' enhancement factor for 1-*mesons'
+ CTParam(58)=1.d0
+ CTPStrg(58)=' scaling factor for DP time-delay'
+
+C DEFAULT SETTINGS FOR CTOption
+ CTOption(1)=1 ! hjd1
+ CTOStrng(1)=' resonance widths are mass dependent '
+ CTOption(2)=0
+ CTOStrng(2)=' conservation of scattering plane'
+ CTOption(3)=0
+ CTOStrng(3)=' use modified detailed balance'
+ CTOption(4)=0
+ CTOStrng(4)=' no initial conf. output '
+ CTOption(5)=0
+ CTOStrng(5)=' fixed random impact parameter'
+ CTOption(6)=0
+ CTOStrng(6)=' no first collisions inside proj/target'
+ CTOption(7)=0
+ CTOStrng(7)=' elastic cross-section enabled (<>0:total=inelast)'
+ CTOption(8)=0
+ CTOStrng(8)=' extrapolate branching ratios '
+ CTOption(9)=0
+ CTOStrng(9)=' use tabulated pp cross-sections '
+ CTOption(10)=0
+ CTOStrng(10)=' enable Pauli Blocker'
+ CTOption(11)=0
+ CTOStrng(11)=' mass reduction for cascade initialization'
+ CTOption(12)=0
+ CTOStrng(12)=' string condition =0 (.ne.0 no strings)'
+ CTOption(13)=0
+ CTOStrng(13)=' enhanced file16 output '
+ CTOption(14)=0
+ CTOStrng(14)=' cos(the) is distributet between -1..1 '
+ CTOption(15)=0
+ CTOStrng(15)=' allow mm&mb-scattering'
+ CTOption(16)=0
+ CTOStrng(16)=' propagate without collisions'
+ CTOption(17)=0
+ CTOStrng(17)=' colload after every timestep '
+ CTOption(18)=0
+ CTOStrng(18)=' final decay of unstable particles'
+ CTOption(19)=0
+ CTOStrng(19)=' allow bbar annihilaion'
+ CTOption(20)=0
+ CTOStrng(20)=' dont generate e+e- instead of bbar'
+ CTOption(21)=0
+ CTOStrng(21)=' use field feynman frgm. function'
+ CTOption(22)=1
+ CTOStrng(22)=' use lund excitation function'
+ CTOption(23)=0
+ CTOStrng(23)=' lorentz contraction of projectile & targed'
+ CTOption(24)=2 ! 1 is default 2 means fast method
+ CTOStrng(24)=' Wood-Saxon initialization'
+ CTOption(25)=0
+ CTOStrng(25)=' phase space corrections for resonance mass'
+ CTOption(26)=0
+ CTOStrng(26)=' use z -> 1-z for diquark-pairs'
+ CTOption(27)=1 ! hjd1
+ CTOStrng(27)=' reference frame (1=target, 2=projectile, else=cms)'
+ CTOption(28)=0
+ CTOStrng(28)=' propagate spectators also '
+ CTOption(29)=2
+ CTOStrng(29)=' no transverse momentum in clustr '
+ CTOption(30)=1
+ CTOStrng(30)=' frozen fermi motion '
+ CTOption(31)=0
+ CTOStrng(31)=' reduced mass spectrum in string'
+ CTOption(32)=0
+ CTOStrng(32)=' masses are distributed acc. to m-dep. widths'
+ CTOption(33)=0
+ CTOStrng(33)=' use tables & m-dep. for pmean in fprwdt & fwidth'
+ CTOption(34)=1
+ CTOStrng(34)=' lifetme according to m-dep. width'
+ CTOption(35)=1
+ CTOStrng(35)=' generate high precision tables'
+ CTOption(36)=0
+ CTOStrng(36)=' normalize Breit-Wigners with m.dep. widths '
+ CTOption(37)=0
+ CTOStrng(37)=' heavy quarks form di-quark clusters'
+ CTOption(38)=0
+ CTOStrng(38)=' scale p-pbar to b-bbar with equal p_lab '
+ CTOption(39)=0
+ CTOStrng(39)=' dont call pauliblocker'
+ CTOption(40)=0
+ CTOStrng(40)=' read old fort.14 file '
+ CTOption(41)=0
+ CTOStrng(41)=' generate extended output for cto40'
+ CTOption(42)=0
+ CTOStrng(42)=' hadrons now have color fluctuations'
+ CTOption(43)=0
+ CTOStrng(43)=' dont generate dimuon intead of dielectron output'
+ CTOption(44)=0
+ CTOStrng(44)=' not used at the moment'
+ CTOption(45)=0
+ CTOStrng(45)=' not used at the moment'
+
+C INITIALIZE ARRAYS FOR SPECIAL PRO/TAR COMBINATIONS
+ do i = 1, 2
+ spityp(i) = 0
+ spiso3(i) = 0
+ enddo
+
+C INITIALIZE ARRAYS FOR SPECIAL PARTICLES
+ EoS = 0
+
+C READ CROSS-SECTION FILES
+Cdh CALL URQREC()
+
+C INITIALIZES SOME ARRAYS
+ call strini ! initialize mixing angles for meson-multipletts
+ call loginit
+
+ IF ( CTOption(33) .EQ. 0 .OR. CTOption(9) .EQ. 0 ) THEN
+ call loadwtab(io)
+ IF ( IUDEBUG .GT. 0 ) WRITE(IFCK,*) 'URQINI: AFTER LOADWTAB'
+ ENDIF
+
+C READ URQMD TOTAL CROSS SECTION TABLE
+c
+c ie=1..41 E=10.0**(float(ie)/10-1.0-0.05) (bin-middle)
+c id=1..9 p,ap,n,an,pi+,pi-,K+,K-,KS
+c ia=1..3 N,O,Ar
+c
+ if(ifurqdat.eq.1)then
+ OPEN(UNIT=76,FILE=furqdat(1:nfurqdat),STATUS='OLD')
+ else
+ OPEN(UNIT=76,FILE='UrQMD-1.3.1-xs.dat',STATUS='OLD')
+ endif
+ read(76,*) adum,iamaxu,idmaxu,iemaxu
+ do ia=1,iamaxu
+ do id=1,idmaxu
+ do ie=1,iemaxu
+ read(76,*) ekdummy,sig_u1(ie,id,ia)
+ enddo
+ read(76,*)
+ read(76,*)
+ enddo
+ enddo
+ close(76)
+
+C IN CASE OF CASCADE MODE, THE POTENTIALS NEED NOT BE CALCULATED
+
+C CALCULATE NORMALIZATION OF RESONANCES DISTRIBUTION...
+ call norm_init
+#endif
+
+
+ xsegymin=0.25d0
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtUrq
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+
+ include 'boxinc.f'
+ include 'inputs.f'
+ include 'options.f'
+
+c commons from coms.f
+ integer Ap, At, Zp, Zt, npart, nbar, nmes, ctag
+ integer nsteps,ranseed,event,eos,dectag,uid_cnt
+ integer NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+ common /sys/ npart, nbar, nmes, ctag,nsteps,uid_cnt,
+ + ranseed,event,Ap,At,Zp,Zt,eos,dectag,
+ + NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+
+ real*8 time, acttime, bdist, ebeam, bimp,bmin,ecm
+ common /rsys/ time,acttime,bdist,bimp,bmin,ebeam,ecm
+
+ real*8
+ + gw, sgw, delr, fdel, dt,
+ + da, db,
+ + Cb0, Yuk0, Pau0, Sky20, Sky30, gamSky, gamYuk, drPau, dpPau,
+ + dtimestep
+c 19 real*8
+ common /pots/ Cb0, Yuk0, Pau0, Sky20, Sky30, gamSky,
+ + gamYuk, drPau, dpPau, gw, sgw, delr, fdel,
+ + dt,da, db,dtimestep
+
+c local
+
+ integer ICUTBL(200),ICU2I3(200),BIM(3)
+ common /urqmdproj/ICUTBL,ICU2I3
+C CONVERSION TABLE CORSIKA TO URQMD
+ DATA ICUTBL/
+ & 0, 0, 0, 0, 0, 0, 101, 101, 101, 106, ! 10
+ & 106,-106, 1, 1, -1,-106, 102, 27, 40, 40, ! 20
+ & 40, 49, 49, 55, -1, -27, -40, -40, -40, -49, ! 30
+ & -49, -55, 0, 0, 0, 0, 0, 0, 0, 0, ! 40
+ & 160 * 0 /
+C TABLE FOR ISOSPIN COMPONENT 2*I3 (CONVERSION CORSIKA TO URQMD)
+ DATA ICU2I3/
+ & 0, 0, 0, 0, 0, 0, 0, 2, -2, -1,
+ & 1, -1, -1, 1, -1, 1, 0, 0, 2, 0,
+ & -2, 1, -1, 0, 1, 0, -2, 0, 2, -1,
+ & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ & 160 * 0 /
+ DATA BIM / 6.D0, 6.D0, 7.D0 /
+
+ double precision caltim,outtim,nucrad,furqcrse
+ integer idtmp,idtrafocx,lt
+
+ if(maprojxs.gt.210)
+ & stop'Mass too big for UrQMD (Mprj<210) !'
+ call cxiclass(idprojxs,iclproxs)
+ bmin=sngl(xsbminim)
+ bdist=xsbmaxim
+C SELECT AND INITIALIZE TARGET
+ trspflg = 0
+ At = matargxs
+ Zt = latargxs
+ lt=1
+ if(matargxs.eq.16)then
+ lt=2
+ elseif(matargxs.eq.40)then
+ lt=3
+ endif
+
+C SET THE PROJECTILE
+ if(laprojxs.ge.0)then
+C PROJECTILE IS A NUCLEUS
+ prspflg = 0
+ Ap = maprojxs
+ Zp = laprojxs
+ else
+C PROJECTILE IS A SPECIAL PARTICLE
+ Ap = 1
+ prspflg = 1
+ idtmp=idtrafocx('nxs','cor',idprojxs)
+ spityp(1) = ICUTBL(idtmp)
+ spiso3(1) = ICU2I3(idtmp)
+ endif
+
+C ENERGY OF COLLISION (LAB-SYSTEM)
+ ebeam = dble(xsekin)
+C eos: impact parameter
+ eos = 0
+C nev: number of events
+ nevents = 1
+C tim: time of propagation
+ caltim = 200.d0
+ outtim = 200.d0
+C fast CASCADE mode
+ if ( eos .eq. 0 ) dtimestep = outtim
+C
+ nsteps = int(0.01d0+caltim/dtimestep)
+ outsteps = int(0.01d0+outtim/dtimestep)
+
+ if ( boxflag .eq. 0 ) then
+
+C initialize nuclei (projectile and target) and store them
+
+C initialize normal projectile
+ if ( prspflg .eq. 0 ) then
+ call cascinit(Zp,Ap,1)
+ endif
+C initialize normal target
+ if ( At .ne. 0 ) then
+ if ( trspflg .eq. 0 ) then
+ call cascinit(Zt,At,2)
+ endif
+ endif
+ endif
+
+
+
+ xsbmax=nucrad(maprojxs)+nucrad(matargxs)+2*CTParam(30)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ xsurqincs=furqcrse()
+#else
+ xsurqincs=1d20
+#endif
+
+ CTOption(5)=1
+ if ( prspflg.eq.0 ) then
+ bdist = BIM(LT)
+ else
+ bdist = xsbmax
+ endif
+ if(xsekin.lt.xsegymin)xsurqincs=0. !below xsegymin, no interaction
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'UrQMD used with (Ek,idproj,matarg,xs) ',xsekin,idprojxs
+ & ,matargxs,xsurqincs
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsurq(iret)
+c-----------------------------------------------------------------------
+c call UrQMD to simulate interaction
+c-----------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+ integer ICUTBL(200),ICU2I3(200)
+ common /urqmdproj/ICUTBL,ICU2I3
+ include 'boxinc.f'
+ include 'inputs.f'
+ include 'options.f'
+c commons from coms.f
+ integer Ap, At, Zp, Zt, npart, nbar, nmes, ctag
+ integer nsteps,ranseed,event,eos,dectag,uid_cnt
+ integer NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+ common /sys/ npart, nbar, nmes, ctag,nsteps,uid_cnt,
+ + ranseed,event,Ap,At,Zp,Zt,eos,dectag,
+ + NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+
+ real*8 time, acttime, bdist, ebeam, bimp,bmin,ecm
+ common /rsys/ time,acttime,bdist,bimp,bmin,ebeam,ecm
+
+ integer nmax
+ parameter (nmax = 500) ! maximum number of particles
+ integer spin(nmax),ncoll(nmax),charge(nmax),strid(nmax),
+ + ityp(nmax),lstcoll(nmax),iso3(nmax),origin(nmax),uid(nmax)
+ real*8
+ + r0(nmax), rx(nmax), ry(nmax), rz(nmax),
+ + p0(nmax), px(nmax), py(nmax), pz(nmax),
+ + fmass(nmax), rww(nmax),
+ + dectime(nmax)
+ common/isys/spin,ncoll,charge,ityp,lstcoll,iso3,origin,strid,
+ + uid
+ common /coor/ r0, rx, ry, rz, p0, px, py, pz, fmass, rww, dectime
+
+c local
+ double precision fmasscx,p0cx
+ integer iret,i,idepos,idpdg,j,nn,idtrafocx,pdgid,ist
+ *,nptlini,np1,np2,ip
+
+
+ iret=0
+ if(abs(xsurqincs).lt.1d-20)goto 1002 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine URMQD Production&',0,0,0)
+#endif
+ nptlxs=0
+
+C NOW THE REAL WORK IS DONE
+ CALL URQMD( 0 )
+
+ if(isx.ge.5)write(ifck,*)'UrQMD: ctag,NElColl=',ctag,NElColl,npart
+
+ if(ctag.le.NElColl)goto 1002 !elastic interaction, included in xs
+
+ call cxconre
+ call cxconwr(ist)
+
+ ncolxs=1
+ nevtxs=1
+ xsbimp=bimp
+ xsphi=0.
+ nptlini=nptlxs+1
+
+c set projectile and target as non final particles
+ do i=1,maprojxs
+ istptlxs(i)=1
+ enddo
+ do j=1,matargxs
+ istptlxs(j)=1
+ enddo
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5)')
+ $ ' number of particles from UrQMD :',npart
+#endif
+
+ do nn=1,npart
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i4,a,i4,i5,2a,5(e11.4,1x))')
+ $ ' URQMD particle ',nn,' id,iso3 :',ityp(nn),iso3(nn)
+ $ , ' before conversion'
+ $ , ' E, P and mass :',p0(nn),px(nn),py(nn),pz(nn),fmass(nn)
+#endif
+
+ idpdg=pdgid(ityp(nn),iso3(nn))
+ idepos=idtrafocx('pdg','nxs',idpdg)
+
+ nptlxs=nptlxs+1
+
+c masses are not constant in UrQMD, use the CONEX one.
+ call cxidmass(idepos,fmasscx)
+ p0cx=px(nn)**2+py(nn)**2+pz(nn)**2+fmasscx**2
+ if(p0cx.gt.0d0)then
+ p0cx=sqrt(p0cx)
+ else !error
+ goto 1001
+ endif
+ iorptlxs(nptlxs)=0
+ jorptlxs(nptlxs)=0
+ istptlxs(nptlxs)=0
+ xsorptl(4,nptlxs)= r0(nn)
+ xsorptl(1,nptlxs)=rx(nn)
+ xsorptl(2,nptlxs)=ry(nn)
+ xsorptl(3,nptlxs)=rz(nn)
+ xsptl(4,nptlxs)=p0cx
+ xsptl(1,nptlxs)=px(nn)
+ xsptl(2,nptlxs)=py(nn)
+ xsptl(3,nptlxs)=pz(nn)
+ xsptl(5,nptlxs)=fmasscx
+ idptlxs(nptlxs)=idepos
+ ityptlxs(nptlxs)=0
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from URQMD ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(i,nptlxs),i=1,5)
+#endif
+
+ enddo
+
+c Decay particles with short life time
+
+ np1=nptlini
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+ 1000 return
+
+ 1001 iret=1
+ goto 1000
+
+ 1002 iret=-1 !elastic
+ goto 1000
+
+ end
+
+c------------------------------------------------------------------------------
+ double precision function furqcrse()
+c------------------------------------------------------------------------------
+c hadron/nucleus-nucleus particle production cross section with UrQMD.
+c------------------------------------------------------------------------------
+#include "conex.incnex"
+ double precision urqcrse
+ furqcrse=urqcrse(xsekin,idprojxs)
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function urqcrse(ek,idpro)
+c------------------------------------------------------------------------------
+c hadron/nucleus-nucleus particle production cross section with UrQMD.
+c------------------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+ integer mxie,mxid,mxia
+ parameter (mxie=41,mxid=10,mxia=3)
+ double precision sig_u1,xsu
+ integer iamaxu,idmaxu,iemaxu
+ common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamaxu,idmaxu,iemaxu
+ double precision xs(3)
+ common /cxs_u2/ xs
+
+ dimension we(3)
+ double precision ye,we,ek
+ integer je,i,id,ia,idpro
+
+
+ urqcrse = 0.d0
+ if(ek.gt.900.d0)return
+ ye = log10(ek)*10.d0+10.5d0
+ if ( ye. lt. 1d0 ) ye = 1.d0
+ je = min(iemaxu-2,int(ye))
+ we(2) = ye-je
+ we(3) = we(2)*(we(2)-1.d0)*.5d0
+ we(1) = 1.d0-we(2)+we(3)
+ we(2) = we(2)-2.d0*we(3)
+
+ id=0
+ if ( idpro .eq. 1120 ) then
+ id = 1
+ elseif( idpro .eq. -1120) then
+ id = 2
+ elseif( idpro .eq. 1220 ) then
+ id = 3
+ elseif( idpro .eq. -1220) then
+ id = 4
+ elseif( idpro .eq. 120 ) then
+ id = 5
+ elseif( idpro .eq. -120) then
+ id = 6
+ elseif( idpro .eq. 130 ) then
+ id = 7
+ elseif( idpro .eq. -130) then
+ id = 8
+ elseif( idpro .eq. 20 .or. idpro .eq. -20 ) then
+ id = 9
+ endif
+
+ if(id.ne.0)then
+
+c ia=1..3
+c N,O,Ar
+ do ia = 1,3
+ xsu=0d0
+ do i = 1,3
+ xsu = xsu + sig_u1(je+i-1,id,ia)*we(i)
+ enddo
+ urqcrse = urqcrse + airw(ia)*xsu
+ enddo
+
+ else
+
+ do ia = 1,3
+ urqcrse = urqcrse + airw(ia)*XS(ia)
+ enddo
+
+ endif
+
+
+ return
+ end
+
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION RANF(idum)
+
+C-----------------------------------------------------------------------
+C FL(UKA) R(A)ND(O)M (GENERATOR)
+C THIS FUNCTON IS CALLED FROM URQMD ROUTINES.
+C-----------------------------------------------------------------------
+ double precision drangen
+ ranf=drangen(dble(idum))
+
+ RETURN
+ END
+
+#endif
+#endif
+#ifdef __FLUKA__
+c 06.09.2011 Link routines between FLUKA2011 and CONEX.
+c author T. Pierog based on CORSIKA and EPOS link to FLUKA
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine IniFluka
+c-----------------------------------------------------------------------
+c Primary initialization for FLUKA
+c-----------------------------------------------------------------------
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ INCLUDE '(DBLPRC)' !
+ INCLUDE '(DIMPAR)' !
+ INCLUDE '(IOUNIT)' !
+ INCLUDE '(FLKCMP)' !
+ INCLUDE '(FLKMAT)' !
+ INCLUDE '(PAREVT)' !
+ INCLUDE '(PHNCCM)' !
+ INCLUDE '(CTITLE)' !
+
+C FLUKA 2011.2 BLOCK DATA PROGRAMS
+ EXTERNAL BDINPT,BDTRNS,BDHDR1,BDHDR2,BDHDR3,BDPART,BDPRDC,
+ & BDNOPT,BDEVAP,BDPREE
+
+ DIMENSION WHAT (6)
+ CHARACTER SDUM*10
+ DATA WHAT / 6 * ZERZER /
+#endif
+
+c CONEX includes
+#include "conex.h"
+#include "conex.incnex"
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+#ifdef __CXDEBUG__
+ call utisx1('inifluka ',4)
+ write(*,'(a)')'initialize FLUKA ...'
+#endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+C open fluka output/error files
+ OPEN(UNIT=LUNOUT,FORM='FORMATTED',STATUS='UNKNOWN',
+ * FILE=fnck(1:nfnck-5)//'fkout')
+ OPEN(UNIT=LUNERR,FORM='FORMATTED',STATUS='UNKNOWN',
+ * FILE=fnck(1:nfnck-5)//'fkerr')
+
+ CALL CMSPPR
+C CLEAR FLUKA STORAGE AREAS
+ ITEXMX = 10000000
+ CALL ZEROIN
+ LEVPRT = .TRUE.
+ LDEEXG = .TRUE.
+ LHEAVY = .TRUE.
+ IFISS = 1
+ LGDHPR = .TRUE.
+C CHARMED PARTICLES SHOULD NOT DECAY WHEN ORIGINATING
+ LCHDCY = .FALSE.
+
+c random numbers initialization
+ NREGS = 4
+C FLUKA MATERIAL NUMBER 1 IS NITROGEN
+ MMAT = 3
+ MEDFLK(2,1) = MMAT
+ ZTAR (MMAT) = 7
+ AMSS (MMAT) = 14.007D+00
+ RHO (MMAT) = ONEONE
+ RHPHNC(MMAT) = ONEONE
+ IFPHNC(MMAT) = 1111
+ MSSNUM(MMAT) = 0
+ AOCMBM(MMAT) = RHO(MMAT) / AMSS(MMAT) * AVOGAD * 1.D-24
+ ICOMP (MMAT) = 0
+ MATNAM(MMAT) = 'NITROGEN'
+
+C FLUKA MATERIAL NUMBER 2 IS OXYGEN
+ IMAT = 4
+ MEDFLK(3,1) = IMAT
+ ZTAR (IMAT) = 8
+ AMSS (IMAT) = 15.9994D+00
+ RHO (IMAT) = ONEONE
+ RHPHNC(IMAT) = ONEONE
+ IFPHNC(IMAT) = 1111
+ MSSNUM(IMAT) = 0
+ AOCMBM(IMAT) = RHO(IMAT) / AMSS(IMAT) * AVOGAD * 1.D-24
+ ICOMP (IMAT) = 0
+ MATNAM(IMAT) = 'OXYGEN'
+
+C FLUKA MATERIAL NUMBER 3 IS ARGON
+ JMAT = 5
+ MEDFLK(4,1) = JMAT
+ ZTAR (JMAT) = 18
+ AMSS (JMAT) = 39.948D+000
+ RHO (JMAT) = ONEONE
+ RHPHNC(JMAT) = ONEONE
+ IFPHNC(JMAT) = 1111
+ MSSNUM(JMAT) = 0
+ AOCMBM(JMAT) = RHO(JMAT) / AMSS(JMAT) * AVOGAD * 1.D-24
+ ICOMP (JMAT) = 0
+ MATNAM(JMAT) = 'ARGON'
+
+C FLUKA MATERIAL NUMBER 4 IS AIR
+ NMAT = 6
+ MEDFLK(1,1) = NMAT
+ ICOMP (NMAT) = 1
+ ICOMPL(NMAT) = 3
+ MATNUM(1) = 3
+ MATNUM(2) = 4
+ MATNUM(3) = 5
+ RHO (NMAT) = ONEONE
+ RHPHNC(NMAT) = ONEONE
+ IFPHNC(NMAT) = 1111
+ CONTNT(1) = 0.92561D-03
+ CONTNT(2) = 0.28361D-03
+ CONTNT(3) = 0.15776D-04
+ RENORM = RHO(NMAT) / ( CONTNT(1) + CONTNT(2) + CONTNT(3) )
+ CONTNT(1) = CONTNT (1) * RENORM
+ CONTNT(2) = CONTNT (2) * RENORM
+ CONTNT(3) = CONTNT (3) * RENORM
+ MATNAM(NMAT) = 'AIR'
+C
+ CALL EVVINI( WHAT,SDUM )
+ CALL SETITB
+
+#endif
+
+
+ xsegymin=0.01d0
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtFlu
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ double precision fflucrse
+
+
+ if(maprojxs.gt.1)
+ & stop'Mass too big for Fluka (Mprj=1) !'
+ call cxiclass(idprojxs,iclproxs)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ xsbmax=10000.d0
+ xsfluincs=fflucrse()
+#else
+ xsbmax=20d0
+ xsfluincs=1d20
+#endif
+
+ if(xsekin.lt.xsegymin)xsfluincs=0. !below egymin, no interaction
+c if(iclproxs.eq.3.and.xsekin.lt.0.1d0)xsfluincs=0. !elastic event for kaons below 100MeV (problem) !
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'Fluka used with (Ek,idproj,matarg,xs) ',xsekin,idprojxs
+ & ,matargxs,xsfluincs
+#endif
+
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsflu(iret)
+c-----------------------------------------------------------------------
+c call Fluka to simulate interaction
+c-----------------------------------------------------------------------
+ INCLUDE '(DBLPRC)' !
+ INCLUDE '(DIMPAR)' !
+ INCLUDE '(FHEAVY)'
+ INCLUDE '(GENSTK)' !
+ INCLUDE '(PAREVT)' !
+ INCLUDE '(PART2)' !
+ INCLUDE '(RESNUC)' !
+#include "conex.h"
+#include "conex.incnex"
+ double precision P0(5),P1,EKIN1,PPROJ,TXX,TYY,TZZ,WEE,POO,PRES(4)
+
+ iret=0
+ if(abs(xsfluincs).lt.1d-20)goto 1002 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine FLUKA Production&',0,0,0)
+#endif
+ nptlxs=0
+ np=0
+
+
+C CONVERT PARTICLE TYPE TO FLUKA
+ KPROJ = idtrafocx('nxs','flk',idprojxs)
+ EKIN1 = xsekin
+C CALCULATE MOMENTUM PPROJ
+ PPROJ = SQRT( EKIN1 * (EKIN1 + 2.D00 * AAM(IPTOKP(KPROJ)) ) )
+ LEVFIN = .FALSE.
+C TARGET
+ if(latargxs.eq.7)then
+ MMMAT = 3
+ elseif(latargxs.eq.8)then
+ MMMAT = 4
+ elseif(latargxs.eq.18)then
+ MMMAT = 5
+ else
+ stop'Wrong mass in air component (FLUKA) !'
+ endif
+C USE THE FLUKA-INTERNALLY USED DIRECTION COSINES:
+ TXX = 0.D0
+ TYY = 0.D0
+ TZZ = 1.D0
+ WEE = ONEONE
+ IJ = KPROJ
+C CALCULATE THE MOMENTUM WITH FLUKA MASSES
+ POO = PPROJ
+C NOW INTERACTION IS PERFORMED
+ CALL EVENTV( IJ,POO,EKIN1,TXX,TYY,TZZ,WEE,MMMAT )
+c write(ifck,*)'target used',ibtar,ichtar,mmmat,ibres
+
+ matargxs=IBTAR !update mass in case of isotope
+
+ ist=1
+ call cxconre
+ call cxconwr(ist)
+
+ nptlini=nptlxs+1
+
+ if(NP.eq.0.and.NPHEAV.eq.0)goto 1001 !no interaction
+
+ ncolxs=1
+ nevtxs=1
+ xsbimp=0.d0
+ xsphi=0.d0
+
+C NOW TREAT THE REMAINING TARGET NUCLEUS
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,550)IBRES,ICRES,EKRES
+ 550 format('FLUKA: remaining nucleus',/,
+ * ' mass=',I3,' charge=',I3,
+ * ' ekin=',g9.2)
+#endif
+ if(IBRES.gt.1)then
+
+ if(IBRES.gt.matargxs)then
+ write(ifck,*)'emsflu:more nucleons in target remnant than '
+ * ,'in target ! ... skip event.'
+ goto 1001
+ endif
+
+ ekin1=EKRES/dble(IBRES)
+ PRES(4)=sqrt(PXRES*PXRES+PYRES*PYRES+PZRES*PZRES)
+ if(PRES(4).gt.0d0)then
+ PRES(3)=PZRES/PRES(4) !Pz
+ PRES(2)=PYRES/PRES(4) !Py
+ PRES(1)=PXRES/PRES(4) !Px
+ elseif(abs(ekin1).lt.1d-6)then
+ PRES(3)=0.d0 !Pz
+ PRES(2)=0.d0 !Py
+ PRES(1)=0.d0 !Px
+ else !ekin and momentum not consistent
+ write(*,*)'emsflu: ekin and momentum not consistent !'
+ * ,' ... skip event.'
+ goto 1001
+ endif
+
+ nptlxs=maprojxs+matargxs+1 !register spectators
+
+ do k=1,IBRES
+
+c final particle
+ nptlxs=nptlxs-1 !go backwards
+ istptlxs(nptlxs)=0
+ if(nptlxs.gt.mxptlxs)stop'FlUKA: mxptlxs too small'
+
+ if(k.le.ICRES)then !protons
+ id=1120
+ P0(5)=AAM(1) !Mass
+ else !neutrons
+ id=1220
+ P0(5)=AAM(8) !Mass
+ endif
+
+ P0(4)=ekin1+P0(5) !Energy
+ P1=sqrt((P0(4)+P0(5))*(P0(4)-P0(5))) !Momentum
+ P0(3)=PRES(3)*P1 !Pz
+ P0(2)=PRES(2)*P1 !Py
+ P0(1)=PRES(1)*P1 !Px
+
+ call flk2cnx(id,P0,1)
+
+ enddo
+ endif
+
+ nptlxs=maprojxs+matargxs
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5)')
+ $ ' number of particles from Fluka :',NP
+#endif
+ do 500 k=1,NP
+
+c LLIST is the code of final particle, P - its 4-momentum and mass.
+ ic=KPART(k)
+ icm=IPTOKP(ic) !convert to internal FLUKA ID to use AAM
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,5(e11.4,1x))')
+ $ ' FLUKA particle ',k,' id :',ic,' before conversion'
+ $ , ' Ekin, cos and mass :',TKI(k),CXR(k),CYR(k),CZR(k),AAM(icm)
+#endif
+
+ if(ic.le.-3)then !send He-3 in fragments
+ NPHEAV=NPHEAV+1
+ if(NPHEAV.gt.MXHEAV)goto 1001 !no room left, skip event
+ KHEAVY(NPHEAV)=abs(ic)
+ TKHEAV(NPHEAV)=TKI(k)
+ CXHEAV(NPHEAV)=CXR(k)
+ CYHEAV(NPHEAV)=CYR(k)
+ CZHEAV(NPHEAV)=CZR(k)
+ goto 500
+ endif
+
+c final particle
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+ if(nptlxs.gt.mxptlxs)stop 'FLUKA: mxptlxs too small'
+
+
+ id=idtrafocx('flk','nxs',ic)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' CONEX particle ',nptlxs,' id :',id,' after conversion'
+#endif
+
+ P0(5)=AAM(icm) !Mass
+ P0(4)=TKI(k)+P0(5) !Energy
+ P1=sqrt((P0(4)+P0(5))*(P0(4)-P0(5))) !Momentum
+ P0(3)=CZR(k)*P1 !Pz
+ P0(2)=CYR(k)*P1 !Py
+ P0(1)=CXR(k)*P1 !Px
+
+ call flk2cnx(id,P0,0)
+
+ 500 continue
+
+
+C NOW TREAT THE HEAVY FRAGMENTS
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5)')
+ $ ' number of fragments from FLUKA :',NPHEAV
+#endif
+
+ do j=1,NPHEAV
+
+c LLIST is the code of final particle, P - its 4-momentum and mass.
+ ic=KHEAVY(J)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,4(e11.4,1x))')
+ $ ' FLUKA fragment ',j,' id :',ic,' before conversion'
+ $ , ' Ekin and cos :',TKHEAV(J),CXHEAV(J),CYHEAV(J),CZHEAV(J)
+#endif
+ IF ( ic .LE. 0 .OR. ic .gt.12 ) THEN
+#ifdef __CXDEBUG__
+ if (isx .ge.1)WRITE(*,*)
+ * 'emsflu: WRONG FRAGMENT: KHEAVY=',KHEAVY(J)
+#endif
+ GOTO 1001
+ ENDIF
+ iz = ICHEAV(ic)
+ ia = IBHEAV(ic)
+
+ ekin1=TKHEAV(J)/dble(ia)
+ PRES(3)=CZHEAV(J) !Pz
+ PRES(2)=CYHEAV(J) !Py
+ PRES(1)=CXHEAV(J) !Px
+
+c if(ia.eq.2.and.iz.eq.1)then !deuterium
+c id=17
+c P0(5)=AAM(-3) !Mass
+c ia=1
+c iz=-1 !no to update the id and the mass in the loop
+c elseif(ia.eq.3.and.iz.eq.1)then !tritium
+c id=18
+c P0(5)=AAM(-4) !Mass
+c ia=1
+c iz=-1 !no to update the id and the mass in the loop
+c elseif(ia.eq.4.and.iz.eq.2)then !helium
+c id=19
+c P0(5)=AAM(-6) !Mass
+c ia=1
+c iz=-1 !no to update the id and the mass in the loop
+c endif !other nucleus
+
+ do k=1,ia
+c final particle
+ nptlxs=nptlxs+1
+ if(k.le.iz)then !protons
+ id=1120
+ P0(5)=AAM(1) !Mass
+ elseif(iz.ge.0)then !neutrons
+ id=1220
+ P0(5)=AAM(8) !Mass
+ endif
+
+ istptlxs(nptlxs)=0
+ if(nptlxs.gt.mxptlxs)stop'FLUKA: mxptl too small'
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' CONEX particle ',nptlxs,' id :',id,' after conversion'
+#endif
+
+ P0(4)=ekin1+P0(5) !Energy
+ P1=sqrt((P0(4)+P0(5))*(P0(4)-P0(5))) !Momentum
+ P0(3)=PRES(3)*P1 !Pz
+ P0(2)=PRES(2)*P1 !Py
+ P0(1)=PRES(1)*P1 !Px
+
+ call flk2cnx(id,P0,0)
+
+ enddo
+
+ enddo
+
+c Decay particles with short life time
+
+ np1=nptlini
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+
+1000 return
+
+1001 iret=1
+ goto 1000
+
+ 1002 iret=-1 !elastic
+ goto 1000
+
+ end
+
+c------------------------------------------------------------------------------
+ subroutine flk2cnx(id,P0,ir)
+c------------------------------------------------------------------------------
+c fill EPOS stack with particle from FLUKA
+c P0 particle momentum
+c id of particle
+c ir =1 for remnant
+c------------------------------------------------------------------------------
+#include "conex.h"
+#include "conex.incnex"
+ double precision P0(5)
+
+ xsptl(1,nptlxs)=P0(1) !P_x
+ xsptl(2,nptlxs)=P0(2) !P_y
+ xsptl(3,nptlxs)=P0(3) !P_z
+ xsptl(4,nptlxs)=P0(4) !E
+ xsptl(5,nptlxs)=P0(5) !mass
+ ityptlxs(nptlxs)=0
+ if(ir.eq.0)then
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ else
+ iorptlxs(nptlxs)=-1
+ jorptlxs(nptlxs)=0
+ endif
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.
+ xstivptl(2,nptlxs)=0.
+ idptlxs(nptlxs)=id
+
+c Put particle in cms frame.
+c call cxutlob5(xsyhaha, xsptl(1,nptlxs), xsptl(2,nptlxs)
+c *, xsptl(3,nptlxs), xsptl(4,nptlxs), xsptl(5,nptlxs))
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from FLUKA ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(i,nptlxs),i=1,5)
+#endif
+
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function fflucrse()
+c------------------------------------------------------------------------------
+c hadron-proton particle production cross section with Fluka.
+c ekin0 - kinetic energy
+c plab0 - particle momentum
+c------------------------------------------------------------------------------
+#include "conex.incnex"
+ double precision EKIN1,PPROJ,SIGREA,ZLDUM
+C-----------------------------------------------------------------------
+
+C CONVERT PARTICLE TYPE TO FLUKA
+ KPROJ = idtrafocx('nxs','flk',idprojxs)
+ EKIN1 = xsekin
+ PPROJ = xspnll
+C MATERIAL NUMBER 1 IS CURRENT MATERIAL
+ MMAT = 6
+C GET THE CROSS SECTION: SIGREA IS MICROSCOPIC CROSS SECTION (MB)
+C ZLDUM IS MACROSCOPIC CROSS SECTION (CM^-1)
+ CALL SIGINM( KPROJ,MMAT,EKIN1,PPROJ,SIGREA,ZLDUM )
+ fflucrse= SIGREA
+
+ return
+ end
+
+
+
+c------------------------------------------------------------------------------
+ double precision function flucrse(ek,mapro,matar,id)
+c------------------------------------------------------------------------------
+c inelastic cross section of FLUKA
+c if id=0, target = air
+c ek - kinetic energy in GeV
+c maproj - projec mass number (1<maproj<64)
+c matarg - projec mass number
+c id - target id (0=air)
+c------------------------------------------------------------------------------
+ implicit none
+#include "conex.h"
+#include "conex.incnex"
+ double precision ek,SINE,AMPRO,AMTAR
+ integer lapro,latar,mapro,matar,id,mt,lt,k
+ flucrse=0d0
+ lapro=max(1,mapro/2)
+ latar=max(1,matar/2)
+ if(id.eq.0)then
+ do k=1,3
+ mt=int(aira(k))
+ lt=max(1,mt/2)
+ call SIGIAA(lapro,mapro,AMPRO,lt,mt,AMTAR,ek,SINE)
+ flucrse=flucrse+airw(k)*SINE
+ enddo
+ else
+ call SIGIAA(lapro,mapro,AMPRO,latar,matar,AMTAR,ek,SINE)
+ flucrse=SINE
+ endif
+ return
+ end
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION FLRNDM()
+
+C-----------------------------------------------------------------------
+C FL(UKA) R(A)ND(O)M (GENERATOR)
+C THIS FUNCTON IS CALLED FROM FLUKA ROUTINES.
+C-----------------------------------------------------------------------
+ double precision dum,drangen
+ flrndm=drangen(dum)
+
+ RETURN
+ END
+
+C=======================================================================
+
+ SUBROUTINE ZEREMF
+
+C-----------------------------------------------------------------------
+C THIS DUMMY SUBROUTINE IS NECESSARY TO OVERRIDE A FLUKA SUBROUTINE
+C WITH IDENTICAL NAME WHICH OTHERWISE WOULD ERASE SOME EPOS COMMONS.
+C THIS SUBROUTINE IS CALLED FROM ZEROIN.
+C-----------------------------------------------------------------------
+
+ INCLUDE '(DBLPRC)'
+ INCLUDE '(DIMPAR)'
+ INCLUDE '(IOUNIT)'
+C-----------------------------------------------------------------------
+
+ RETURN
+ END
+
+#endif
+#endif
+#ifdef __GHEISHA__
+c Last modifications 03.07.2020 Compatibility with CORSIKA8 by T.Pierog
+c 07.04.2008 Compatibility gcc4
+c 18.01.2007 update to compile with CORSIKA with GHEISHA in double precision
+c 19.05.2004 Link routines between Gheisha and Conex.
+c author T. Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine IniGheisha
+c-----------------------------------------------------------------------
+c Primary initialization for Gheisha
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ COMMON /GHECRELABCT/ELCUT
+ DOUBLE PRECISION ELCUT(4)
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+
+#ifdef __CXDEBUG__
+ call utisx1('inighe ',4)
+ write(*,'(a)')'initialize Gheisha ...'
+#endif
+
+c common model parameters setting
+ call nghini
+ xsegymin=0.05d0
+ elcut(1)=enymin
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtGhe
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+c Gheisha Common
+ real anquasiel
+ common/ghecsquel/anquasiel,iquasiel
+
+ anquasiel=0.
+ if(maprojxs.gt.1)
+ & stop'Nucleus too big for Gheisha (Mmax=1) !'
+ xsbminim=0.d0
+ xsbmaxim=10000.d0
+ idp=(idprojxs/10)*10 !convert to bound state
+ icp=idtrafocx('nxs','ghe',idp)
+ if(icp.eq.8)icp=icp-nint(sign(1.d0,drangen(dummy)-0.5d0)) !pi0 (or rho0) = pi+ or pi-
+ ict=idtrafocx('nxs','ghe',idtargxs)
+ xsgheincs=CxGheSig(xspnll,xsekin,icp,ict
+ & ,matargxs,latargxs)
+ if(xsekin.lt.xsegymin)xsgheincs=0.d0 !below egymin, no interaction
+ xsbmax=20.d0
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'Gheisha used with (E,pz,proj,targ(A,Z))',xselab,xspnll,icp,ict
+ & ,'(',matargxs,',',latargxs,')'
+#endif
+
+ return
+ end
+
+c------------------------------------------------------------------------------
+ subroutine ghecrse(ek,idpro,idtar,latar,matar,sigi,sige)
+c------------------------------------------------------------------------------
+c inelastic and elastic cross section from gheisha
+c ek - kinetic lab energy
+c idpro - id of projectile
+c idtar - id of target(idtar=0 corresponds to air)
+c latar - charge of target
+c matar - mass of target
+c output :
+c sigi - inelastic cross section
+c sige - elastic cross section
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+c Gheisha Common
+ COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
+ DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM
+ INTEGER K0FLAG
+ PARAMETER (KKK=3)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON /GHECGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#else
+ COMMON /CGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#endif
+ DOUBLE PRECISION ACOMP(KKK),ZCOMP(KKK),WCOMP(KKK)
+
+ call cxidmass(idpro,amp)
+ p=sqrt(max(0.d0,(ek+2.d0*amp)*ek))
+ icp=idtrafocx('nxs','ghe',idpro)
+ if(icp.eq.8)icp=icp-nint(sign(1.d0,drangen(dummy)-0.5d0)) !pi0 = pi+ or pi-
+ ict=idtrafocx('nxs','ghe',idtar)
+ sigi=CxGheSig(p,ek,icp,ict,matar,latar)
+ sige=0.d0
+ do k=1,kk
+ sige=sige+AIEL(k)
+ enddo
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsghe(iret)
+c-----------------------------------------------------------------------
+c call gheisha to simulate interaction
+C itypr = -1 REACTION CROSS SECTIONS NOT YET TABULATED/PROGRAMMED
+C = 0 NO INTERACTION
+C = 1 ELASTIC SCATTERING
+C = 2 INELASTIC SCATTERING
+C = 3 NUCLEAR FISSION WITH INELEASTIC SCATTERING
+C = 4 NEUTRON CAPTURE
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ real anquasiel
+ common/ghecsquel/anquasiel,iquasiel
+
+
+ iret=0
+ itypr=0
+
+ if(abs(xsgheincs).lt.1d-20)goto 1001 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine Gheisha Production&',0,0,0)
+#endif
+ ntry=0
+ 10 continue
+ ntry=ntry+1
+ if(ntry.gt.10)goto 1001 !no interaction
+
+ ncolxs=1
+ nevtxs=1
+ nptlxs=0
+ xsbimp=0.d0
+ xsphi=0.d0
+
+ ist=1
+ call cxconre
+ call cxconwr(ist)
+
+ call CXGHEI(itypr)
+
+ if(itypr.le.1)goto 1000 !no interaction
+
+c Decay particles with short life time
+
+ np1=1
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+ mlim=0
+ nmes=0
+ if(iabs(idprojxs).le.1000)mlim=1
+ do i=1,nptlxs
+ if(istptlxs(i).eq.0.and.iabs(idptlxs(i)).lt.1000)nmes=nmes+1
+ enddo
+ if(nmes.eq.mlim)itypr=5
+
+ if(itypr.eq.5)then
+ if(ntry.eq.1)anquasiel=anquasiel+1.
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)'Quasi-elastic event'
+#endif
+ if(iquasiel.eq.0)then
+ if(ntry.le.100)then
+ goto 10
+ else
+ nptlxs=0
+ endif
+ endif
+ endif
+
+ if(itypr.eq.-1)stop'Problem in Gheisha'
+
+1000 return
+
+1001 iret=1
+ goto 1000
+
+ end
+
+c--------------------------------------------------------------------------
+ subroutine cx2ghe(idghe,pnex)
+c--------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension pnex(5)
+ idnex=idptlxs(1)
+ idghe=idtrafocx('nxs','ghe',idnex)
+ if(idghe.eq.8)idghe=idghe-nint(sign(1.d0,drangen(dummy)-0.5d0)) !pi0 = pi+ or pi-
+ do ii=1,2
+ pnex(ii)=0.d0
+ enddo
+ pnex(3)=xspnll
+ pnex(4)=xselab
+ pnex(5)=xsamproj
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,5(e11.4,1x))')
+ $ ' Initial Gheisha particle, id :',idghe
+ $ , ' momentum :',(pnex(k),k=1,5)
+#endif
+ end
+
+c--------------------------------------------------------------------------
+ subroutine ghe2cx(idghe,pnex)
+c--------------------------------------------------------------------------
+c Put gheisha particle with momentum pnex into conex stack
+c imod=1 put new particle
+c--------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ dimension pnex(5)
+
+ idnex=idtrafocx('ghe','nxs',idghe)
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'gheisha: mxptlxs too small'
+ istptlxs(nptlxs)=0
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ idptlxs(nptlxs)=idnex
+ P=0.d0
+ do ii=1,5
+ xsptl(ii,nptlxs)=pnex(ii)
+ P=P+pnex(ii)*pnex(ii)
+ enddo
+ xsptl(4,nptlxs)=SQRT(P)
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+
+c Put particle in cms frame.
+c call cxutlob5(xsyhaha, xsptl(1,nptlxs), xsptl(2,nptlxs)
+c *, xsptl(3,nptlxs), xsptl(4,nptlxs), xsptl(5,nptlxs))
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from Gheisha ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ end
+
+c-----------------------------------------------------------------------
+*CMZ : 24/04/2003 by T. PIEROG IK FZK KARLSRUHE
+*-- Author : The CONEX development group 24/04/2003
+C=======================================================================
+
+ SUBROUTINE CXGHEI(INTE)
+
+C-----------------------------------------------------------------------
+C C(ONE)X GHE(ISHA) I(NTERFACE)
+C
+C MAIN STEERING SUBROUT. FOR HADRON PACKAGE GHEISHA ***
+C THIS SUBROUTINE IS CALLED FROM EMSGHE.
+C
+C RETURN INTE (SEE DEFINITION BELOW)
+C
+C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG)
+C REDESIGN FOR CORSIKA : P. GABRIEL IK1 FZK KARLSRUHE
+C REDESIGN FOR CONEX : T. PIEROG IK3 FZK KARLSRUHE
+C-----------------------------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ dimension pnex(5)
+ common/cxair/airz(3),aira(3),airw(3),airavz,airava,airi(3)
+*KEEP,CGCOMP.
+ PARAMETER (KKK=3)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON /GHECGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#else
+ COMMON /CGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#endif
+ DOUBLE PRECISION ACOMP(KKK),ZCOMP(KKK),WCOMP(KKK)
+*KEEP,ELABCT.
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON /GHECRELABCT/ELCUT
+#else
+ COMMON /CRELABCT/ELCUT
+#endif
+ DOUBLE PRECISION ELCUT(4)
+c$$$*KEEP,RUNPAR.
+ COMMON /CONEXDBINC/MCXDBUG
+ INTEGER MCXDBUG
+
+ COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
+ DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM
+ INTEGER K0FLAG
+
+C --- GHEISHA COMMONS ---
+ PARAMETER (MXGKGH=100)
+ PARAMETER (MXGKPV=MXGKGH)
+ COMMON /VECUTY/ PV(10,MXGKPV)
+
+ COMMON /CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI,
+ $ SMU,CT,CTKCH,CTK0,
+ $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM,
+ $ RMASS(35),RCHARG(35)
+
+ DOUBLE PRECISION MP,MPI,MMU,MEL,MKCH,MK0,
+ * ML0,MSP,MS0,MSM,MX0,MXM
+
+ PARAMETER (MXEVEN=12*MXGKGH)
+ COMMON /GEVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN)
+
+ COMMON /PRNTFL/ INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,
+ * LPRT,NPRT(10)
+ LOGICAL LPRT,NPRT
+
+
+C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH ---
+C --- WITH VARIABLE "NEVENT" IN GEANT COMMON ---
+
+ PARAMETER (MXGKCU=MXGKGH)
+ COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG,
+ $ ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5),
+ $ RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU),
+ $ ATNO2,ZNO2
+
+C --- "IPART" CHANGED TO "KPART" IN COMMON /RESULT/ DUE TO CLASH ---
+C --- WITH VARIABLE "IPART" IN GEANT COMMON ---
+
+ COMMON /RESULT/ XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ,
+ $ USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,KPART,
+ $ IND,LCALO,ICEL,SINL,COSL,SINP,COSP,
+ $ XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD,
+ $ XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT
+ DOUBLE PRECISION NCH,INTCT
+
+C --- "ABSL(21)" CHANGED TO "ABSLTH(21)" IN COMMON /MAT/ DUE TO CLASH ---
+C --- WITH VARIABLE "ABSL" IN GEANT COMMON ---
+
+ COMMON /MAT / DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSLTH(21),
+ * CDEN(21),X0DEN(21),X1DEN(21),RION(21),
+ * FRAC1(21,10),DEN1(21,10),ATNO1(21,10),
+ * ZNO1(21,10),
+ * PARMAT(21,10),MATID(21),MATID1(21,24),MDEN(21),
+ * IFRAT,IFRAC(21),LMAT
+
+* DIMENSION IPELOS(35)
+c$$$ REAL EMAX,EEESQ
+
+ DIMENSION RNDM(1)
+
+c$$$ DIMENSION KIPART(48),IKPART(35)
+c$$$C --- ANGLES FOR NEW COUPLING WITH CORSIKA D. HECK DEC. 2000
+c$$$ DOUBLE PRECISION PHIRAN,PHIG,THETG
+
+ SAVE
+
+C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
+C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I ---
+C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I ---
+
+c$$$ DATA KIPART/
+c$$$ $ 1, 3, 4, 2, 5, 6, 8, 7,
+c$$$ $ 9, 12, 10, 13, 16, 14, 15, 11,
+c$$$ $ 35, 18, 20, 21, 22, 26, 27, 33,
+c$$$ $ 17, 19, 23, 24, 25, 28, 29, 34,
+c$$$ $ 35, 35, 35, 35, 35, 35, 35, 35,
+c$$$ $ 35, 35, 35, 35, 30, 31, 32, 35/
+c$$$
+c$$$ DATA IKPART/
+c$$$ $ 1, 4, 2, 3, 5, 6, 8, 7,
+c$$$ $ 9, 11, 16, 10, 12, 14, 15, 13,
+c$$$ $ 25, 18, 26, 19, 20, 21, 27, 28,
+c$$$ $ 29, 22, 23, 30, 31, 45, 46, 47,
+c$$$ $ 24, 32, 48/
+
+
+C --- DENOTE STABLE PARTICLES ACCORDING TO GHEISHA CODE ---
+C --- STABLE : GAMMA, NEUTRINO, ELECTRON, PROTON AND HEAVY FRAGMENTS ---
+C --- WHEN STOPPING THESE PARTICLES ONLY LOOSE THEIR KINETIC ENERGY ---
+* DATA IPELOS/
+* $ 1, 1, 0, 1, 0, 0, 0, 0,
+* $ 0, 0, 0, 0, 0, 1, 0, 0,
+* $ 0, 0, 0, 0, 0, 0, 0, 0,
+* $ 0, 0, 0, 0, 0, 1, 1, 1,
+* $ 0, 0, 1/
+
+C --- LOWERBOUND OF KINETIC ENERGY BIN IN N CROSS-SECTION TABLES ---
+ DATA TEKLOW /0.0001D0/
+
+C --- KINETIC ENERGY TO SWITCH FROM "CASN" TO "GNSLWD" FOR N CASCADE ---
+ DATA SWTEKN /0.05D0/
+C-----------------------------------------------------------------------
+
+C --- INITIALIZE RELEVANT GHEISHA VARIABLES ---
+
+ call cx2ghe(KPART,pnex)
+
+
+
+C MIXING OF NEUTRAL KAONS
+ IF ( KPART .EQ. 11 .OR. KPART .EQ. 12 ) THEN
+ CALL GRNDM( RNDM,1 )
+ IF ( RNDM(1) .LT. 0.5 ) THEN
+ KPART = 11
+ ELSE
+ KPART = 12
+ ENDIF
+ ENDIF
+ KKPART = KPART
+
+C --- TRANSPORT THE TRACK NUMBER TO GHEISHA AND INITIALIZE SOME NUMBERS
+C --- NTK=ITRA ITRA = CURRENT TRACK NUMBER IN GEANT (GCKINE)
+ NTK = 0
+ INTCT = 0.0D0
+ NEXT = 1
+ NTOT = 0
+ INTE = 0
+ TOF = 0.0D0
+
+c$$$C --- RESET ITYPE
+c$$$ SECPAR(1) = 0.D0
+
+C --- FILL RESULT COMMON FOR THIS TRACK WITH CORSIKA VALUES ---
+
+c iptl=1
+ AMAS = RMASS(KPART)
+ NCH = RCHARG(KPART)
+ XEND = 0.D0 !xorptl(1,iptl)
+ YEND = 0.D0 !xorptl(2,iptl)
+ ZEND = 0.D0 !xorptl(3,iptl)
+ USERW = 0.0D0
+
+ P=sqrt(pnex(1)**2+pnex(2)**2+pnex(3)**2)
+ PX = pnex(1)/P
+ PY = pnex(2)/P
+ PZ = pnex(3)/P
+
+ AMASQ=AMAS*AMAS
+ EN = SQRT(AMASQ+P*P)
+ EK = ABS ( EN - ABS(AMAS) )
+
+ if(abs(P-SQRT((EN-AMAS)*(EN+AMAS))).gt.1.d-3)
+ $write(MCXDBUG,'("On-Shell problem in Gheisha: ",2(g12.6,1x),i3)')
+ $ P,SQRT((EN-AMAS)*(EN+AMAS)),kpart
+
+
+#ifdef __CXDEBUG__
+ if(nprt(9))
+ $ write(MCXDBUG,'("in: ",5(g12.6,1x),i3)') P*PX,P*PY,P*PZ,EN
+ $ ,sqrt(amasq),kpart
+#endif
+
+ SINL=0.0D0
+ COSL=1.0D0
+ SINP=0.0D0
+ COSP=1.0D0
+C
+ IF (ABS(P) .LE. 1.0E-10) GO TO 1
+ SINL=PZ
+ COSL=SQRT(ABS(1.0-SINL**2))
+C
+ 1 CONTINUE
+ CALL GRNDM(RNDM,1)
+ PHI=RNDM(1)*TWPI
+ IF ((PX .EQ. 0.0D0) .AND. (PY .EQ. 0.0D0)) GOTO 3
+ IF (ABS(PX) .LT. 1.D-10) GOTO 2
+ PHI=ATAN2(PY,PX)
+ GOTO 3
+C
+ 2 CONTINUE
+ IF (PY .GT. 0.0D0) PHI=PI/2.0D0
+ IF (PY .LE. 0.0D0) PHI=3.0*PI/2.0D0
+C
+ 3 CONTINUE
+ SINP=SIN(PHI)
+ COSP=COS(PHI)
+
+C --- SET GHEISHA INDEX FOR THE CURRENT MEDIUM ALWAYS TO 1 ---
+ IND = 1
+
+C --- TRANSFER GLOBAL MATERIAL CONSTANTS FOR CURRENT MEDIUM ---
+C --- DETAILED DATA FOR COMPOUNDS IS OBTAINED VIA SUBROUT. COMPO ---
+
+ ATNO(IND+1) = airava !14.56 !atnxs, ztnxs : see cxghesig
+ ZNO(IND+1) = airavz ! 7.265
+ DEN(IND+1) = 0.0D0
+ RADLTH(IND+1)= 0.0D0
+ ABSLTH(IND+1)= 0.0D0
+
+C --- SETUP PARMAT FOR PHYSICS STEERING ---
+ PARMAT(IND+1,10)=0.0D0
+
+c 5 CONTINUE
+
+C --- INDICATE LIGHT (<= PI) AND HEAVY PARTICLES (HISTORICALLY) ---
+C --- CALIM CODE ---
+ J = 2
+ TEST = RMASS(7)-0.001D0
+ IF (ABS(AMAS) .LT. TEST) J=1
+
+C *** DIVISION INTO VARIOUS INTERACTION CHANNELS DENOTED BY "INTE" ***
+C THE CONVENTION FOR "INT" IS THE FOLLOWING
+
+C INTE = -1 REACTION CROSS-SECTIONS NOT YET TABULATED/PROGRAMMED
+C = 0 NO INTERACTION
+C = 1 ELASTIC SCATTERING
+C = 2 INELASTIC SCATTERING
+C = 3 NUCLEAR FISSION WITH INELASTIC SCATTERING
+C = 4 NEUTRON CAPTURE
+
+C --- INTACT CODE ---
+ ALAM1 = 0.0D0
+ CALL GRNDM( RNDM,1 )
+ RAT = RNDM(1)*ALAM
+
+C --- DEFAULT VALUES FOR AIR
+ ATNO2 = airava !14.56
+ ZNO2 = airavz !7.265
+
+ DO K = 1, KK
+ ATNO2 = ACOMP(K)
+ ZNO2 = ZCOMP(K)
+
+C --- TRY FOR ELASTIC SCATTERING --- !elastic scattering not use
+ctp INTE = 1
+ctp ALAM1 = ALAM1+AIEL(K)
+ctp IF (RAT .LT. ALAM1) GOTO 8
+
+C --- TRY FOR INELASTIC SCATTERING ---
+ INTE = 2
+ ALAM1 = ALAM1+AIIN(K)
+ IF (RAT .LT. ALAM1) GOTO 8
+
+C --- TRY FOR NEUTRON CAPTURE --- !neutron capture scattering not use
+ctp INTE = 4
+ctp ALAM1 = ALAM1+AICA(K)
+ctp IF (RAT .LT. ALAM1) GOTO 8
+
+ ENDDO
+
+C --- NO REACTION SELECTED ==> ELASTIC SCATTERING ---
+ INTE = 1
+
+C *** TAKE ACTION ACCORDING TO SELECTED REACTION CHANNEL ***
+C --- FOLLOWING CODE IS A TRANSLATION OF "CALIM" INTO GEANT JARGON ---
+
+ 8 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,1001) INTE
+ 1001 FORMAT(' *CXGHEI* INTERACTION TYPE CHOSEN INTE = ',I3)
+#endif
+
+ IF (INTE .NE. 4) GOTO 10
+
+C --- NEUTRON CAPTURE ---
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2000)
+ 2000 FORMAT(' *CXGHEI* SUBROUT. CAPTUR WILL BE CALLED')
+#endif
+ CALL CAPTUR( NOPT )
+ GOTO 40
+
+ 10 CONTINUE
+ IF (INTE .NE. 3) GO TO 11
+C --- NUCLEAR FISSION ---
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2001
+ 2001 FORMAT(' *GHEISH* ROUTINE FISSIO WILL BE CALLED')
+#endif
+c ISTOP=1
+ TKIN=FISSIO(EK)
+ GO TO 40
+
+ 11 CONTINUE
+
+C --- ELASTIC AND INELASTIC SCATTERING ---
+ PV(1,MXGKPV) = P*PX
+ PV(2,MXGKPV) = P*PY
+ PV(3,MXGKPV) = P*PZ
+ PV(4,MXGKPV) = EN
+ PV(5,MXGKPV) = AMAS
+ PV(6,MXGKPV) = NCH
+ PV(7,MXGKPV) = TOF
+ PV(8,MXGKPV) = KPART
+ PV(9,MXGKPV) = 0.D0
+ PV(10,MXGKPV)= USERW
+
+C --- ADDITIONAL PARAMETERS TO SIMULATE FERMI MOTION AND EVAPORATION ---
+ DO JENP = 1, 10
+ ENP(JENP) = 0.D0
+ ENDDO
+ ENP(5) = EK
+ ENP(6) = EN
+ ENP(7) = P
+
+ IF (INTE .NE. 1) GOTO 12
+
+C *** ELASTIC SCATTERING PROCESSES ***
+
+C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS ---
+ IF ((KPART .GE. 30) .AND. (KPART .LE. 32)) GOTO 35
+
+C --- NORMAL ELASTIC SCATTERING FOR LIGHT MEDIA ---
+ IF (ATNO2 .LT. 1.5D0) GOTO 35
+
+C --- COHERENT ELASTIC SCATTERING FOR HEAVY MEDIA ---
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2002)
+ 2002 FORMAT(' *CXGHEI* SUBROUT. COSCAT WILL BE CALLED')
+#endif
+ CALL COSCAT
+ GOTO 40
+
+C *** NON-ELASTIC SCATTERING PROCESSES ***
+ 12 CONTINUE
+
+C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS ---
+ IF ((KPART .GE. 30) .AND. (KPART .LE. 32)) GOTO 35
+
+C *** USE SOMETIMES NUCLEAR REACTION SUBROUT. "NUCREC" FOR LOW ENERGY
+C *** PROTON AND NEUTRON SCATTERING ***
+ CALL GRNDM( RNDM,1 )
+ TEST1 = RNDM(1)
+ TEST2 = 4.5D0*(EK-0.01D0)
+ IF ((KPART .EQ. 14) .AND. (TEST1 .GT. TEST2)) GOTO 85
+ IF ((KPART .EQ. 16) .AND. (TEST1 .GT. TEST2)) GOTO 86
+
+C *** FERMI MOTION AND EVAPORATION ***
+ TKIN = CINEMA(EK)
+ PV(9,MXGKPV) = TKIN
+ ENP(5) = EK+TKIN
+C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
+ IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW
+ ENP(6) = ENP(5)+ABS(AMAS)
+ ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
+ ENP(7) = SQRT(ABS(ENP(7)))
+ TKIN = FERMIG(ENP(5))
+ ENP(5) = ENP(5)+TKIN
+C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
+ IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW
+ ENP(6) = ENP(5)+ABS(AMAS)
+ ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
+ ENP(7) = SQRT(ABS(ENP(7)))
+ TKIN = EXNU(ENP(5))
+ ENP(5) = ENP(5)-TKIN
+C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
+ IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW
+ ENP(6) = ENP(5)+ABS(AMAS)
+ ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
+ ENP(7) = SQRT(ABS(ENP(7)))
+
+C *** IN CASE OF ENERGY ABOVE CUT-OFF LET THE PARTICLE CASCADE ***
+ IF ( ENP(5) .GT. ELCUT(1)) GOTO 35
+
+C --- SECOND CHANCE FOR ANTI-BARYONS DUE TO POSSIBLE ANNIHILATION ---
+ IF ((AMAS .GE. 0.0D0) .OR. (KPART .LE. 14)) GOTO 13
+ ANNI = 1.3D0*P
+ IF (ANNI .GT. 0.4D0) ANNI=0.4D0
+ CALL GRNDM( RNDM,1 )
+ TEST = RNDM(1)
+ IF (TEST .GT. ANNI) GOTO 35
+
+C *** PARTICLE WITH ENERGY BELOW CUT-OFF ***
+C --- ==> ONLY NUCLEAR EVAPORATION AND QUASI-ELASTIC SCATTERING ---
+ 13 CONTINUE
+
+#ifdef __CXDEBUG__
+ IF (NPRT(9))WRITE(MCXDBUG,1002) KPART,EK,EN,P,ENP(5),ENP(6),ENP(7)
+ 1002 FORMAT(' *CXGHEI* ENERGY BELOW CUT-OFF FOR GHEISHA PARTICLE ',I3/
+ $ ' EK,EN,P,ENP(5),ENP(6),ENP(7) = ',6(G12.5,1X))
+#endif
+
+ctp We don't wan't nuclear evaporation or quasi-elastic scattering -> no interaction
+ctp GOTO 40
+
+
+ IF ((KPART .NE. 14) .AND. (KPART .NE. 16)) GOTO 14
+ IF (KPART .EQ. 16) GOTO 86
+
+C --- SLOW PROTON ---
+ 85 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2003) EK,KPART
+ 2003 FORMAT(' *CXGHEI* SUBROUT. NUCREC WILL BE CALLED',
+ $ ' EK = ',G12.5,' GEV KPART = ',I3)
+#endif
+ CALL NUCREC( NOPT,2 )
+
+ IF (NOPT .NE. 0) GOTO 50
+
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2004)EK,KPART
+ 2004 FORMAT(' *CXGHEI* SUBROUT. COSCAT WILL BE CALLED',
+ $ ' EK = ',G12.5,' GEV KPART = ',I3)
+#endif
+ CALL COSCAT
+ GOTO 40
+
+C --- SLOW NEUTRON ---
+ 86 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2015)
+#endif
+ NUCFLG = 0
+ CALL GNSLWD( NUCFLG,INTE,NFL,TEKLOW )
+ IF (NUCFLG .NE. 0) GOTO 50
+ GOTO 40
+
+C --- OTHER SLOW PARTICLES ---
+ 14 CONTINUE
+ IPA(1) = KPART
+C --- DECIDE FOR PROTON OR NEUTRON TARGET ---
+ IPA(2) = 16
+ CALL GRNDM( RNDM,1 )
+ TEST1 = RNDM(1)
+ TEST2 = ZNO2/ATNO2
+ IF (TEST1 .LT. TEST2) IPA(2)=14
+ AVERN = 0.0D0
+ NFL = 1
+ IF (IPA(2) .EQ. 16) NFL=2
+ IPPP = KPART
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2005)
+ 2005 FORMAT(' *CXGHEI* SUBROUT. TWOB WILL BE CALLED')
+#endif
+ CALL TWOB( IPPP,NFL,AVERN )
+ GOTO 40
+
+C --- INITIALIZATION OF CASCADE QUANTITIES ---
+ 35 CONTINUE
+
+C *** CASCADE GENERATION ***
+C --- CALCULATE FINAL STATE MULTIPLICITY AND LONGITUDINAL AND ---
+C --- TRANSVERSE MOMENTUM DISTRIBUTIONS ---
+
+C --- FIXED PARTICLE TYPE TO STEER THE CASCADE ---
+ KKPART = KPART
+
+C --- NO CASCADE FOR LEPTONS ---
+ IF (KKPART .LE. 6) GOTO 9999
+
+C *** WHAT TO DO WITH "NEW PARTICLES" FOR GHEISHA ?????? ***
+C --- RETURN FOR THE TIME BEING ---
+ IF (KKPART .GE. 35) GOTO 9999
+
+C --- CASCADE OF HEAVY FRAGMENTS
+ IF ((KKPART .GE. 30) .AND. (KKPART .LE. 32)) GOTO 390
+
+C --- INITIALIZE THE IPA ARRAY ---
+* CALL VZERO( IPA(1),MXGKCU )
+CDH
+ DO III = 1, MXGKCU
+ IPA(III) = 0
+ ENDDO
+
+
+C --- CASCADE OF OMEGA - AND OMEGA - BAR ---
+ IF (KKPART .EQ. 33) GOTO 330
+ IF (KKPART .EQ. 34) GOTO 331
+
+ NVEPAR = KKPART-17
+ IF (NVEPAR .LE. 0) GOTO 15
+ GOTO (318,319,320,321,322,323,324,325,326,327,328,329),NVEPAR
+
+ 15 CONTINUE
+ NVEPAR = KKPART-6
+ GOTO (307,308,309,310,311,312,313,314,315,316,317,318),NVEPAR
+
+C --- PI+ CASCADE ---
+ 307 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2006)
+ 2006 FORMAT(' *CXGHEI* SUBROUT. CASPIP WILL BE CALLED')
+#endif
+ CALL CASPIP( J,INTE,NFL )
+ GOTO 40
+
+C --- PI0 ==> NO CASCADE ---
+ 308 CONTINUE
+ GOTO 40
+
+C --- PI- CASCADE ---
+ 309 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2007)
+ 2007 FORMAT(' *CXGHEI* SUBROUT. CASPIM WILL BE CALLED')
+#endif
+ CALL CASPIM( J,INTE,NFL )
+ GOTO 40
+
+C --- K+ CASCADE ---
+ 310 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2008)
+ 2008 FORMAT(' *CXGHEI* SUBROUT. CASKP WILL BE CALLED')
+#endif
+ CALL CASKP( J,INTE,NFL )
+ GOTO 40
+
+C --- K0 CASCADE ---
+ 311 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2009)
+ 2009 FORMAT(' *CXGHEI* SUBROUT. CASK0 WILL BE CALLED')
+#endif
+ CALL CASK0( J,INTE,NFL )
+ GOTO 40
+
+C --- K0 BAR CASCADE ---
+ 312 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2010)
+ 2010 FORMAT(' *CXGHEI* SUBROUT. CASK0B WILL BE CALLED')
+#endif
+ CALL CASK0B( J,INTE,NFL )
+ GOTO 40
+
+C --- K- CASCADE ---
+ 313 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2011)
+ 2011 FORMAT(' *CXGHEI* SUBROUT. CASKM WILL BE CALLED')
+#endif
+ CALL CASKM( J,INTE,NFL )
+ GOTO 40
+
+C --- PROTON CASCADE ---
+ 314 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2012)
+ 2012 FORMAT(' *CXGHEI* SUBROUT. CASP WILL BE CALLED')
+#endif
+ CALL CASP( J,INTE,NFL )
+ GOTO 40
+
+C --- PROTON BAR CASCADE ---
+ 315 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2013)
+ 2013 FORMAT(' *CXGHEI* SUBROUT. CASPB WILL BE CALLED')
+#endif
+ CALL CASPB( J,INTE,NFL )
+ GOTO 40
+
+C --- NEUTRON CASCADE ---
+ 316 CONTINUE
+ NUCFLG = 0
+ IF (EK .GT. SWTEKN) THEN
+ CALL CASN( J,INTE,NFL )
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2014)
+ 2014 FORMAT(' *CXGHEI* SUBROUT. CASN WILL BE CALLED')
+#endif
+ ELSE
+ CALL GNSLWD( NUCFLG,INTE,NFL,TEKLOW )
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2015)
+ 2015 FORMAT(' *CXGHEI* SUBROUT. GNSLWD WILL BE CALLED')
+#endif
+ ENDIF
+ IF (NUCFLG .NE. 0) GOTO 50
+ GOTO 40
+
+C --- NEUTRON BAR CASCADE ---
+ 317 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2016)
+ 2016 FORMAT(' *CXGHEI* SUBROUT. CASNB WILL BE CALLED')
+#endif
+ CALL CASNB( J,INTE,NFL )
+ GOTO 40
+
+C --- LAMBDA CASCADE ---
+ 318 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2017)
+ 2017 FORMAT(' *CXGHEI* SUBROUT. CASL0 WILL BE CALLED')
+#endif
+ CALL CASL0( J,INTE,NFL )
+ GOTO 40
+
+C --- LAMBDA BAR CASCADE ---
+ 319 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2018)
+ 2018 FORMAT(' *CXGHEI* SUBROUT. CASAL0 WILL BE CALLED')
+#endif
+ CALL CASAL0( J,INTE,NFL )
+ GOTO 40
+
+C --- SIGMA + CASCADE ---
+ 320 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2019)
+ 2019 FORMAT(' *CXGHEI* SUBROUT. CASSP WILL BE CALLED')
+#endif
+ CALL CASSP( J,INTE,NFL )
+ GOTO 40
+
+C --- SIGMA 0 ==> NO CASCADE ---
+ 321 CONTINUE
+ GOTO 40
+
+C --- SIGMA - CASCADE ---
+ 322 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2020)
+ 2020 FORMAT(' *CXGHEI* SUBROUT. CASSM WILL BE CALLED')
+#endif
+ CALL CASSM( J,INTE,NFL )
+ GOTO 40
+
+C --- SIGMA + BAR CASCADE ---
+ 323 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2021)
+ 2021 FORMAT(' *CXGHEI* SUBROUT. CASASP WILL BE CALLED')
+#endif
+ CALL CASASP( J,INTE,NFL )
+ GOTO 40
+
+C --- SIGMA 0 BAR ==> NO CASCADE ---
+ 324 CONTINUE
+ GOTO 40
+
+C --- SIGMA - BAR CASCADE ---
+ 325 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2022)
+ 2022 FORMAT(' *CXGHEI* SUBROUT. CASASM WILL BE CALLED')
+#endif
+ CALL CASASM( J,INTE,NFL )
+ GOTO 40
+
+C --- XI 0 CASCADE ---
+ 326 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2023
+ 2023 FORMAT(' *CXGHEI* SUBROUT. CASX0 WILL BE CALLED')
+#endif
+ CALL CASX0( J,INTE,NFL )
+ GOTO 40
+
+C --- XI - CASCADE ---
+ 327 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2024
+ 2024 FORMAT(' *CXGHEI* SUBROUT. CASXM WILL BE CALLED')
+#endif
+ CALL CASXM( J,INTE,NFL )
+ GOTO 40
+
+C --- XI 0 BAR CASCADE ---
+ 328 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2025
+ 2025 FORMAT(' *CXGHEI* SUBROUT. CASAX0 WILL BE CALLED')
+#endif
+ CALL CASAX0( J,INTE,NFL )
+ GOTO 40
+
+C --- XI - BAR CASCADE ---
+ 329 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2026
+ 2026 FORMAT(' *CXGHEI* SUBROUT. CASAXM WILL BE CALLED')
+#endif
+ CALL CASAXM( J,INTE,NFL )
+ GOTO 40
+
+C --- OMEGA - CASCADE ---
+ 330 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2027
+ 2027 FORMAT(' *CXGHEI* SUBROUT. CASOM WILL BE CALLED')
+#endif
+ CALL CASOM( J,INTE,NFL )
+ GOTO 40
+
+C --- OMEGA - BAR CASCADE ---
+ 331 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) PRINT 2028
+ 2028 FORMAT(' *CXGHEI* SUBROUT. CASAOM WILL BE CALLED')
+#endif
+ CALL CASAOM( J,INTE,NFL )
+ GOTO 40
+
+C --- HEAVY FRAGMENT CASCADE ---
+ 390 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,2090)
+ 2090 FORMAT(' *CXGHEI* SUBROUT. CASFRG WILL BE CALLED')
+#endif
+ NUCFLG = 0
+ CALL CASFRG( NUCFLG,INTE,NFL )
+ IF (NUCFLG .NE. 0) GOTO 50
+
+C *** CHECK WHETHER THERE ARE NEW PARTICLES GENERATED ***
+ 40 CONTINUE
+ IF ((NTOT .NE. 0) .OR. (KKPART .NE. KPART)) GOTO 50
+
+C
+C --- NO SECONDARIES GENERATED AND PARTICLE IS STILL THE SAME ---
+C --- ==> COPY PROJECTILE BACK IN CONEX ---
+C --- In case of crazy momentum value ==> no change to CONEX stack ---
+ IF (P .LT. 0.) GO TO 41
+ call ghe2cx(KPART,pnex)
+
+ 41 CONTINUE
+
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,1003)NTOT,KPART,KKPART
+ 1003 FORMAT(' *GHEISH* NO SEC. GEN. NTOT,KPART,KKPART = ',
+ $ 3(I3,1X)/
+ $ ' CURRENT PARTICLE ON THE STACK AGAIN')
+#endif
+ GO TO 9999
+C
+C *** CURRENT PARTICLE IS NOT THE SAME AS IN THE BEGINNING OR/AND ***
+C *** ONE OR MORE SECONDARIES HAVE BEEN GENERATED ***
+ 50 CONTINUE
+
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,1004)NTOT,KPART,KKPART
+ 1004 FORMAT(' *CXGHEI* SEC. GEN. NTOT,KPART,KKPART = ',
+ $ 3(I3,1X))
+#endif
+
+C --- INITIAL PARTICLE TYPE HAS BEEN CHANGED ==> PUT NEW TYPE ON ---
+C --- THE TEMPORARY STACK ---
+
+C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT ---
+ IF ((KPART .NE. 11) .AND. (KPART .NE. 12)) GOTO 52
+ CALL GRNDM( RNDM,1 )
+ KPART = int(11.5D0+RNDM(1))
+
+ 52 CONTINUE
+
+C --- IN CASE THE NEW PARTICLE IS A NEUTRINO ==> FORGET IT ---
+ IF (KPART .EQ. 2) GOTO 60
+ pnex(1)=PX*P
+ pnex(2)=PY*P
+ pnex(3)=PZ*P
+ pnex(4)=0.d0
+ pnex(5)=abs(RMASS(KPART))
+ call ghe2cx(KPART,pnex)
+
+C *** CHECK WHETHER SECONDARIES HAVE BEEN GENERATED AND COPY THEM ***
+C *** ALSO ON THE GEANT STACK ***
+ 60 CONTINUE
+
+C --- ALL QUANTITIES ARE TAKEN FROM THE GHEISHA STACK WHERE THE ---
+C --- CONVENTION IS THE FOLLOWING ---
+C
+C EVE(INDEX+ 1)= X
+C EVE(INDEX+ 2)= Y
+C EVE(INDEX+ 3)= Z
+C EVE(INDEX+ 4)= NCAL
+C EVE(INDEX+ 5)= NCELL
+C EVE(INDEX+ 6)= MASS
+C EVE(INDEX+ 7)= CHARGE
+C EVE(INDEX+ 8)= TOF
+C EVE(INDEX+ 9)= PX
+C EVE(INDEX+10)= PY
+C EVE(INDEX+11)= PZ
+C EVE(INDEX+12)= TYPE
+
+ IF ( NTOT .LE. 0 ) GOTO 9999
+
+C --- ONE OR MORE SECONDARIES HAVE BEEN GENERATED ---
+ DO 61 L = 1, NTOT
+ INDEX = (L-1)*12
+ JND = int(EVE(INDEX+12))
+
+C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT ---
+ IF ((JND .NE. 11) .AND. (JND .NE. 12)) GOTO 63
+ CALL GRNDM( RNDM,1 )
+ JND = int(11.5D0+RNDM(1))
+
+C --- FORGET ABOUT NEUTRINOS ---
+ 63 CONTINUE
+ IF ( JND .EQ. 2 ) GOTO 61
+
+
+ PLX = EVE(INDEX+9)
+ PLY = EVE(INDEX+10)
+ PLZ = EVE(INDEX+11)
+ pnex(1)=PLX
+ pnex(2)=PLY
+ pnex(3)=PLZ
+ pnex(4)=0.d0
+ pnex(5)=abs(EVE(INDEX+6)) ! RMASS()
+ call ghe2cx(JND,pnex)
+
+ 61 CONTINUE
+
+
+ 9999 CONTINUE
+
+ RETURN
+ END
+
+*CMZ : 05/02/2003 09.12.43 by D. HECK IK FZK KARLSRUHE
+*-- Author : The CORSIKA development group 21/04/1994
+C=======================================================================
+
+ SUBROUTINE NGHINI
+
+C-----------------------------------------------------------------------
+C N(EXUS) GH(EISHA) INI(TIALIZATION)
+C INITIALIZATION OF RELEVANT GHEISHA VARIABLES.
+C THIS SUBROUTINE IS CALLED FROM IniGheisha.
+C
+C ORIGIN : GHEISHA SUBROUT. "GHEINI", F.CARMINATI
+C REDESIGN FOR CORSIKA : P. GABRIEL IK1 FZK KARLSRUHE
+C REDESIGN FOR CONEX : P. T. PIEROG IK3 FZK KARLSRUHE
+C-----------------------------------------------------------------------
+
+
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ COMMON /CONEXDBINC/MCXDBUG
+ INTEGER MCXDBUG
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
+ DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM
+ INTEGER K0FLAG
+
+C --- GHEISHA COMMONS ---
+C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES ---
+ COMMON /KGINIT/ KGINIT(50)
+
+ COMMON /CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI,
+ $ SMU,CT,CTKCH,CTK0,
+ $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM,
+ $ RMASS(35),RCHARG(35)
+
+ DOUBLE PRECISION MP,MPI,MMU,MEL,MKCH,MK0,
+ * ML0,MSP,MS0,MSM,MX0,MXM
+
+ PARAMETER (MXGKGH=100)
+ PARAMETER (MXEVEN=12*MXGKGH)
+ COMMON /GEVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN)
+
+ PARAMETER (MXGKPV=MXGKGH)
+ COMMON /VECUTY/ PV(10,MXGKPV)
+
+C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS ---
+C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND ---
+ COMMON /LIMITS/ EXPXL,EXPXU
+
+
+C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH ---
+C --- WITH VARIABLE "NEVENT" IN GEANT COMMON ---
+
+ PARAMETER (MXGKCU=MXGKGH)
+ COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG,
+ $ ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5),
+ $ RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU),
+ $ ATNO2,ZNO2
+#endif
+ COMMON /PRNTFL/ INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,
+ * LPRT,NPRT(10)
+ LOGICAL LPRT,NPRT
+
+ SAVE
+
+C Conex COMMON
+ integer ighenexs
+ common /cxighnx/ ighenexs(35)
+ common/xscnsta/xspi,xsainfin
+#ifdef __CXDEBUG__
+ parameter (mxisx=200)
+ character*500 subisx,textisx
+ integer isx,nisx,isxsub,isxsave,isxxsave
+ common/cxisx/isx,nisx,subisx(mxisx),isxsub(mxisx)
+ & ,isxsave,isxxsave,textisx
+#endif
+ character*500 fnho,fnck,fnwle,fnwhe,fndkz,fndkl,fndks,fndkm
+ &,fnilo,fndke,fndkn,fndkg,fnwgh,fnwgl
+ integer ifho,ifck,ifwle,ifwhe,ifdkz,ifdkl,ifdks,ifdkm,ifilo
+ &,ifdke,ifdkn,ifdkg,ifwgh,ifwgl
+ common /cxfiles/fnho,ifho,fnck,ifck,fnwle,ifwle,fnwhe,ifwhe
+ &,fndkz,ifdkz,fndkl,ifdkl,fndks,ifdks,fndkm,ifdkm,fnilo,ifilo
+ &,fndke,ifdke,fndkn,ifdkn,fndkg,ifdkg,fnwgh,ifwgh
+ &,fnwgl,ifwgl
+C-----------------------------------------------------------------------
+
+
+C --- SET GHEISHA I/O UNITS TO THE SAME AS FOR CONEX --
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ INBCD=6
+ NEWBCD=6
+#endif
+#ifdef __CXDEBUG__
+ IF (isx.ge.8) NEWBCD=ifck
+ MCXDBUG=ifck
+#else
+ MCXDBUG=6
+#endif
+
+C --- INITIALIZE ALL GHEISHA PRINT FLAGS AS FALSE ---
+C --- ACTIVATION IS DONE BY "DEBUG" STEERING CARD ---
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ DO J = 1, 10
+ NPRT(J)=.FALSE.
+ ENDDO
+#endif
+ jmax=0
+#ifdef __CXDEBUG__
+ if(isx.ge.8)jmax=min(isx-1,10)
+#endif
+ do j=1,jmax
+ NPRT(J)=.TRUE.
+ enddo
+#ifdef __CXDEBUG__
+ if(isx.ge.8)NPRT(9)=.TRUE.
+#endif
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ LPRT=.FALSE.
+ DO I = 1, MXGKPV
+ DO J = 1, 10
+ PV(J,I)=0.D0
+ ENDDO
+ ENDDO
+
+C --- INITIALIZE KGINIT ARRAY ---
+ DO J = 1, 50
+ KGINIT(J)=0
+ ENDDO
+
+C --- INITIALIZE SOME CUT-OFF PARAMETERS WITH CONEX VALUES ---
+ TOFCUT=xsainfin !1.0E+20
+ NSIZE=MXEVEN
+ K0FLAG=0
+ CENG(3)=0.D0
+ CENG(4)=0.D0
+
+C --- INITIALIZE PI, 2*PI, PI/2 AND PARTICLE PARAMETERS ---
+ PI=xspi
+ TWPI=2.0D0*PI
+ PIBTW=PI/2.0D0
+C *** GAMMA ***
+ call cxidmass(ighenexs(1),am)
+ RMASS(1)=am
+ RCHARG(1)=0.0D0
+C *** NEUTRINO ***
+ call cxidmass(ighenexs(2),am)
+ RMASS(2)=am
+ RCHARG(2)=0.0D0
+C *** E+ ***
+ call cxidmass(ighenexs(3),am)
+ RMASS(3)=am
+ RCHARG(3)=1.0D0
+C *** E- ***
+ call cxidmass(ighenexs(4),am)
+ RMASS(4)=am
+ RCHARG(4)=-1.0D0
+C *** MU+ ***
+ call cxidmass(ighenexs(5),am)
+ RMASS(5)=am
+ RCHARG(5)=1.0D0
+C *** MU- ***
+ call cxidmass(ighenexs(6),am)
+ RMASS(6)=am
+ RCHARG(6)=-1.0D0
+C *** PI+ ***
+ call cxidmass(ighenexs(7),am)
+ RMASS(7)=am
+ RCHARG(7)=1.0D0
+ CT=780.4
+C *** PI0 ***
+ call cxidmass(ighenexs(8),am)
+ RMASS(8)=am
+ RCHARG(8)=0.0D0
+C *** PI- ***
+ call cxidmass(ighenexs(9),am)
+ RMASS(9)=am
+ RCHARG(9)=-1.0D0
+C *** K+ ***
+ call cxidmass(ighenexs(10),am)
+ RMASS(10)=am
+ RCHARG(10)=1.0D0
+ CTKCH=370.9
+C *** K0 SHORT (==> K0) ***
+ call cxidmass(ighenexs(11),am)
+ RMASS(11)=am
+ RCHARG(11)=0.0D0
+ CTK0=2.675
+C *** K0 LONG (==> K0 BAR) ***
+ call cxidmass(ighenexs(12),am)
+ RMASS(12)=-am
+ RCHARG(12)=0.0D0
+C *** K- ***
+ call cxidmass(ighenexs(13),am)
+ RMASS(13)=am
+ RCHARG(13)=-1.0D0
+C *** P ***
+ call cxidmass(ighenexs(14),am)
+ RMASS(14)=am
+ RCHARG(14)=1.0D0
+C *** P BAR ***
+ call cxidmass(ighenexs(15),am)
+ RMASS(15)=-am
+ RCHARG(15)=-1.0D0
+C *** N ***
+ call cxidmass(ighenexs(16),am)
+ RMASS(16)=am
+ RCHARG(16)=0.0D0
+C *** N BAR ***
+ call cxidmass(ighenexs(17),am)
+ RMASS(17)=-am
+ RCHARG(17)=0.0D0
+C *** L0 ***
+ call cxidmass(ighenexs(18),am)
+ RMASS(18)=am
+ RCHARG(18)=0.0D0
+ CTL0=7.89
+C *** L0 BAR ***
+ call cxidmass(ighenexs(19),am)
+ RMASS(19)=-am
+ RCHARG(19)=0.0D0
+C *** S+ ***
+ call cxidmass(ighenexs(20),am)
+ RMASS(20)=am
+ RCHARG(20)=1.0D0
+ CTSP=2.40
+C *** S0 ***
+ call cxidmass(ighenexs(21),am)
+ RMASS(21)=am
+ RCHARG(21)=0.0D0
+C *** S- ***
+ call cxidmass(ighenexs(22),am)
+ RMASS(22)=am
+ RCHARG(22)=-1.0D0
+ CTSM=4.44
+C *** S+ BAR ***
+ call cxidmass(ighenexs(23),am)
+ RMASS(23)=-am
+ RCHARG(23)=-1.0D0
+C *** S0 BAR ***
+ call cxidmass(ighenexs(24),am)
+ RMASS(24)=-am
+ RCHARG(24)=0.0D0
+C *** S- BAR ***
+ call cxidmass(ighenexs(25),am)
+ RMASS(25)=-am
+ RCHARG(25)=1.0D0
+C *** XI0 ***
+ call cxidmass(ighenexs(26),am)
+ RMASS(26)=am
+ RCHARG(26)=0.0D0
+ CTX0=8.69
+C *** XI- ***
+ call cxidmass(ighenexs(27),am)
+ RMASS(27)=am
+ RCHARG(27)=-1.0D0
+ CTXM=4.92
+C *** XI0 BAR ***
+ call cxidmass(ighenexs(28),am)
+ RMASS(28)=-am
+ RCHARG(28)=0.0D0
+ CTX0=8.69
+C *** XI- BAR ***
+ call cxidmass(ighenexs(29),am)
+ RMASS(29)=-am
+ RCHARG(29)=1.0D0
+C *** DEUTERON ***
+ call cxidmass(ighenexs(30),am)
+ RMASS(30)=am
+ RCHARG(30)=1.0D0
+C *** TRITON ***
+ call cxidmass(ighenexs(31),am)
+ RMASS(31)=am
+ RCHARG(31)=1.0D0
+C *** ALPHA ***
+ call cxidmass(ighenexs(32),am)
+ RMASS(32)=am
+ RCHARG(32)=2.0D0
+C *** OMEGA- ***
+ call cxidmass(ighenexs(33),am)
+ RMASS(33)=am
+ RCHARG(33)=-1.0D0
+C *** OMEGA- BAR ***
+ call cxidmass(ighenexs(34),am)
+ RMASS(34)=-am
+ RCHARG(34)=1.0D0
+C *** NEW PARTICLE (GEANTINO) ***
+ RMASS(35)=0.0D0
+ RCHARG(35)=0.0D0
+
+#ifdef __CXDEBUG__
+ IF (NPRT(4))
+ $ WRITE(MCXDBUG,1000) (I,RMASS(I),RCHARG(I),I=1,33),
+ $ CT,CTKCH,CTK0,CTL0,CTSP,CTSM,CTX0,CTXM
+ 1000 FORMAT(' *CGHINI* === GHEISHA PARTICLE PROPERTIES ==='/
+ $ '0INDEX',5X,'MASS (GEV)',5X,'CHARGE'/1H /
+ $ 33(1H ,1X,I3,5X,F11.6,6X,F5.2/),
+ $ '0PI +- CT = ',G12.5,' K +- CT = ',G12.5/
+ $ ' K0 CT = ',G12.5,' L0 CT = ',G12.5/
+ $ ' S+ CT = ',G12.5,' S- CT = ',G12.5/
+ $ ' X0 CT = ',G12.5,' X- CT = ',G12.5)
+#endif
+
+ MP=RMASS(14)
+ MPI=RMASS(7)
+ MMU=RMASS(5)
+ MEL=RMASS(3)
+ MKCH=RMASS(10)
+ MK0=RMASS(11)
+ SMP=MP**2
+ SMPI=MPI**2
+ SMU=MMU**2
+ ML0=RMASS(18)
+ MSP=RMASS(20)
+ MS0=RMASS(21)
+ MSM=RMASS(22)
+ MX0=RMASS(26)
+ MXM=RMASS(27)
+
+C --- LOAD LIMITS FOR INTRINSIC FUNCTION ARGUMENTS ---
+ EXPXL = -82.0D0
+ EXPXU = 82.0D0
+
+#ifdef __CXDEBUG__
+ IF (NPRT(10)) WRITE(MCXDBUG,1001) EXPXL,EXPXU
+ 1001 FORMAT(' *GHEINI* === INTRINSIC FUNCTION BOUNDARIES ==='/
+ $ ' EXPXL,EXPXU = ',2(G12.5,1X))
+#endif
+#endif
+
+ RETURN
+ END
+
+*CMZ : 25/04/2003 by T. Pierog IK FZK KARLSRUHE
+*-- Author : The CONEX development group 25/04/2003
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION CXGHESIG( PPART,EKIN,KPART,ITARG,IATARG
+ * ,IZTARG )
+
+C-----------------------------------------------------------------------
+C GH(EISHA) SIG(MA)
+C
+C CALCULATION OF THE PROBABILITIES FOR (IN)ELASTIC INTERACTIONS ***
+C THIS FUNCTION IS CALLED FROM BOX2
+C ARGUMENTS:
+C PPART = R*8 PARTICLE MOMENTUM (GEV)
+C EKIN = R*8 KINETIC ENERGY (GEV)
+C KPART = INCIDENT PARTICLE TYPE
+C IATAR = TARGET PARTICLE MASS (A)
+C IZTAR = TARGET PARTICLE CHARGE (Z)
+C
+C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG)
+C REDESIGN FOR CORSIKA : P. GABRIEL IK1 FZK KARLSRUHE
+C REDESIGN FOR CONEX : T. PIEROG IK3 FZK KARLSRUHE
+C-----------------------------------------------------------------------
+C *** KPART DENOTES THE GHEISHA PARTICLE INDEX ***
+C
+C CONVENTION :
+C
+C PARTICLE IPART
+C ------------------------------
+C GAMMA 1
+C NEUTRINO 2
+C POSITRON 3
+C ELECTRON 4
+C MUON + 5
+C MUON - 6
+C PION + 7
+C PION 0 8
+C PION - 9
+C KAON + 10
+C KAON 0 S (= K(0)) 11
+C KAON 0 L (= K(0) BAR) 12
+C KAON - 13
+C PROTON 14
+C PROTON BAR 15
+C NEUTRON 16
+C NEUTRON BAR 17
+C LAMBDA 18
+C LAMBDA BAR 19
+C SIGMA + 20
+C SIGMA 0 21
+C SIGMA - 22
+C SIGMA + BAR 23
+C SIGMA 0 BAR 24
+C SIGMA - BAR 25
+C XSI 0 26
+C XSI - 27
+C XSI 0 BAR 28
+C XSI - BAR 29
+C DEUTERON 30
+C TRITON 31
+C ALPHA 32
+C OMEGA - 33
+C OMEGA - BAR 34
+C NEW PARTICLES 35
+C
+C-----------------------------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ common/cxair/airz(3),aira(3),airw(3),airavz,airava,airi(3)
+ PARAMETER (KKK=3)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON /GHECGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#else
+ COMMON /CGCOMP/ ACOMP,ZCOMP,WCOMP,KK
+#endif
+ DOUBLE PRECISION ACOMP(KKK),ZCOMP(KKK),WCOMP(KKK)
+ COMMON /CONEXDBINC/MCXDBUG
+ INTEGER MCXDBUG
+
+ COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
+ DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM
+ INTEGER K0FLAG
+
+C --- GHEISHA COMMONS ---
+ COMMON /RESULT/ XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ,
+ * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,
+ * IND,LCALO,ICEL,SINL,COSL,SINP,COSP,
+ * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD,
+ * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT
+ DOUBLE PRECISION NCH,INTCT
+
+ COMMON /PRNTFL/ INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,
+ * LPRT,NPRT(10)
+ LOGICAL LPRT,NPRT
+
+
+ DIMENSION ALPHA(35),ALPHAC(41),IPART2(7),CSA(4)
+ DIMENSION PARTEL(35),PARTIN(35),INTRC(35)
+* DIMENSION ICORR(35)
+
+C --- DIMENSION STATEMENTS FOR CROSS-SECTION DATA ---
+ DIMENSION PLAB(41),CSEL(35,41),CSIN(35,41),CSPIEL(3,41),
+ $ CSPIIN(3,41),CSPNEL(3,41),CSPNIN(3,41),
+ $ ELAB(17),CNLWAT(15),CNLWEL(15,17),CNLWIN(15,17),
+ $ CSCAP(100)
+
+C --- DIMENSION STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
+C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I ---
+C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I ---
+
+
+ SAVE
+
+C --- CROSS-SECTION DATA BY "PCSDAT" 01-FEB-1989 ---
+ DATA PLAB /
+ $ 0.00000D0 , 0.10000D0 , 0.15000D0 , 0.20000D0 , 0.25000D0 ,
+ $ 0.30000D0 , 0.35000D0 , 0.40000D0 , 0.45000D0 , 0.50000D0 ,
+ $ 0.55000D0 , 0.60000D0 , 0.65000D0 , 0.70000D0 , 0.75000D0 ,
+ $ 0.80000D0 , 0.85000D0 , 0.90000D0 , 0.95000D0 , 1.0000D0 ,
+ $ 1.1000D0 , 1.2000D0 , 1.3000D0 , 1.4000D0 , 1.5000D0 ,
+ $ 1.6000D0 , 1.8000D0 , 2.0000D0 , 2.2000D0 , 2.4000D0 ,
+ $ 2.6000D0 , 2.8000D0 , 3.0000D0 , 4.0000D0 , 5.0000D0 ,
+ $ 6.0000D0 , 8.0000D0 , 10.000D0 , 20.000D0 , 100.00D0 ,
+ $ 1000.0D0 /
+
+C ELASTIC SCATTERING CROSS-SECTIONS ON FREE PROTONS
+C GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-)
+ DATA ((CSEL(I,J),I=1,6),J=1,41) / 246 * 0.D0 /
+C PI(0)
+ DATA (CSEL( 8,J),J=1,41) / 41 * 0.D0 /
+C SIGMA(0)
+ DATA (CSEL(21,J),J=1,41) / 41 * 0.D0 /
+C SIGMA(0)_BAR
+ DATA (CSEL(24,J),J=1,41) / 41 * 0.D0 /
+C DEUTERIUM, TRITIUM, ALPHA
+ DATA ((CSEL(I,J),I=30,32),J=1,41) / 123 * 0.D0 /
+C NEW PARTICLES
+ DATA (CSEL(35,J),J=1,41) / 41 * 0.D0 /
+C PI(+)
+ DATA (CSEL( 7,J),J=1,41) /
+ $ 0.00000D0 , 6.0000D0 , 20.000D0 , 71.000D0 , 155.00D0 ,
+ $ 195.00D0 , 130.00D0 , 78.000D0 , 60.000D0 , 32.000D0 ,
+ $ 23.500D0 , 18.500D0 , 15.000D0 , 12.500D0 , 10.000D0 ,
+ $ 9.1000D0 , 8.6000D0 , 8.8000D0 , 9.5000D0 , 10.600D0 ,
+ $ 13.000D0 , 15.500D0 , 17.100D0 , 17.200D0 , 16.200D0 ,
+ $ 15.000D0 , 12.300D0 , 10.200D0 , 9.0000D0 , 8.0000D0 ,
+ $ 7.3000D0 , 6.8000D0 , 6.5000D0 , 5.8000D0 , 5.4000D0 ,
+ $ 5.2000D0 , 5.0000D0 , 4.9000D0 , 3.8000D0 , 3.2000D0 ,
+ $ 3.5000D0 /
+C PI(-)
+ DATA (CSEL( 9,J),J=1,41) /
+ $ 0.00000D0 , 1.0000D0 , 3.0000D0 , 8.0000D0 , 18.000D0 ,
+ $ 25.000D0 , 27.500D0 , 12.300D0 , 10.600D0 , 11.000D0 ,
+ $ 12.500D0 , 14.500D0 , 17.000D0 , 19.400D0 , 19.800D0 ,
+ $ 16.800D0 , 14.000D0 , 14.800D0 , 20.000D0 , 26.100D0 ,
+ $ 19.500D0 , 15.000D0 , 12.800D0 , 11.500D0 , 10.500D0 ,
+ $ 9.8000D0 , 8.8000D0 , 8.2000D0 , 7.8000D0 , 7.5000D0 ,
+ $ 7.2000D0 , 7.0000D0 , 6.8000D0 , 6.1000D0 , 5.7000D0 ,
+ $ 5.4000D0 , 4.9000D0 , 4.6000D0 , 4.0000D0 , 3.3000D0 ,
+ $ 3.5000D0 /
+C K(+)
+ DATA (CSEL(10,J),J=1,41) /
+ $ 10.000D0 , 11.200D0 , 11.300D0 , 11.400D0 , 11.500D0 ,
+ $ 11.600D0 , 11.800D0 , 12.000D0 , 12.100D0 , 12.200D0 ,
+ $ 12.300D0 , 12.400D0 , 12.500D0 , 12.500D0 , 12.500D0 ,
+ $ 12.400D0 , 12.300D0 , 12.200D0 , 12.000D0 , 11.800D0 ,
+ $ 11.200D0 , 11.500D0 , 9.9000D0 , 9.4000D0 , 8.8000D0 ,
+ $ 8.4000D0 , 7.5000D0 , 6.9000D0 , 6.3000D0 , 5.9000D0 ,
+ $ 5.5000D0 , 5.2000D0 , 5.0000D0 , 4.0000D0 , 3.5000D0 ,
+ $ 3.3000D0 , 3.1000D0 , 3.1000D0 , 3.0000D0 , 2.5000D0 ,
+ $ 3.0000D0 /
+C K(0) SHORT (= K(0))
+ DATA (CSEL(11,J),J=1,41) /
+ $ 10.000D0 , 11.200D0 , 11.300D0 , 11.400D0 , 11.500D0 ,
+ $ 11.600D0 , 11.800D0 , 12.000D0 , 12.100D0 , 12.200D0 ,
+ $ 12.300D0 , 12.400D0 , 12.500D0 , 12.500D0 , 12.500D0 ,
+ $ 12.400D0 , 12.300D0 , 12.200D0 , 12.000D0 , 11.800D0 ,
+ $ 11.200D0 , 11.500D0 , 9.9000D0 , 9.4000D0 , 8.8000D0 ,
+ $ 8.4000D0 , 7.5000D0 , 6.9000D0 , 6.3000D0 , 5.9000D0 ,
+ $ 5.5000D0 , 5.2000D0 , 5.0000D0 , 4.0000D0 , 3.5000D0 ,
+ $ 3.3000D0 , 3.1000D0 , 3.1000D0 , 3.0000D0 , 2.5000D0 ,
+ $ 3.0000D0 /
+C K(0) LONG (= K(0)_BAR)
+ DATA (CSEL(12,J),J=1,41) /
+ $ 160.83D0 , 82.800D0 , 58.575D0 , 43.683D0 , 34.792D0 ,
+ $ 28.650D0 , 24.367D0 , 20.917D0 , 18.192D0 , 16.300D0 ,
+ $ 14.608D0 , 13.017D0 , 12.250D0 , 11.700D0 , 12.017D0 ,
+ $ 14.075D0 , 15.842D0 , 16.433D0 , 16.042D0 , 15.008D0 ,
+ $ 12.575D0 , 10.708D0 , 9.2000D0 , 8.0167D0 , 7.2833D0 ,
+ $ 7.0750D0 , 6.6333D0 , 6.1250D0 , 5.6583D0 , 5.2750D0 ,
+ $ 4.9333D0 , 4.6250D0 , 4.4583D0 , 3.7333D0 , 3.3833D0 ,
+ $ 3.1833D0 , 2.9833D0 , 2.7500D0 , 2.3667D0 , 2.2000D0 ,
+ $ 2.6000D0 /
+C K(-)
+ DATA (CSEL(13,J),J=1,41) /
+ $ 300.00D0 , 140.00D0 , 97.000D0 , 70.000D0 , 55.000D0 ,
+ $ 45.000D0 , 37.000D0 , 31.000D0 , 26.000D0 , 23.000D0 ,
+ $ 20.000D0 , 17.000D0 , 15.500D0 , 14.500D0 , 14.700D0 ,
+ $ 18.500D0 , 22.000D0 , 23.000D0 , 22.500D0 , 20.700D0 ,
+ $ 16.500D0 , 14.000D0 , 11.500D0 , 9.6000D0 , 8.6000D0 ,
+ $ 8.5000D0 , 8.3000D0 , 7.6000D0 , 7.0000D0 , 6.4000D0 ,
+ $ 5.9000D0 , 5.5000D0 , 5.3000D0 , 4.4000D0 , 4.1000D0 ,
+ $ 3.9000D0 , 3.7000D0 , 3.3000D0 , 2.6000D0 , 2.5000D0 ,
+ $ 3.0000D0 /
+C PROTON
+ DATA (CSEL(14,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 20.000D0 , 20.500D0 , 21.000D0 , 22.000D0 ,
+ $ 23.000D0 , 24.000D0 , 24.000D0 , 24.400D0 , 24.500D0 ,
+ $ 25.000D0 , 25.500D0 , 26.000D0 , 26.500D0 , 27.000D0 ,
+ $ 27.000D0 , 26.000D0 , 23.000D0 , 21.500D0 , 20.000D0 ,
+ $ 19.000D0 , 18.000D0 , 17.000D0 , 13.000D0 , 11.500D0 ,
+ $ 10.300D0 , 9.4000D0 , 9.0000D0 , 8.8000D0 , 7.0000D0 ,
+ $ 7.5000D0 /
+C PROTON_BAR
+ DATA (CSEL(15,J),J=1,41) /
+ $ 200.00D0 , 163.00D0 , 141.00D0 , 120.00D0 , 111.00D0 ,
+ $ 99.500D0 , 92.500D0 , 86.500D0 , 82.000D0 , 78.000D0 ,
+ $ 74.000D0 , 71.000D0 , 67.500D0 , 65.000D0 , 62.500D0 ,
+ $ 59.700D0 , 58.100D0 , 56.300D0 , 54.700D0 , 52.700D0 ,
+ $ 50.000D0 , 48.400D0 , 47.000D0 , 46.000D0 , 45.200D0 ,
+ $ 42.800D0 , 39.200D0 , 36.300D0 , 32.800D0 , 30.400D0 ,
+ $ 28.100D0 , 26.300D0 , 24.500D0 , 19.250D0 , 16.840D0 ,
+ $ 14.600D0 , 12.340D0 , 11.210D0 , 8.8500D0 , 7.5000D0 ,
+ $ 7.5000D0 /
+C NEUTRON
+ DATA (CSEL(16,J),J=1,41) /
+ $ 4200.0D0 , 440.00D0 , 420.00D0 , 400.00D0 , 230.00D0 ,
+ $ 160.00D0 , 105.00D0 , 80.000D0 , 62.000D0 , 50.000D0 ,
+ $ 45.000D0 , 41.000D0 , 38.000D0 , 36.000D0 , 35.000D0 ,
+ $ 34.000D0 , 33.000D0 , 32.000D0 , 31.500D0 , 31.000D0 ,
+ $ 30.500D0 , 30.000D0 , 29.500D0 , 29.000D0 , 28.500D0 ,
+ $ 28.000D0 , 26.000D0 , 23.000D0 , 21.500D0 , 20.000D0 ,
+ $ 19.000D0 , 18.000D0 , 17.000D0 , 13.000D0 , 11.500D0 ,
+ $ 10.300D0 , 9.4000D0 , 9.0000D0 , 8.8000D0 , 7.0000D0 ,
+ $ 7.5000D0 /
+C NEUTRON_BAR
+ DATA (CSEL(17,J),J=1,41) /
+ $ 185.88D0 , 133.23D0 , 119.37D0 , 102.86D0 , 93.102D0 ,
+ $ 82.752D0 , 76.205D0 , 71.008D0 , 67.366D0 , 64.096D0 ,
+ $ 60.891D0 , 58.501D0 , 55.735D0 , 53.773D0 , 51.839D0 ,
+ $ 49.671D0 , 48.485D0 , 47.045D0 , 45.803D0 , 44.306D0 ,
+ $ 42.623D0 , 41.786D0 , 41.115D0 , 40.630D0 , 40.129D0 ,
+ $ 38.242D0 , 35.233D0 , 32.662D0 , 29.639D0 , 27.573D0 ,
+ $ 25.536D0 , 23.948D0 , 22.356D0 , 17.723D0 , 15.614D0 ,
+ $ 13.653D0 , 11.675D0 , 10.653D0 , 8.6198D0 , 7.4464D0 ,
+ $ 7.4821D0 /
+C LAMBDA
+ DATA (CSEL(18,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 19.067D0 , 19.333D0 , 19.500D0 , 19.833D0 ,
+ $ 20.567D0 , 21.800D0 , 22.900D0 , 23.869D0 , 23.809D0 ,
+ $ 22.161D0 , 21.488D0 , 19.732D0 , 19.433D0 , 19.345D0 ,
+ $ 19.029D0 , 18.121D0 , 16.280D0 , 15.258D0 , 14.280D0 ,
+ $ 13.644D0 , 12.963D0 , 12.316D0 , 9.5333D0 , 8.4333D0 ,
+ $ 7.5728D0 , 6.9696D0 , 6.7518D0 , 6.6175D0 , 5.6000D0 ,
+ $ 6.1145D0 /
+C LAMBDA_BAR
+ DATA (CSEL(19,J),J=1,41) /
+ $ 157.65D0 , 73.701D0 , 76.096D0 , 68.571D0 , 57.305D0 ,
+ $ 49.257D0 , 43.616D0 , 40.024D0 , 38.098D0 , 36.287D0 ,
+ $ 34.674D0 , 33.105D0 , 31.712D0 , 30.685D0 , 29.613D0 ,
+ $ 28.602D0 , 28.336D0 , 28.075D0 , 27.786D0 , 27.215D0 ,
+ $ 26.380D0 , 26.146D0 , 25.108D0 , 24.783D0 , 24.360D0 ,
+ $ 23.219D0 , 21.431D0 , 20.095D0 , 18.382D0 , 17.267D0 ,
+ $ 16.100D0 , 15.175D0 , 14.271D0 , 11.573D0 , 10.305D0 ,
+ $ 9.1471D0 , 8.0149D0 , 7.4349D0 , 6.2499D0 , 5.8928D0 ,
+ $ 6.0774D0 /
+C SIGMA(+)
+ DATA (CSEL(20,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 19.067D0 , 19.333D0 , 19.500D0 , 19.833D0 ,
+ $ 20.567D0 , 21.800D0 , 22.900D0 , 23.869D0 , 23.809D0 ,
+ $ 22.161D0 , 21.488D0 , 19.732D0 , 19.433D0 , 19.345D0 ,
+ $ 19.029D0 , 18.121D0 , 16.280D0 , 15.258D0 , 14.280D0 ,
+ $ 13.644D0 , 12.963D0 , 12.316D0 , 9.5333D0 , 8.4333D0 ,
+ $ 7.5728D0 , 6.9696D0 , 6.7518D0 , 6.6175D0 , 5.6000D0 ,
+ $ 6.1145D0 /
+C SIGMA(-)
+ DATA (CSEL(22,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 19.067D0 , 19.333D0 , 19.500D0 , 19.833D0 ,
+ $ 20.567D0 , 21.800D0 , 22.900D0 , 23.869D0 , 23.809D0 ,
+ $ 22.161D0 , 21.488D0 , 19.732D0 , 19.433D0 , 19.345D0 ,
+ $ 19.029D0 , 18.121D0 , 16.280D0 , 15.258D0 , 14.280D0 ,
+ $ 13.644D0 , 12.963D0 , 12.316D0 , 9.5333D0 , 8.4333D0 ,
+ $ 7.5728D0 , 6.9696D0 , 6.7518D0 , 6.6175D0 , 5.6000D0 ,
+ $ 6.1145D0 /
+C SIGMA(+)_BAR
+ DATA (CSEL(23,J),J=1,41) /
+ $ 185.88D0 , 133.23D0 , 119.37D0 , 102.86D0 , 93.102D0 ,
+ $ 82.752D0 , 76.205D0 , 71.008D0 , 67.366D0 , 64.096D0 ,
+ $ 60.891D0 , 58.104D0 , 55.241D0 , 53.140D0 , 50.934D0 ,
+ $ 48.660D0 , 47.566D0 , 46.585D0 , 45.581D0 , 44.003D0 ,
+ $ 41.134D0 , 39.374D0 , 36.878D0 , 35.523D0 , 34.503D0 ,
+ $ 32.334D0 , 29.365D0 , 27.370D0 , 24.705D0 , 22.921D0 ,
+ $ 21.229D0 , 19.879D0 , 18.559D0 , 14.625D0 , 12.758D0 ,
+ $ 11.041D0 , 9.3440D0 , 8.5484D0 , 6.7104D0 , 6.0000D0 ,
+ $ 6.1131D0 /
+C SIGMA(-)_BAR
+ DATA (CSEL(25,J),J=1,41) /
+ $ 157.65D0 , 73.701D0 , 76.096D0 , 68.571D0 , 57.305D0 ,
+ $ 49.257D0 , 43.616D0 , 40.024D0 , 38.098D0 , 36.287D0 ,
+ $ 34.674D0 , 33.105D0 , 31.712D0 , 30.685D0 , 29.613D0 ,
+ $ 28.602D0 , 28.336D0 , 28.075D0 , 27.786D0 , 27.215D0 ,
+ $ 26.380D0 , 26.146D0 , 25.108D0 , 24.783D0 , 24.360D0 ,
+ $ 23.219D0 , 21.431D0 , 20.095D0 , 18.382D0 , 17.267D0 ,
+ $ 16.100D0 , 15.175D0 , 14.271D0 , 11.573D0 , 10.305D0 ,
+ $ 9.1471D0 , 8.0149D0 , 7.4349D0 , 6.2499D0 , 5.8928D0 ,
+ $ 6.0774D0 /
+C XI(0)
+ DATA (CSEL(26,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 18.133D0 , 18.167D0 , 18.000D0 , 17.667D0 ,
+ $ 18.133D0 , 19.600D0 , 21.800D0 , 23.338D0 , 23.118D0 ,
+ $ 19.323D0 , 17.476D0 , 13.464D0 , 12.367D0 , 11.691D0 ,
+ $ 11.057D0 , 10.242D0 , 9.5593D0 , 9.0151D0 , 8.5591D0 ,
+ $ 8.2884D0 , 7.9253D0 , 7.6311D0 , 6.0667D0 , 5.3667D0 ,
+ $ 4.8456D0 , 4.5392D0 , 4.5036D0 , 4.4351D0 , 4.2000D0 ,
+ $ 4.7289D0 /
+C XI(-)
+ DATA (CSEL(27,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 18.133D0 , 18.167D0 , 18.000D0 , 17.667D0 ,
+ $ 18.133D0 , 19.600D0 , 21.800D0 , 23.338D0 , 23.118D0 ,
+ $ 19.323D0 , 17.476D0 , 13.464D0 , 12.367D0 , 11.691D0 ,
+ $ 11.057D0 , 10.242D0 , 9.5593D0 , 9.0151D0 , 8.5591D0 ,
+ $ 8.2884D0 , 7.9253D0 , 7.6311D0 , 6.0667D0 , 5.3667D0 ,
+ $ 4.8456D0 , 4.5392D0 , 4.5036D0 , 4.4351D0 , 4.2000D0 ,
+ $ 4.7289D0 /
+C XI(0)_BAR
+ DATA (CSEL(28,J),J=1,41) /
+ $ 157.65D0 , 73.701D0 , 76.096D0 , 68.571D0 , 57.305D0 ,
+ $ 49.257D0 , 43.616D0 , 40.024D0 , 38.098D0 , 36.287D0 ,
+ $ 34.674D0 , 32.708D0 , 31.218D0 , 30.052D0 , 28.707D0 ,
+ $ 27.591D0 , 27.417D0 , 27.615D0 , 27.564D0 , 26.913D0 ,
+ $ 24.891D0 , 23.734D0 , 20.871D0 , 19.677D0 , 18.734D0 ,
+ $ 17.311D0 , 15.563D0 , 14.803D0 , 13.448D0 , 12.615D0 ,
+ $ 11.794D0 , 11.106D0 , 10.474D0 , 8.4745D0 , 7.4498D0 ,
+ $ 6.5350D0 , 5.6835D0 , 5.3300D0 , 4.3406D0 , 4.4464D0 ,
+ $ 4.7083D0 /
+C XI(-)_BAR
+ DATA (CSEL(29,J),J=1,41) /
+ $ 143.53D0 , 43.935D0 , 54.462D0 , 51.429D0 , 39.407D0 ,
+ $ 32.510D0 , 27.321D0 , 24.532D0 , 23.465D0 , 22.383D0 ,
+ $ 21.566D0 , 20.209D0 , 19.453D0 , 18.825D0 , 18.046D0 ,
+ $ 17.562D0 , 17.802D0 , 18.360D0 , 18.667D0 , 18.519D0 ,
+ $ 17.514D0 , 17.120D0 , 14.985D0 , 14.306D0 , 13.663D0 ,
+ $ 12.753D0 , 11.596D0 , 11.165D0 , 10.287D0 , 9.7882D0 ,
+ $ 9.2294D0 , 8.7539D0 , 8.3300D0 , 6.9480D0 , 6.2234D0 ,
+ $ 5.5881D0 , 5.0189D0 , 4.7733D0 , 4.1104D0 , 4.3929D0 ,
+ $ 4.6905D0 /
+C OMEGA(-)
+ DATA (CSEL(33,J),J=1,41) /
+ $ 1100.0D0 , 115.00D0 , 105.00D0 , 100.00D0 , 56.000D0 ,
+ $ 40.000D0 , 27.000D0 , 22.000D0 , 21.000D0 , 20.000D0 ,
+ $ 20.000D0 , 18.133D0 , 18.167D0 , 18.000D0 , 17.667D0 ,
+ $ 18.133D0 , 19.600D0 , 21.800D0 , 23.338D0 , 23.118D0 ,
+ $ 19.323D0 , 17.476D0 , 13.464D0 , 12.367D0 , 11.691D0 ,
+ $ 11.057D0 , 10.242D0 , 9.5593D0 , 9.0151D0 , 8.5591D0 ,
+ $ 8.2884D0 , 7.9253D0 , 7.6311D0 , 6.0667D0 , 5.3667D0 ,
+ $ 4.8456D0 , 4.5392D0 , 4.5036D0 , 4.4351D0 , 4.2000D0 ,
+ $ 4.7289D0 /
+C OMEGA(-)_BAR
+ DATA (CSEL(34,J),J=1,41) /
+ $ 143.53D0 , 43.935D0 , 54.462D0 , 51.429D0 , 39.407D0 ,
+ $ 32.510D0 , 27.321D0 , 24.532D0 , 23.465D0 , 22.383D0 ,
+ $ 21.566D0 , 20.209D0 , 19.453D0 , 18.825D0 , 18.046D0 ,
+ $ 17.562D0 , 17.802D0 , 18.360D0 , 18.667D0 , 18.519D0 ,
+ $ 17.514D0 , 17.120D0 , 14.985D0 , 14.306D0 , 13.663D0 ,
+ $ 12.753D0 , 11.596D0 , 11.165D0 , 10.287D0 , 9.7882D0 ,
+ $ 9.2294D0 , 8.7539D0 , 8.3300D0 , 6.9480D0 , 6.2234D0 ,
+ $ 5.5881D0 , 5.0189D0 , 4.7733D0 , 4.1104D0 , 4.3929D0 ,
+ $ 4.6905D0 /
+
+C INELASTIC CROSS-SECTIONS ON FREE PROTONS
+C GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-)
+ DATA ((CSIN(I,J),I=1,6),J=1,41) / 246 * 0.D0 /
+C PI(0)
+ DATA (CSIN( 8,J),J=1,41) / 41 * 0.D0 /
+C SIGMA(0)
+ DATA (CSIN(21,J),J=1,41) / 41 * 0.D0 /
+C SIGMA(0)_BAR
+ DATA (CSIN(24,J),J=1,41) / 41 * 0.D0 /
+C DEUTERIUM, TRITIUM, ALPHA
+ DATA ((CSIN(I,J),I=30,32),J=1,41) / 123 * 0.D0 /
+C NEW PARTICLES
+ DATA (CSIN(35,J),J=1,41) / 41 * 0.D0 /
+C PI(+)
+ DATA (CSIN( 7,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.50000D0 , 1.2000D0 , 1.7000D0 ,
+ $ 2.2500D0 , 3.0000D0 , 3.6000D0 , 4.5000D0 , 5.4000D0 ,
+ $ 6.3000D0 , 8.6000D0 , 9.0000D0 , 10.000D0 , 11.500D0 ,
+ $ 14.000D0 , 17.000D0 , 19.500D0 , 22.000D0 , 24.000D0 ,
+ $ 21.500D0 , 18.500D0 , 19.000D0 , 20.500D0 , 22.200D0 ,
+ $ 23.000D0 , 23.300D0 , 23.000D0 , 21.000D0 , 20.500D0 ,
+ $ 20.200D0 , 20.100D0 , 20.000D0 , 20.000D0 , 20.000D0 ,
+ $ 21.000D0 /
+C PI(-)
+ DATA (CSIN( 9,J),J=1,41) /
+ $ 0.00000D0 , 3.0000D0 , 9.2000D0 , 20.500D0 , 36.500D0 ,
+ $ 45.000D0 , 28.000D0 , 19.500D0 , 15.500D0 , 14.200D0 ,
+ $ 15.500D0 , 17.500D0 , 20.000D0 , 23.000D0 , 26.000D0 ,
+ $ 20.000D0 , 23.000D0 , 26.500D0 , 32.000D0 , 35.000D0 ,
+ $ 28.500D0 , 22.000D0 , 22.500D0 , 23.500D0 , 24.000D0 ,
+ $ 24.500D0 , 26.000D0 , 27.500D0 , 27.500D0 , 27.000D0 ,
+ $ 26.500D0 , 25.500D0 , 25.000D0 , 23.000D0 , 22.500D0 ,
+ $ 22.200D0 , 22.000D0 , 22.000D0 , 21.200D0 , 20.700D0 ,
+ $ 21.000D0 /
+C K(+)
+ DATA (CSIN(10,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.50000D0 , 1.5000D0 , 2.7000D0 , 3.8000D0 , 4.8000D0 ,
+ $ 6.5000D0 , 7.6000D0 , 8.4000D0 , 9.0000D0 , 9.4000D0 ,
+ $ 9.8000D0 , 10.500D0 , 11.000D0 , 11.500D0 , 11.800D0 ,
+ $ 12.200D0 , 12.400D0 , 12.600D0 , 13.200D0 , 13.500D0 ,
+ $ 13.700D0 , 14.000D0 , 14.200D0 , 14.500D0 , 16.400D0 ,
+ $ 17.000D0 /
+C K(0) SHORT (= K(0))
+ DATA (CSIN(11,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.50000D0 , 1.5000D0 , 2.7000D0 , 3.8000D0 , 4.8000D0 ,
+ $ 6.5000D0 , 7.6000D0 , 8.4000D0 , 9.0000D0 , 9.4000D0 ,
+ $ 9.8000D0 , 10.500D0 , 11.000D0 , 11.500D0 , 11.800D0 ,
+ $ 12.200D0 , 12.400D0 , 12.600D0 , 13.200D0 , 13.500D0 ,
+ $ 13.700D0 , 14.000D0 , 14.200D0 , 14.500D0 , 16.400D0 ,
+ $ 17.000D0 /
+C K(0) LONG (= K(0)_BAR)
+ DATA (CSIN(12,J),J=1,41) /
+ $ 266.67D0 , 133.33D0 , 83.333D0 , 57.083D0 , 44.500D0 ,
+ $ 33.250D0 , 24.583D0 , 20.833D0 , 18.333D0 , 16.083D0 ,
+ $ 15.625D0 , 15.083D0 , 14.833D0 , 15.083D0 , 15.833D0 ,
+ $ 17.042D0 , 18.958D0 , 20.758D0 , 22.533D0 , 22.825D0 ,
+ $ 21.250D0 , 18.567D0 , 17.767D0 , 18.100D0 , 19.933D0 ,
+ $ 20.783D0 , 21.225D0 , 21.000D0 , 20.558D0 , 20.258D0 ,
+ $ 20.017D0 , 19.767D0 , 19.600D0 , 19.183D0 , 18.850D0 ,
+ $ 18.575D0 , 18.350D0 , 18.175D0 , 17.808D0 , 17.558D0 ,
+ $ 19.250D0 /
+C K(-)
+ DATA (CSIN(13,J),J=1,41) /
+ $ 400.00D0 , 200.00D0 , 120.00D0 , 81.000D0 , 62.000D0 ,
+ $ 47.000D0 , 35.000D0 , 28.000D0 , 24.000D0 , 21.000D0 ,
+ $ 19.500D0 , 19.000D0 , 18.800D0 , 19.000D0 , 20.000D0 ,
+ $ 21.000D0 , 23.000D0 , 25.000D0 , 27.000D0 , 27.500D0 ,
+ $ 25.500D0 , 22.000D0 , 20.800D0 , 21.000D0 , 23.000D0 ,
+ $ 24.000D0 , 24.000D0 , 23.800D0 , 23.000D0 , 22.500D0 ,
+ $ 22.000D0 , 21.600D0 , 21.400D0 , 21.000D0 , 20.500D0 ,
+ $ 20.200D0 , 19.800D0 , 19.500D0 , 18.600D0 , 17.500D0 ,
+ $ 20.000D0 /
+C PROTON
+ DATA (CSIN(14,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.10000D0 , 1.5000D0 ,
+ $ 7.0000D0 , 12.000D0 , 17.000D0 , 19.500D0 , 20.500D0 ,
+ $ 22.000D0 , 23.500D0 , 24.800D0 , 25.800D0 , 26.500D0 ,
+ $ 27.000D0 , 27.500D0 , 28.000D0 , 30.000D0 , 31.000D0 ,
+ $ 32.000D0 , 32.500D0 , 32.500D0 , 33.000D0 , 33.500D0 ,
+ $ 34.000D0 /
+C PROTON_BAR
+ DATA (CSIN(15,J),J=1,41) /
+ $ 1500.0D0 , 1160.0D0 , 310.00D0 , 230.00D0 , 178.00D0 ,
+ $ 153.00D0 , 134.00D0 , 124.00D0 , 113.00D0 , 106.00D0 ,
+ $ 101.00D0 , 96.000D0 , 92.000D0 , 89.000D0 , 87.000D0 ,
+ $ 84.000D0 , 81.000D0 , 78.500D0 , 76.500D0 , 75.000D0 ,
+ $ 72.000D0 , 70.000D0 , 68.000D0 , 64.500D0 , 63.000D0 ,
+ $ 62.000D0 , 61.000D0 , 59.500D0 , 58.500D0 , 56.500D0 ,
+ $ 56.500D0 , 56.000D0 , 55.500D0 , 52.000D0 , 50.000D0 ,
+ $ 48.000D0 , 45.000D0 , 44.000D0 , 39.200D0 , 34.500D0 ,
+ $ 34.500D0 /
+C NEUTRON
+ DATA (CSIN(16,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.10000D0 , 1.5000D0 ,
+ $ 7.0000D0 , 12.000D0 , 17.000D0 , 19.500D0 , 20.500D0 ,
+ $ 22.000D0 , 23.500D0 , 24.800D0 , 25.800D0 , 26.500D0 ,
+ $ 27.000D0 , 27.500D0 , 28.000D0 , 30.000D0 , 31.000D0 ,
+ $ 32.000D0 , 32.500D0 , 32.500D0 , 33.000D0 , 33.500D0 ,
+ $ 34.000D0 /
+C NEUTRON_BAR
+ DATA (CSIN(17,J),J=1,41) /
+ $ 1394.1D0 , 948.17D0 , 262.43D0 , 197.14D0 , 149.30D0 ,
+ $ 127.25D0 , 110.39D0 , 101.79D0 , 92.834D0 , 87.104D0 ,
+ $ 83.109D0 , 79.099D0 , 75.965D0 , 73.627D0 , 72.161D0 ,
+ $ 69.889D0 , 67.595D0 , 65.595D0 , 64.057D0 , 63.054D0 ,
+ $ 61.377D0 , 60.434D0 , 59.485D0 , 56.970D0 , 55.931D0 ,
+ $ 55.398D0 , 54.827D0 , 53.538D0 , 52.861D0 , 51.247D0 ,
+ $ 51.344D0 , 50.992D0 , 50.644D0 , 47.876D0 , 46.358D0 ,
+ $ 44.887D0 , 42.577D0 , 41.815D0 , 38.180D0 , 34.254D0 ,
+ $ 34.418D0 /
+C LAMBDA
+ DATA (CSIN(18,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.97815D-01, 1.4577D0 ,
+ $ 6.2052D0 , 10.112D0 , 12.902D0 , 14.300D0 , 14.688D0 ,
+ $ 15.505D0 , 16.379D0 , 17.554D0 , 18.309D0 , 18.920D0 ,
+ $ 19.389D0 , 19.804D0 , 20.284D0 , 22.000D0 , 22.733D0 ,
+ $ 23.527D0 , 24.097D0 , 24.382D0 , 24.816D0 , 26.800D0 ,
+ $ 27.719D0 /
+C LAMBDA_BAR
+ DATA (CSIN(19,J),J=1,41) /
+ $ 1182.4D0 , 524.50D0 , 167.30D0 , 131.43D0 , 91.895D0 ,
+ $ 75.743D0 , 63.184D0 , 57.376D0 , 52.502D0 , 49.313D0 ,
+ $ 47.326D0 , 44.762D0 , 43.222D0 , 42.015D0 , 41.221D0 ,
+ $ 40.244D0 , 39.504D0 , 39.145D0 , 38.860D0 , 38.731D0 ,
+ $ 37.987D0 , 37.814D0 , 36.326D0 , 34.750D0 , 33.953D0 ,
+ $ 33.635D0 , 33.349D0 , 32.938D0 , 32.785D0 , 32.092D0 ,
+ $ 32.373D0 , 32.312D0 , 32.329D0 , 31.261D0 , 30.597D0 ,
+ $ 30.073D0 , 29.228D0 , 29.182D0 , 27.683D0 , 27.107D0 ,
+ $ 27.956D0 /
+C SIGMA(+)
+ DATA (CSIN(20,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.97815D-01, 1.4577D0 ,
+ $ 6.2052D0 , 10.112D0 , 12.902D0 , 14.300D0 , 14.688D0 ,
+ $ 15.505D0 , 16.379D0 , 17.554D0 , 18.309D0 , 18.920D0 ,
+ $ 19.389D0 , 19.804D0 , 20.284D0 , 22.000D0 , 22.733D0 ,
+ $ 23.527D0 , 24.097D0 , 24.382D0 , 24.816D0 , 26.800D0 ,
+ $ 27.719D0 /
+C SIGMA(-)
+ DATA (CSIN(22,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.97815D-01, 1.4577D0 ,
+ $ 6.2052D0 , 10.112D0 , 12.902D0 , 14.300D0 , 14.688D0 ,
+ $ 15.505D0 , 16.379D0 , 17.554D0 , 18.309D0 , 18.920D0 ,
+ $ 19.389D0 , 19.804D0 , 20.284D0 , 22.000D0 , 22.733D0 ,
+ $ 23.527D0 , 24.097D0 , 24.382D0 , 24.816D0 , 26.800D0 ,
+ $ 27.719D0 /
+C SIGMA(+)_BAR
+ DATA (CSIN(23,J),J=1,41) /
+ $ 1394.1D0 , 948.17D0 , 262.43D0 , 197.14D0 , 149.30D0 ,
+ $ 127.25D0 , 110.39D0 , 101.79D0 , 92.834D0 , 87.104D0 ,
+ $ 83.109D0 , 78.563D0 , 75.292D0 , 72.760D0 , 70.900D0 ,
+ $ 68.467D0 , 66.314D0 , 64.955D0 , 63.746D0 , 62.623D0 ,
+ $ 59.233D0 , 56.946D0 , 53.355D0 , 49.810D0 , 48.090D0 ,
+ $ 46.839D0 , 45.695D0 , 44.863D0 , 44.062D0 , 42.599D0 ,
+ $ 42.684D0 , 42.328D0 , 42.041D0 , 39.508D0 , 37.880D0 ,
+ $ 36.299D0 , 34.075D0 , 33.553D0 , 29.723D0 , 27.600D0 ,
+ $ 28.120D0 /
+C SIGMA(-)_BAR
+ DATA (CSIN(25,J),J=1,41) /
+ $ 1182.4D0 , 524.50D0 , 167.30D0 , 131.43D0 , 91.895D0 ,
+ $ 75.743D0 , 63.184D0 , 57.376D0 , 52.502D0 , 49.313D0 ,
+ $ 47.326D0 , 44.762D0 , 43.222D0 , 42.015D0 , 41.221D0 ,
+ $ 40.244D0 , 39.504D0 , 39.145D0 , 38.860D0 , 38.731D0 ,
+ $ 37.987D0 , 37.814D0 , 36.326D0 , 34.750D0 , 33.953D0 ,
+ $ 33.635D0 , 33.349D0 , 32.938D0 , 32.785D0 , 32.092D0 ,
+ $ 32.373D0 , 32.312D0 , 32.329D0 , 31.261D0 , 30.597D0 ,
+ $ 30.073D0 , 29.228D0 , 29.182D0 , 27.683D0 , 27.107D0 ,
+ $ 27.956D0 /
+C XI(0)
+ DATA (CSIN(26,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.95639D-01, 1.4154D0 ,
+ $ 5.4104D0 , 8.2240D0 , 8.8031D0 , 9.1000D0 , 8.8761D0 ,
+ $ 9.0095D0 , 9.2576D0 , 10.307D0 , 10.818D0 , 11.341D0 ,
+ $ 11.778D0 , 12.108D0 , 12.569D0 , 14.000D0 , 14.467D0 ,
+ $ 15.054D0 , 15.694D0 , 16.263D0 , 16.632D0 , 20.100D0 ,
+ $ 21.438D0 /
+C XI(-)
+ DATA (CSIN(27,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.95639D-01, 1.4154D0 ,
+ $ 5.4104D0 , 8.2240D0 , 8.8031D0 , 9.1000D0 , 8.8761D0 ,
+ $ 9.0095D0 , 9.2576D0 , 10.307D0 , 10.818D0 , 11.341D0 ,
+ $ 11.778D0 , 12.108D0 , 12.569D0 , 14.000D0 , 14.467D0 ,
+ $ 15.054D0 , 15.694D0 , 16.263D0 , 16.632D0 , 20.100D0 ,
+ $ 21.438D0 /
+C XI(0)_BAR
+ DATA (CSIN(28,J),J=1,41) /
+ $ 1182.4D0 , 524.50D0 , 167.30D0 , 131.43D0 , 91.895D0 ,
+ $ 75.743D0 , 63.184D0 , 57.376D0 , 52.502D0 , 49.313D0 ,
+ $ 47.326D0 , 44.225D0 , 42.549D0 , 41.148D0 , 39.960D0 ,
+ $ 38.822D0 , 38.223D0 , 38.505D0 , 38.549D0 , 38.301D0 ,
+ $ 35.843D0 , 34.326D0 , 30.196D0 , 27.590D0 , 26.112D0 ,
+ $ 25.076D0 , 24.217D0 , 24.264D0 , 23.985D0 , 23.445D0 ,
+ $ 23.713D0 , 23.647D0 , 23.726D0 , 22.892D0 , 22.119D0 ,
+ $ 21.485D0 , 20.726D0 , 20.921D0 , 19.226D0 , 20.454D0 ,
+ $ 21.658D0 /
+C XI(-)_BAR
+ DATA (CSIN(29,J),J=1,41) /
+ $ 1076.5D0 , 312.66D0 , 119.74D0 , 98.571D0 , 63.193D0 ,
+ $ 49.990D0 , 39.579D0 , 35.168D0 , 32.335D0 , 30.417D0 ,
+ $ 29.434D0 , 27.325D0 , 26.514D0 , 25.775D0 , 25.120D0 ,
+ $ 24.711D0 , 24.818D0 , 25.600D0 , 26.106D0 , 26.355D0 ,
+ $ 25.220D0 , 24.760D0 , 21.681D0 , 20.060D0 , 19.044D0 ,
+ $ 18.474D0 , 18.044D0 , 18.301D0 , 18.347D0 , 18.192D0 ,
+ $ 18.557D0 , 18.639D0 , 18.870D0 , 18.769D0 , 18.478D0 ,
+ $ 18.372D0 , 18.302D0 , 18.735D0 , 18.206D0 , 20.207D0 ,
+ $ 21.576D0 /
+C OMEGA(-)
+ DATA (CSIN(33,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 ,
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.95639D-01, 1.4154D0 ,
+ $ 5.4104D0 , 8.2240D0 , 8.8031D0 , 9.1000D0 , 8.8761D0 ,
+ $ 9.0095D0 , 9.2576D0 , 10.307D0 , 10.818D0 , 11.341D0 ,
+ $ 11.778D0 , 12.108D0 , 12.569D0 , 14.000D0 , 14.467D0 ,
+ $ 15.054D0 , 15.694D0 , 16.263D0 , 16.632D0 , 20.100D0 ,
+ $ 21.438D0 /
+C OMEGA(-)_BAR
+ DATA (CSIN(34,J),J=1,41) /
+ $ 1076.5D0 , 312.66D0 , 119.74D0 , 98.571D0 , 63.193D0 ,
+ $ 49.990D0 , 39.579D0 , 35.168D0 , 32.335D0 , 30.417D0 ,
+ $ 29.434D0 , 27.325D0 , 26.514D0 , 25.775D0 , 25.120D0 ,
+ $ 24.711D0 , 24.818D0 , 25.600D0 , 26.106D0 , 26.355D0 ,
+ $ 25.220D0 , 24.760D0 , 21.681D0 , 20.060D0 , 19.044D0 ,
+ $ 18.474D0 , 18.044D0 , 18.301D0 , 18.347D0 , 18.192D0 ,
+ $ 18.557D0 , 18.639D0 , 18.870D0 , 18.769D0 , 18.478D0 ,
+ $ 18.372D0 , 18.302D0 , 18.735D0 , 18.206D0 , 20.207D0 ,
+ $ 21.576D0 /
+
+C ELASTIC CROSS-SECTION FOR MEDI WITH PIONS
+C ALUMINIUM
+ DATA (CSPIEL( 1,J),J=1,41) /
+ $ 0.00000D0 , 350.00D0 , 580.00D0 , 600.00D0 , 550.00D0 ,
+ $ 450.00D0 , 410.00D0 , 370.00D0 , 340.00D0 , 230.00D0 ,
+ $ 220.00D0 , 205.00D0 , 180.00D0 , 155.00D0 , 145.00D0 ,
+ $ 140.00D0 , 160.00D0 , 195.00D0 , 235.00D0 , 250.00D0 ,
+ $ 270.00D0 , 280.00D0 , 300.00D0 , 300.00D0 , 290.00D0 ,
+ $ 285.00D0 , 265.00D0 , 240.00D0 , 230.00D0 , 222.00D0 ,
+ $ 204.00D0 , 196.00D0 , 190.00D0 , 170.00D0 , 170.00D0 ,
+ $ 160.00D0 , 150.00D0 , 140.00D0 , 120.00D0 , 80.000D0 ,
+ $ 80.000D0 /
+C COPPER
+ DATA (CSPIEL( 2,J),J=1,41) /
+ $ 0.00000D0 , 700.00D0 , 1000.0D0 , 1200.0D0 , 1300.0D0 ,
+ $ 1300.0D0 , 1250.0D0 , 1250.0D0 , 1100.0D0 , 1000.0D0 ,
+ $ 940.00D0 , 740.00D0 , 700.00D0 , 670.00D0 , 660.00D0 ,
+ $ 670.00D0 , 680.00D0 , 700.00D0 , 735.00D0 , 800.00D0 ,
+ $ 810.00D0 , 820.00D0 , 820.00D0 , 810.00D0 , 800.00D0 ,
+ $ 800.00D0 , 700.00D0 , 600.00D0 , 500.00D0 , 470.00D0 ,
+ $ 440.00D0 , 410.00D0 , 380.00D0 , 330.00D0 , 330.00D0 ,
+ $ 330.00D0 , 330.00D0 , 330.00D0 , 285.00D0 , 240.00D0 ,
+ $ 240.00D0 /
+C LEAD
+ DATA (CSPIEL( 3,J),J=1,41) /
+ $ 0.00000D0 , 1700.0D0 , 2200.0D0 , 2200.0D0 , 1800.0D0 ,
+ $ 1300.0D0 , 1200.0D0 , 900.00D0 , 900.00D0 , 1000.0D0 ,
+ $ 1100.0D0 , 1300.0D0 , 1400.0D0 , 1420.0D0 , 1490.0D0 ,
+ $ 1560.0D0 , 1580.0D0 , 1690.0D0 , 1795.0D0 , 2000.0D0 ,
+ $ 2070.0D0 , 2140.0D0 , 2050.0D0 , 2010.0D0 , 1970.0D0 ,
+ $ 1880.0D0 , 1690.0D0 , 1500.0D0 , 1420.0D0 , 1390.0D0 ,
+ $ 1350.0D0 , 1360.0D0 , 1370.0D0 , 1280.0D0 , 1290.0D0 ,
+ $ 1295.0D0 , 1250.0D0 , 1200.0D0 , 1050.0D0 , 900.00D0 ,
+ $ 900.00D0 /
+C INELASTIC CROSS-SECTION FOR MEDIA WITH PIONS
+C ALIMINUIM
+ DATA (CSPIIN( 1,J),J=1,41) /
+ $ 0.00000D0 , 200.00D0 , 320.00D0 , 500.00D0 , 600.00D0 ,
+ $ 600.00D0 , 590.00D0 , 530.00D0 , 510.00D0 , 470.00D0 ,
+ $ 430.00D0 , 425.00D0 , 420.00D0 , 425.00D0 , 425.00D0 ,
+ $ 430.00D0 , 430.00D0 , 435.00D0 , 435.00D0 , 440.00D0 ,
+ $ 430.00D0 , 430.00D0 , 420.00D0 , 420.00D0 , 420.00D0 ,
+ $ 415.00D0 , 415.00D0 , 410.00D0 , 410.00D0 , 408.00D0 ,
+ $ 406.00D0 , 404.00D0 , 400.00D0 , 380.00D0 , 340.00D0 ,
+ $ 340.00D0 , 340.00D0 , 340.00D0 , 340.00D0 , 340.00D0 ,
+ $ 340.00D0 /
+C COPPER
+ DATA (CSPIIN( 2,J),J=1,41) /
+ $ 0.00000D0 , 400.00D0 , 800.00D0 , 1000.0D0 , 1100.0D0 ,
+ $ 1200.0D0 , 1150.0D0 , 1050.0D0 , 1000.0D0 , 900.00D0 ,
+ $ 860.00D0 , 860.00D0 , 850.00D0 , 850.00D0 , 840.00D0 ,
+ $ 830.00D0 , 820.00D0 , 810.00D0 , 805.00D0 , 800.00D0 ,
+ $ 800.00D0 , 800.00D0 , 800.00D0 , 800.00D0 , 800.00D0 ,
+ $ 800.00D0 , 800.00D0 , 800.00D0 , 800.00D0 , 780.00D0 ,
+ $ 760.00D0 , 740.00D0 , 720.00D0 , 720.00D0 , 700.00D0 ,
+ $ 690.00D0 , 680.00D0 , 670.00D0 , 665.00D0 , 660.00D0 ,
+ $ 660.00D0 /
+C LEAD
+ DATA (CSPIIN( 3,J),J=1,41) /
+ $ 0.00000D0 , 1000.0D0 , 1900.0D0 , 2600.0D0 , 2900.0D0 ,
+ $ 3000.0D0 , 2800.0D0 , 2600.0D0 , 2500.0D0 , 2300.0D0 ,
+ $ 2200.0D0 , 2000.0D0 , 1900.0D0 , 1880.0D0 , 1860.0D0 ,
+ $ 1840.0D0 , 1820.0D0 , 1810.0D0 , 1805.0D0 , 1800.0D0 ,
+ $ 1780.0D0 , 1760.0D0 , 1750.0D0 , 1740.0D0 , 1730.0D0 ,
+ $ 1720.0D0 , 1710.0D0 , 1700.0D0 , 1680.0D0 , 1660.0D0 ,
+ $ 1650.0D0 , 1640.0D0 , 1630.0D0 , 1620.0D0 , 1610.0D0 ,
+ $ 1605.0D0 , 1600.0D0 , 1600.0D0 , 1550.0D0 , 1500.0D0 ,
+ $ 1500.0D0 /
+C ELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS
+C ALUMINIUM
+ DATA (CSPNEL( 1,J),J=1,41) /
+ $ 2100.0D0 , 1800.0D0 , 1500.0D0 , 1050.0D0 , 900.00D0 ,
+ $ 950.00D0 , 800.00D0 , 650.00D0 , 570.00D0 , 390.00D0 ,
+ $ 300.00D0 , 240.00D0 , 230.00D0 , 230.00D0 , 220.00D0 ,
+ $ 220.00D0 , 225.00D0 , 225.00D0 , 240.00D0 , 240.00D0 ,
+ $ 290.00D0 , 330.00D0 , 335.00D0 , 350.00D0 , 355.00D0 ,
+ $ 370.00D0 , 350.00D0 , 330.00D0 , 310.00D0 , 290.00D0 ,
+ $ 270.00D0 , 265.00D0 , 260.00D0 , 230.00D0 , 210.00D0 ,
+ $ 210.00D0 , 200.00D0 , 200.00D0 , 190.00D0 , 180.00D0 ,
+ $ 180.00D0 /
+C COPPER
+ DATA (CSPNEL( 2,J),J=1,41) /
+ $ 3800.0D0 , 2900.0D0 , 1850.0D0 , 1550.0D0 , 1450.0D0 ,
+ $ 1520.0D0 , 1460.0D0 , 1300.0D0 , 1140.0D0 , 880.00D0 ,
+ $ 700.00D0 , 620.00D0 , 540.00D0 , 560.00D0 , 460.00D0 ,
+ $ 460.00D0 , 470.00D0 , 470.00D0 , 480.00D0 , 480.00D0 ,
+ $ 580.00D0 , 600.00D0 , 610.00D0 , 620.00D0 , 620.00D0 ,
+ $ 620.00D0 , 590.00D0 , 580.00D0 , 460.00D0 , 440.00D0 ,
+ $ 420.00D0 , 400.00D0 , 480.00D0 , 430.00D0 , 380.00D0 ,
+ $ 380.00D0 , 380.00D0 , 380.00D0 , 380.00D0 , 380.00D0 ,
+ $ 380.00D0 /
+C LEAD
+ DATA (CSPNEL( 3,J),J=1,41) /
+ $ 7000.0D0 , 6000.0D0 , 4500.0D0 , 3350.0D0 , 2700.0D0 ,
+ $ 3000.0D0 , 3550.0D0 , 3970.0D0 , 3280.0D0 , 2490.0D0 ,
+ $ 2100.0D0 , 1510.0D0 , 1440.0D0 , 1370.0D0 , 1370.0D0 ,
+ $ 1370.0D0 , 1400.0D0 , 1400.0D0 , 1420.0D0 , 1420.0D0 ,
+ $ 1440.0D0 , 1460.0D0 , 1460.0D0 , 1450.0D0 , 1450.0D0 ,
+ $ 1470.0D0 , 1400.0D0 , 1400.0D0 , 1380.0D0 , 1370.0D0 ,
+ $ 1360.0D0 , 1350.0D0 , 1340.0D0 , 1330.0D0 , 1320.0D0 ,
+ $ 1310.0D0 , 1305.0D0 , 1300.0D0 , 1300.0D0 , 1300.0D0 ,
+ $ 1300.0D0 /
+C INELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS
+C ALUMINIUM
+ DATA (CSPNIN( 1,J),J=1,41) /
+ $ 0.00000D0 , 200.00D0 , 400.00D0 , 800.00D0 , 800.00D0 ,
+ $ 550.00D0 , 500.00D0 , 450.00D0 , 430.00D0 , 410.00D0 ,
+ $ 400.00D0 , 390.00D0 , 380.00D0 , 370.00D0 , 370.00D0 ,
+ $ 370.00D0 , 365.00D0 , 365.00D0 , 360.00D0 , 360.00D0 ,
+ $ 360.00D0 , 360.00D0 , 365.00D0 , 370.00D0 , 375.00D0 ,
+ $ 380.00D0 , 400.00D0 , 410.00D0 , 420.00D0 , 430.00D0 ,
+ $ 440.00D0 , 440.00D0 , 440.00D0 , 440.00D0 , 440.00D0 ,
+ $ 440.00D0 , 440.00D0 , 440.00D0 , 440.00D0 , 440.00D0 ,
+ $ 440.00D0 /
+C COPPER
+ DATA (CSPNIN( 2,J),J=1,41) /
+ $ 0.00000D0 , 400.00D0 , 950.00D0 , 1050.0D0 , 1050.0D0 ,
+ $ 980.00D0 , 940.00D0 , 900.00D0 , 860.00D0 , 820.00D0 ,
+ $ 800.00D0 , 780.00D0 , 760.00D0 , 740.00D0 , 740.00D0 ,
+ $ 740.00D0 , 730.00D0 , 730.00D0 , 720.00D0 , 720.00D0 ,
+ $ 720.00D0 , 720.00D0 , 730.00D0 , 740.00D0 , 750.00D0 ,
+ $ 760.00D0 , 800.00D0 , 820.00D0 , 820.00D0 , 820.00D0 ,
+ $ 820.00D0 , 820.00D0 , 820.00D0 , 820.00D0 , 820.00D0 ,
+ $ 820.00D0 , 820.00D0 , 820.00D0 , 820.00D0 , 820.00D0 ,
+ $ 820.00D0 /
+C LEAD
+ DATA (CSPNIN( 3,J),J=1,41) /
+ $ 0.00000D0 , 0.00000D0 , 500.00D0 , 1450.0D0 , 1700.0D0 ,
+ $ 1800.0D0 , 1750.0D0 , 1730.0D0 , 1720.0D0 , 1710.0D0 ,
+ $ 1700.0D0 , 1690.0D0 , 1660.0D0 , 1630.0D0 , 1630.0D0 ,
+ $ 1630.0D0 , 1600.0D0 , 1600.0D0 , 1580.0D0 , 1580.0D0 ,
+ $ 1580.0D0 , 1580.0D0 , 1600.0D0 , 1630.0D0 , 1650.0D0 ,
+ $ 1670.0D0 , 1760.0D0 , 1800.0D0 , 1800.0D0 , 1800.0D0 ,
+ $ 1800.0D0 , 1800.0D0 , 1800.0D0 , 1800.0D0 , 1800.0D0 ,
+ $ 1800.0D0 , 1800.0D0 , 1800.0D0 , 1800.0D0 , 1800.0D0 ,
+ $ 1800.0D0 /
+ DATA ELAB /
+ $ 0.10000D-03, 0.20000D-03, 0.30000D-03, 0.40000D-03, 0.50000D-03,
+ $ 0.70000D-03, 0.10000D-02, 0.20000D-02, 0.30000D-02, 0.40000D-02,
+ $ 0.50000D-02, 0.70000D-02, 0.10000D-01, 0.15000D-01, 0.20000D-01,
+ $ 0.25000D-01, 0.32700D-01/
+C TABLES FOR VARIOUS ATOMIC WEIGHTS
+ DATA CNLWAT /
+ $ 1.0000D0 , 16.000D0 , 27.000D0 , 56.000D0 , 59.000D0 ,
+ $ 64.000D0 , 91.000D0 , 112.00D0 , 119.00D0 , 127.00D0 ,
+ $ 137.00D0 , 181.00D0 , 207.00D0 , 209.00D0 , 238.00D0 /
+ DATA (CNLWEL( 1,J),J=1,17) /
+ $ 6000.0D0 , 5500.0D0 , 5200.0D0 , 4900.0D0 , 4800.0D0 ,
+ $ 4400.0D0 , 4000.0D0 , 2900.0D0 , 2200.0D0 , 1800.0D0 ,
+ $ 1400.0D0 , 1100.0D0 , 900.00D0 , 700.00D0 , 600.00D0 ,
+ $ 560.00D0 , 520.00D0 /
+ DATA (CNLWEL( 2,J),J=1,17) /
+ $ 5400.0D0 , 5050.0D0 , 4800.0D0 , 4600.0D0 , 4399.0D0 ,
+ $ 4090.0D0 , 3700.0D0 , 2600.0D0 , 1950.0D0 , 1600.0D0 ,
+ $ 1300.0D0 , 900.00D0 , 700.00D0 , 800.00D0 , 1050.0D0 ,
+ $ 1250.0D0 , 1320.0D0 /
+ DATA (CNLWEL( 3,J),J=1,17) /
+ $ 5500.0D0 , 5150.0D0 , 4900.0D0 , 4699.0D0 , 4490.0D0 ,
+ $ 4150.0D0 , 3750.0D0 , 2790.0D0 , 2100.0D0 , 1650.0D0 ,
+ $ 1300.0D0 , 950.00D0 , 800.00D0 , 860.00D0 , 1000.0D0 ,
+ $ 1090.0D0 , 1080.0D0 /
+ DATA (CNLWEL( 4,J),J=1,17) /
+ $ 5499.0D0 , 4970.0D0 , 4450.0D0 , 4080.0D0 , 3750.0D0 ,
+ $ 3380.0D0 , 2900.0D0 , 2400.0D0 , 2380.0D0 , 2350.0D0 ,
+ $ 2300.0D0 , 2100.0D0 , 1720.0D0 , 1370.0D0 , 1200.0D0 ,
+ $ 1060.0D0 , 870.00D0 /
+ DATA (CNLWEL( 5,J),J=1,17) /
+ $ 5399.0D0 , 4710.0D0 , 4180.0D0 , 3760.0D0 , 3460.0D0 ,
+ $ 3150.0D0 , 2730.0D0 , 2270.0D0 , 1850.0D0 , 1850.0D0 ,
+ $ 2130.0D0 , 2330.0D0 , 2120.0D0 , 1640.0D0 , 1310.0D0 ,
+ $ 1100.0D0 , 1050.0D0 /
+ DATA (CNLWEL( 6,J),J=1,17) /
+ $ 5099.0D0 , 4405.0D0 , 3825.0D0 , 3455.0D0 , 3125.0D0 ,
+ $ 2695.0D0 , 2350.0D0 , 1850.0D0 , 1580.0D0 , 1820.0D0 ,
+ $ 2050.0D0 , 2210.0D0 , 2000.0D0 , 1590.0D0 , 1310.0D0 ,
+ $ 1120.0D0 , 1040.0D0 /
+ DATA (CNLWEL( 7,J),J=1,17) /
+ $ 6290.0D0 , 5960.0D0 , 5640.0D0 , 5370.0D0 , 5150.0D0 ,
+ $ 4800.0D0 , 4250.0D0 , 3150.0D0 , 2470.0D0 , 2100.0D0 ,
+ $ 2230.0D0 , 2420.0D0 , 2450.0D0 , 2050.0D0 , 1760.0D0 ,
+ $ 1550.0D0 , 1330.0D0 /
+ DATA (CNLWEL( 8,J),J=1,17) /
+ $ 6885.0D0 , 6650.0D0 , 6350.0D0 , 6150.0D0 , 6000.0D0 ,
+ $ 5700.0D0 , 5360.0D0 , 4250.0D0 , 2800.0D0 , 1870.0D0 ,
+ $ 1810.0D0 , 1820.0D0 , 2170.0D0 , 2450.0D0 , 2150.0D0 ,
+ $ 1700.0D0 , 1390.0D0 /
+ DATA (CNLWEL( 9,J),J=1,17) /
+ $ 6600.0D0 , 6500.0D0 , 6400.0D0 , 6249.0D0 , 6190.0D0 ,
+ $ 5950.0D0 , 5520.0D0 , 4250.0D0 , 2750.0D0 , 1900.0D0 ,
+ $ 1850.0D0 , 1950.0D0 , 2340.0D0 , 2800.0D0 , 2540.0D0 ,
+ $ 2100.0D0 , 1760.0D0 /
+ DATA (CNLWEL(10,J),J=1,17) /
+ $ 7400.0D0 , 7200.0D0 , 6999.0D0 , 6840.0D0 , 6655.0D0 ,
+ $ 6320.0D0 , 5820.0D0 , 4400.0D0 , 2850.0D0 , 2000.0D0 ,
+ $ 1800.0D0 , 1800.0D0 , 2150.0D0 , 2600.0D0 , 2350.0D0 ,
+ $ 1950.0D0 , 2100.0D0 /
+ DATA (CNLWEL(11,J),J=1,17) /
+ $ 7900.0D0 , 7700.0D0 , 7499.0D0 , 7390.0D0 , 7202.0D0 ,
+ $ 6810.0D0 , 6360.0D0 , 4920.0D0 , 3450.0D0 , 2600.0D0 ,
+ $ 2200.0D0 , 1950.0D0 , 2300.0D0 , 2800.0D0 , 2650.0D0 ,
+ $ 2250.0D0 , 2050.0D0 /
+ DATA (CNLWEL(12,J),J=1,17) /
+ $ 7900.0D0 , 7750.0D0 , 7699.0D0 , 7590.0D0 , 7450.0D0 ,
+ $ 7200.0D0 , 6850.0D0 , 5650.0D0 , 4400.0D0 , 3700.0D0 ,
+ $ 3400.0D0 , 2800.0D0 , 2700.0D0 , 3100.0D0 , 3250.0D0 ,
+ $ 3100.0D0 , 2750.0D0 /
+ DATA (CNLWEL(13,J),J=1,17) /
+ $ 6100.0D0 , 5950.0D0 , 5750.0D0 , 5599.0D0 , 5440.0D0 ,
+ $ 5200.0D0 , 4800.0D0 , 4300.0D0 , 5800.0D0 , 5750.0D0 ,
+ $ 4800.0D0 , 3420.0D0 , 2650.0D0 , 3200.0D0 , 3650.0D0 ,
+ $ 3500.0D0 , 2980.0D0 /
+ DATA (CNLWEL(14,J),J=1,17) /
+ $ 6100.0D0 , 5950.0D0 , 5750.0D0 , 5599.0D0 , 5440.0D0 ,
+ $ 5200.0D0 , 4800.0D0 , 4300.0D0 , 5800.0D0 , 5750.0D0 ,
+ $ 4800.0D0 , 3420.0D0 , 2650.0D0 , 3200.0D0 , 3650.0D0 ,
+ $ 3500.0D0 , 2980.0D0 /
+ DATA (CNLWEL(15,J),J=1,17) /
+ $ 6600.0D0 , 6350.0D0 , 6100.0D0 , 5899.0D0 , 5690.0D0 ,
+ $ 5300.0D0 , 4850.0D0 , 4450.0D0 , 5650.0D0 , 5700.0D0 ,
+ $ 4950.0D0 , 3850.0D0 , 3050.0D0 , 3050.0D0 , 3460.0D0 ,
+ $ 3650.0D0 , 3340.0D0 /
+ DATA (CNLWIN( 1,J),J=1,17) / 17*0.0D0 /
+ DATA (CNLWIN( 2,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 ,
+ $ 10.000D0 , 50.000D0 , 100.00D0 , 200.00D0 , 300.00D0 ,
+ $ 400.00D0 , 600.00D0 , 700.00D0 , 750.00D0 , 700.00D0 ,
+ $ 700.00D0 , 680.00D0 /
+ DATA (CNLWIN( 3,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 ,
+ $ 50.000D0 , 100.00D0 , 260.00D0 , 450.00D0 , 600.00D0 ,
+ $ 700.00D0 , 800.00D0 , 900.00D0 , 940.00D0 , 900.00D0 ,
+ $ 860.00D0 , 820.00D0 /
+ DATA (CNLWIN( 4,J),J=1,17) /
+ $ 1.0000D0 , 80.000D0 , 200.00D0 , 320.00D0 , 400.00D0 ,
+ $ 520.00D0 , 700.00D0 , 1000.0D0 , 1120.0D0 , 1200.0D0 ,
+ $ 1200.0D0 , 1200.0D0 , 1180.0D0 , 1130.0D0 , 1100.0D0 ,
+ $ 1090.0D0 , 1080.0D0 /
+ DATA (CNLWIN( 5,J),J=1,17) /
+ $ 1.0000D0 , 90.000D0 , 220.00D0 , 340.00D0 , 420.00D0 ,
+ $ 550.00D0 , 720.00D0 , 1080.0D0 , 1300.0D0 , 1400.0D0 ,
+ $ 1420.0D0 , 1420.0D0 , 1380.0D0 , 1260.0D0 , 1190.0D0 ,
+ $ 1150.0D0 , 1100.0D0 /
+ DATA (CNLWIN( 6,J),J=1,17) /
+ $ 1.0000D0 , 95.000D0 , 225.00D0 , 345.00D0 , 425.00D0 ,
+ $ 555.00D0 , 750.00D0 , 1150.0D0 , 1500.0D0 , 1680.0D0 ,
+ $ 1700.0D0 , 1690.0D0 , 1550.0D0 , 1360.0D0 , 1240.0D0 ,
+ $ 1180.0D0 , 1120.0D0 /
+ DATA (CNLWIN( 7,J),J=1,17) /
+ $ 10.000D0 , 140.00D0 , 260.00D0 , 380.00D0 , 450.00D0 ,
+ $ 600.00D0 , 750.00D0 , 1200.0D0 , 1580.0D0 , 1800.0D0 ,
+ $ 1820.0D0 , 1830.0D0 , 1800.0D0 , 1750.0D0 , 1690.0D0 ,
+ $ 1650.0D0 , 1620.0D0 /
+ DATA (CNLWIN( 8,J),J=1,17) /
+ $ 15.000D0 , 150.00D0 , 300.00D0 , 400.00D0 , 500.00D0 ,
+ $ 650.00D0 , 840.00D0 , 1500.0D0 , 2100.0D0 , 2130.0D0 ,
+ $ 2140.0D0 , 2130.0D0 , 2080.0D0 , 2000.0D0 , 1950.0D0 ,
+ $ 1900.0D0 , 1860.0D0 /
+ DATA (CNLWIN( 9,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 ,
+ $ 150.00D0 , 380.00D0 , 1000.0D0 , 1650.0D0 , 2100.0D0 ,
+ $ 2100.0D0 , 2100.0D0 , 2060.0D0 , 1950.0D0 , 1860.0D0 ,
+ $ 1800.0D0 , 1740.0D0 /
+ DATA (CNLWIN(10,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 , 45.000D0 ,
+ $ 180.00D0 , 380.00D0 , 1050.0D0 , 1900.0D0 , 2300.0D0 ,
+ $ 2300.0D0 , 2200.0D0 , 2150.0D0 , 2000.0D0 , 1900.0D0 ,
+ $ 1800.0D0 , 1750.0D0 /
+ DATA (CNLWIN(11,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 , 48.000D0 ,
+ $ 190.00D0 , 390.00D0 , 1080.0D0 , 2000.0D0 , 2400.0D0 ,
+ $ 2400.0D0 , 2300.0D0 , 2200.0D0 , 2100.0D0 , 1950.0D0 ,
+ $ 1850.0D0 , 1800.0D0 /
+ DATA (CNLWIN(12,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 , 50.000D0 ,
+ $ 200.00D0 , 400.00D0 , 1100.0D0 , 2100.0D0 , 2500.0D0 ,
+ $ 2500.0D0 , 2450.0D0 , 2300.0D0 , 2100.0D0 , 2000.0D0 ,
+ $ 1900.0D0 , 1850.0D0 /
+ DATA (CNLWIN(13,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 ,
+ $ 100.00D0 , 350.00D0 , 900.00D0 , 1400.0D0 , 2000.0D0 ,
+ $ 2300.0D0 , 2380.0D0 , 2400.0D0 , 2300.0D0 , 2250.0D0 ,
+ $ 2200.0D0 , 2120.0D0 /
+ DATA (CNLWIN(14,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 ,
+ $ 100.00D0 , 350.00D0 , 900.00D0 , 1400.0D0 , 2000.0D0 ,
+ $ 2300.0D0 , 2380.0D0 , 2400.0D0 , 2300.0D0 , 2250.0D0 ,
+ $ 2200.0D0 , 2120.0D0 /
+ DATA (CNLWIN(15,J),J=1,17) /
+ $ 0.00000D0 , 0.00000D0 , 0.00000D0 , 1.0000D0 , 10.000D0 ,
+ $ 100.00D0 , 400.00D0 , 950.00D0 , 1600.0D0 , 2200.0D0 ,
+ $ 2550.0D0 , 2750.0D0 , 2700.0D0 , 2600.0D0 , 2540.0D0 ,
+ $ 2450.0D0 , 2360.0D0 /
+ DATA (CSCAP(J),J=1,50) /
+ $ 6.0000D0 , 5.7000D0 , 5.5000D0 , 5.3000D0 , 5.2000D0 ,
+ $ 5.1000D0 , 5.0000D0 , 4.9000D0 , 4.8000D0 , 4.8000D0 ,
+ $ 4.8000D0 , 4.8000D0 , 4.8000D0 , 4.8000D0 , 4.8000D0 ,
+ $ 4.8000D0 , 4.9000D0 , 5.0000D0 , 5.2000D0 , 5.5000D0 ,
+ $ 6.0000D0 , 6.7000D0 , 7.5000D0 , 8.5000D0 , 10.000D0 ,
+ $ 12.000D0 , 14.500D0 , 19.000D0 , 26.500D0 , 40.000D0 ,
+ $ 75.000D0 , 120.00D0 , 180.00D0 , 260.00D0 , 360.00D0 ,
+ $ 330.00D0 , 60.000D0 , 7.0000D0 , 9.5000D0 , 20.000D0 ,
+ $ 75.000D0 , 140.00D0 , 250.00D0 , 360.00D0 , 480.00D0 ,
+ $ 580.00D0 , 590.00D0 , 500.00D0 , 300.00D0 , 100.00D0 /
+ DATA (CSCAP(J),J=51,100) /
+ $ 200.00D0 , 300.00D0 , 400.00D0 , 470.00D0 , 500.00D0 ,
+ $ 430.00D0 , 100.00D0 , 20.000D0 , 22.000D0 , 40.000D0 ,
+ $ 560.00D0 , 950.00D0 , 1000.0D0 , 1000.0D0 , 1000.0D0 ,
+ $ 990.00D0 , 920.00D0 , 860.00D0 , 790.00D0 , 740.00D0 ,
+ $ 650.00D0 , 600.00D0 , 540.00D0 , 470.00D0 , 440.00D0 ,
+ $ 390.00D0 , 360.00D0 , 340.00D0 , 320.00D0 , 310.00D0 ,
+ $ 280.00D0 , 2.0000D0 , 2.5000D0 , 6.0000D0 , 13.000D0 ,
+ $ 38.000D0 , 65.000D0 , 140.00D0 , 280.00D0 , 300.00D0 ,
+ $ 430.00D0 , 580.00D0 , 650.00D0 , 800.00D0 , 920.00D0 ,
+ $ 1100.0D0 , 1250.0D0 , 1400.0D0 , 1550.0D0 , 1700.0D0 /
+C --- END OF CROSS-SECTION DATA STATEMENTS ---
+
+C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
+C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I ---
+C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I ---
+
+c$$$ DATA KIPART/
+c$$$ $ 1, 3, 4, 2, 5, 6, 8, 7,
+c$$$ $ 9, 12, 10, 13, 16, 14, 15, 11,
+c$$$ $ 35, 18, 20, 21, 22, 26, 27, 33,
+c$$$ $ 17, 19, 23, 24, 25, 28, 29, 34,
+c$$$ $ 35, 35, 35, 35, 35, 35, 35, 35,
+c$$$ $ 35, 35, 35, 35, 30, 31, 32, 35/
+
+* DATA IKPART/
+* $ 1, 4, 2, 3, 5, 6, 8, 7,
+* $ 9, 11, 16, 10, 12, 14, 15, 13,
+* $ 25, 18, 26, 19, 20, 21, 27, 28,
+* $ 29, 22, 23, 30, 31, 45, 46, 47,
+* $ 24, 32, 48/
+
+
+C PARAMETER (ONETHR=1./3.)
+ DATA ONETHR / .33333333D0/
+ DATA ALPHA / 6*0.7D0,
+ + 0.75D0 ,0.75D0 ,0.75D0 ,
+ + 0.76D0,0.76D0 ,0.76D0 ,0.76D0 ,
+ + 0.685D0,0.63D0 ,0.685D0,0.63D0,0.685D0,0.63D0,
+ + 3*0.685D0,3*0.63D0,2*0.685D0,2*0.63D0,
+ + 3*0.7D0,0.685D0,0.63D0,0.7D0/
+ DATA ALPHAC /1.2D0,1.2D0,1.2D0,1.15D0,0.90D0,0.91D0,0.98D0,
+ + 1.06D0,1.10D0,1.11D0,1.10D0,1.08D0,1.05D0,1.01D0,
+ + 0.985D0,0.962D0,0.945D0,0.932D0,0.925D0,0.920D0,
+ + 0.920D0,0.921D0,0.922D0,0.923D0,0.928D0,0.931D0,
+ + 0.940D0,0.945D0,0.950D0,0.955D0,0.958D0,0.962D0,
+ + 0.965D0,0.976D0,0.982D0,0.988D0,0.992D0,1.010D0,
+ + 1.020D0,1.030D0,1.040D0/
+ DATA PARTEL/6*0.D0,29*1.D0/
+ DATA PARTIN/6*0.D0,1.00D0,0.00D0,1.05D0,1.20D0,1.35D0,1.30D0,
+ + 1.20D0,1.00D0,1.30D0,1.00D0,1.30D0,1.00D0,1.30D0,
+ + 1.00D0,1.00D0,1.00D0,1.30D0,1.30D0,1.30D0,1.00D0,
+ + 1.00D0,1.30D0,1.30D0,1.00D0,1.D0,1.D0,1.D0,1.3D0,
+ + 1.D0/
+* DATA ICORR /14*1, 0, 1, 0, 1, 0, 3*1, 3*0, 2*1, 2*0, 4*1, 2*0/
+C-- SET INTRC TO 0 FOR IPART = 26-29, 33, 34 ( XI'S AND OMEGA'S )
+C-DH- DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 1, 4*0, 3*1, 3*0 /
+C-- RESET INTRC FOR IPART = 26-29, 33, 34 ( XI'S AND OMEGA'S )
+ DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 10*1, 0/
+
+C CROSS-SECTIONS ON NUCLEUS ARE KNOWN ONLY FOR PIONS AND PROTONS.
+C THE GENERAL LAW SIGMA(A)=1.25*SIGMA(TOT,PROTON)*A**ALPHA IS VALID
+C ONLY FOR MOMENTA > 2 GEV.THE PARAMETRIZATION DONE HERE GIVES ONLY
+C A BEHAVIOUR AVERAGED OVER MOMENTA AND PARTICLE TYPES.
+C FOR A DETECTOR WITH ONLY A FEW MATERIALS IT'S OF COURSE MUCHBETTER
+C TO USE TABLES OF THE MEASURED CROSS-SECTIONS .
+C FOR ELEMENTS WITH THE FOLLOWING ATOMIC NUMBERS MEASURED CROSS-
+C SECTIONS ARE AVAILABLE (SEE "PCSDATA").
+
+C H AL CU PB
+ DATA CSA /1.D0 ,27.00D0 ,63.54D0 ,207.19D0 /
+ DATA IPART2/9,8,7,11,10,13,12/
+ SAVE ALPHA,ALPHAC,PARTEL,PARTIN,CSA,IPART2,INTRC
+
+
+C --- INITIALIZE CXGHESIG AND SWITCH TO GHEISHA PARTICLE CODE ---
+ CXGHESIG=0.0D0
+ IPART=KPART
+
+C --- NO INTERACTION FOR GAMMAS, NEUTRINOS, ELECTRONS, POSITRONS, MUONS,
+C --- NEUTRAL PIONS, NEUTRAL SIGMAS AND ANTISIGMAS AND NEW PARTICLES.
+ IF ( INTRC(IPART) .EQ. 0 ) GOTO 160
+ P=PPART
+ EK=EKIN
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ if(itarg.eq.0)then
+ KK = 3
+ WCOMP(1) = airw(1)
+ WCOMP(2) = airw(2)
+ WCOMP(3) = airw(3)
+ ACOMP(1) = aira(1)
+ ACOMP(2) = aira(2)
+ ACOMP(3) = aira(3)
+ ZCOMP(1) = airz(1)
+ ZCOMP(2) = airz(2)
+ ZCOMP(3) = airz(3)
+ else
+ KK = 1
+ WCOMP(KK)= 1.D0
+ ACOMP(KK)= dble(IATARG)
+ ZCOMP(KK)= dble(IZTARG)
+ endif
+#endif
+
+C --- INITIALIZE THE CROSS-SECTIONS WITH 0.0 ---
+ DO K = 1, KK
+ AIEL(K)=0.0D0
+ AIIN(K)=0.0D0
+ AICA(K)=0.0D0
+ ENDDO
+C
+ IF ((IPART .GE. 30) .AND. (IPART .LE. 32)) THEN
+
+C --- TAKE GEOMETRICAL CROSS-SECTIONS FOR INELASTIC SCATTERING ---
+C --- OF DEUTERONS, TRITONS AND ALPHAS ---
+ IF ( IPART .EQ. 30 ) THEN
+ APART=2.0D0**ONETHR
+ ELSEIF ( IPART .EQ. 31 ) THEN
+ APART=3.0D0**ONETHR
+ ELSEIF ( IPART .EQ. 32 ) THEN
+ APART=4.0D0**ONETHR
+ ENDIF
+ DO K = 1, KK
+ AIIN(K)=49.0D0*(APART+ACOMP(K)**ONETHR)**2
+ ENDDO
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,10000)
+#endif
+
+ ELSEIF ((IPART .EQ. 16) .AND. (EK .LE. 0.0327D0)) THEN
+
+C --- USE TABLES FOR LOW ENERGY NEUTRONS ---
+C --- GET ENERGY BIN ---
+ JE2=17
+ DO J = 2, 17
+ IF (EK .LT. ELAB(J)) THEN
+ JE2=J
+ GOTO 40
+ ENDIF
+ ENDDO
+
+ 40 JE1=JE2-1
+ EKX=MAX(EK,1.0D-9)
+ DELAB=ELAB(JE2)-ELAB(JE1)
+ DO 70 K = 1, KK
+C --- GET A BIN ---
+ JA2=15
+ DO J = 2, 15
+ IF (ACOMP(K) .LT. CNLWAT(J)) THEN
+ JA2=J
+ GOTO 60
+ ENDIF
+ ENDDO
+ 60 JA1=JA2-1
+ DNLWAT=CNLWAT(JA2)-CNLWAT(JA1)
+
+C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RCE*X+RCA*X+B ---
+
+C --- ELASTIC CROSS-SECTION ---
+C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 ---
+ DY = CNLWEL(JA1,JE2)-CNLWEL(JA1,JE1)
+ RCE = DY/DELAB
+C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 ---
+ DY = CNLWEL(JA2,JE1)-CNLWEL(JA1,JE1)
+ RCA = DY/DNLWAT
+ B = CNLWEL(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1)
+ AIEL(K) = RCE*EK+RCA*ACOMP(K)+B
+
+C --- INELASTIC CROSS-SECTION ---
+C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 ---
+ DY = CNLWIN(JA1,JE2)-CNLWIN(JA1,JE1)
+ RCE = DY/DELAB
+C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 ---
+ DY = CNLWIN(JA2,JE1)-CNLWIN(JA1,JE1)
+ RCA = DY/DNLWAT
+ B = CNLWIN(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1)
+ AIIN(K) = RCE*EK+RCA*ACOMP(K)+B
+ IZNO = int(ZCOMP(K)+0.01D0)
+ AICA(K) = 11.12D0*CSCAP(IZNO)/(EKX*1.0E6)**0.577D0
+ 70 CONTINUE
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,10100)
+#endif
+ ELSE
+
+C --- USE PARAMETRIZATION OF CROSS-SECTION DATA FOR ALL OTHER CASES ---
+
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,10200)
+#endif
+
+C --- GET MOMENTUM BIN ---
+ J = 40
+ DO I = 2, 41
+ IF (P .LT. PLAB(I)) THEN
+ J=I-1
+ GOTO 90
+ ENDIF
+ ENDDO
+
+C --- START WITH CROSS-SECTIONS FOR SCATTERING ON FREE PROTONS ---
+C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B ---
+ 90 DX = PLAB(J+1)-PLAB(J)
+C --- ELASTIC CROSS-SECTION ---
+ DY = CSEL(IPART,J+1)-CSEL(IPART,J)
+ RC = DY/DX
+ B = CSEL(IPART,J)-RC*PLAB(J)
+ AIELIN = RC*P+B
+C --- INELASTIC CROSS-SECTION ---
+ DY = CSIN(IPART,J+1)-CSIN(IPART,J)
+ RC = DY/DX
+ B = CSIN(IPART,J)-RC*PLAB(J)
+ AIININ = RC*P+B
+ ALPH = ALPHA(IPART)
+ IF ( IPART .LT. 14 ) THEN
+ DY = ALPHAC(J+1)-ALPHAC(J)
+ RC = DY/DX
+ B = ALPHAC(J)-RC*PLAB(J)
+ CORFAC = RC*P+B
+ ALPH = ALPH*CORFAC
+
+ IPART3 = IPART2(IPART-6)
+
+C --- ELASTIC CROSS-SECTION ---
+ DY = CSEL(IPART3,J+1)-CSEL(IPART3,J)
+ RC = DY/DX
+ B = CSEL(IPART3,J)-RC*PLAB(J)
+ XSECEL = RC*P+B
+C --- INELASTIC CROSS-SECTION ---
+ DY = CSIN(IPART3,J+1)-CSIN(IPART3,J)
+ RC = DY/DX
+ B = CSIN(IPART3,J)-RC*PLAB(J)
+ XSECIN = RC*P+B
+
+ ENDIF
+
+C --- NOW MAKE CROSS-SECTIONS FOR COMPONENT K OF COMPOSITION
+ DO 100 K = 1, KK
+ AIEL(K) = AIELIN
+ AIIN(K) = AIININ
+
+ IF ( ACOMP(K) .GE. 1.5D0 ) THEN
+
+C --- A-DEPENDENCE FROM PARAMETRIZATION ---
+ CREL = 1.0D0
+ CRIN = 1.0D0
+C --- GET MEDIUM BIN 1=HYDR. 2=AL 3=CU 4=PB ---
+ I = 3
+ IF ( ACOMP(K) .LT. 50.0D0 ) I = 2
+ IF ( ACOMP(K) .GT. 100.0D0 ) I = 4
+ IF ((IPART .EQ. 14) .OR. (IPART .EQ. 16)) THEN
+
+C --- PROTONS AND NEUTRONS ---
+
+C --- ELASTIC CROSS-SECTION ---
+ DY=CSPNEL(I-1,J+1)-CSPNEL(I-1,J)
+ RC=DY/DX
+ B=CSPNEL(I-1,J)-RC*PLAB(J)
+ XSECEL=RC*P+B
+C --- INELASTIC CROSS-SECTION ---
+ DY=CSPNIN(I-1,J+1)-CSPNIN(I-1,J)
+ RC=DY/DX
+ B=CSPNIN(I-1,J)-RC*PLAB(J)
+ XSECIN=RC*P+B
+ IF (AIEL(K) .GE. 0.001D0) CREL=XSECEL/(0.36D0*AIEL(K)*
+ + CSA(I)**1.17D0)
+ AITOT=AIEL(K)+AIIN(K)
+ IF (AITOT .GE. 0.001D0) CRIN=XSECIN/(AITOT*CSA(I)**
+ + ALPH)
+
+ ELSEIF (IPART .LT. 15) THEN
+
+C --- CALCULATE CORRECTION FACTORS FROM VALUES ON AL,CU,PB FOR ALL ---
+C --- MESONS USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B ---
+C --- NOTE THAT DATA IS ONLY AVAILABLE FOR PIONS AND PROTONS
+ WGCH=0.5D0
+ IF (ACOMP(K) .LT. 20.0D0)
+ + WGCH=0.5D0+0.5D0*EXP(-(ACOMP(K)-1.0D0))
+ AIEL(K)=WGCH*AIEL(K)+(1.0D0-WGCH)*XSECEL
+ AIIN(K)=WGCH*AIIN(K)+(1.0D0-WGCH)*XSECIN
+
+C --- THIS SECTION NOT FOR KAONS ---
+ IF (IPART .LT. 10) THEN
+
+C --- ELASTIC CROSS-SECTION ---
+ DY=CSPIEL(I-1,J+1)-CSPIEL(I-1,J)
+ RC=DY/DX
+ B=CSPIEL(I-1,J)-RC*PLAB(J)
+ XSPIEL=RC*P+B
+C --- INELASTIC CROSS-SECTION ---
+ DY=CSPIIN(I-1,J+1)-CSPIIN(I-1,J)
+ RC=DY/DX
+ B=CSPIIN(I-1,J)-RC*PLAB(J)
+ XSPIIN=RC*P+B
+
+ IF (AIEL(K) .GE. 0.001D0) CREL=XSPIEL/(0.36D0* AIEL(K)
+ + *CSA(I)**1.17D0)
+ AITOT=AIEL(K)+AIIN(K)
+ IF (AITOT .GE. 0.001D0) CRIN=XSPIIN/(AITOT*CSA(I)
+ + **ALPH)
+ ENDIF
+ ENDIF
+ AIIN(K)=CRIN*(AIIN(K)+AIEL(K))*ACOMP(K)**ALPH
+ AIEL(K)=CREL*0.36D0*AIEL(K)*ACOMP(K)**1.17D0
+ AIEL(K)=AIEL(K)*PARTEL(IPART)
+ AIIN(K)=AIIN(K)*PARTIN(IPART)
+ ENDIF
+ 100 CONTINUE
+
+ ENDIF
+
+C --- CALCULATE INTERACTION PROBABILITY ---
+
+ ALAM=0.0D0
+ DO K = 1, KK
+ AIEL(K) = AIEL(K)*WCOMP(K)
+ AIIN(K) = AIIN(K)*WCOMP(K)
+ AICA(K) = AICA(K)*WCOMP(K)
+ ALAM = ALAM + AIIN(K)!+ AIEL(K) + AICA(K) !tttt only inelastic cs for MC
+ ENDDO
+
+C --- PASS THE CROSS-SECTION (MBARN) TO CORSIKA ---
+ CXGHESIG=ALAM
+
+ GOTO 999
+
+ 160 CONTINUE
+C --- PRINTOUT OF SKIPPED PARTICLES IN CASE OF INTERFACE DEBUG ---
+#ifdef __CXDEBUG__
+ IF (NPRT(9)) WRITE(MCXDBUG,10300) IPART
+10000 FORMAT(' *CXGHESIG* GEOM X-SECT. FOR INEL. SCAT. OF D,T AND ALPH')
+10100 FORMAT(' *CXGHESIG* X-SECT. FROM LOW ENERGY NEUTRON TABLES')
+10200 FORMAT(' *CXGHESIG* X-SECT. FROM PARAMETRIZATION OF DATA')
+10300 FORMAT(' *CXGHESIG* GHEISHA PARTICLE ',I3,' SKIPPED')
+#endif
+ 999 RETURN
+ END
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+*CMZ : 28/02/2002 10.19.04 by D. HECK IK FZK KARLSRUHE
+*-- Author : CERN PROGLIB# M103
+C=======================================================================
+
+ SUBROUTINE FLPSOR(A,N)
+
+C-----------------------------------------------------------------------
+C CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113
+C ORIG. 29/04/78
+C-----------------------------------------------------------------------
+C SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
+C INCREASING VALUES
+C
+C PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78
+C-----------------------------------------------------------------------
+
+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
+ DIMENSION A(*)
+ COMMON /SLATE/ LT(20),RT(20)
+ INTEGER R,RT
+ SAVE
+C-----------------------------------------------------------------------
+
+ LEVEL=1
+ LT(1)=1
+ RT(1)=N
+ 10 L=LT(LEVEL)
+ R=RT(LEVEL)
+ LEVEL=LEVEL-1
+ 20 IF ( R .GT. L ) GOTO 200
+ IF ( LEVEL ) 50,50,10
+C
+C SUBDIVIDE THE INTERVAL L,R
+C L : LOWER LIMIT OF THE INTERVAL (INPUT)
+C R : UPPER LIMIT OF THE INTERVAL (INPUT)
+C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
+C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
+C
+ 200 I=L
+ J=R
+ M=(L+R)/2
+ X=A(M)
+ 220 IF ( A(I) .GE. X ) GOTO 230
+ I=I+1
+ GOTO 220
+ 230 IF ( A(J) .LE. X ) GOTO 231
+ J=J-1
+ GOTO 230
+C
+ 231 IF ( I .GT. J ) GOTO 232
+ W=A(I)
+ A(I)=A(J)
+ A(J)=W
+ I=I+1
+ J=J-1
+ IF (I .LE. J ) GOTO 220
+C
+ 232 LEVEL=LEVEL+1
+ IF ( (R-I) .GE. (J-L) ) GOTO 30
+ LT(LEVEL)=L
+ RT(LEVEL)=J
+ L=I
+ GOTO 20
+ 30 LT(LEVEL)=I
+ RT(LEVEL)=R
+ R=J
+ GOTO 20
+ 50 RETURN
+ END
+
+
+C=======================================================================
+
+ SUBROUTINE GRNDM(RVEC,LENV)
+
+C-----------------------------------------------------------------------
+C G(HEISHA) R(A)ND(O)M (NUMBER GENERATOR)
+C
+C THIS SUBROUTINE IS CALLED FROM GHEISHA ROUTINES.
+C ARGUMENTS:
+C RVEC = VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS(REAL)
+C LENV = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED)
+C-- Author : T. PIEROG IK FZK KARLSRUHE 25/04/2003
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION RVEC(*),drangen
+ INTEGER IVEC,LENV
+C-----------------------------------------------------------------------
+
+ DO IVEC = 1, LENV
+ RVEC(IVEC) = drangen(dble(IVEC))
+ ENDDO
+
+ RETURN
+ END
+#endif
+
+#endif
+#ifdef __QGSJET__
+c Last modifications 07.04.2008 Compatibility gcc4 by T.Pierog
+c 18.01.2007 update to compile with CORSIKA
+c 17.11.2006 add ifragm=0,1 or 2
+c 19.05.2003 Link routines between QGSJet03 and CONEX.
+c author T. Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine IniQGSJet
+c-----------------------------------------------------------------------
+c Primary initialization for QGSJet
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ COMMON /Q_DEBUG/ DEBUG
+ COMMON /Q_AREA43/ MONIOU
+ integer debug
+ double precision BQGS,BMAXQGS,BMAXNEX,BMINNEX,XA(64,3),XB(64,3)
+ COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX !ctp
+#endif
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+
+#ifdef __CXDEBUG__
+ call utisx1('iniqgs ',4)
+ write(*,'(a)')'initialize QGSJet ...'
+#endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ debug=0
+#ifdef __CXDEBUG__
+ if(isx.ge.8)debug=isx-7
+ moniou=ifck
+#else
+ moniou=6
+#endif
+c common model parameters setting
+ call psaset
+c particular model parameters setting
+ call xxaset
+c common initialization procedure
+ call qgspsaini
+ BMAXNEX=dble(xsbmaxim)
+ BMINNEX=dble(xsbminim)
+#endif
+ if(ilowegy.ne.1.or.MCleModel.eq.2)xsegymin=0.1d0
+ if(MCModel.eq.2)xsegymax=min(xsegymax,5.d13)
+
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtQGS
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+c QGSJet Common
+ double precision XA(64,3),XB(64,3),BQGS,BMAXQGS,BMAXNEX,BMINNEX,e0
+ COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX
+#endif
+
+
+ if(matargxs.gt.64.or.maprojxs.gt.64)
+ & stop'Nucleus too big for QGSJet (Mmax=64) !'
+ call cxiclass(idprojxs,iclproxs)
+ call cxiclass(idtargxs,icltarxs)
+ e0=dble(xselab)
+ idp=(idprojxs/10)*10 !convert to bound state
+ icp=idtrafocx('nxs','qgs',idp)
+ if(icp.eq.0)icp=1-2*int(drangen(dummy)+0.5d0) !pi0 or rho0 = pi+ or pi-
+ call xxaini(e0,icp,maprojxs,matargxs)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ xsbmax=BMAXQGS
+ xsqgsincs=fqgscrse(xselab,maprojxs,matargxs)
+#else
+ xsbmax=20d0
+ xsqgsincs=1d20
+#endif
+ if(xsekin.lt.xsegymin)xsqgsincs=0.d0 !below egymin, no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'QGSJet used with (E,proj,maproj,matarg,bmax)',e0,icp,maprojxs
+ & ,matargxs,xsbmax
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsqgs(iret)
+c-----------------------------------------------------------------------
+c call qgsjet to simulate interaction
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ double precision XA(64,3),XB(64,3),BQGS,BMAXQGS,BMAXNEX,BMINNEX
+ COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX
+ common /q_area12/ nsp
+ common /q_area14/ esp(4,95000),ich(95000)
+ double precision esp
+c NSF - number of secondary fragments;
+c IAF(i) - mass of the i-th fragment
+ COMMON /Q_AREA13/ NSF,IAF(56)
+ COMMON /Q_AREA99/ NWT
+#else
+ common /area12/ nsp
+ common /area14/ esp(4,95000),ich(95000)
+ double precision esp
+c NSF - number of secondary fragments;
+c IAF(i) - mass of the i-th fragment
+ COMMON /AREA13/ NSF,IAF(56)
+ COMMON /AREA99/ NWT
+#endif
+
+ iret=0
+ if(abs(xsqgsincs).lt.1d-20)goto 1001 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine QGSJet Production&',0,0,0)
+#endif
+ nptlxs=0
+ nsp=0
+ nsf=0
+ nwt=0
+ call psconf
+
+ ncolxs=1
+ nevtxs=1
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ if(BQGS.ge.0.d0)then
+ xsbimp=BQGS
+ xsphi=2.d0*xspi*drangen(dummy)
+ else
+#endif
+ xsbimp=0.d0
+ xsphi=0.d0
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ endif
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*)'impact parameter ',xsbimp
+#endif
+
+#endif
+
+ ist=1
+ call cxconre
+ call cxconwr(ist)
+
+ nptlini=nptlxs+1
+
+
+c keep the projectile spectators as fragments
+ if(ifragm.eq.2)then
+
+ if(NSF.gt.0)then
+ do is=1,NSF !count the number of spectators
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5)')
+ $ ' Projecticle Fragment ',is,' Mass :',IAF(is)
+#endif
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+ if(IAF(is).eq.1)then
+ id=idptlxs(is)
+ xsptl(3,nptlxs)=xsptl(3,is)
+ xsptl(4,nptlxs)=xsptl(4,is)
+ xsptl(5,nptlxs)=xsptl(5,is)
+ else
+ if(IAF(is).eq.2)then
+ id=17
+ elseif(IAF(is).eq.3)then
+ id=18
+ elseif(IAF(is).eq.4)then
+ id=19
+ else
+ id=IAF(is)*100
+ endif
+ call cxidmass(id,am)
+ xsptl(4,nptlxs)=dble(IAF(is))*xsptl(4,is) !Etot
+ xsptl(5,nptlxs)=am !mass
+ pz2tmp=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+ if(pz2tmp.gt.0.d0)then
+ xsptl(3,nptlxs)=sqrt(pz2tmp) !Pz
+ else
+ write(*,*)'Warning in emsqgs !'
+ write(*,*)'energy of fragment too small :',IAF(is),am
+ & ,xsptl(4,nptlxs)
+ xsptl(3,nptlxs)=xsptl(4,nptlxs)
+ endif
+ endif
+ xsptl(1,nptlxs)=0.d0 !P_x
+ xsptl(2,nptlxs)=0.d0 !P_y
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' Fragment from qgsjet ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ enddo
+ endif
+
+c make the projectile spectators as free nucleons
+
+ else
+ ns=0
+ if(NSF.gt.0)then
+ do is=1,NSF !count the number of spectators
+ ns=ns+IAF(is)
+ enddo
+ if(ifragm.eq.1)then
+c remaining nucleus is one fragment
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+ xsptl(1,nptlxs)=0.d0
+ xsptl(2,nptlxs)=0.d0
+ xsptl(4,nptlxs)=0.d0
+ inucl=0
+ do is=1,ns
+ inucl=inucl+1
+ xsptl(4,nptlxs)=xsptl(4,nptlxs)+xsptl(4,is)
+ enddo
+ idnucl=100*inucl
+ call cxidmass(idnucl,am)
+ xsptl(5,nptlxs)=am !mass
+ ptot=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+ xsptl(3,nptlxs)=sqrt(ptot)
+ ityptlxs(nptlxs)=0
+ istptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=xsorptl(1,1)
+ xsorptl(2,nptlxs)=xsorptl(2,1)
+ xsorptl(3,nptlxs)=xsorptl(3,1)
+ xsorptl(4,nptlxs)=xsorptl(4,1)
+ xstivptl(1,nptlxs)=xstivptl(1,1)
+ xstivptl(2,nptlxs)=xstivptl(2,1)
+ idptlxs(nptlxs)=idnucl
+ else
+ do is=1,ns !make the ns first projectile nucleon actives
+ istptlxs(is)=0
+ enddo
+ endif
+ endif
+ endif
+
+c restore target spectators
+ ns=0
+ if(NWT.lt.matargxs)then
+ ns=matargxs-NWT
+ do is=maprojxs+1,maprojxs+ns !make the ns first target nucleon actives
+ istptlxs(is)=0
+ enddo
+ endif
+
+
+ do is=1,nsp
+
+c ich is the type of secondary hadron, esp - its transverse momentum,
+c and its energy
+c the following notations for the particles types are used: 0 - pi0, 1 -
+c pi+,
+c -1 - pi-, 2 - p, -2 - p, 3 - n, -3 - n, 4 - k+, -4 - k-, 5 - k0s, -5 -
+c k0l
+ ic=ich(is)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,4(e11.4,1x))')
+ $ ' qgsjet particle ',is,' id :',ic,' before conversion'
+ $ , ' momentum :',(esp(k,is),k=1,4)
+#endif
+
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'qgsjet: mxptlxs too small'
+ id=idtrafocx('qgs','nxs',ic)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' conex particle ',nptlxs,' id :',id,' after conversion'
+#endif
+ call cxidmass(id,am)
+
+
+ xsptl(1,nptlxs)=esp(3,is) !P_x
+ xsptl(2,nptlxs)=esp(4,is) !P_y
+ xsptl(3,nptlxs)=esp(2,is) !P_z
+ xsptl(4,nptlxs)=esp(1,is) !E
+ xsptl(5,nptlxs)=am !mass
+ istptlxs(nptlxs)=0
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from qgsjet ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ enddo
+
+c Decay particles with short life time
+
+ np1=nptlini
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+
+1000 return
+
+1001 iret=1
+ goto 1000
+
+ end
+
+
+c------------------------------------------------------------------------------
+ double precision function fqgscrse(egy,mapr,matg)
+c------------------------------------------------------------------------------
+c hadron-nucleus (hadron-proton) and nucl-nucl particle production cross section
+c with qgsjet.
+c egy - total lab energy
+c maproj - projec mass number (1<maproj<64)
+c matarg - target mass number (1<matarg<64)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.incnex"
+ dimension wk(3),wa(3),wb(3)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ double precision gsect,qgsasect
+ COMMON /Q_XSECT/ GSECT(10,5,4)
+ COMMON /Q_AREA48/ QGSASECT(10,6,4)
+#else
+ double precision gsect,asect
+ COMMON /XSECT/ GSECT(10,5,4)
+ COMMON /AREA48/ ASECT(10,6,4)
+#endif
+
+ fqgscrse=0.d0
+ ye=max(1.d0,log10(egy))
+ je=min(8,int(ye))
+
+ wk(2)=ye-je
+ wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
+ wk(1)=1.d0-wk(2)+wk(3)
+ wk(2)=wk(2)-2.d0*wk(3)
+
+ ya=dble(matg)
+ ya=log(ya)*0.72134752d0+1.d0 !0.72134752=1/ln(4)
+ ja=min(int(ya),2)
+ wa(2)=ya-ja
+ wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
+ wa(1)=1.d0-wa(2)+wa(3)
+ wa(2)=wa(2)-2.d0*wa(3)
+
+ if(mapr.eq.1)then
+
+ do i=1,3
+ do m=1,3
+ fqgscrse=fqgscrse+gsect(je+i-1,iclproxs,ja+m-1)*wk(i)*wa(m)
+ enddo
+ enddo
+
+ else
+
+ yb=mapr
+ yb=log(yb*0.5d0)*1.442695d0+1.d0 !1.442695=1/ln(2)
+ jb=min(int(yb),4)
+ wb(2)=yb-jb
+ wb(3)=wb(2)*(wb(2)-1.d0)*.5d0
+ wb(1)=1.d0-wb(2)+wb(3)
+ wb(2)=wb(2)-2.d0*wb(3)
+
+ do i=1,3
+ do m=1,3
+ do n=1,3
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ fqgscrse=fqgscrse+qgsasect(je+i-1,jb+n-1,ja+m-1)
+ & *wk(i)*wa(m)*wb(n)
+#else
+ fqgscrse=fqgscrse+asect(je+i-1,jb+n-1,ja+m-1)
+ & *wk(i)*wa(m)*wb(n)
+#endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ fqgscrse=exp(fqgscrse)
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function qgscrse(egy,mapro,matar,id)
+c------------------------------------------------------------------------------
+c inelastic cross section of qgsjet
+c (id=0 corresponds to air)
+c egy - total lab energy
+c maproj - projec mass number (1<maproj<64)
+c matarg - target mass number (1<matarg<64)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+
+ qgscrse=0.d0
+ if(id.eq.0)then
+ do k=1,3
+ mt=int(aira(k))
+ qgscrse=qgscrse+airw(k)*fqgscrse(egy,mapro,mt)
+ enddo
+ else
+ qgscrse=fqgscrse(egy,mapro,matar)
+ endif
+
+ return
+ end
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+c--------------------------------------------------------------------
+ double precision function psran(b10)
+
+
+c--------------------------------------------------------------------
+c Random number generator
+c--------------------------------------------------------------------
+ double precision b10,drangen
+ psran=drangen(b10)
+
+ return
+ end
+
+#endif
+#endif
+#ifdef __QGSJETII__
+c Last modifications 07.04.2008 Compatibility gcc4 by T.Pierog
+c 18.01.2007 update to compile with CORSIKA
+c 17.11.2006 update ifragm definition
+c 19.05.2003 Link routines between QGSJET-II and CONEX.
+c author T. Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine IniQGSJETII
+c-----------------------------------------------------------------------
+c Primary initialization for QGSJET-II
+c-----------------------------------------------------------------------
+ parameter(iapmax=208)
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ integer debug
+ common /qgdebug/ debug
+ common /qgarr43/ moniou
+ double precision bqgs,bmaxqgs,bmaxnex,bminnex,xan,xbn
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+#endif
+ CHARACTER DATDIR*(132)
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+
+#ifdef __CXDEBUG__
+ call utisx1('iniqgsII ',4)
+ write(*,'(a)')'initialize QGSJET-II ...'
+#endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ debug=0
+#ifdef __CXDEBUG__
+ if(isx.ge.8)debug=isx-7
+ moniou=ifck
+#else
+ moniou=6
+#endif
+c model parameter setting
+ call qgset
+c common initialization procedure
+ DATDIR="qgsjetII"
+ call qgaini(DATDIR)
+ BMAXNEX=dble(xsbmaxim)
+ BMINNEX=dble(xsbminim)
+#endif
+
+ if(ilowegy.ne.1.or.MCleModel.eq.6)xsegymin=0.1d0
+ if(MCModel.eq.6)xsegymax=min(xsegymax,5.d13)
+
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtQGSII
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+c QGSJET-II Common
+ parameter(iapmax=208)
+ double precision bqgs,bmaxqgs,bmaxnex,bminnex,xan,xbn,e0,qgsect
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+
+
+ if(matargxs.gt.iapmax.or.maprojxs.gt.iapmax)
+ & stop'Nucleus too big for QGSJET-II (Mmax=64) !'
+ call cxiclass(idprojxs,iclproxs)
+ call cxiclass(idtargxs,icltarxs)
+ e0=dble(xselab)
+ idp=(idprojxs/10)*10 !convert to bound state
+ icp=idtrafocx('nxs','qgs',idp)
+ if(icp.eq.0)icp=1-2*int(drangen(dummy)+0.5d0) !pi0 or rho0 = pi+ or pi-
+c if(abs(icp).eq.6)icp=3 !replace lambda by neutron -> TP200309 not done like this in CORSIKA (only decay)
+ if(abs(icp).gt.5)
+ & stop'Projectile not allowed in QGSJET-II !'
+ call qgini(e0,icp,maprojxs,matargxs)
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ xsbmax=BMAXQGS
+ xsqgsIIincs=qgsect(e0,iclproxs,maprojxs,matargxs)
+#else
+ xsbmax=20d0
+ xsqgsIIincs=1d20
+#endif
+ if(xsekin.lt.xsegymin)xsqgsIIincs=0.d0 !below egymin, no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'QGSJET-II used with (E,proj,maproj,matarg,bmax)',e0,icp
+ & ,maprojxs,matargxs,xsbmax
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsqgsII(iret)
+c-----------------------------------------------------------------------
+c call qgsjet-II to simulate interaction
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ parameter(iapmax=208,nptmax=95000)
+ double precision bqgs,bmaxqgs,bmaxnex,bminnex,xan,xbn,esp
+ common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)
+ *,bqgs,bmaxqgs,bmaxnex,bminnex
+ common /qgarr12/ nsp
+ common /qgarr14/ esp(4,nptmax),ich(nptmax)
+c nsf - number of secondary fragments;
+c iaf(i) - mass of the i-th fragment
+ common /qgarr13/ nsf,iaf(iapmax)
+ common /qgarr55/ nwt,nwp
+
+ iret=0
+ if(abs(xsqgsIIincs).lt.1d-20)goto 1001 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine QGSJet-II Production&',0,0,0)
+#endif
+ nptlxs=0
+ nsp=0
+ nsf=0
+ nwt=0
+ call qgconf
+
+ ncolxs=1
+ nevtxs=1
+ if(BQGS.ge.0.d0)then
+ xsbimp=BQGS
+ xsphi=2.d0*xspi*drangen(dummy)
+ else
+ xsbimp=0.d0
+ xsphi=0.d0
+ endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.6)write(ifck,*)'impact parameter ',xsbimp
+#endif
+
+#endif
+
+ ist=1
+ call cxconre
+ call cxconwr(ist)
+
+ nptlini=nptlxs+1
+
+
+c keep the projectile spectators as fragments
+ if(ifragm.eq.2)then
+
+ if(NSF.gt.0)then
+ do is=1,NSF !count the number of spectators
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5)')
+ $ ' Projecticle Fragment ',is,' Mass :',IAF(is)
+#endif
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+ if(IAF(is).eq.1)then
+ id=idptlxs(is)
+ xsptl(3,nptlxs)=xsptl(3,is)
+ xsptl(4,nptlxs)=xsptl(4,is)
+ xsptl(5,nptlxs)=xsptl(5,is)
+ else
+ if(IAF(is).eq.2)then
+ id=17
+ elseif(IAF(is).eq.3)then
+ id=18
+ elseif(IAF(is).eq.4)then
+ id=19
+ else
+ id=IAF(is)*100
+ endif
+ call cxidmass(id,am)
+ xsptl(4,nptlxs)=dble(IAF(is))*xsptl(4,is) !Etot
+ xsptl(5,nptlxs)=am !mass
+ pz2tmp=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+ if(pz2tmp.gt.0.d0)then
+ xsptl(3,nptlxs)=sqrt(pz2tmp) !Pz
+ else
+ write(*,*)'Warning in emsqgs !'
+ write(*,*)'energy of fragment too small :',IAF(is),am
+ & ,xsptl(4,nptlxs)
+ xsptl(3,nptlxs)=xsptl(4,nptlxs)
+ endif
+ endif
+ xsptl(1,nptlxs)=0.d0 !P_x
+ xsptl(2,nptlxs)=0.d0 !P_y
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' Fragment from qgsjet ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ enddo
+ endif
+
+c make the projectile spectators as free nucleons
+
+ else
+ ns=0
+ if(NSF.gt.0)then
+ do is=1,NSF !count the number of spectators
+ ns=ns+IAF(is)
+ enddo
+ if(ifragm.eq.1)then
+c remaining nucleus is one fragment
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+ xsptl(1,nptlxs)=0.d0
+ xsptl(2,nptlxs)=0.d0
+ xsptl(4,nptlxs)=0.d0
+ inucl=0
+ do is=1,ns
+ inucl=inucl+1
+ xsptl(4,nptlxs)=xsptl(4,nptlxs)+xsptl(4,is)
+ enddo
+ idnucl=100*inucl
+ call cxidmass(idnucl,am)
+ xsptl(5,nptlxs)=am !mass
+ ptot=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+ xsptl(3,nptlxs)=sqrt(ptot)
+ ityptlxs(nptlxs)=0
+ istptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=xsorptl(1,1)
+ xsorptl(2,nptlxs)=xsorptl(2,1)
+ xsorptl(3,nptlxs)=xsorptl(3,1)
+ xsorptl(4,nptlxs)=xsorptl(4,1)
+ xstivptl(1,nptlxs)=xstivptl(1,1)
+ xstivptl(2,nptlxs)=xstivptl(2,1)
+ idptlxs(nptlxs)=idnucl
+ else
+ do is=1,ns !make the ns first projectile nucleon actives
+ istptlxs(is)=0
+ enddo
+ endif
+ endif
+ endif
+
+c restore target spectators
+ ns=0
+ if(NWT.lt.matargxs)then
+ ns=matargxs-NWT
+ do is=maprojxs+1,maprojxs+ns !make the ns first target nucleon actives
+ istptlxs(is)=0
+ enddo
+ endif
+
+
+ do is=1,nsp
+
+c ich is the type of secondary hadron, esp - its transverse momentum,
+c and its energy
+c the following notations for the particles types are used: 0 - pi0, 1 -
+c pi+,
+c -1 - pi-, 2 - p, -2 - p, 3 - n, -3 - n, 4 - k+, -4 - k-, 5 - k0s, -5 -
+c k0l
+ ic=ich(is)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,4(e11.4,1x))')
+ $ ' qgsjet particle ',is,' id :',ic,' before conversion'
+ $ , ' momentum :',(esp(k,is),k=1,4)
+#endif
+
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'qgsjet: mxptlxs too small'
+ id=idtrafocx('qgs','nxs',ic)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' conex particle ',nptlxs,' id :',id,' after conversion'
+#endif
+ call cxidmass(id,am)
+
+
+ xsptl(1,nptlxs)=esp(3,is) !P_x
+ xsptl(2,nptlxs)=esp(4,is) !P_y
+ xsptl(3,nptlxs)=esp(2,is) !P_z
+ xsptl(4,nptlxs)=esp(1,is) !E
+ xsptl(5,nptlxs)=am !mass
+ istptlxs(nptlxs)=0
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from qgsjet ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ enddo
+
+c Decay particles with short life time
+
+ np1=nptlini
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+
+1000 return
+
+1001 iret=1
+ goto 1000
+
+ end
+
+c------------------------------------------------------------------------------
+ double precision function qgsIIcrse(egy,mapro,matar,id)
+c------------------------------------------------------------------------------
+c inelastic cross section of qgsjet-II
+c (id=0 corresponds to air)
+c egy - total lab energy
+c maproj - projec mass number (1<maproj<64)
+c matarg - target mass number (1<matarg<64)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+ qgsIIcrse=0.d0
+ if(id.eq.0)then
+ do k=1,3
+ mt=int(aira(k))
+ qgsIIcrse=qgsIIcrse+airw(k)*qgsect(egy,iclproxs,mapro,mt)
+ enddo
+ else
+ qgsIIcrse=qgsect(egy,iclproxs,mapro,matar)
+ endif
+
+ return
+ end
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+c--------------------------------------------------------------------
+ double precision function qgran(b10)
+c--------------------------------------------------------------------
+c Random number generator
+c--------------------------------------------------------------------
+ double precision b10,drangen
+ qgran=drangen(b10)
+
+ return
+ end
+
+
+ subroutine LzmaOpenFile(name)
+ character*256 name,name2
+ name2=name
+ end
+
+ subroutine LzmaCloseFile()
+ end
+
+ subroutine LzmaFillArray(dum,idum)
+ double precision dum,dum2
+ integer idum,idum2
+ dum2=dum
+ idum2=idum
+ end
+
+ integer function size(array)
+ double precision array(*)
+ size=int(array(1))
+ end
+#endif
+
+#endif
+#ifdef __SIBYLL21__
+c Last modifications 07.04.2008 Compatibility gcc4 by T.Pierog
+c 18.05.2010 update to compile with CORSIKA after modification of 2008
+c 18.01.2007 update to compile with CORSIKA
+c 29.11.2004 Link routines between SIBYLL2.1 and CONEX.
+c author T. Pierog
+
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+
+c-----------------------------------------------------------------------
+ subroutine IniSibyll
+c-----------------------------------------------------------------------
+c Primary initialization for Sibyll
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ 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)
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+
+#ifdef __CXDEBUG__
+ call utisx1('inisib ',4)
+ write(*,'(a)')'initialize Sibyll ...'
+#endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ Ndebug=0
+#endif
+#ifdef __CXDEBUG__
+ if(isx.ge.8)Ndebug=isx-7
+#endif
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+
+c divert output
+ lun = 7
+
+C... SIBYLL initialization
+ CALL SIBYLL_INI
+
+C...Cross sections for nucleus-nucleus and hadron nucleus
+ CALL NUC_NUC_INI
+
+C...define all particles as unstable
+ do i=1,99
+ IDB(i) = abs(IDB(i)) ! >0 means unstable
+ enddo
+c EgyHiLoLim=max(100.d0,EgyHiLoLim)
+
+#endif
+
+ xsegymax=min(xsegymax,5d13)
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+ end
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtSib
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+ 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)
+
+
+ if((matargxs.gt.18.and.idtargxs.ne.0).or.maprojxs.gt.56)
+ & stop'Mass too big for Sibyll (Mtrg<18, Mprj<56) !'
+ id=idtrafocx('nxs','sib',idprojxs)
+ ida=abs(id)
+ if(ida.lt.6.or.ida.gt.99.or.(ida.gt.14.and.ida.lt.21))then
+ write(ifmt,*)'Wrong projectile for Sibyll:',ida
+ stop'projectile not allowed in Sibyll !'
+ endif
+ if(idtargxs.ne.0.and.idtargxs.ne.1120)
+ & stop'target not allowed in Sibyll !'
+ call cxiclass(idprojxs,iclproxs)
+ xsbmax=20.d0
+ idtrgsibxs=idtargxs
+ xssibincs=fsibcrse(xsecms)
+ if(xsekin.lt.xsegymin)xssibincs=0.d0 !below xsegymin, no interaction
+
+
+ if(nrnodyxs.gt.0)then !decaying particles
+ do nod=1,nrnodyxs
+ idd=abs(idtrafocx('nxs','sib',nodyxs(nod)))
+ if(idd.lt.50)IDB(idd) = -abs(IDB(idd))
+ enddo
+ endif
+
+!in Sibyll, all hadronic particle above 15 has to decay (interaction not allowed)
+ do iid=15,33
+ IDB(iid) = abs(IDB(iid))
+ enddo
+c Strange baryons (34 to 39) can interact
+ do iid=40,99
+ IDB(iid) = abs(IDB(iid))
+ enddo
+
+#ifdef __CXDEBUG__
+ if(isx.ge.2)then
+ call ranfgt(seed) !get seed before shower
+ write(ifck,*)
+ & 'Sibyll used with (E,proj,maproj,matarg)',xsecms,id,maprojxs
+ & ,matargxs,seed
+ endif
+#endif
+
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emssib(iret)
+c-----------------------------------------------------------------------
+c call Sibyll to simulate interaction
+c-----------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+C SIBYLL
+ 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 NNSOF,NNJET,JDIF,NWD,NJET,NSOF
+ COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max),
+ & JDIF(NW_max),NWD,NJET,NSOF
+
+ COMMON /S_PLNUC/ PA(5,40000), LLA(40000), NPA
+ COMMON /S_CLDIF/ LDIFF
+ INTEGER LDIFF
+#ifdef CONEX_EXTENSIONS
+ PARAMETER (IAMAX=56)
+ COMMON /S_NUCLST/ LBEGIN(IAMAX), LEND(IAMAX), LUSED
+#endif
+
+ iret=0
+ if(abs(xssibincs).lt.1d-20)goto 1001 !no interaction
+#ifdef __CXDEBUG__
+ if(isx.ge.4)call cxalist('Determine Sibyll Production&',0,0,0)
+#endif
+
+#ifdef CONEX_EXTENSIONS
+ imaxnuc=0
+#endif
+ nptlxs=0
+ NP=0
+ NPA=0
+ LDIFF=0 !all types of events
+
+ ncolxs=1
+ nevtxs=1
+ xsbimp=0.d0
+ xsphi=0.d0
+
+ ist=1
+ call cxconre
+ call cxconwr(ist)
+
+#ifdef CONEX_EXTENSIONS
+ do ru_cnt=1,nptlxs
+ idnucrct(ru_cnt)=0 ! particle do not originat from interaction
+ enddo
+#endif
+ itrg=matargxs
+ if(itrg.gt.18)stop'target not allowed in Sibyll (2) !'
+ if(maprojxs.eq.1)then !hadronic projectile
+ L0=idtrafocx('nxs','sib',idprojxs)
+c itrg=13 is proton target
+ CALL SIBYLL (L0, itrg, xsecms)
+ CALL DECSIB
+c#ifdef CONEX_EXTENSIONS
+c if (doResampling) then
+c call resampleSIBYLL(NP, xselab, idprojxs, SQS, xsamproj)
+c endif
+c#endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5)')
+ $ ' number of particles from Sibyll :',NP
+#endif
+#ifdef CONEX_EXTENSIONS
+ imaxnuc=1
+ npnucs(1)=0
+#endif
+ do k=1,NP
+
+c LLIST is the code of final particle, P - its 4-momentum and mass.
+ ic=LLIST(k)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,4(e11.4,1x))')
+ $ ' Sibyll particle ',k,' id :',ic,' before conversion'
+ $ , ' momentum :',(P(k,i),i=1,5)
+#endif
+
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'Sibyll: mxptlxs too small'
+
+ if(abs(ic).ge.10000)then
+ ic=ic-sign(10000,ic)
+ istptlxs(nptlxs)=1
+#ifdef CONEX_EXTENSIONS
+ idnucrct(nptlxs)=0 ! BAD PARTICLE (instable, non-final)
+#endif
+ else
+ istptlxs(nptlxs)=0
+#ifdef CONEX_EXTENSIONS
+ idnucrct(nptlxs)=1 ! all particles from the same nucleon-air interaction
+ npnucs(1)=npnucs(1)+1
+#endif
+ endif
+
+ id=idtrafocx('sib','nxs',ic)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' conex particle ',nptlxs,' id :',id,' after conversion'
+#endif
+
+
+ xsptl(1,nptlxs)=P(k,1) !P_x
+ xsptl(2,nptlxs)=P(k,2) !P_y
+ xsptl(3,nptlxs)=P(k,3) !P_z
+ xsptl(4,nptlxs)=P(k,4) !E
+ xsptl(5,nptlxs)=P(k,5) !mass
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from Sibyll ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(i,nptlxs),i=1,5)
+#endif
+
+
+ enddo
+ ns=0
+ if(NWD.lt.matargxs)then
+ ns=matargxs-NWD
+ do is=maprojxs+1,maprojxs+ns !make the ns first target nucleon actives
+ istptlxs(is)=0
+ enddo
+ endif
+ else !for nucleus projectile
+ ns=0 !number of projectile spectators
+ nbar=0
+ IAP = maprojxs
+ CALL SIBNUC (IAP, itrg, xsecms)
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5)')
+ $ ' number of particles from Sibyll :',NPA
+#endif
+#ifdef CONEX_EXTENSIONS
+ imaxnuc=LUSED
+ do ID_NUC=1,LUSED
+ npnucs(ID_NUC)=1+LEND(ID_NUC)-LBEGIN(ID_NUC)
+c ru write(*,*) 'SIBYLL SEMI-SUPERPOSITION MAPPING:',
+c ru & ' ID_NUC,LBEGIN, LEND, npnucs', ID_NUC,
+c ru & LBEGIN(ID_NUC), LEND(ID_NUC), npnucs(ID_NUC)
+ enddo
+#endif
+ do k=1,NPA
+
+c LLIST is the code of final particle, P - its 4-momentum and mass.
+ ic=LLA(k)
+
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,2a,5(e11.4,1x))')
+ $ ' Sibyll particle ',k,' id :',ic,' before conversion'
+ $ , ' momentum :',(PA(i,k),i=1,5)
+#endif
+
+
+ nNuc=0
+ if(ic.ge.1001) then !count spectators
+ nNuc=ic-1000
+ if(ifragm.le.1
+ & .or.dble(PA(4,k))/dble(nNuc).lt.xsegymin)then !nuclear interaction only above min energy, otherwise : fragmentation
+ ns=ns+nNuc
+ goto 100
+ elseif(ic.eq.1001)then
+ if(drangen(dummy).lt.0.45d0) then
+ ic = 13
+ else
+ ic = 14
+ endif
+ nNuc=0
+ else
+ ptm=sqrt(PA(1,k)*PA(1,k)+PA(2,k)*PA(2,k)+PA(5,k)*PA(5,k))
+ PA(4,k)=PA(4,k)*float(nNuc) !energy by nucleon
+ PA(3,k)=sign(sqrt((PA(4,k)+ptm)*(PA(4,k)-ptm)),PA(3,k))
+ endif
+ endif
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'Sibyll: mxptlxs too small'
+ id=idtrafocx('sib','nxs',ic)
+#ifdef __CXDEBUG__
+ if(isx.ge.7)write(ifck,'(a,i5,a,i5,a)')
+ $ ' conex particle ',nptlxs,' id :',id,' after conversion'
+#endif
+
+
+ nbar=nbar+nNuc
+ if(abs(id).gt.1000.and.nNuc.eq.0)then
+ nbar=nbar+sign(1,id)
+ endif
+#ifdef CONEX_EXTENSIONS
+ idnucrct(nptlxs)=0 ! initial: no nucleon interaction
+ do ID_NUC=1,LUSED
+ if (k.ge.LBEGIN(ID_NUC).and.k.le.LEND(ID_NUC))then
+ idnucrct(nptlxs)=ID_NUC
+ goto 4557 ! break loop
+ endif
+ enddo
+ 4557 xsptl(1,nptlxs)=PA(1,k) !P_x
+#else
+ xsptl(1,nptlxs)=PA(1,k) !P_x
+#endif
+ xsptl(2,nptlxs)=PA(2,k) !P_y
+ xsptl(3,nptlxs)=PA(3,k) !P_z
+ xsptl(4,nptlxs)=PA(4,k) !E
+ xsptl(5,nptlxs)=PA(5,k) !mass
+ istptlxs(nptlxs)=0
+ ityptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs+matargxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=0.d0
+ xsorptl(2,nptlxs)=0.d0
+ xsorptl(3,nptlxs)=0.d0
+ xsorptl(4,nptlxs)=0.d0
+ xstivptl(1,nptlxs)=0.d0
+ xstivptl(2,nptlxs)=0.d0
+ idptlxs(nptlxs)=id
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3,a,i3)')
+ $ ' particle from Sibyll ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(i,nptlxs),i=1,5), ' nbar :',nbar
+#endif
+
+
+ 100 enddo
+ ntw=nbar-(maprojxs-ns)
+ nsf=0
+ if(ntw.lt.matargxs)then
+ nts=matargxs-ntw
+ do is=maprojxs+1,maprojxs+nts !make the nts first target nucleon actives (not wounded)
+ istptlxs(is)=0
+ enddo
+ else
+ nsf=maprojxs+matargxs-nbar
+ endif
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i3,a,i3,a,i2,a)')
+ $ ' target spectators :',matargxs-ntw
+ $ ,' projectile spectators (ns) :',nsf,' (',ns,')'
+#endif
+ if((ifragm.le.1.or.nsf.gt.ns).and.nsf.le.maprojxs)then
+ if(ifragm.eq.2)ns=nsf-ns
+ if(ifragm.eq.1.and.ns.gt.0)then
+c remaining nucleus is one fragment
+ nptlxs=nptlxs+1
+ istptlxs(nptlxs)=0
+#ifdef CONEX_EXTENSIONS
+ idnucrct(nptlxs)=0 ! initial: no nucleon interaction
+#endif
+ xsptl(1,nptlxs)=0.d0
+ xsptl(2,nptlxs)=0.d0
+ xsptl(4,nptlxs)=0.d0
+ inucl=0
+ do is=1,ns
+ inucl=inucl+1
+ xsptl(4,nptlxs)=xsptl(4,nptlxs)+xsptl(4,is)
+ enddo
+ idnucl=100*inucl
+ call cxidmass(idnucl,am)
+ xsptl(5,nptlxs)=am !mass
+ ptot=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+ xsptl(3,nptlxs)=sqrt(ptot)
+ ityptlxs(nptlxs)=0
+ istptlxs(nptlxs)=0
+ iorptlxs(nptlxs)=1
+ jorptlxs(nptlxs)=maprojxs
+ ifrptlxs(1,nptlxs)=0
+ ifrptlxs(2,nptlxs)=0
+ xsorptl(1,nptlxs)=xsorptl(1,1)
+ xsorptl(2,nptlxs)=xsorptl(2,1)
+ xsorptl(3,nptlxs)=xsorptl(3,1)
+ xsorptl(4,nptlxs)=xsorptl(4,1)
+ xstivptl(1,nptlxs)=xstivptl(1,1)
+ xstivptl(2,nptlxs)=xstivptl(2,1)
+ idptlxs(nptlxs)=idnucl
+ else
+ do is=1,ns !make the nsf first projectile nucleon actives (not wounded)
+ istptlxs(is)=0
+ enddo
+ endif
+ endif
+ endif
+
+c Decay particles with short life time
+
+ np1=1
+41 np2=nptlxs
+ do 42 ip=np1,np2
+ call cxhdecas(ip,iret)
+ if(iret.ne.0)goto 1001
+42 continue
+ np1=np2+1
+ if(np1.le.nptlxs)goto 41
+
+
+
+1000 return
+
+1001 iret=1
+ goto 1000
+
+ end
+
+
+c------------------------------------------------------------------------------
+ double precision function fsibcrse(egy)
+c------------------------------------------------------------------------------
+c hadron-proton particle production cross section with Sibyll.
+c egy - center of mass energy
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+ DIMENSION SDIF(3)
+#include "conex.incnex"
+
+ if(iclproxs.eq.1)then
+ L=2
+ elseif(iclproxs.eq.2)then
+ L=1
+ else
+ L=3
+ endif
+ call SIB_SIGMA_HP(L,egy,ST,SEL,SINEL,SDIF,SL,RHO)
+ fsibcrse=SINEL
+
+ return
+ end
+
+c------------------------------------------------------------------------------
+ double precision function sibcrse(egy,mapro,id)
+c------------------------------------------------------------------------------
+c inelastic cross section of Sibyll (only for hadron-air and
+c nucleus-air)
+c egy - lab energy per nucleon in GeV
+c maproj - projec mass number (1<maproj<64)
+c id - proj id (sibyll code)
+c------------------------------------------------------------------------------
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+ COMMON /CLENNN/ SSIGNUC(60), ALNUC(60)
+
+ sibcrse=1.d+35
+ E0=egy*1.e-3 !e0 in TeV
+ if(mapro.eq.1)then
+ AL0=FPNI(E0,id) !Sibyll interaction lenght
+ else
+ CALL SIGNUC_INI(mapro,E0) ! fills SSIGNUC and ALNUC
+ AL0=ALNUC(mapro) !Sibyll interaction lenght
+ endif
+
+c conversion to cross section with conex air composition
+ if(AL0.gt.0.d0)sibcrse=airava/(avog*AL0)
+
+ return
+ end
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+c--------------------------------------------------------------------
+ double precision function S_RNDM(idum)
+c--------------------------------------------------------------------
+c random number generator
+c--------------------------------------------------------------------
+ double precision drangen
+ 1 S_RNDM=drangen(dble(idum))
+ if(S_RNDM.le.0d0.or.S_RNDM.ge.1d0) goto 1
+
+ return
+ end
+
+C=======================================================================
+
+ DOUBLE PRECISION FUNCTION GASDEV(IDUM)
+
+C-----------------------------------------------------------------------
+C Gaussian deviation
+c linked to corsikas gaussian random number generator to keep
+c random number sequence intact.
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ DOUBLE PRECISION RANNOR,XMEAN,XDEV
+ INTEGER IDUM
+ SAVE
+ EXTERNAL RANNOR
+C-----------------------------------------------------------------------
+ GASDEV = IDUM
+ XMEAN = 0.D0
+ XDEV = 1.D0
+ GASDEV = RANNOR(XMEAN,XDEV)
+
+ RETURN
+ END
+
+#endif
+#endif
+#ifdef __EPOS__
+c Last modifications 03.07.2020 Compatibility with CORSIKA8 by T.Pierog
+c 07.04.2008 Compatibility gcc4
+c 18.01.2007 update to compile with CORSIKA
+c 05.09.2005 Add QGSJET-II subroutine definition to compile
+c with preprocessing command -D__ALL__ without __QGSJETII__
+c 18.05.04 Link file for conex with nexus
+c author T. Pierog
+
+#ifdef __STD__
+#define __GHEISHA__
+#define __QGSJET__
+#define __ANALYSIS__
+#endif
+
+c-----------------------------------------------------------------------
+ subroutine IniEpos
+c-----------------------------------------------------------------------
+#include "epos.inc"
+#include "epos.incems"
+ double precision seedp
+
+c Conex common
+
+ double precision airz,aira,airw,airavz,airava,airi
+ common/cxair/airz(3),aira(3),airw(3),airavz,airava,airi(3)
+ common/xsfiles/ixsfcx
+ character*500 xsfnch,xsfnii,xsfnid,xsfnie,xsfnrj,xsfncs
+ common/xsfname/ xsfnch, xsfnii, xsfnid, xsfnie, xsfnrj, xsfncs
+ common/xsnfname/nxsfnch,nxsfnii,nxsfnid,nxsfnie,nxsfnrj,nxsfncs
+ double precision xsegymin,xsegymax,xselab,xsecms,xsekin,xspnll
+ *,xsengy
+ common/xsenrgy/xsegymin,xsegymax,xselab,xsecms,xsekin,xspnll
+ *,xsengy
+ parameter(mxnodyxs=20)
+ common/xsnodcy/nrnodyxs,nodyxs(mxnodyxs)
+ common/xsappli/iapplxs,modelxs
+ common/xsevent/neventxs,iframexs
+ integer ifragm
+ common/cxfragm/ifragm
+c data inicnt/0/
+ data init/0/
+ save init
+
+ if(init.ge.1)return
+ init=init+1
+
+#ifdef __CXDEBUG__
+
+ call utisx1('iniepos ',4)
+ write(*,'(a)')'initialize EPOS ...'
+#endif
+
+ if(ilowegy.ne.1.or.MCleModel.eq.4)xsegymin=dble(0.5*egymin**2)
+ if(MCModel.eq.4)xsegymax=min(xsegymax,dble(0.5*egymax**2))
+ nrnody=nrnodyxs
+ do i=1,nrnody
+ nody(i)= nodyxs(i)
+ enddo
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+ inicnt=inicnt+1
+c isetcs=2 ! epos cross-section from tabulated calculation (h-A and AA)
+ isetcs=3 ! epos cross-section from tabulated simulations (h-A and A-A)
+ infragm=ifragm
+ isigma=0 !do not print out the cross section on screen
+ ionudi=1
+
+
+ nfnii=nxsfnii ! epos file name
+ fnii=xsfnii
+ nfnid=nxsfnid
+ fnid=xsfnid
+ nfnie=nxsfnie
+ fnie=xsfnie
+ nfnrj=nxsfnrj
+ fnrj=xsfnrj
+ nfncs=nxsfncs
+ fncs=xsfncs
+ nfnch=nxsfnch
+ fnch=xsfnch
+
+c air
+
+ do i=1,3
+ airanxs(i)=sngl(aira(i))
+ airznxs(i)=sngl(airz(i))
+ airwnxs(i)=sngl(airw(i))
+ enddo
+ airavanxs=sngl(airava)
+ airavznxs=sngl(airavz)
+
+ iappl = iapplxs
+ nevent = neventxs
+ iframe = iframexs
+
+ if(fnch(1:nfnch).ne.'none')
+ & open(ifcx,file=fnch(1:nfnch),status='unknown')
+
+ call iclass(idproj,iclpro)
+ call iclass(idtarg,icltar)
+ if(inicnt.eq.1)then
+ call ranfgt(seedp) !not to change the seed ...
+ call hdecin(.false.)
+ call hnbspd(iospec)
+ ktnbod=0
+ call hnbpajini
+ if(iclegy2.gt.1)then
+ egyfac=(egymax*1.0001/egylow)**(1./float(iclegy2-1))
+ else
+ egyfac=1.
+ endif
+ endif
+ maproj=mamx !to set difnuc up to the maximum mass
+ call conini
+ call psaini
+ call ranfst(seedp) ! ... after this initialization
+
+#endif
+
+#ifdef __CXDEBUG__
+ call utisx2
+#endif
+
+ end
+
+
+c-----------------------------------------------------------------------
+ subroutine IniEvtEpo
+c-----------------------------------------------------------------------
+c Initialization for each type of event (for given proj, targ and egy)
+c-----------------------------------------------------------------------
+#include "epos.inc"
+ common/geom/rmproj,rmtarg,bmax,bkmx
+ double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
+ common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat /ctain/mtain
+ double precision rcproj,rctarg
+ common/geom1/rcproj,rctarg
+c Conex common
+#ifdef __CXDEBUG__
+ parameter (mxisx=200)
+ character*500 subisx,textisx
+ common/cxisx/isx,nisx,subisx(mxisx),isxsub(mxisx) !also in gheisha_nexus
+ & ,isxsave,isxxsave,textisx
+ character*500 fnho,fnck,fnwle,fnwhe,fndkz,fndkl,fndks,fndkm
+ &,fnilo,fndke,fndkn,fndkg,fnwgh,fnwgl
+ common /cxfiles/fnho,ifho,fnck,ifck,fnwle,ifwle,fnwhe,ifwhe
+ &,fndkz,ifdkz,fndkl,ifdkl,fndks,ifdks,fndkm,ifdkm,fnilo,ifilo
+ &,fndke,ifdke,fndkn,ifdkn,fndkg,ifdkg,fnwgh,ifwgh
+ &,fnwgl,ifwgl
+#endif
+ double precision xsegymin,xsegymax,xselab,xsecms,xsekin,xspnll
+ *,xsengy
+ common/xsenrgy/xsegymin,xsegymax,xselab,xsecms,xsekin,xspnll
+ *,xsengy
+ common/xsnucl1/laprojxs,maprojxs,latargxs,matargxs
+ common/xshadr2/idprojxs,idtargxs
+ double precision xsamproj,xsamtarg,xsypjtl,xsyhaha,xspnullx
+ common/xschadron/xsamproj,xsamtarg,xsypjtl,xsyhaha,xspnullx
+ double precision xsrmproj,xsrmtarg,xsbmax,xsbminim,xsbmaxim,xsbkmx
+ common/xsgeom/xsrmproj,xsrmtarg,xsbmax,xsbminim,xsbmaxim,xsbkmx
+ double precision xsrcproj,xsrctarg
+ common/xsgeom1/xsrcproj,xsrctarg
+ double precision xstpro,xszpro,xsttar,xsztar,xsttaus
+ &,xsdetap,xsdetat
+ common/xscttaus/xstpro,xszpro,xsttar,xsztar,xsttaus
+ &,xsdetap,xsdetat
+
+ maproj=maprojxs
+ laproj=laprojxs
+ matarg=matargxs
+ latarg=latargxs
+ idproj=idprojxs
+ idtarg=idtargxs
+ amproj=xsamproj
+ amtarg=xsamtarg
+ call idspin(idproj,ispin,jspin,istra)
+ isoproj=sign(1,idproj)*ispin
+ call idspin(idtarg,ispin,jspin,istra)
+ isotarg=sign(1,idtarg)*ispin
+
+ engy=sngl(xsengy)
+ elab=sngl(xselab)
+ ecms=sngl(xsecms)
+ ekin=sngl(xsekin)
+ pnll=sngl(xspnll)
+ pnullx=sngl(xspnullx)
+ yhaha=sngl(xsyhaha)
+ ypjtl=sngl(xsypjtl)
+ detap=xsdetap
+ detat=xsdetat
+ tpro=xstpro
+ zpro=xszpro
+ ttar=xsttar
+ ztar=xsztar
+
+c xsbminim=dble(bminim) !not needed and can interfer with other MC
+c xsbmaxim=dble(bmaxim)
+
+ call iclass(idproj,iclpro)
+ call iclass(idtarg,icltar)
+ call emsini(engy,idproj,idtarg)
+ call paramini(1)
+ bkmxndif=conbmxndif()
+ bkmx=conbmx()
+ xsbkmx=dble(bkmx)
+
+ if(maproj.gt.1.or.matarg.gt.1)then
+ xsbmax=xsrmproj+xsrmtarg
+ else
+ xsbmax=xsbkmx
+ endif
+
+ bimevt=-1
+ bmax=sngl(xsbmax)
+ rmproj=sngl(xsrmproj)
+ rmtarg=sngl(xsrmtarg)
+ rcproj=xsrcproj
+ rctarg=xsrctarg
+ call xsigma !set some variabkle according to xs
+ if(idtarg.eq.0)idtarg=1120 !air = nucleus
+#ifdef __CXDEBUG__
+ if(isx.ge.2)write(ifck,*)
+ & 'Epos used with (E,proj,maproj,matarg,bmax)',elab,idproj
+ & ,maproj,matarg,bmax
+#endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ double precision function cxepocrse(ek,mapro,matar,id)
+c-----------------------------------------------------------------------
+c Epos cross section in double precision
+c-----------------------------------------------------------------------
+#include "epos.inc"
+ double precision ek
+ common/xshad10/iclproxs,icltarxs !in conex.incnex
+
+ iclpro=iclproxs
+ icltar=icltarxs
+
+ cxepocrse=dble(eposcrse(sngl(ek),mapro,matar,id))
+
+ end
+
+c-----------------------------------------------------------------------
+ subroutine EposInput
+c-----------------------------------------------------------------------
+#include "epos.inc"
+ common/cxsubro/isubin !also in conex.inc
+ nopen=0
+#ifdef __CXSUB__
+ ifop=isubin
+#else
+ ifop=5
+#endif
+ call aread
+ end
+
+c-----------------------------------------------------------------------
+ subroutine emsepo(iret)
+c-----------------------------------------------------------------------
+c call epos to simulate interaction
+c-----------------------------------------------------------------------
+c Conex common
+ implicit double precision (a-h,o-z)
+#include "conex.h"
+#include "conex.incnex"
+
+c epos common
+ parameter (mxptl=200000) !max nr of particles in epos particle list
+ common/col3/ncol,kolpt
+ common/prnt1/iprmpt,ish,ishsub,irandm,irewch,iecho,modsho,idensi
+ common/cptl/nptl,pptl(5,mxptl),iorptl(mxptl),idptl(mxptl)
+ *,istptl(mxptl),tivptl(2,mxptl),ifrptl(2,mxptl),jorptl(mxptl)
+ *,xorptl(4,mxptl),ibptl(4,mxptl),ityptl(mxptl)
+ real pptl,xorptl,tivptl,gaumx,wtmini,wtstep
+ common/wana2/isphis,ispall,wtmini,wtstep,iwcent,iana,nbdky
+ common/othe1/istore,istmax,gaumx,irescl,ntrymx,nclean,iopdg,ioidch
+ integer iLHC,ipytune
+ common/LHCtune/iLHC,ipytune
+ integer iorsce,iorsdf,iorshh,ionudi
+ common/cjinti/iorsce,iorsdf,iorshh,ionudi
+
+
+c double precision pfrx(mamxs),pfry(mamxs)
+c integer ityp(mamxs)
+
+ nptlxs=0
+ nevtxs=1
+ iret=0
+c irest = maprojxs*100+abs(laprojxs)
+c inew=0
+
+ call utpri('emsepo',ish,ishini,4)
+
+ call emsaaa(iret)
+
+ if(iret.ne.0)goto 1001
+
+ ncolxs=ncol
+
+ if(ish.ge.2)call alist('list before fragmentation&',1,nptl)
+
+ iclu=0
+ if(iLHC.eq.1.and.iorsdf.eq.3)iclu=1 !in case of fusion, don't use Z first time
+ call gakfra(iclu,iret)
+ if(iret.gt.0)goto 1001
+ if(ish.ge.4)
+ & call alist('list after fragmentation&',1,nptl)
+ if(irescl.eq.1)then
+ call utghost(iret)
+ if(iret.gt.0)goto 1001
+ endif
+
+ nbdky=nptl
+ call bjinta(ier)
+ if(ier.eq.1)goto 1001
+ if(ish.ge.4)
+ & call alist('list after int/decays&',1,nptl)
+ if(irescl.eq.1)then
+ call utresc(iret)
+ if(ish.ge.4)call alist('list after rescaling&',1,nptl)
+ if(iret.gt.0)goto 1001
+ endif
+
+ if(ifragm.gt.0.and.(maprojxs.gt.1.or.matargxs.gt.1))then
+ call emsfrag(iret)
+ if(iret.gt.0)goto 1001
+ endif
+
+ if(ish.ge.2)call alistf('EPOS&')
+
+ do is=1,nptl
+
+ if(istptl(is).eq.0)then
+ nptlxs=nptlxs+1
+ if(nptlxs.gt.mxptlxs)stop'Epos: mxptlxs too small'
+ id=idptl(is)
+ if(id.gt.10000)id=mod(id,10000)/10*100 !proj A
+
+ call cxidmass(id,am)
+
+ istptlxs(nptlxs)=istptl(is)
+c if ( is .le. maprojxs .and.
+c * iorptl(is) .eq. 0 .and. istptl(is) .eq. 0 ) then
+c if ( ifragm .ne. 0 ) then
+cc compose projectile spectators to remaining nucleus
+c istptlxs(nptlxs)=1
+c idrest = nptlxs
+c if ( id .eq. 1120 ) then
+c inew = inew + 101
+c irest = irest - 101
+c elseif ( id .eq. 1220 ) then
+c inew = inew + 100
+c irest = irest - 100
+c endif
+c endif
+c elseif( is .le. maprojxs .and.
+c * iorptl(is) .eq. 0 .and. istptl(is) .eq. 1 ) then
+c jorptl(is)=1
+c endif
+ xsptl(1,nptlxs)=dble(pptl(1,is))
+ xsptl(2,nptlxs)=dble(pptl(2,is))
+ xsptl(3,nptlxs)=dble(pptl(3,is))
+ xsptl(4,nptlxs)=dble(pptl(4,is))
+ xsptl(5,nptlxs)=am !mass
+ ityptlxs(nptlxs)=ityptl(is)
+ iorptlxs(nptlxs)=iorptl(is)
+ jorptlxs(nptlxs)=jorptl(is)
+ ifrptlxs(1,nptlxs)=ifrptl(1,is)
+ ifrptlxs(2,nptlxs)=ifrptl(2,is)
+ xsorptl(1,nptlxs)=dble(xorptl(1,is))
+ xsorptl(2,nptlxs)=dble(xorptl(2,is))
+ xsorptl(3,nptlxs)=dble(xorptl(3,is))
+ xsorptl(4,nptlxs)=dble(xorptl(4,is))
+ xstivptl(1,nptlxs)=dble(tivptl(1,is))
+ xstivptl(2,nptlxs)=dble(tivptl(2,is))
+ idptlxs(nptlxs)=id
+
+
+#ifdef __CXDEBUG__
+ if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+ $ ' particle from EPOS ',nptlxs,' id :',idptlxs(nptlxs)
+ $ , ' momentum :',(xsptl(k,nptlxs),k=1,5)
+#endif
+
+ endif
+
+
+ enddo
+c if(inew.eq.0)goto 1000
+c
+c nptlxsa=nptlxs
+c
+c if( inew .eq. 100 .or. inew .eq. 101 ) then
+cc remaining nucleus is single neutron or proton
+c istptlxs(idrest)=0
+c goto 1000
+c
+c elseif ( ifragm .ge. 2 ) then
+cc remaining nucleus is evaporating nucleons and alpha particles
+c jfin = 0
+c call cxvapor( maprojxs,inew,jfin,ityp,pfrx,pfry )
+c if ( jfin .eq. 0 ) goto 1000
+cc loop to treat the remanents of the desintegrated fragment
+c do 135 j = 1, jfin
+c if(mod(ityp(j),100).eq.0)then
+c inucl= ityp(j)/100
+c idnucl=100*inucl
+c else
+c inucl=1
+c idnucl=ityp(j)
+c endif
+c ea = dble(inucl) * dble(pptl(4,idrest))
+c#ifdef __CXDEBUG__
+c if (isx.ge.6) write(ifck,*) 'fragment: j,id,ea=',
+c * j,idnucl,ea
+c#endif
+cc momenta squared
+c call cxidmass(idnucl,am)
+c ptm = ( ea - dble(am) ) * ( ea + dble(am) )
+c pt2 = pfrx(j)**2 + pfry(j)**2
+c if ( pt2 .ge. ptm ) then
+c#ifdef __CXDEBUG__
+c if (isx.ge.2) write(ifck,*) 'emsepo: pt reject particle',j
+c#endif
+c pfrx(j)=0.d0
+c pfry(j)=0.d0
+c endif
+c plong=ptm-pt2
+c if ( plong .ge. 0.d0)then
+c plong = sqrt( plong )
+c else
+c#ifdef __CXDEBUG__
+c if (isx.ge.2) write(ifck,*) 'emsepo: ptm reject particle',j
+c#endif
+c do is=1,inucl
+c if(istptlxs(is).eq.1.and.jorptlxs(is).eq.0)istptlxs(is)=0
+c enddo
+c goto 135
+c endif
+c nptlxs=nptlxs+1
+c istptlxs(nptlxs)=0
+c xsptl(1,nptlxs)=pfrx(j)
+c xsptl(2,nptlxs)=pfry(j)
+c xsptl(3,nptlxs)=plong
+c xsptl(4,nptlxs)=ea
+c xsptl(5,nptlxs)=am !mass
+c ityptlxs(nptlxs)=0
+c iorptlxs(nptlxs)=1
+c jorptlxs(nptlxs)=maprojxs
+c ifrptlxs(1,nptlxs)=0
+c ifrptlxs(2,nptlxs)=0
+c xsorptl(1,nptlxs)=xsorptl(1,idrest)
+c xsorptl(2,nptlxs)=xsorptl(2,idrest)
+c xsorptl(3,nptlxs)=xsorptl(3,idrest)
+c xsorptl(4,nptlxs)=xsorptl(4,idrest)
+c xstivptl(1,nptlxs)=xstivptl(1,idrest)
+c xstivptl(2,nptlxs)=xstivptl(2,idrest)
+c idptlxs(nptlxs)=idnucl
+c 135 continue
+c
+c elseif ( ifragm .eq. 1 ) then
+cc remaining nucleus is one fragment
+c nptlxs=nptlxs+1
+c istptlxs(nptlxs)=0
+c xsptl(1,nptlxs)=0.d0
+c xsptl(2,nptlxs)=0.d0
+c xsptl(4,nptlxs)=0.d0
+c inucl=0
+c do is=1,maprojxs
+c if(iorptl(is).eq.0.and.jorptl(is).eq.0)then
+c inucl=inucl+1
+c xsptl(4,nptlxs)=xsptl(4,nptlxs)+dble(pptl(4,is))
+c endif
+c enddo
+c idnucl=100*inucl
+c call cxidmass(idnucl,am)
+c xsptl(5,nptlxs)=am !mass
+c ptot=(xsptl(4,nptlxs)+am)*(xsptl(4,nptlxs)-am)
+c xsptl(3,nptlxs)=sqrt(ptot)
+c ityptlxs(nptlxs)=0
+c istptlxs(nptlxs)=0
+c iorptlxs(nptlxs)=1
+c jorptlxs(nptlxs)=maprojxs
+c ifrptlxs(1,nptlxs)=0
+c ifrptlxs(2,nptlxs)=0
+c xsorptl(1,nptlxs)=xsorptl(1,idrest)
+c xsorptl(2,nptlxs)=xsorptl(2,idrest)
+c xsorptl(3,nptlxs)=xsorptl(3,idrest)
+c xsorptl(4,nptlxs)=xsorptl(4,idrest)
+c xstivptl(1,nptlxs)=xstivptl(1,idrest)
+c xstivptl(2,nptlxs)=xstivptl(2,idrest)
+c idptlxs(nptlxs)=idnucl
+c endif
+c
+c#ifdef __CXDEBUG__
+c do is=nptlxsa+1,nptlxs
+c if(isx.ge.5)write(ifck,'(a,i5,a,i5,a,4(e11.4,1x),f6.3)')
+c $ ' particle from EPOS ',is,' id :',idptlxs(is)
+c $ , ' momentum :',(xsptl(k,is),k=1,5)
+c enddo
+c#endif
+
+
+ 1000 call utprix('emsepo',ish,ishini,4)
+ return
+
+
+1001 iret=1
+ goto 1000
+
+ end
+
+#if !__CXCORSIKA__ && !__CORSIKA8__
+
+c-----------------------------------------------------------------------
+ subroutine ranfini(seed,iseq,iqq)
+c-----------------------------------------------------------------------
+ double precision seed,dummy
+ integer iseq,iqq,idum
+ dummy=seed
+ idum=iqq
+ idum=iseq
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine ranfcv(seed)
+c-----------------------------------------------------------------------
+c Convert input seed to EPOS random number seed
+c Useless with ranf
+c-----------------------------------------------------------------------
+ double precision seed,dummy
+ dummy=seed
+
+ return
+ end
+#endif
+#endif
--
GitLab